Add support for Guile & Guix.

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)

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}}) {

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(

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$/;
 

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, (
+                    push @res, "--arg", $input, buildInputToString($exprType, $alt);
-                        "{ 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} . "\"" : "") .
-                        ";}"
-                    );
                 }
                 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";

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 \

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 <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 <arg ...> 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)))))

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 = {};

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
+    nixExprInput  text not null, -- name of the jobsetInput containing the Nix or Guix expression
-    nixExprPath   text not null, -- relative path of the Nix 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