vriska/hydra
0
0
Fork 0
forked from lix-project/hydra
Code Pull requests Activity

Add support for Guile & Guix.

Browse source
This commit is contained in:
Ludovic Courtès 2012-08-16 19:07:04 +02:00
parent 4ade8c5a1b
commit f27ae1d566
9 changed files with 281 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
configure.ac
View file

@ -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)

7
src/lib/Hydra/Controller/Build.pm
View file

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

5
src/lib/Hydra/Controller/Jobset.pm
View file

@ -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(

2
src/lib/Hydra/Controller/Project.pm
View file

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

60
src/lib/Hydra/Helper/AddBuilds.pm
View file

@ -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";

1
src/script/Makefile.am
View file

@ -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 \

214
src/script/hydra-eval-guile-jobs Executable file
View file

@ -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)))))

5
src/script/hydra-evaluator
View file

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

4
src/sql/hydra.sql
View file

@ -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