From f27ae1d5663680400cb99cfb898970f34d8d21be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 16 Aug 2012 19:07:04 +0200 Subject: [PATCH] Add support for Guile & Guix. --- configure.ac | 1 + src/lib/Hydra/Controller/Build.pm | 7 +- src/lib/Hydra/Controller/Jobset.pm | 5 + src/lib/Hydra/Controller/Project.pm | 2 + src/lib/Hydra/Helper/AddBuilds.pm | 60 ++++++-- src/script/Makefile.am | 1 + src/script/hydra-eval-guile-jobs | 214 ++++++++++++++++++++++++++++ src/script/hydra-evaluator | 5 +- src/sql/hydra.sql | 4 +- 9 files changed, 281 insertions(+), 18 deletions(-) create mode 100755 src/script/hydra-eval-guile-jobs diff --git a/configure.ac b/configure.ac index 00609af2..5d066959 100644 --- a/configure.ac +++ b/configure.ac @@ -75,6 +75,7 @@ CPPFLAGS="$old_CPPFLAGS" LIBS="$old_LIBS" PKG_CHECK_MODULES([BDW_GC], [bdw-gc]) +PKG_CHECK_MODULES([GUILE], [guile-2.0], [HAVE_GUILE=yes], [HAVE_GUILE=no]) testPath="$(dirname $(type -p expr))" AC_SUBST(testPath) diff --git a/src/lib/Hydra/Controller/Build.pm b/src/lib/Hydra/Controller/Build.pm index b79eccbb..59a1c663 100644 --- a/src/lib/Hydra/Controller/Build.pm +++ b/src/lib/Hydra/Controller/Build.pm @@ -463,6 +463,11 @@ sub clone_submit : Chained('build') PathPart('clone/submit') Args(0) { my ($nixExprPath, $nixExprInputName) = Hydra::Controller::Jobset::nixExprPathFromParams $c; + # When the expression is in a .scm file, assume it's a Guile + Guix + # build expression. + my $exprType = + $c->request->params->{"nixexprpath"} =~ /.scm$/ ? "guile" : "nix"; + my $jobName = trim $c->request->params->{"jobname"}; error($c, "Invalid job name: $jobName") if $jobName !~ /^$jobNameRE$/; @@ -488,7 +493,7 @@ sub clone_submit : Chained('build') PathPart('clone/submit') Args(0) { error($c, $@) if $@; } - my ($jobs, $nixExprInput) = evalJobs($inputInfo, $nixExprInputName, $nixExprPath); + my ($jobs, $nixExprInput) = evalJobs($inputInfo, $exprType, $nixExprInputName, $nixExprPath); my $job; foreach my $j (@{$jobs->{job}}) { diff --git a/src/lib/Hydra/Controller/Jobset.pm b/src/lib/Hydra/Controller/Jobset.pm index 11f3b350..2651fd11 100644 --- a/src/lib/Hydra/Controller/Jobset.pm +++ b/src/lib/Hydra/Controller/Jobset.pm @@ -223,6 +223,11 @@ sub updateJobset { my $jobsetName = trim $c->request->params->{"name"}; error($c, "Invalid jobset name: ‘$jobsetName’") if $jobsetName !~ /^$jobsetNameRE$/; + # When the expression is in a .scm file, assume it's a Guile + Guix + # build expression. + my $exprType = + $c->request->params->{"nixexprpath"} =~ /.scm$/ ? "guile" : "nix"; + my ($nixExprPath, $nixExprInput) = nixExprPathFromParams $c; $jobset->update( diff --git a/src/lib/Hydra/Controller/Project.pm b/src/lib/Hydra/Controller/Project.pm index 050a7d40..c2474e9a 100644 --- a/src/lib/Hydra/Controller/Project.pm +++ b/src/lib/Hydra/Controller/Project.pm @@ -146,6 +146,8 @@ sub create_jobset_submit : Chained('project') PathPart('create-jobset/submit') A requireProjectOwner($c, $c->stash->{project}); my $jobsetName = trim $c->request->params->{name}; + my $exprType = + $c->request->params->{"nixexprpath"} =~ /.scm$/ ? "guile" : "nix"; error($c, "Invalid jobset name: ‘$jobsetName’") if $jobsetName !~ /^$jobsetNameRE$/; diff --git a/src/lib/Hydra/Helper/AddBuilds.pm b/src/lib/Hydra/Helper/AddBuilds.pm index 0d57dee0..c51757cc 100644 --- a/src/lib/Hydra/Helper/AddBuilds.pm +++ b/src/lib/Hydra/Helper/AddBuilds.pm @@ -644,8 +644,47 @@ sub fetchInput { } +sub booleanToString { + my ($exprType, $value) = @_; + my $result; + if ($exprType eq "guile") { + if ($value eq "true") { + $result = "#t"; + } else { + $result = "#f"; + } + $result = $value; + } else { + $result = $value; + } + return $result; +} + +sub buildInputToString { + my ($exprType, $input) = @_; + my $result; + if ($exprType eq "guile") { + $result = "'((file-name . \"" . ${input}->{storePath} . "\")" . + (defined $input->{revision} ? "(revision . \"" . $input->{revision} . "\")" : "") . + (defined $input->{revCount} ? "(revision-count . " . $input->{revCount} . ")" : "") . + (defined $input->{gitTag} ? "(git-tag . \"" . $input->{gitTag} . "\")" : "") . + (defined $input->{shortRev} ? "(short-revision . \"" . $input->{shortRev} . "\")" : "") . + (defined $input->{version} ? "(version . \"" . $input->{version} . "\")" : "") . + ")"; + } else { + $result = "{ outPath = builtins.storePath " . $input->{storePath} . "" . + (defined $input->{revision} ? "; rev = \"" . $input->{revision} . "\"" : "") . + (defined $input->{revCount} ? "; revCount = " . $input->{revCount} . "" : "") . + (defined $input->{gitTag} ? "; gitTag = \"" . $input->{gitTag} . "\"" : "") . + (defined $input->{shortRev} ? "; shortRev = \"" . $input->{shortRev} . "\"" : "") . + (defined $input->{version} ? "; version = \"" . $input->{version} . "\"" : "") . + ";}"; + } + return $result; +} + sub inputsToArgs { - my ($inputInfo) = @_; + my ($inputInfo, $exprType) = @_; my @res = (); foreach my $input (keys %{$inputInfo}) { @@ -658,18 +697,10 @@ sub inputsToArgs { push @res, "--argstr", $input, $alt->{value}; } when ("boolean") { - push @res, "--arg", $input, $alt->{value}; + push @res, "--arg", $input, booleanToString($exprType, $alt->{value}); } when (["path", "build", "git", "hg", "sysbuild"]) { - push @res, "--arg", $input, ( - "{ outPath = builtins.storePath " . $alt->{storePath} . "" . - (defined $alt->{revision} ? "; rev = \"" . $alt->{revision} . "\"" : "") . - (defined $alt->{revCount} ? "; revCount = " . $alt->{revCount} . "" : "") . - (defined $alt->{gitTag} ? "; gitTag = \"" . $alt->{gitTag} . "\"" : "") . - (defined $alt->{shortRev} ? "; shortRev = \"" . $alt->{shortRev} . "\"" : "") . - (defined $alt->{version} ? "; version = \"" . $alt->{version} . "\"" : "") . - ";}" - ); + push @res, "--arg", $input, buildInputToString($exprType, $alt); } when (["svn", "svn-checkout", "bzr", "bzr-checkout"]) { push @res, "--arg", $input, ( @@ -711,7 +742,7 @@ sub captureStdoutStderr { sub evalJobs { - my ($inputInfo, $nixExprInputName, $nixExprPath) = @_; + my ($inputInfo, $exprType, $nixExprInputName, $nixExprPath) = @_; my $nixExprInput = $inputInfo->{$nixExprInputName}->[0] or die "Cannot find the input containing the job expression.\n"; @@ -719,8 +750,11 @@ sub evalJobs { if scalar @{$inputInfo->{$nixExprInputName}} != 1; my $nixExprFullPath = $nixExprInput->{storePath} . "/" . $nixExprPath; + my $evaluator = ($exprType eq "guile") ? "hydra-eval-guile-jobs" : "hydra-eval-jobs"; + print STDERR "evaluator ${evaluator}\n"; + (my $res, my $jobsXml, my $stderr) = captureStdoutStderr(10800, - ("hydra-eval-jobs", $nixExprFullPath, "--gc-roots-dir", getGCRootsDir, "-j", 1, inputsToArgs($inputInfo))); + ($evaluator, $nixExprFullPath, "--gc-roots-dir", getGCRootsDir, "-j", 1, inputsToArgs($inputInfo, $exprType))); die "Cannot evaluate the Nix expression containing the jobs:\n$stderr" unless $res; print STDERR "$stderr"; diff --git a/src/script/Makefile.am b/src/script/Makefile.am index 95ea105a..586b8498 100644 --- a/src/script/Makefile.am +++ b/src/script/Makefile.am @@ -6,6 +6,7 @@ bin_SCRIPTS = \ hydra-init \ hydra-build \ hydra-evaluator \ + hydra-eval-guile-jobs \ hydra-queue-runner \ hydra-server \ hydra-update-gc-roots \ diff --git a/src/script/hydra-eval-guile-jobs b/src/script/hydra-eval-guile-jobs new file mode 100755 index 00000000..a234a58f --- /dev/null +++ b/src/script/hydra-eval-guile-jobs @@ -0,0 +1,214 @@ +#!/bin/sh +# Aside from this initial boilerplate, this is actually -*- scheme -*- code. +main="(module-ref (resolve-interface '(hydra-eval-guile-jobs)) 'eval-guile-jobs)" + +# Make sure no undeclared dependency is leaked. Guix has to be +# provided as an input through Hydra. Guix itself must thus be built via a +# recipe written in the Nix language. +unset GUILE_LOAD_PATH +unset GUILE_LOAD_COMPILED_PATH + +exec ${GUILE:-guile} --no-auto-compile \ + -l "$0" -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; Copyright (C) 2012 Ludovic Courtès +;;; +;;; Hydra is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Hydra is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Hydra. If not, see . + +(define-module (hydra-eval-guile-jobs) + #:use-module (sxml simple) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:export (job-evaluations->xml + eval-guile-jobs)) + +(define (guix-variable module name) + "Dynamically link variable NAME under Guix module MODULE and return it. +Note: this is used instead of `@', because when using `@' in an uncompiled +file, Guile tries to load the module directly as it reads the source, which +fails in our case, leading to the creation of empty (guix ...) modules." + ;; TODO: fail with an XML error description + (let ((m (resolve-interface `(guix ,module)))) + (module-ref m name))) + +(define (%derivation-system drv) + ;; XXX: Awful hack to workaround the fact that `derivation-system', which + ;; is a macro, cannot be referred to dynamically. + (struct-ref drv 3)) + +(define strip-store-path + (let ((store-path-rx + (make-regexp "^.*/nix/store/[^-]+-(.+)$"))) + (lambda (path) + (or (and=> (regexp-exec store-path-rx path) + (lambda (match) + (let ((path (match:substring match 1))) + path))) + path)))) + +(define (derivation-path->name drv) + "Return the base name of DRV, sans hash and `.drv' extension." + (let ((d (strip-store-path drv))) + (if (string-suffix? ".drv" d) + (string-drop-right d 4) + d))) + +(define (job-evaluations->sxml jobs) + "Return the hydra-eval-jobs SXML form for the result of JOBS, a list of +symbol/thunk pairs." + `(*TOP* + (*PI* xml "version='1.0' encoding='utf-8'") + "\n" + (jobs "\n" + ,@(map (match-lambda + (((? symbol? name) . (? thunk? thunk)) + (let* ((result (save-module-excursion + (lambda () + (set-current-module %user-module) + (with-output-to-port (%make-void-port "w") + thunk)))) + (drv (assoc-ref result 'derivation))) + (define (opt-attr xml-name name) + (match (assoc name result) + ((_ . value) + `((,xml-name ,value))) + (_ + '()))) + + ;; XXX: Add tags? + `(job (@ (jobName ,name) + (drvPath ,drv) + (outPath + ;; Resolve Guix modules lazily. + ,((guix-variable 'derivations + 'derivation-path->output-path) + drv)) + ,@(opt-attr 'homepage 'home-page) + ,@(opt-attr 'license 'license) + ,@(opt-attr 'description 'description) + ,@(opt-attr 'longDescription 'long-description) + (maintainers + ,(string-join (or (assoc-ref result 'maintainers) + '()) + ", ")) + (maxSilent + ,(number->string (or (assoc-ref result + 'max-silent-time) + 3600))) + (timeout + ,(number->string (or (assoc-ref result 'timeout) + 7200))) + (nixName ,(derivation-path->name drv)) + (schedulingPriority + ,(number->string (or (assoc-ref result + 'scheduling-priority) + 10))) + (system + ,(call-with-input-file drv + (compose %derivation-system + (guix-variable 'derivations + 'read-derivation))))) + "\n")))) + jobs)))) + +(define (job-evaluations->xml jobs port) + (set-port-encoding! port "UTF-8") + (sxml->xml (job-evaluations->sxml jobs) port)) + + +;;; +;;; Command-line entry point. +;;; + +(define (parse-arguments args) + "Traverse ARGS, a list of command-line arguments compatible with +`hydra-eval-jobs', and return the name of the file that defines the jobs, an +expression that returns the entry point in that file (a unary procedure), the +list of name/value pairs passed to that entry point, as well as a GC root +directory or #f." + (define (module-directory dir) + (let ((d (string-append dir "/share/guile/site/2.0"))) + (if (file-exists? d) + d + dir))) + + (let loop ((args args) + (result '()) + (file #f) + (entry 'hydra-jobs) + (roots-dir #f)) + (match args + (() + (if (not file) + (error "hydra-eval-guile-jobs: no expression file given") + (values file entry (reverse result) roots-dir))) + (("-I" name=dir rest ...) + (let* ((dir (match (string-tokenize name=dir + (char-set-complement (char-set + #\=))) + ((_ dir) dir) + ((dir) dir))) + (dir* (module-directory dir))) + (format (current-error-port) "adding `~a' to the load path~%" dir*) + (set! %load-path (cons dir* %load-path)) + (set! %load-compiled-path (cons dir* %load-compiled-path))) + (loop rest result file entry roots-dir)) + (("--argstr" name value rest ...) + (loop rest (alist-cons (string->symbol name) value result) + file entry roots-dir)) + (("--arg" name expr rest ...) + (let ((value (eval (call-with-input-string expr read) + (current-module)))) + (loop rest (alist-cons (string->symbol name) value result) + file entry roots-dir))) + (("--gc-roots-dir" dir rest ...) + (loop rest result file entry dir)) + (("-j" _ rest ...) ; XXX: what's this? + (loop rest result file entry roots-dir)) + (("--entry" expr rest ...) ; entry point, like `guile -e' + (let ((expr (call-with-input-string expr read))) + (loop rest result file expr roots-dir))) + ((file rest ...) ; source file that defines the jobs + (loop rest result file entry roots-dir)) + (_ + (error "hydra-eval-guile-jobs: invalid arguments" args))))) + +(define %user-module + ;; Hydra user module. + ;; TODO: Make it a sandbox. + (let ((m (make-module))) + (beautify-user-module! m) + m)) + +(define (eval-guile-jobs . args) + (setlocale LC_ALL "") + + (let-values (((file entry args gc-roots-dir) + (parse-arguments args))) + + (save-module-excursion + (lambda () + (set-current-module %user-module) + + ;; The standard output must contain only XML. + (with-output-to-port (%make-void-port "w") + (lambda () + (primitive-load file))))) + + (let* ((entry (eval entry %user-module)) + (store ((guix-variable 'store 'open-connection))) + (jobs (entry store args))) + (job-evaluations->xml jobs (current-output-port))))) diff --git a/src/script/hydra-evaluator b/src/script/hydra-evaluator index 1fc0d260..3ee3edac 100755 --- a/src/script/hydra-evaluator +++ b/src/script/hydra-evaluator @@ -100,6 +100,7 @@ sub permute { sub checkJobset { my ($project, $jobset) = @_; my $inputInfo = {}; + my $exprType = $jobset->nixexprpath =~ /.scm$/ ? "guile" : "nix"; # Fetch all values for all inputs. my $checkoutStart = time; @@ -109,7 +110,7 @@ sub checkJobset { # Hash the arguments to hydra-eval-jobs and check the # JobsetInputHashes to see if the previous evaluation had the same # inputs. If so, bail out. - my @args = ($jobset->nixexprinput, $jobset->nixexprpath, inputsToArgs($inputInfo)); + my @args = ($jobset->nixexprinput, $jobset->nixexprpath, inputsToArgs($inputInfo, $exprType)); my $argsHash = sha256_hex("@args"); my $prevEval = getPrevJobsetEval($db, $jobset, 0); if (defined $prevEval && $prevEval->hash eq $argsHash) { @@ -122,7 +123,7 @@ sub checkJobset { # Evaluate the job expression. my $evalStart = time; - my ($jobs, $nixExprInput) = evalJobs($inputInfo, $jobset->nixexprinput, $jobset->nixexprpath); + my ($jobs, $nixExprInput) = evalJobs($inputInfo, $exprType, $jobset->nixexprinput, $jobset->nixexprpath); my $evalStop = time; my $jobOutPathMap = {}; diff --git a/src/sql/hydra.sql b/src/sql/hydra.sql index ebe2e429..d978081e 100644 --- a/src/sql/hydra.sql +++ b/src/sql/hydra.sql @@ -49,8 +49,8 @@ create table Jobsets ( name text not null, project text not null, description text, - nixExprInput text not null, -- name of the jobsetInput containing the Nix expression - nixExprPath text not null, -- relative path of the Nix expression + nixExprInput text not null, -- name of the jobsetInput containing the Nix or Guix expression + nixExprPath text not null, -- relative path of the Nix or Guix expression errorMsg text, -- used to signal the last evaluation error etc. for this jobset errorTime integer, -- timestamp associated with errorMsg lastCheckedTime integer, -- last time the evaluator looked at this jobset