base: Provide 'build-derivations' with the full list of derivations.

This improves parallelism when 'max-jobs' is large.

* src/cuirass/base.scm (build-packages): Rewrite to pass the complete
list of derivations to 'build-derivations' at once.  Handle multiple outputs.
* src/schema.sql (Builds): Make "output" part of the primary key.

Co-authored-by: Mathieu Lirzin <mthl@gnu.org>

.dir-locals.el

@@ -1,11 +1,19 @@
-;; Per-directory local variables for GNU Emacs 23 and later.
+;;; Directory Local Variables
+;;; For more information see (info "(emacs) Directory Variables")
 
 ((nil
-  . ((fill-column . 78)
-     (tab-width   .  8)
-
-     ;; For use with 'bug-reference-prog-mode'.
-     (bug-reference-url-format . "http://bugs.gnu.org/%s")
-     (bug-reference-bug-regexp
-      . "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>")))
- (scheme-mode     . ((indent-tabs-mode . nil))))
+  (fill-column . 78)
+  (tab-width . 8)
+  (bug-reference-url-format . "http://bugs.gnu.org/%s")
+  (bug-reference-bug-regexp
+   . "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>"))
+ (scheme-mode
+  (indent-tabs-mode)
+  (eval put 'call-with-time 'scheme-indent-function 1)
+  (eval put 'test-error 'scheme-indent-function 1)
+  (eval put 'make-parameter 'scheme-indent-function 1)
+  (eval put 'with-database 'scheme-indent-function 1))
+ (texinfo-mode
+  (indent-tabs-mode)
+  (fill-column . 72)
+  (ispell-local-dictionary . "american")))

.gitignore

@@ -1,18 +1,27 @@
 *.go
+*.info
 *.log
 *.trs
+.dirstamp
 /*.status
 /INSTALL
 /aclocal.m4
 /autom4te.cache/
+/bin/cuirass
+/bin/evaluate
 /build-aux/config.guess
 /build-aux/config.sub
 /build-aux/install-sh
+/build-aux/mdate-sh
 /build-aux/missing
+/build-aux/test-driver
+/build-aux/texinfo.tex
+/cache/
+/config.cache
 /configure
+/doc/version.texi
+/src/cuirass/config.scm
 Makefile
 Makefile.in
 pre-inst-env
-/bin/cuirass
-/config.cache
-/cache/
+stamp-vti

Makefile.am

@@ -1,27 +1,74 @@
 ## Process this file with automake to produce Makefile.in.
 
-bin_SCRIPTS = bin/cuirass
+# Copyright © 1995-2016 Free Software Foundation, Inc.
+# Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
+#
+# This file is part of Cuirass.
+#
+# Cuirass 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, or (at your option)
+# any later version.
+#
+# Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+bin_SCRIPTS = bin/cuirass bin/evaluate
 noinst_SCRIPTS = pre-inst-env
 
-dist_pkgmodule_DATA = src/cuirass/base.scm
-nodist_pkgmodule_DATA = $(dist_pkgmodule_DATA:%.scm=%.go)
+guilesitedir = $(datarootdir)/guile/site/2.0
+dist_guilesite_DATA = src/cuirass.scm
+nodist_guilesite_DATA = $(dist_guilesite_DATA:.scm=.go)
 
-TEST_EXTENSIONS = .scm
-AM_TESTS_ENVIRONMENT = env GUILE_AUTO_COMPILE='0'
+pkgmoduledir = $(guilesitedir)/$(PACKAGE)
+dist_pkgmodule_DATA = \
+  src/cuirass/base.scm \
+  src/cuirass/database.scm \
+  src/cuirass/http.scm \
+  src/cuirass/repo.scm \
+  src/cuirass/ui.scm \
+  src/cuirass/utils.scm
+
+nodist_pkgmodule_DATA = \
+  $(dist_pkgmodule_DATA:.scm=.go) \
+  src/cuirass/config.scm \
+  src/cuirass/config.go
+
+dist_pkgdata_DATA = src/schema.sql
+
+TEST_EXTENSIONS = .scm .sh
+AM_TESTS_ENVIRONMENT = \
+  env GUILE_AUTO_COMPILE='0' \
+  testsrcdir='$(abs_top_srcdir)/tests' \
+  testbuilddir='$(abs_top_builddir)/tests'
 
 SCM_LOG_DRIVER = \
   $(builddir)/pre-inst-env $(GUILE) \
   $(srcdir)/build-aux/test-driver.scm
 
-TESTS = tests/base.scm
+SH_LOG_COMPILER = $(top_builddir)/pre-inst-env $(SHELL)
+AM_SH_LOG_FLAGS = -x -e
+
+TESTS = \
+  tests/base.scm \
+## tests/basic.sh # takes too long to execute
+  tests/database.scm \
+  tests/http.scm \
+  tests/repo.scm \
+  tests/ui.scm \
+  tests/utils.scm
 
 # Unset 'GUILE_LOAD_COMPILED_PATH' altogether while compiling.  Otherwise, if
-# $GUILE_LOAD_COMPILED_PATH contains $(cuirassmoduledir), we may find .go
-# files in there that are newer than the local .scm files (for instance
-# because the user ran 'make install' recently).  When that happens, we end up
-# loading those previously-installed .go files, which may be stale, thereby
-# breaking the whole thing.  Set GUILE_AUTO_COMPILE to 0 to avoid
-# auto-compiling guild.
+# $GUILE_LOAD_COMPILED_PATH contains $(pkgmoduledir), we may find .go files in
+# there that are newer than the local .scm files (for instance because the
+# user ran 'make install' recently).  When that happens, we end up loading
+# those previously-installed .go files, which may be stale, thereby breaking
+# the whole thing.  Set GUILE_AUTO_COMPILE to 0 to avoid auto-compiling guild.
 #
 # XXX: Use the C locale for when Guile lacks
 # <http://git.sv.gnu.org/cgit/guile.git/commit/?h=stable-2.0&id=e2c6bf3866d1186c60bacfbd4fe5037087ee5e3f>.
@@ -35,7 +82,32 @@ TESTS = tests/base.scm
 	  --warn=format --warn=unbound-variable --warn=arity-mismatch \
 	  --target="$(host)" --output="$@" "$<" $(devnull_verbose)
 
+CLEANFILES = \
+  $(nodist_guilesite_DATA) \
+  $(dist_pkgmodule_DATA:.scm=.go) \
+  src/cuirass/config.go
+
+.PHONY:	sql-check
+sql-check: src/schema.sql
+	@echo "$<"
+	$(AM_V_at)sqlite3 tmp-$$$.db < $< ; \
+	rm tmp-$$$.db
+
+## -------------- ##
+## Distribution.  ##
+## -------------- ##
+
+EXTRA_DIST = \
+  .dir-locals.el \
+  bin/cuirass.in \
+  bin/evaluate.in \
+  bootstrap \
+  build-aux/guix.scm \
+  src/cuirass/config.scm.in \
+  $(TESTS)
+
 dist-hook: gen-ChangeLog
+	$(AM_V_GEN)echo $(VERSION) > $(distdir)/.tarball-version
 
 .PHONY: gen-ChangeLog
 gen-ChangeLog:
@@ -50,11 +122,78 @@ gen-ChangeLog:
 	      mv $(distdir)/cl-t $(distdir)/ChangeLog; } \
 	fi
 
-EXTRA_DIST = \
-  .dir-locals.el \
-  $(TESTS)
+## ----------------- ##
+## Generated files.  ##
+## ----------------- ##
 
-CLEANFILES = $(nodist_pkgmodule_DATA)
+# 'AC_CONFIG_FILES' doesn't fully expand variables that depend on ${prefix}.
+# To use such variables in source files and scripts while following GNU Coding
+# Standards, let 'make' manage their replacement.
+
+# Use config.status to substitute the remainder where a single expansion is
+# sufficient.  We use a funny notation here to avoid configure substitutions
+# in our text.
+do_subst = ( $(SED) \
+  -e "s,@configure_input[@],Generated from $$in.  Do not edit by hand.,g" \
+  -e 's,@datadir[@],$(datadir),g' \
+  -e 's,@GUILE[@],$(GUILE),g' \
+  -e 's,@localstatedir[@],$(localstatedir),g' \
+  -e 's,@PACKAGE_LOAD_COMPILED_PATH[@],$(guilesitedir),g' \
+  -e 's,@PACKAGE_LOAD_PATH[@],$(guilesitedir),g' \
+  | $(SHELL) ./config.status --file=- )
+
+# Generic instructions to perform the substitution.  Generated files shouldn't
+# contain unexpanded '@substitutions@', and should be made read-only, to
+# prevent them from being edited by mistake instead of the file they are
+# generated from.
+generate_file = \
+  $(AM_V_GEN)rm -f $@ $@-t; \
+  $(MKDIR_P) $(@D); \
+  in=$@.in && $(do_subst) <$(srcdir)/$$in >$@-t; \
+  if LC_ALL=C grep '@[a-zA-Z0-9_][a-zA-Z0-9_]*@' $@-t; then \
+    echo "$@ contains unexpanded substitution (see lines above)"; \
+    exit 1; \
+  fi; \
+  chmod a-w $@-t; mv -f $@-t $@
+
+# These files depend on Makefile so they are rebuilt if $(VERSION),
+# $(datadir) or other do_subst'ituted variables change.
+bin/cuirass: $(srcdir)/bin/cuirass.in
+bin/evaluate: $(srcdir)/bin/evaluate.in
+$(bin_SCRIPTS): Makefile
+	$(generate_file); chmod +x $@
+src/cuirass/config.scm: $(srcdir)/src/cuirass/config.scm.in Makefile
+	$(generate_file)
+
+# Guile modules require 'src/cuirass/config.scm' to exist before their
+# compilation.
+BUILT_SOURCES = src/cuirass/config.scm
+
+MOSTLYCLEANFILES = $(bin_SCRIPTS) src/cuirass/config.scm
+
+## --------------- ##
+## Documentation.  ##
+## --------------- ##
+
+info_TEXINFOS = doc/cuirass.texi
+doc_cuirass_TEXINFOS = doc/fdl-1.3.texi
+
+# Install the examples.
+nobase_dist_pkgdata_DATA = \
+  examples/gnu-system.scm \
+  examples/guix-jobs.scm \
+  examples/hello-singleton.scm \
+  examples/hello-subset.scm
+
+## -------------- ##
+## Installation.  ##
+## -------------- ##
+
+# Ensure that the scripts will find their module directories.
+install-exec-hook:
+	$(SED) \
+	  -e 's,^#GUILE_LOAD,GUILE_LOAD,g' \
+	  -i $(DESTDIR)$(bindir)/cuirass
 
 ## -------------- ##
 ## Silent rules.  ##

README

@@ -1,10 +1,63 @@
-Cuirass is continuous integration system using GNU Guix.  It is
-intended as replacement for Hydra.
+Cuirass is a continuous integration tool using GNU Guix.  It is intended as a
+replacement for Hydra.
 
 Requirements
 ============
 
-GNU Guix must be installed along with all its development dependencies
-as described here:
+Cuirass currently depends on the following packages:
 
-  https://www.gnu.org/software/guix/manual/html_node/Building-from-Git.html#Building-from-Git
+  - GNU Guile 2.0.9 or later
+  - GNU Guix (and all its development dependencies)
+  - GNU Make
+  - Guile-JSON
+  - Guile-SQLite3
+  - Git
+
+A convenient way to install those dependencies is to install Guix and execute
+the following command:
+
+   $ guix environment -l build-aux/guix.scm
+
+This will build and enter an environment which provides all the necessary
+dependencies.
+
+Build Instructions
+==================
+
+When all the dependencies are available on you system, in order to build and
+install Cuirass, you can proceed with the usual:
+
+   $ ./configure && sudo make install
+
+An alternative way is to directly install Cuirass in your Guix profile, using:
+
+   $ guix package -f build-aux/guix.scm
+
+To build it, but not install it, run:
+
+   $ guix build -f build-aux/guix.scm
+
+Example
+=======
+
+A quick way to manually test Cuirass is to execute:
+
+  ./pre-inst-env cuirass --specifications=examples/hello-singleton.scm --database=test.db
+
+This will read the file "examples/hello-singleton.scm" which contains a list of
+specifications and add them to the database "test.db" which is created if it
+doesn't already exist.
+
+'cuirass' then loops evaluating/building the specs.  The database keeps track
+of the specifications in order to allow users to accumulate specifications.
+To resume the evaluation/build process you can execute the same command
+without the '--specifications' option:
+
+  ./pre-inst-env cuirass --database=test.db
+
+Contributing
+============
+
+See the manual for useful hacking informations, by running
+
+  info -f doc/cuirass.info "Contributing"

bin/cuirass.in

@@ -1,90 +1,63 @@
 #!/bin/sh
 # -*- scheme -*-
+# @configure_input@
+#GUILE_LOAD_PATH="@PACKAGE_LOAD_PATH@${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
+#GUILE_LOAD_COMPILED_PATH="@PACKAGE_LOAD_COMPILED_PATH@${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
 exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
 !#
-;;;; cuirass - continuous integration system
-;;;
+;;;; cuirass -- continuous integration tool
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
-;;; Cuirass 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.
+;;; Cuirass 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.
 ;;;
-;;; Cuirass is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
-(use-modules (cuirass base)
-             (ice-9 match))
+(use-modules (cuirass)
+             (cuirass ui)
+             (cuirass utils)
+             (ice-9 getopt-long))
 
-(define %guix-repository
-  (make-parameter "git://git.savannah.gnu.org/guix.git"))
+(define (show-help)
+  (format #t "Usage: ~a [OPTIONS]~%" (%program-name))
+  (display "Run build jobs from internal database.
 
-(define* (pull-changes dir)
-  "Get the latest version of Guix repository.  Clone repository in directory
-DIR if required."
-  (or (file-exists? dir) (mkdir dir))
-  (with-directory-excursion dir
-    (let ((guixdir "guix"))
-      (or (file-exists? guixdir)
-          (system* "git" "clone" (%guix-repository) guixdir))
-      (with-directory-excursion guixdir
-        (and (zero? (system* "git" "fetch")) ;no 'git pull' to avoid merges
-             (zero? (system* "git" "reset" "--hard" "origin/master")))))))
+      --one-shot            Evaluate and build jobs only once
+      --cache-directory=DIR Use DIR for storing repository data
+  -L  --load-path=DIR       Prepend DIR to Guix package module search path.
+  -S  --specifications=SPECFILE
+                            Add specifications from SPECFILE to database.
+  -D  --database=DB         Use DB to store build results.
+  -p  --port=NUM            Port of the HTTP server.
+  -I, --interval=N          Wait N seconds between each poll
+      --use-substitutes     Allow usage of pre-built substitutes
+  -V, --version             Display version
+  -h, --help                Display this help message")
+  (newline)
+  (show-package-information))
 
-(define (compile dir)
-  "Compile files in Guix cloned repository in directory DIR."
-  (with-directory-excursion (string-append dir "/guix")
-    (or (file-exists? "configure") (system* "./bootstrap"))
-    (or (file-exists? "Makefile")
-        (system* "./configure" "--localstatedir=/var"))
-    (zero? (system* "make" "-j" (number->string (current-processor-count))))))
-
-(define %user-module
-  ;; Cuirass user module.
-  (let ((m (make-module)))
-    (beautify-user-module! m)
-    m))
-
-(define (build-packages store jobs)
-  "Build JOBS which is a list of job.  ((job-symbol pair ...) ...)"
-  (map (lambda (thing)
-         (let ((name (symbol->string (car thing)))
-               (drv  (cdadr thing)))
-           (format #t "building ~A => ~A~%" name drv)
-           ((guix-variable 'derivations 'build-derivations) store (list drv))))
-       jobs))
-
-(define (evaluate dir)
-  "Evaluate and build package derivations in directory DIR."
-  (save-module-excursion
-   (lambda ()
-     (set-current-module %user-module)
-     (primitive-load (string-append dir "/guix/build-aux/hydra/gnu-system.scm"))))
-  (let ((store ((guix-variable 'store 'open-connection))))
-    (dynamic-wind
-      (const #t)
-      (lambda ()
-        ((guix-variable 'store 'set-build-options) store
-         #:use-substitutes? #f)
-        (build-packages
-         store
-         (match ((module-ref %user-module 'hydra-jobs) store '())
-           (((names . thunks) ...)
-            (map (lambda (job thunk)
-                   (format (current-error-port) "evaluating '~a'... " job)
-                   (force-output (current-error-port))
-                   (cons job (call-with-time-display thunk)))
-                 names thunks)))))
-      (lambda ()
-        ((guix-variable 'store 'close-connection) store)))))
+(define %options
+  '((one-shot                         (value #f))
+    (cache-directory                  (value #t))
+    (load-path      (single-char #\L) (value #t))
+    (specifications (single-char #\S) (value #t))
+    (database       (single-char #\D) (value #t))
+    (port           (single-char #\p) (value #t))
+    (interval       (single-char #\I) (value #t))
+    (use-substitutes                  (value #f))
+    (version        (single-char #\V) (value #f))
+    (help           (single-char #\h) (value #f))))
 
 
 ;;;
@@ -92,12 +65,41 @@ DIR if required."
 ;;;
 
 (define* (main #:optional (args (command-line)))
-  (match args
-    ((program interval)
-     (let ((cachedir (getenv "CUIRASS_CACHEDIR")))
-       (while #t
-         (pull-changes cachedir)
-         (compile cachedir)
-         (evaluate cachedir)
-         (sleep (string->number interval)))))
-    (_ (main (list (car args) "60")))))
+  (let ((opts (getopt-long args %options)))
+    (parameterize
+        ((%program-name     (car args))
+         (%package-database (option-ref opts 'database (%package-database)))
+         (%package-cachedir
+          (option-ref opts 'cache-directory (%package-cachedir)))
+         (%guix-package-path
+          (option-ref opts 'load-path (%guix-package-path)))
+         (%use-substitutes? (option-ref opts 'use-substitutes #f)))
+      (cond
+       ((option-ref opts 'help #f)
+        (show-help)
+        (exit 0))
+       ((option-ref opts 'version #f)
+        (show-version)
+        (exit 0))
+       (else
+        (let ((one-shot? (option-ref opts 'one-shot #f))
+              (port      (string->number (option-ref opts 'port "8080")))
+              (interval  (string->number (option-ref opts 'interval "10")))
+              (specfile  (option-ref opts 'specifications #f)))
+          (with-database db
+            (and specfile
+                 (let ((new-specs (save-module-excursion
+                                   (λ ()
+                                     (set-current-module (make-user-module))
+                                     (primitive-load specfile)))))
+                   (for-each (λ (spec) (db-add-specification db spec))
+                             new-specs)))
+            (if one-shot?
+                (process-specs db (db-get-specifications db))
+                (begin
+                  (call-with-new-thread
+                   (λ ()
+                     (while #t
+                       (process-specs db (db-get-specifications db))
+                       (sleep interval))))
+                  (run-cuirass-server db #:port port))))))))))

bin/evaluate.in

@@ -0,0 +1,87 @@
+#!/bin/sh
+# -*- scheme -*-
+# @configure_input@
+GUILE_LOAD_PATH="$1${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
+export GUILE_LOAD_PATH
+exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
+!#
+;;;; evaluate -- convert a specification to a job list
+;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (cuirass)
+             (cuirass utils)
+             (ice-9 match)
+             (ice-9 pretty-print)
+             (guix store))
+
+(define* (main #:optional (args (command-line)))
+  (match args
+    ((command load-path guix-package-path cachedir specstr database)
+     ;; Load FILE, a Scheme file that defines Hydra jobs.
+     (let ((%user-module (make-fresh-user-module))
+           (spec         (with-input-from-string specstr read))
+           (stdout       (current-output-port))
+           (stderr       (current-error-port)))
+       (save-module-excursion
+        (λ ()
+          (set-current-module %user-module)
+          (with-directory-excursion
+              (string-append cachedir "/" (assq-ref spec #:name))
+            (primitive-load (assq-ref spec #:file)))))
+       (with-store store
+         (unless (assoc-ref spec #:use-substitutes?)
+           ;; Make sure we don't resort to substitutes.
+           (set-build-options store #:use-substitutes? #f #:substitute-urls '()))
+         ;; Grafts can trigger early builds.  We do not want that to happen
+         ;; during evaluation, so use a sledgehammer to catch such problems.
+         (set! build-things
+               (λ (store . args)
+                 (display "error: trying to build things during evaluation!~%"
+                          stderr)
+                 (simple-format stderr "'build-things' arguments: ~S~%" args)
+                 (exit 1)))
+         (parameterize ((%package-database database)
+                        (%use-substitutes? (assoc-ref spec #:use-substitutes?)))
+           (unless (string-null? guix-package-path)
+             (set-guix-package-path! guix-package-path))
+           ;; Call the entry point of FILE and print the resulting job sexp.
+           (let* ((proc-name (assq-ref spec #:proc))
+                  (proc    (module-ref %user-module proc-name))
+                  (thunks  (proc store (assq-ref spec #:arguments)))
+                  (db      (db-open))
+                  (commit  (assq-ref spec #:current-commit))
+                  (eval    `((#:specification . ,(assq-ref spec #:name))
+                             (#:revision . ,commit)))
+                  (eval-id (db-add-evaluation db eval)))
+             (pretty-print
+              (map (λ (thunk)
+                     (let* ((job  (call-with-time-display thunk))
+                            ;; Keep track of SPEC id in the returned jobs.
+                            (job* (acons #:eval-id eval-id job)))
+                       (db-add-derivation db job*)
+                       job*))
+                   thunks)
+              stdout)
+             (db-close db))))))
+    ((command _ ...)
+     (simple-format (current-error-port) "Usage: ~A FILE
+Evaluate the Hydra jobs defined in FILE.~%"
+                    command)
+     (exit 1))))

bootstrap

@@ -0,0 +1,5 @@
+#!/bin/sh
+# Initialize the build system.
+
+set -e -x
+exec autoreconf -vfi

build-aux/git-version-gen

@@ -0,0 +1,226 @@
+#!/bin/sh
+# Print a version string.
+scriptversion=2016-12-25.10; # UTC
+
+# Copyright (C) 2007-2016 Free Software Foundation, Inc.
+#
+# This program 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.
+#
+# This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+# This script is derived from GIT-VERSION-GEN from GIT: http://git.or.cz/.
+# It may be run two ways:
+# - from a git repository in which the "git describe" command below
+#   produces useful output (thus requiring at least one signed tag)
+# - from a non-git-repo directory containing a .tarball-version file, which
+#   presumes this script is invoked like "./git-version-gen .tarball-version".
+
+# In order to use intra-version strings in your project, you will need two
+# separate generated version string files:
+#
+# .tarball-version - present only in a distribution tarball, and not in
+#   a checked-out repository.  Created with contents that were learned at
+#   the last time autoconf was run, and used by git-version-gen.  Must not
+#   be present in either $(srcdir) or $(builddir) for git-version-gen to
+#   give accurate answers during normal development with a checked out tree,
+#   but must be present in a tarball when there is no version control system.
+#   Therefore, it cannot be used in any dependencies.  GNUmakefile has
+#   hooks to force a reconfigure at distribution time to get the value
+#   correct, without penalizing normal development with extra reconfigures.
+#
+# .version - present in a checked-out repository and in a distribution
+#   tarball.  Usable in dependencies, particularly for files that don't
+#   want to depend on config.h but do want to track version changes.
+#   Delete this file prior to any autoconf run where you want to rebuild
+#   files to pick up a version string change; and leave it stale to
+#   minimize rebuild time after unrelated changes to configure sources.
+#
+# As with any generated file in a VC'd directory, you should add
+# /.version to .gitignore, so that you don't accidentally commit it.
+# .tarball-version is never generated in a VC'd directory, so needn't
+# be listed there.
+#
+# Use the following line in your configure.ac, so that $(VERSION) will
+# automatically be up-to-date each time configure is run (and note that
+# since configure.ac no longer includes a version string, Makefile rules
+# should not depend on configure.ac for version updates).
+#
+# AC_INIT([GNU project],
+#         m4_esyscmd([build-aux/git-version-gen .tarball-version]),
+#         [bug-project@example])
+#
+# Then use the following lines in your Makefile.am, so that .version
+# will be present for dependencies, and so that .version and
+# .tarball-version will exist in distribution tarballs.
+#
+# EXTRA_DIST = $(top_srcdir)/.version
+# BUILT_SOURCES = $(top_srcdir)/.version
+# $(top_srcdir)/.version:
+#	echo $(VERSION) > $@-t && mv $@-t $@
+# dist-hook:
+#	echo $(VERSION) > $(distdir)/.tarball-version
+
+
+me=$0
+
+version="git-version-gen $scriptversion
+
+Copyright 2011 Free Software Foundation, Inc.
+There is NO warranty.  You may redistribute this software
+under the terms of the GNU General Public License.
+For more information about these matters, see the files named COPYING."
+
+usage="\
+Usage: $me [OPTION]... \$srcdir/.tarball-version [TAG-NORMALIZATION-SED-SCRIPT]
+Print a version string.
+
+Options:
+
+   --prefix PREFIX    prefix of git tags (default 'v')
+   --fallback VERSION
+                      fallback version to use if \"git --version\" fails
+
+   --help             display this help and exit
+   --version          output version information and exit
+
+Running without arguments will suffice in most cases."
+
+prefix=v
+fallback=
+
+while test $# -gt 0; do
+  case $1 in
+    --help) echo "$usage"; exit 0;;
+    --version) echo "$version"; exit 0;;
+    --prefix) shift; prefix=${1?};;
+    --fallback) shift; fallback=${1?};;
+    -*)
+      echo "$0: Unknown option '$1'." >&2
+      echo "$0: Try '--help' for more information." >&2
+      exit 1;;
+    *)
+      if test "x$tarball_version_file" = x; then
+        tarball_version_file="$1"
+      elif test "x$tag_sed_script" = x; then
+        tag_sed_script="$1"
+      else
+        echo "$0: extra non-option argument '$1'." >&2
+        exit 1
+      fi;;
+  esac
+  shift
+done
+
+if test "x$tarball_version_file" = x; then
+    echo "$usage"
+    exit 1
+fi
+
+tag_sed_script="${tag_sed_script:-s/x/x/}"
+
+nl='
+'
+
+# Avoid meddling by environment variable of the same name.
+v=
+v_from_git=
+
+# First see if there is a tarball-only version file.
+# then try "git describe", then default.
+if test -f $tarball_version_file
+then
+    v=`cat $tarball_version_file` || v=
+    case $v in
+        *$nl*) v= ;; # reject multi-line output
+        [0-9]*) ;;
+        *) v= ;;
+    esac
+    test "x$v" = x \
+        && echo "$0: WARNING: $tarball_version_file is missing or damaged" 1>&2
+fi
+
+if test "x$v" != x
+then
+    : # use $v
+# Otherwise, if there is at least one git commit involving the working
+# directory, and "git describe" output looks sensible, use that to
+# derive a version string.
+elif test "`git log -1 --pretty=format:x . 2>&1`" = x \
+    && v=`git describe --abbrev=4 --match="$prefix*" HEAD 2>/dev/null \
+          || git describe --abbrev=4 HEAD 2>/dev/null` \
+    && v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \
+    && case $v in
+         $prefix[0-9]*) ;;
+         *) (exit 1) ;;
+       esac
+then
+    # Is this a new git that lists number of commits since the last
+    # tag or the previous older version that did not?
+    #   Newer: v6.10-77-g0f8faeb
+    #   Older: v6.10-g0f8faeb
+    case $v in
+        *-*-*) : git describe is okay three part flavor ;;
+        *-*)
+            : git describe is older two part flavor
+            # Recreate the number of commits and rewrite such that the
+            # result is the same as if we were using the newer version
+            # of git describe.
+            vtag=`echo "$v" | sed 's/-.*//'`
+            commit_list=`git rev-list "$vtag"..HEAD 2>/dev/null` \
+                || { commit_list=failed;
+                     echo "$0: WARNING: git rev-list failed" 1>&2; }
+            numcommits=`echo "$commit_list" | wc -l`
+            v=`echo "$v" | sed "s/\(.*\)-\(.*\)/\1-$numcommits-\2/"`;
+            test "$commit_list" = failed && v=UNKNOWN
+            ;;
+    esac
+
+    # Change the first '-' to a '.', so version-comparing tools work properly.
+    # Remove the "g" in git describe's output string, to save a byte.
+    v=`echo "$v" | sed 's/-/./;s/\(.*\)-g/\1-/'`;
+    v_from_git=1
+elif test "x$fallback" = x || git --version >/dev/null 2>&1; then
+    v=UNKNOWN
+else
+    v=$fallback
+fi
+
+v=`echo "$v" |sed "s/^$prefix//"`
+
+# Test whether to append the "-dirty" suffix only if the version
+# string we're using came from git.  I.e., skip the test if it's "UNKNOWN"
+# or if it came from .tarball-version.
+if test "x$v_from_git" != x; then
+  # Don't declare a version "dirty" merely because a time stamp has changed.
+  git update-index --refresh > /dev/null 2>&1
+
+  dirty=`exec 2>/dev/null;git diff-index --name-only HEAD` || dirty=
+  case "$dirty" in
+      '') ;;
+      *) # Append the suffix only if there isn't one already.
+          case $v in
+            *-dirty) ;;
+            *) v="$v-dirty" ;;
+          esac ;;
+  esac
+fi
+
+# Omit the trailing newline, so that m4_esyscmd can use the result directly.
+printf %s "$v"
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "scriptversion="
+# time-stamp-format: "%:y-%02m-%02d.%02H"
+# time-stamp-time-zone: "UTC0"
+# time-stamp-end: "; # UTC"
+# End:

build-aux/guix.scm

@@ -0,0 +1,96 @@
+;;;; guix.scm -- Guix package definition
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (ice-9 popen)
+             (ice-9 rdelim)
+             (gnu)
+             (guix)
+             (srfi srfi-1))
+
+(define (keep-cuirass-file? file stat)
+  ;; Return #t if FILE in Cuirass repository must be kept, #f otherwise. FILE
+  ;; is an absolute file name and STAT is the result of 'lstat' applied to
+  ;; FILE.
+  (not (or (any (λ (str) (string-contains file str))
+                '(".git" "autom4te" "Makefile.in" ".go" ".log"
+                  "stamp-vti" ".dirstamp"))
+           (any (λ (str) (string-suffix? str file))
+                '("trs""configure" "Makefile" "config.status" "pre-inst-env"
+                  "aclocal.m4" "bin/cuirass" "bin/evaluate" "config.cache"
+                  "guix.scm")))))
+
+(define %aux-dir
+  (current-source-directory))
+
+(define %srcdir
+  (dirname %aux-dir))
+
+(define (git-version-gen)
+  ;; Return a string containing Cuirass version number.
+  (let* ((cmd  "git-version-gen .tarball-version")
+         (port (open-input-pipe (string-append %aux-dir "/" cmd)))
+         (str  (read-line port)))
+    (close-pipe port)
+    str))
+
+(define (spec+package-list spec)
+  (list spec (specification->package spec)))
+
+(package
+  (inherit (specification->package "cuirass"))
+  (version (git-version-gen))
+  (source (local-file %srcdir #:recursive? #t
+                      #:select? keep-cuirass-file?))
+  (arguments
+   '(#:phases
+     (modify-phases %standard-phases
+       (add-after 'unpack 'disable-repo-tests
+         ;; Disable tests that use a connection to the Guix daemon.
+         (λ _
+           (substitute* "Makefile.am"
+             (("tests/repo.scm \\\\") "\\"))
+           #t))
+       (add-before 'configure 'bootstrap
+         (λ _ (zero? (system* "sh" "bootstrap"))))
+       (add-after 'install 'wrap-program
+         (lambda* (#:key inputs outputs #:allow-other-keys)
+           ;; Wrap the 'cuirass' command to refer to the right modules.
+           (let* ((out    (assoc-ref outputs "out"))
+                  (json   (assoc-ref inputs "guile-json"))
+                  (sqlite (assoc-ref inputs "guile-sqlite3"))
+                  (guix   (assoc-ref inputs "guix"))
+                  (mods   (string-append json "/share/guile/site/2.0:"
+                                         sqlite "/share/guile/site/2.0:"
+                                         guix "/share/guile/site/2.0")))
+             (wrap-program (string-append out "/bin/cuirass")
+               `("GUILE_LOAD_PATH" ":" prefix (,mods))
+               `("GUILE_LOAD_COMPILED_PATH" ":" prefix (,mods)))))))))
+  (inputs
+   (map spec+package-list
+        '("guile@2.0"
+          "guile-json"
+          "guile-sqlite3"
+          "guix")))
+  (native-inputs
+   (map spec+package-list
+        '("autoconf"
+          "automake"
+          "bash"
+          "pkg-config"
+          "texinfo"))))

build-aux/pre-inst-env.in

@@ -22,17 +22,12 @@ abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`"
 
 GUILE_LOAD_COMPILED_PATH="$abs_top_builddir/src${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
 GUILE_LOAD_PATH="$abs_top_builddir/src:$abs_top_srcdir/src${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
+export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
+
+CUIRASS_DATADIR="$abs_top_srcdir/src"
+export CUIRASS_DATADIR
 
 PATH="$abs_top_builddir/bin:$PATH"
 export PATH
 
-CUIRASS_CACHEDIR="$abs_top_builddir/cache"
-export CUIRASS_CACHEDIR
-
-# Append Guix cloned repository to Guile load paths.
-guixdir="$CUIRASS_CACHEDIR/guix"
-GUILE_LOAD_COMPILED_PATH="$guixdir:$GUILE_LOAD_COMPILED_PATH"
-GUILE_LOAD_PATH="$guixdir:$GUILE_LOAD_PATH"
-export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
-
 exec "$@"

configure.ac

@@ -1,12 +1,37 @@
+## Process this file with autoconf to produce a configure script.
+
+# Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
+#
+# This file is part of Cuirass.
+#
+# Cuirass 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, or (at your option)
+# any later version.
+#
+# Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
 AC_PREREQ([2.61])
-AC_INIT([Cuirass], [0.0.1], [bug-guix@gnu.org])
+AC_INIT([Cuirass],
+  m4_esyscmd([build-aux/git-version-gen .tarball-version]),
+  [bug-cuirass@framalistes.org], [cuirass],
+  [https://notabug.org/mthl/cuirass/])
 AC_CONFIG_SRCDIR([bin/cuirass.in])
 AC_CONFIG_AUX_DIR([build-aux])
+AC_REQUIRE_AUX_FILE([git-version-gen])
 AC_REQUIRE_AUX_FILE([test-driver.scm])
 AM_INIT_AUTOMAKE([foreign subdir-objects -Wall])
 AM_SILENT_RULES([yes])		# enables silent rules by default
 
 AC_CANONICAL_HOST
+AC_PROG_MKDIR_P
+AC_PROG_SED
 
 PKG_CHECK_MODULES([GUILE], [guile-2.0 >= 2.0.7])
 AC_PATH_PROG([GUILE], [guile])
@@ -14,13 +39,11 @@ AC_PATH_PROG([GUILD], [guild])
 AS_IF([test -z "$ac_cv_path_GUILD"],
   [AC_MSG_ERROR(['guild' program cannot be found.])])
 
-moduledir="${datarootdir}/guile/site/2.0"
-pkgmoduledir="${moduledir}/cuirass"
-AC_SUBST([moduledir])
-AC_SUBST([pkgmoduledir])
+GUILE_MODULE_REQUIRED([guix])
+GUILE_MODULE_REQUIRED([json])
+GUILE_MODULE_REQUIRED([sqlite3])
 
 AC_CONFIG_FILES([Makefile])
-AC_CONFIG_FILES([bin/cuirass], [chmod +x bin/cuirass])
 AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in],
   [chmod +x pre-inst-env])
 AC_OUTPUT

doc/cuirass.texi

@@ -0,0 +1,227 @@
+\input texinfo
+@setfilename cuirass.info
+@documentencoding UTF-8
+@include version.texi
+@settitle Cuirass Reference Manual
+@setchapternewpage odd
+
+@copying
+
+This manual is for Cuirass version @value{VERSION}, a build automation
+server.
+
+Copyright @copyright{} 2016, 2017 Mathieu Lirzin
+
+@quotation
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.  A
+copy of the license is included in the section entitled ``GNU Free
+Documentation License''.
+@end quotation
+@end copying
+
+@dircategory Software development
+@direntry
+* Cuirass: (cuirass).       Build automation server.
+@end direntry
+
+@titlepage
+@title Cuirass Reference Manual
+@subtitle Build automation server
+@subtitle for version @value{VERSION}, @value{UPDATED}
+@author by Mathieu Lirzin
+
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@contents
+
+@ifnottex
+@node Top
+@top Cuirass
+@insertcopying
+@end ifnottex
+
+@c *********************************************************************
+@menu
+* Introduction::                What is Cuirass about?
+
+Tutorial sections:
+* Overview::                    A quick tour of Cuirass
+
+Reference sections:
+* Invocation::                  How to run Cuirass.
+
+* Contributing::                Your help needed!
+* GNU Free Documentation License::  The license of this manual.
+* Concept Index::               Concepts.
+
+@end menu
+
+@c *********************************************************************
+@node Introduction
+@unnumbered Introduction
+@cindex introduction
+
+@dfn{Cuirass} is a general-purpose build automation server that checks
+out source files from @acronym{VCS, Version Control System}
+repositories, executes a @dfn{build job}, and notifies the results of
+that job.  A build job consists of a combinaison of tasks such as
+compiling source code to binary code and running automated tests.
+Notification is achieved by using a database that stores the build
+results associated with an HTTP server that provides a convenient way to
+access them.
+
+Cuirass is inspired by the @url{https://nixos.org/hydra/, Hydra}
+continuous build system. Unlike Hydra, it is built on top of the
+@url{https://www.gnu.org/software/guix/, GNU Guix} functional package
+manager.
+
+The goal of Cuirass is to provide both on-demand, scheduled, and
+triggered builds.  A Build server is an important tool in the software
+development process, because it allows modifying the source code while
+ensuring the portability and robustness of those changes.  It is the
+basis of the @dfn{Continuous integration} practice.
+
+@menu
+* Continuous Integration::      A Software development practice
+@end menu
+
+@c *********************************************************************
+@node Continuous Integration
+@unnumberedsec Continuous Integration
+
+@c *********************************************************************
+@node Overview
+@chapter Overview
+
+@command{cuirass} acts as a daemon polling @acronym{VCS, version control
+system} repositories for changes, and evaluating a derivation when
+something has changed (@pxref{Derivations, Derivations,, guix, Guix}).
+As a final step the derivation is realised and the result of that build
+allows you to know if the job succeed or not.
+
+What is actually done by @command{cuirass} is specified in a @dfn{job
+specification} which is represented as an association list which is a
+basic and traditional Scheme data structure.  Here is an example of what
+a specification might look like:
+
+@lisp
+ `((#:name . "hello")
+   (#:url . "git://git.savannah.gnu.org/guix.git")
+   (#:branch . "master")
+   (#:no-compile? . #t)
+   (#:load-path . ".")
+   (#:proc . cuirass-jobs)
+   (#:file . "/tmp/drv-file.scm")
+   (#:arguments (subset . "hello")))
+@end lisp
+
+In this specification the keys are Scheme keywords which have the nice
+property of being self evaluating.  This means that they can't refer to
+another value like symbols do.
+
+Currently the only way to add those specifications to cuirass is to put
+a list of them in a file and set the @code{--specifications} command
+line option argument with the file name when launching the daemon
+(@pxref{Invocation}).  The specifications are persistent (they are kept
+in a SQLite database) so the next time @command{cuirass} is run the
+previously added specifications will remain active even if you don't
+keep the @code{--specifications} option.
+
+@c *********************************************************************
+@node Invocation
+@chapter Invoking cuirass
+@cindex invoking cuirass
+@cindex cuirass invocation
+@cindex options for invoking cuirass
+
+The usual way to invoke @code{cuirass} is as follows:
+
+@example
+cuirass --specifications @var{specs}
+@end example
+
+Additionally the following options can be used.
+
+@table @code
+@item --one-shot
+Instead of executing @code{cuirass} as a daemon looping over the jobs.
+Only evaluate and build the specifications once.
+
+@item --cache-directory=@var{directory}
+@var{directory} is the place where the VCS repositories used by the jobs
+are stored.
+
+@item --specifications=@var{specifications-file}
+@itemx -S @var{specifications-file}
+Add the specifications defined in @var{specifications-file} in the job
+database before launching the evaluation and build processes.
+
+@item --database=@var{database}
+@itemx -D @var{database}
+Use @var{database} as the database containing the jobs and the past
+build results. Since @code{cuirass} uses SQLite as a database engine,
+@var{database} must be a file name.  If the file doesn't exist, it will
+be created.
+
+@item --port=@var{num}
+@itemx -p @var{num}
+Make the HTTP interface listen on port @var{num}.  Use port 8080 by
+default.
+
+@item --interval=@var{n}
+@itemx -I @var{n}
+Wait @var{n} seconds between each poll.
+
+@item --use-substitutes
+This can be useful when you are not interested in building the
+dependencies of a particular job.
+
+@item --version
+@itemx -V
+Display the actual version of @code{cuirass}.
+
+@item --help
+@itemx -h
+Display an help message that summarize all the options provided.
+@end table
+
+@c *********************************************************************
+@node Contributing
+@chapter Contributing
+
+Everyone is welcome to contribute to Cuirass.  You can report bugs, send
+patches and share your ideas with others by sending emails the
+@email{bug-cuirass@@framalistes.org, mailing list}.
+
+Development is done using the Git distributed version control system.
+Thus, access to the repository is not strictly necessary.  We welcome
+contributions in the form of patches as produced by @code{git
+format-patch}.  Please write commit logs in the ChangeLog format
+(@pxref{Change Logs,,, standards, GNU Coding Standards}); you can check
+the commit history for examples.
+
+When posting a patch to the mailing list, use @samp{[PATCH] @dots{}} as
+a subject.  You may use your email client or the @command{git
+send-email} command.  We prefer to get patches in plain text messages,
+either inline or as MIME attachments.  You are advised to pay attention
+if your email client changes anything like line breaks or indentation
+which could potentially break the patches.
+
+@c *********************************************************************
+@node GNU Free Documentation License
+@appendix GNU Free Documentation License
+@cindex license, GNU Free Documentation License
+@include fdl-1.3.texi
+
+@c *********************************************************************
+@node Concept Index
+@unnumbered Concept Index
+@printindex cp
+
+@bye

doc/fdl-1.3.texi

@@ -0,0 +1,505 @@
+@c The GNU Free Documentation License.
+@center Version 1.3, 3 November 2008
+
+@c This file is intended to be included within another document,
+@c hence no sectioning command or @node.
+
+@display
+Copyright @copyright{} 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc.
+@uref{http://fsf.org/}
+
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+@end display
+
+@enumerate 0
+@item
+PREAMBLE
+
+The purpose of this License is to make a manual, textbook, or other
+functional and useful document @dfn{free} in the sense of freedom: to
+assure everyone the effective freedom to copy and redistribute it,
+with or without modifying it, either commercially or noncommercially.
+Secondarily, this License preserves for the author and publisher a way
+to get credit for their work, while not being considered responsible
+for modifications made by others.
+
+This License is a kind of ``copyleft'', which means that derivative
+works of the document must themselves be free in the same sense.  It
+complements the GNU General Public License, which is a copyleft
+license designed for free software.
+
+We have designed this License in order to use it for manuals for free
+software, because free software needs free documentation: a free
+program should come with manuals providing the same freedoms that the
+software does.  But this License is not limited to software manuals;
+it can be used for any textual work, regardless of subject matter or
+whether it is published as a printed book.  We recommend this License
+principally for works whose purpose is instruction or reference.
+
+@item
+APPLICABILITY AND DEFINITIONS
+
+This License applies to any manual or other work, in any medium, that
+contains a notice placed by the copyright holder saying it can be
+distributed under the terms of this License.  Such a notice grants a
+world-wide, royalty-free license, unlimited in duration, to use that
+work under the conditions stated herein.  The ``Document'', below,
+refers to any such manual or work.  Any member of the public is a
+licensee, and is addressed as ``you''.  You accept the license if you
+copy, modify or distribute the work in a way requiring permission
+under copyright law.
+
+A ``Modified Version'' of the Document means any work containing the
+Document or a portion of it, either copied verbatim, or with
+modifications and/or translated into another language.
+
+A ``Secondary Section'' is a named appendix or a front-matter section
+of the Document that deals exclusively with the relationship of the
+publishers or authors of the Document to the Document's overall
+subject (or to related matters) and contains nothing that could fall
+directly within that overall subject.  (Thus, if the Document is in
+part a textbook of mathematics, a Secondary Section may not explain
+any mathematics.)  The relationship could be a matter of historical
+connection with the subject or with related matters, or of legal,
+commercial, philosophical, ethical or political position regarding
+them.
+
+The ``Invariant Sections'' are certain Secondary Sections whose titles
+are designated, as being those of Invariant Sections, in the notice
+that says that the Document is released under this License.  If a
+section does not fit the above definition of Secondary then it is not
+allowed to be designated as Invariant.  The Document may contain zero
+Invariant Sections.  If the Document does not identify any Invariant
+Sections then there are none.
+
+The ``Cover Texts'' are certain short passages of text that are listed,
+as Front-Cover Texts or Back-Cover Texts, in the notice that says that
+the Document is released under this License.  A Front-Cover Text may
+be at most 5 words, and a Back-Cover Text may be at most 25 words.
+
+A ``Transparent'' copy of the Document means a machine-readable copy,
+represented in a format whose specification is available to the
+general public, that is suitable for revising the document
+straightforwardly with generic text editors or (for images composed of
+pixels) generic paint programs or (for drawings) some widely available
+drawing editor, and that is suitable for input to text formatters or
+for automatic translation to a variety of formats suitable for input
+to text formatters.  A copy made in an otherwise Transparent file
+format whose markup, or absence of markup, has been arranged to thwart
+or discourage subsequent modification by readers is not Transparent.
+An image format is not Transparent if used for any substantial amount
+of text.  A copy that is not ``Transparent'' is called ``Opaque''.
+
+Examples of suitable formats for Transparent copies include plain
+ASCII without markup, Texinfo input format, La@TeX{} input
+format, SGML or XML using a publicly available
+DTD, and standard-conforming simple HTML,
+PostScript or PDF designed for human modification.  Examples
+of transparent image formats include PNG, XCF and
+JPG@.  Opaque formats include proprietary formats that can be
+read and edited only by proprietary word processors, SGML or
+XML for which the DTD and/or processing tools are
+not generally available, and the machine-generated HTML,
+PostScript or PDF produced by some word processors for
+output purposes only.
+
+The ``Title Page'' means, for a printed book, the title page itself,
+plus such following pages as are needed to hold, legibly, the material
+this License requires to appear in the title page.  For works in
+formats which do not have any title page as such, ``Title Page'' means
+the text near the most prominent appearance of the work's title,
+preceding the beginning of the body of the text.
+
+The ``publisher'' means any person or entity that distributes copies
+of the Document to the public.
+
+A section ``Entitled XYZ'' means a named subunit of the Document whose
+title either is precisely XYZ or contains XYZ in parentheses following
+text that translates XYZ in another language.  (Here XYZ stands for a
+specific section name mentioned below, such as ``Acknowledgements'',
+``Dedications'', ``Endorsements'', or ``History''.)  To ``Preserve the Title''
+of such a section when you modify the Document means that it remains a
+section ``Entitled XYZ'' according to this definition.
+
+The Document may include Warranty Disclaimers next to the notice which
+states that this License applies to the Document.  These Warranty
+Disclaimers are considered to be included by reference in this
+License, but only as regards disclaiming warranties: any other
+implication that these Warranty Disclaimers may have is void and has
+no effect on the meaning of this License.
+
+@item
+VERBATIM COPYING
+
+You may copy and distribute the Document in any medium, either
+commercially or noncommercially, provided that this License, the
+copyright notices, and the license notice saying this License applies
+to the Document are reproduced in all copies, and that you add no other
+conditions whatsoever to those of this License.  You may not use
+technical measures to obstruct or control the reading or further
+copying of the copies you make or distribute.  However, you may accept
+compensation in exchange for copies.  If you distribute a large enough
+number of copies you must also follow the conditions in section 3.
+
+You may also lend copies, under the same conditions stated above, and
+you may publicly display copies.
+
+@item
+COPYING IN QUANTITY
+
+If you publish printed copies (or copies in media that commonly have
+printed covers) of the Document, numbering more than 100, and the
+Document's license notice requires Cover Texts, you must enclose the
+copies in covers that carry, clearly and legibly, all these Cover
+Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
+the back cover.  Both covers must also clearly and legibly identify
+you as the publisher of these copies.  The front cover must present
+the full title with all words of the title equally prominent and
+visible.  You may add other material on the covers in addition.
+Copying with changes limited to the covers, as long as they preserve
+the title of the Document and satisfy these conditions, can be treated
+as verbatim copying in other respects.
+
+If the required texts for either cover are too voluminous to fit
+legibly, you should put the first ones listed (as many as fit
+reasonably) on the actual cover, and continue the rest onto adjacent
+pages.
+
+If you publish or distribute Opaque copies of the Document numbering
+more than 100, you must either include a machine-readable Transparent
+copy along with each Opaque copy, or state in or with each Opaque copy
+a computer-network location from which the general network-using
+public has access to download using public-standard network protocols
+a complete Transparent copy of the Document, free of added material.
+If you use the latter option, you must take reasonably prudent steps,
+when you begin distribution of Opaque copies in quantity, to ensure
+that this Transparent copy will remain thus accessible at the stated
+location until at least one year after the last time you distribute an
+Opaque copy (directly or through your agents or retailers) of that
+edition to the public.
+
+It is requested, but not required, that you contact the authors of the
+Document well before redistributing any large number of copies, to give
+them a chance to provide you with an updated version of the Document.
+
+@item
+MODIFICATIONS
+
+You may copy and distribute a Modified Version of the Document under
+the conditions of sections 2 and 3 above, provided that you release
+the Modified Version under precisely this License, with the Modified
+Version filling the role of the Document, thus licensing distribution
+and modification of the Modified Version to whoever possesses a copy
+of it.  In addition, you must do these things in the Modified Version:
+
+@enumerate A
+@item
+Use in the Title Page (and on the covers, if any) a title distinct
+from that of the Document, and from those of previous versions
+(which should, if there were any, be listed in the History section
+of the Document).  You may use the same title as a previous version
+if the original publisher of that version gives permission.
+
+@item
+List on the Title Page, as authors, one or more persons or entities
+responsible for authorship of the modifications in the Modified
+Version, together with at least five of the principal authors of the
+Document (all of its principal authors, if it has fewer than five),
+unless they release you from this requirement.
+
+@item
+State on the Title page the name of the publisher of the
+Modified Version, as the publisher.
+
+@item
+Preserve all the copyright notices of the Document.
+
+@item
+Add an appropriate copyright notice for your modifications
+adjacent to the other copyright notices.
+
+@item
+Include, immediately after the copyright notices, a license notice
+giving the public permission to use the Modified Version under the
+terms of this License, in the form shown in the Addendum below.
+
+@item
+Preserve in that license notice the full lists of Invariant Sections
+and required Cover Texts given in the Document's license notice.
+
+@item
+Include an unaltered copy of this License.
+
+@item
+Preserve the section Entitled ``History'', Preserve its Title, and add
+to it an item stating at least the title, year, new authors, and
+publisher of the Modified Version as given on the Title Page.  If
+there is no section Entitled ``History'' in the Document, create one
+stating the title, year, authors, and publisher of the Document as
+given on its Title Page, then add an item describing the Modified
+Version as stated in the previous sentence.
+
+@item
+Preserve the network location, if any, given in the Document for
+public access to a Transparent copy of the Document, and likewise
+the network locations given in the Document for previous versions
+it was based on.  These may be placed in the ``History'' section.
+You may omit a network location for a work that was published at
+least four years before the Document itself, or if the original
+publisher of the version it refers to gives permission.
+
+@item
+For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve
+the Title of the section, and preserve in the section all the
+substance and tone of each of the contributor acknowledgements and/or
+dedications given therein.
+
+@item
+Preserve all the Invariant Sections of the Document,
+unaltered in their text and in their titles.  Section numbers
+or the equivalent are not considered part of the section titles.
+
+@item
+Delete any section Entitled ``Endorsements''.  Such a section
+may not be included in the Modified Version.
+
+@item
+Do not retitle any existing section to be Entitled ``Endorsements'' or
+to conflict in title with any Invariant Section.
+
+@item
+Preserve any Warranty Disclaimers.
+@end enumerate
+
+If the Modified Version includes new front-matter sections or
+appendices that qualify as Secondary Sections and contain no material
+copied from the Document, you may at your option designate some or all
+of these sections as invariant.  To do this, add their titles to the
+list of Invariant Sections in the Modified Version's license notice.
+These titles must be distinct from any other section titles.
+
+You may add a section Entitled ``Endorsements'', provided it contains
+nothing but endorsements of your Modified Version by various
+parties---for example, statements of peer review or that the text has
+been approved by an organization as the authoritative definition of a
+standard.
+
+You may add a passage of up to five words as a Front-Cover Text, and a
+passage of up to 25 words as a Back-Cover Text, to the end of the list
+of Cover Texts in the Modified Version.  Only one passage of
+Front-Cover Text and one of Back-Cover Text may be added by (or
+through arrangements made by) any one entity.  If the Document already
+includes a cover text for the same cover, previously added by you or
+by arrangement made by the same entity you are acting on behalf of,
+you may not add another; but you may replace the old one, on explicit
+permission from the previous publisher that added the old one.
+
+The author(s) and publisher(s) of the Document do not by this License
+give permission to use their names for publicity for or to assert or
+imply endorsement of any Modified Version.
+
+@item
+COMBINING DOCUMENTS
+
+You may combine the Document with other documents released under this
+License, under the terms defined in section 4 above for modified
+versions, provided that you include in the combination all of the
+Invariant Sections of all of the original documents, unmodified, and
+list them all as Invariant Sections of your combined work in its
+license notice, and that you preserve all their Warranty Disclaimers.
+
+The combined work need only contain one copy of this License, and
+multiple identical Invariant Sections may be replaced with a single
+copy.  If there are multiple Invariant Sections with the same name but
+different contents, make the title of each such section unique by
+adding at the end of it, in parentheses, the name of the original
+author or publisher of that section if known, or else a unique number.
+Make the same adjustment to the section titles in the list of
+Invariant Sections in the license notice of the combined work.
+
+In the combination, you must combine any sections Entitled ``History''
+in the various original documents, forming one section Entitled
+``History''; likewise combine any sections Entitled ``Acknowledgements'',
+and any sections Entitled ``Dedications''.  You must delete all
+sections Entitled ``Endorsements.''
+
+@item
+COLLECTIONS OF DOCUMENTS
+
+You may make a collection consisting of the Document and other documents
+released under this License, and replace the individual copies of this
+License in the various documents with a single copy that is included in
+the collection, provided that you follow the rules of this License for
+verbatim copying of each of the documents in all other respects.
+
+You may extract a single document from such a collection, and distribute
+it individually under this License, provided you insert a copy of this
+License into the extracted document, and follow this License in all
+other respects regarding verbatim copying of that document.
+
+@item
+AGGREGATION WITH INDEPENDENT WORKS
+
+A compilation of the Document or its derivatives with other separate
+and independent documents or works, in or on a volume of a storage or
+distribution medium, is called an ``aggregate'' if the copyright
+resulting from the compilation is not used to limit the legal rights
+of the compilation's users beyond what the individual works permit.
+When the Document is included in an aggregate, this License does not
+apply to the other works in the aggregate which are not themselves
+derivative works of the Document.
+
+If the Cover Text requirement of section 3 is applicable to these
+copies of the Document, then if the Document is less than one half of
+the entire aggregate, the Document's Cover Texts may be placed on
+covers that bracket the Document within the aggregate, or the
+electronic equivalent of covers if the Document is in electronic form.
+Otherwise they must appear on printed covers that bracket the whole
+aggregate.
+
+@item
+TRANSLATION
+
+Translation is considered a kind of modification, so you may
+distribute translations of the Document under the terms of section 4.
+Replacing Invariant Sections with translations requires special
+permission from their copyright holders, but you may include
+translations of some or all Invariant Sections in addition to the
+original versions of these Invariant Sections.  You may include a
+translation of this License, and all the license notices in the
+Document, and any Warranty Disclaimers, provided that you also include
+the original English version of this License and the original versions
+of those notices and disclaimers.  In case of a disagreement between
+the translation and the original version of this License or a notice
+or disclaimer, the original version will prevail.
+
+If a section in the Document is Entitled ``Acknowledgements'',
+``Dedications'', or ``History'', the requirement (section 4) to Preserve
+its Title (section 1) will typically require changing the actual
+title.
+
+@item
+TERMINATION
+
+You may not copy, modify, sublicense, or distribute the Document
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense, or distribute it is void, and
+will automatically terminate your rights under this License.
+
+However, if you cease all violation of this License, then your license
+from a particular copyright holder is reinstated (a) provisionally,
+unless and until the copyright holder explicitly and finally
+terminates your license, and (b) permanently, if the copyright holder
+fails to notify you of the violation by some reasonable means prior to
+60 days after the cessation.
+
+Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License.  If your rights have been terminated and not permanently
+reinstated, receipt of a copy of some or all of the same material does
+not give you any rights to use it.
+
+@item
+FUTURE REVISIONS OF THIS LICENSE
+
+The Free Software Foundation may publish new, revised versions
+of the GNU Free Documentation License from time to time.  Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.  See
+@uref{http://www.gnu.org/copyleft/}.
+
+Each version of the License is given a distinguishing version number.
+If the Document specifies that a particular numbered version of this
+License ``or any later version'' applies to it, you have the option of
+following the terms and conditions either of that specified version or
+of any later version that has been published (not as a draft) by the
+Free Software Foundation.  If the Document does not specify a version
+number of this License, you may choose any version ever published (not
+as a draft) by the Free Software Foundation.  If the Document
+specifies that a proxy can decide which future versions of this
+License can be used, that proxy's public statement of acceptance of a
+version permanently authorizes you to choose that version for the
+Document.
+
+@item
+RELICENSING
+
+``Massive Multiauthor Collaboration Site'' (or ``MMC Site'') means any
+World Wide Web server that publishes copyrightable works and also
+provides prominent facilities for anybody to edit those works.  A
+public wiki that anybody can edit is an example of such a server.  A
+``Massive Multiauthor Collaboration'' (or ``MMC'') contained in the
+site means any set of copyrightable works thus published on the MMC
+site.
+
+``CC-BY-SA'' means the Creative Commons Attribution-Share Alike 3.0
+license published by Creative Commons Corporation, a not-for-profit
+corporation with a principal place of business in San Francisco,
+California, as well as future copyleft versions of that license
+published by that same organization.
+
+``Incorporate'' means to publish or republish a Document, in whole or
+in part, as part of another Document.
+
+An MMC is ``eligible for relicensing'' if it is licensed under this
+License, and if all works that were first published under this License
+somewhere other than this MMC, and subsequently incorporated in whole
+or in part into the MMC, (1) had no cover texts or invariant sections,
+and (2) were thus incorporated prior to November 1, 2008.
+
+The operator of an MMC Site may republish an MMC contained in the site
+under CC-BY-SA on the same site at any time before August 1, 2009,
+provided the MMC is eligible for relicensing.
+
+@end enumerate
+
+@page
+@heading ADDENDUM: How to use this License for your documents
+
+To use this License in a document you have written, include a copy of
+the License in the document and put the following copyright and
+license notices just after the title page:
+
+@smallexample
+@group
+  Copyright (C)  @var{year}  @var{your name}.
+  Permission is granted to copy, distribute and/or modify this document
+  under the terms of the GNU Free Documentation License, Version 1.3
+  or any later version published by the Free Software Foundation;
+  with no Invariant Sections, no Front-Cover Texts, and no Back-Cover
+  Texts.  A copy of the license is included in the section entitled ``GNU
+  Free Documentation License''.
+@end group
+@end smallexample
+
+If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
+replace the ``with@dots{}Texts.''@: line with this:
+
+@smallexample
+@group
+    with the Invariant Sections being @var{list their titles}, with
+    the Front-Cover Texts being @var{list}, and with the Back-Cover Texts
+    being @var{list}.
+@end group
+@end smallexample
+
+If you have Invariant Sections without Cover Texts, or some other
+combination of the three, merge those two alternatives to suit the
+situation.
+
+If your document contains nontrivial examples of program code, we
+recommend releasing these examples in parallel under your choice of
+free software license, such as the GNU General Public License,
+to permit their use in free software.
+
+@c Local Variables:
+@c ispell-local-pdict: "ispell-dict"
+@c End:

examples/gnu-system.scm

@@ -0,0 +1,231 @@
+;;;; gnu-system.scm - build jobs for Guix
+;;;
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+;; Attempt to use Guix modules from git repository.
+(eval-when (compile load eval)
+  ;; Ignore any available .go, and force recompilation.  This is because our
+  ;; checkout in the store has mtime set to the epoch, and thus .go files look
+  ;; newer, even though they may not correspond.
+  (set! %fresh-auto-compile #t))
+
+(use-modules (guix config)
+             (guix store)
+             (guix grafts)
+             (guix packages)
+             (guix derivations)
+             (guix monads)
+             ((guix licenses)
+              #:select (gpl3+ license-name license-uri license-comment))
+             ((guix utils) #:select (%current-system))
+             ((guix scripts system) #:select (read-operating-system))
+             (gnu packages)
+             (gnu packages commencement)
+             (gnu packages guile)
+             (gnu packages make-bootstrap)
+             (gnu system)
+             (gnu system vm)
+             (gnu system install)
+             (srfi srfi-1)
+             (ice-9 match))
+
+(define (license->alist lcs)
+  "Return LCS <license> object as an alist."
+  ;; Sometimes 'license' field is a list of licenses.
+  (if (list? lcs)
+      (map license->alist lcs)
+      `((name . ,(license-name lcs))
+        (uri . ,(license-uri lcs))
+        (comment . ,(license-comment lcs)))))
+
+(define (package-metadata package)
+  "Convert PACKAGE to an alist suitable for Hydra."
+  `((#:description . ,(package-synopsis package))
+    (#:long-description . ,(package-description package))
+    (#:license . ,(license->alist (package-license package)))
+    (#:home-page . ,(package-home-page package))
+    (#:maintainers . ("bug-guix@gnu.org"))
+    (#:max-silent-time . ,(or (assoc-ref (package-properties package)
+                                         'max-silent-time)
+                              3600))      ;1 hour by default
+    (#:timeout . ,(or (assoc-ref (package-properties package) 'timeout)
+                      72000))))           ;20 hours by default
+
+(define (package-job store job-name package system)
+  "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
+  (λ ()
+    `((#:job-name . ,(string-append (symbol->string job-name) "." system))
+      (#:derivation . ,(derivation-file-name
+                        (parameterize ((%graft? #f))
+                          (package-derivation store package system
+                                              #:graft? #f))))
+      ,@(package-metadata package))))
+
+(define (package-cross-job store job-name package target system)
+  "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE
+for TARGET on SYSTEM."
+  (λ ()
+    `((#:job-name . ,(string-join (list target (symbol->string job-name) system)
+                                  "."))
+      (#:derivation . ,(derivation-file-name
+                        (parameterize ((%graft? #f))
+                          (package-cross-derivation store package target system
+                                                    #:graft? #f))))
+      ,@(package-metadata package))))
+
+(define %core-packages
+  ;; Note: Don't put the '-final' package variants because (1) that's
+  ;; implicit, and (2) they cannot be cross-built (due to the explicit input
+  ;; chain.)
+  (append (map specification->package
+               '("gcc@4.8" "gcc@4.9" "gcc@5" "glibc" "binutils"
+                 "gmp" "mpfr" "mpc" "coreutils" "findutils" "diffutils" "patch" "sed" "grep"
+                 "gawk" "gettext" "hello" "zlib" "gzip" "xz"))
+          (list guile-2.0
+                %bootstrap-binaries-tarball
+                %binutils-bootstrap-tarball
+                %glibc-bootstrap-tarball
+                %gcc-bootstrap-tarball
+                %guile-bootstrap-tarball
+                %bootstrap-tarballs)))
+
+(define %packages-to-cross-build
+  %core-packages)
+
+(define %cross-targets
+  '("mips64el-linux-gnu"
+    "mips64el-linux-gnuabi64"))
+
+(define (tarball-job store system)
+  "Return Hydra jobs to build the self-contained Guix binary tarball."
+  (λ ()
+    `((#:job-name . (string-append "binary-tarball." system))
+      (#:derivation . ,(derivation-file-name
+                        (parameterize ((%graft? #f))
+                          (run-with-store store
+                            (mbegin %store-monad
+                              (set-guile-for-build (default-guile))
+                              (self-contained-tarball))
+                            #:system system))))
+      (#:description . "Stand-alone binary Guix tarball")
+      (#:long-description . "This is a tarball containing binaries of Guix
+and all its dependencies, and ready to be installed on non-GuixSD
+distributions.")
+      (#:license . ,(license->alist gpl3+))
+      (#:home-page . ,%guix-home-page-url)
+      (#:maintainers . ("bug-guix@gnu.org")))))
+
+(define %job-name
+  ;; Return the name of a package's job.
+  (compose string->symbol package-full-name))
+
+(define package->job
+  (let ((base-packages
+         (delete-duplicates
+          (append-map (match-lambda
+                       ((_ package _ ...)
+                        (match (package-transitive-inputs package)
+                          (((_ inputs _ ...) ...)
+                           inputs))))
+                      %final-inputs))))
+    (lambda (store package system)
+      "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
+valid."
+      (cond ((member package base-packages)
+             #f)
+            ((supported-package? package system)
+             (package-job store (%job-name package) package system))
+            (else
+             #f)))))
+
+
+;;;
+;;; Hydra entry point.
+;;;
+
+(define (hydra-jobs store arguments)
+  "Return Hydra jobs."
+  (define subset
+    (match (assoc-ref arguments 'subset)
+      ("core" 'core)                    ; only build core packages
+      ("hello" 'hello)                  ; only build hello
+      (_ 'all)))                        ; build everything
+
+  (define (cross-jobs system)
+    (define (from-32-to-64? target)
+      ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.  This hack
+      ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
+      ;; mips64el-linux-gnuabi64.
+      (and (or (string-prefix? "i686-" system)
+               (string-prefix? "armhf-" system))
+           (string-suffix? "64" target)))
+
+    (define (same? target)
+      ;; Return true if SYSTEM and TARGET are the same thing.  This is so we
+      ;; don't try to cross-compile to 'mips64el-linux-gnu' from
+      ;; 'mips64el-linux'.
+      (string-contains target system))
+
+    (define (either proc1 proc2)
+      (lambda (x)
+        (or (proc1 x) (proc2 x))))
+
+    (append-map (lambda (target)
+                  (map (lambda (package)
+                         (package-cross-job store (%job-name package)
+                                            package target system))
+                       %packages-to-cross-build))
+                (remove (either from-32-to-64? same?) %cross-targets)))
+
+  ;; Turn off grafts.  Grafting is meant to happen on the user's machines.
+  (parameterize ((%graft? #f))
+    ;; Return one job for each package, except bootstrap packages.
+    (append-map (lambda (system)
+                  (case subset
+                    ((all)
+                     ;; Build everything, including replacements.
+                     (let ((pkgs (fold-packages
+                                  (lambda (package result)
+                                    (if (package-replacement package)
+                                        (cons* package
+                                               (package-replacement package)
+                                               result)
+                                        (cons package result)))
+                                  '())))
+                       (append (filter-map (lambda (pkg)
+                                             (package->job store pkg system))
+                                           pkgs)
+                               (list (tarball-job store system))
+                               (cross-jobs system))))
+                    ((core)
+                     ;; Build core packages only.
+                     (append (map (lambda (package)
+                                    (package-job store (%job-name package)
+                                                 package system))
+                                  %core-packages)
+                             (cross-jobs system)))
+                    ((hello)
+                     ;; Build hello package only.
+                     (if (string=? system (%current-system))
+                         (let ((hello (specification->package "hello")))
+                           (list (package-job store (%job-name hello) hello system)))
+                         '()))
+                    (else
+                     (error "unknown subset" subset))))
+                %hydra-supported-systems)))

examples/guix-jobs.scm

@@ -0,0 +1,37 @@
+;;; guix-jobs.scm -- job specification test for Guix
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define (local-file file)
+  ;; In the common case jobs will be defined relative to the repository.
+  ;; However for testing purpose use local gnu-system.scm instead.
+  (string-append (dirname (current-filename)) "/" file))
+
+(define job-base
+  `((#:name . "guix")
+    (#:url . "git://git.savannah.gnu.org/guix.git")
+    (#:load-path . ".")
+    (#:file . ,(local-file "gnu-system.scm"))
+    (#:proc . hydra-jobs)))
+
+(define guix-master
+  (acons #:branch "master" job-base))
+
+(define guix-0.10
+  (acons #:tag "v0.10.0" job-base))
+
+(list guix-master guix-0.10)

examples/guix-track-git.scm

@@ -0,0 +1,221 @@
+;;; guix-track-git.scm -- job specification tracking a guix packages's git
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+;;;
+;;; This file defines build jobs for the Hydra continuation integration
+;;; tool.
+;;;
+
+(define local-guix (string-append (getenv "HOME") "/src/guix"))
+(define local-cuirass (string-append (getenv "HOME") "/src/cuirass/src"))
+
+;; Attempt to use our very own Guix modules.
+(eval-when (compile load eval)
+
+  (set! %load-path (cons* local-guix local-cuirass %load-path))
+  (set! %load-path (cons (string-append local-cuirass "/gnu/packages/patches") %load-path))
+  (set! %load-compiled-path (cons local-guix %load-compiled-path))
+  (set! %load-compiled-path (cons local-cuirass %load-compiled-path))
+
+  ;; Ignore any available .go, and force recompilation.  This is because our
+  ;; checkout in the store has mtime set to the epoch, and thus .go files look
+  ;; newer, even though they may not correspond.
+  (set! %fresh-auto-compile #t))
+
+(use-modules (guix config)
+             (guix store)
+             (guix grafts)
+             (guix packages)
+             (guix derivations)
+             (guix monads)
+             ((guix licenses)
+              #:select (gpl3+ license-name license-uri license-comment))
+             ((guix utils) #:select (%current-system))
+             ((guix scripts system) #:select (read-operating-system))
+             (gnu packages)
+             (gnu packages gcc)
+             (gnu packages base)
+             (gnu packages gawk)
+             (gnu packages guile)
+             (gnu packages gettext)
+             (gnu packages compression)
+             (gnu packages multiprecision)
+             (gnu packages make-bootstrap)
+             (gnu packages commencement)
+             (gnu packages package-management)
+             (gnu system)
+             (gnu system vm)
+             (gnu system install)
+             (gnu tests)
+             (srfi srfi-1)
+             (srfi srfi-26)
+             (ice-9 optargs)
+             (ice-9 match))
+
+;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
+;; port to the bit bucket, let us write to the error port instead.
+(setvbuf (current-error-port) _IOLBF)
+(set-current-output-port (current-error-port))
+
+(define (license->alist lcs)
+  "Return LCS <license> object as an alist."
+  ;; Sometimes 'license' field is a list of licenses.
+  (if (list? lcs)
+      (map license->alist lcs)
+      `((name . ,(license-name lcs))
+        (uri . ,(license-uri lcs))
+        (comment . ,(license-comment lcs)))))
+
+(define (package-metadata package)
+  "Convert PACKAGE to an alist suitable for Hydra."
+  `((#:description . ,(package-synopsis package))
+    (#:long-description . ,(package-description package))
+    (#:license . ,(license->alist (package-license package)))
+    (#:home-page . ,(package-home-page package))
+    (#:maintainers . ("bug-guix@gnu.org"))
+    (#:max-silent-time . ,(or (assoc-ref (package-properties package)
+                                         'max-silent-time)
+                              3600))      ;1 hour by default
+    (#:timeout . ,(or (assoc-ref (package-properties package) 'timeout)
+                      72000))))           ;20 hours by default
+
+(define (package-job store job-name package system)
+  "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
+  (λ ()
+    `((#:job-name . ,(string-append (symbol->string job-name) "." system))
+      (#:derivation . ,(derivation-file-name
+                        (parameterize ((%graft? #f))
+                          (package-derivation store package system
+                                              #:graft? #f))))
+      ,@(package-metadata package))))
+
+(define job-name
+  ;; Return the name of a package's job.
+  (compose string->symbol package-full-name))
+
+(define package->job
+  (let ((base-packages
+         (delete-duplicates
+          (append-map (match-lambda
+                       ((_ package _ ...)
+                        (match (package-transitive-inputs package)
+                          (((_ inputs _ ...) ...)
+                           inputs))))
+                      %final-inputs))))
+    (lambda (store package system)
+      "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
+valid."
+      (cond ((member package base-packages)
+             #f)
+            ((supported-package? package system)
+             (package-job store (job-name package) package system))
+            (else
+             #f)))))
+
+;;; END hydra/gnu-system.scm
+
+
+;;;
+;;; Cuirass CI tracking packages' git
+;;;
+
+(use-modules (srfi srfi-11)
+             (srfi srfi-9 gnu)
+             (rnrs io ports)
+             (gnu packages)
+             (guix base32)
+             (guix git-download)
+             (guix hash)
+             (guix packages)
+             (guix serialization)
+             (guix utils)
+             (guix ui)
+             (cuirass base))
+
+(define (url->file-name url)
+  (string-trim
+   (string-map (lambda (c) (if (memq c (string->list ":/")) #\- c)) url)
+    #\-))
+
+(define* (package->spec pkg #:key (branch "master") commit url)
+  (let ((url (or url ((compose git-reference-url origin-uri package-source) pkg))))
+    `((#:name . ,(url->file-name url))
+      (#:url . ,url)
+      (#:branch . ,branch)
+      (#:commit . ,commit))))
+
+(define (vcs-file? file stat)
+  (case (stat:type stat)
+    ((directory)
+     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+    (else
+     #f)))
+
+(define select? (negate vcs-file?))
+
+(define (file-hash file)
+  ;; Compute the hash of FILE.
+  ;; Catch and gracefully report possible '&nar-error' conditions.
+  (with-error-handling
+    (let-values (((port get-hash) (open-sha256-port)))
+      (write-file file port #:select? select?)
+      (flush-output-port port)
+      (get-hash))))
+
+(define (commit? string)
+  (string-every (string->char-set "0123456789abcdef") string))
+
+(define (call-with-output-fdes fdes new-file thunk)
+  (let ((outport (fdes->outport fdes))
+        (port (open-file new-file "w")))
+    (move->fdes port fdes)
+    (let ((result (thunk)))
+      (move->fdes port fdes)
+      result)))
+
+(define* (package->git-tracked pkg #:key (branch "master") commit url)
+  (let* ((source (package-source pkg))
+         (uri (origin-uri source)))
+    (if (not branch) pkg
+        (let* ((spec (package->spec pkg #:branch branch #:commit commit #:url url))
+               (commit (call-with-output-fdes 1 "/dev/null"
+                                              (lambda () (fetch-repository spec))))
+               (url (or url (git-reference-url uri)))
+               (git-dir (string-append (%package-cachedir) "/" (url->file-name url)))
+               (hash (bytevector->nix-base32-string (file-hash git-dir)))
+               (source (origin (uri (git-reference (url url) (commit commit)))
+                              (method git-fetch)
+                              (sha256 (base32 hash)))))
+          (set-fields pkg ((package-source) source))))))
+
+
+;;;
+;;; Guix entry point.
+;;;
+
+(define (guix-jobs store arguments)
+  (let* ((name (or (assoc-ref arguments 'name) "hello"))
+         (pkg (specification->package name))
+         (branch (or (assoc-ref arguments 'branch) "master"))
+         (url (assoc-ref arguments 'url))
+         (pkg.git (package->git-tracked pkg #:branch branch #:url url))
+         (system (or (assoc-ref arguments 'system) "x86_64-linux")))
+    (parameterize ((%graft? #f))
+      (list (package-job store (job-name pkg) pkg.git system)))))

examples/hello-git.scm

@@ -0,0 +1,53 @@
+;;; hello-git.scm -- job specification test for hello git repository
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (srfi srfi-1))
+
+(define (local-file file)
+  ;; In the common case jobs will be defined relative to the repository.
+  ;; However for testing purpose use local gnu-system.scm instead.
+  (string-append (dirname (current-filename)) "/" file))
+
+(define (url->file-name url)
+  (string-trim
+   (string-map (lambda (c) (if (memq c (string->list ":/")) #\- c)) url)
+   #\-))
+
+(define vc
+  ;; where your version-control checkouts live
+  (string-append (getenv "HOME") "/src"))
+(define guix-checkout (string-append vc "/guix"))
+
+;; building GNU hello from git is too much work
+;; (define hello-checkout (string-append vc "/hello"))
+;; (define hello-git "http://git.savannah.gnu.org/r/hello.git")
+;; ... so let's track cuirass' git
+(define cuirass-checkout (string-append vc "/cuirass"))
+(define cuirass-git "https://notabug.org/mthl/cuirass")
+;;(define cuirass-git "https://gitlab.com/janneke/cuirass.git")
+
+(list
+ `((#:name . ,(url->file-name cuirass-checkout))
+   (#:url . ,cuirass-git)
+   (#:branch . "master")
+   (#:no-compile? . #t)
+   (#:load-path . ,guix-checkout)
+   (#:proc . guix-jobs)
+   (#:file . ,(local-file "guix-track-git.scm"))
+   (#:arguments (name . "cuirass") (url . ,cuirass-git))))

examples/hello-singleton.scm

@@ -0,0 +1,33 @@
+;;; hello-singleton.scm -- job specification test for hello in master
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define (local-file file)
+  ;; In the common case jobs will be defined relative to the repository.
+  ;; However for testing purpose use local gnu-system.scm instead.
+  (string-append (dirname (current-filename)) "/" file))
+
+(define hello-master
+  `((#:name . "guix")
+    (#:url . "git://git.savannah.gnu.org/guix.git")
+    (#:load-path . ".")
+    (#:file . ,(local-file "gnu-system.scm"))
+    (#:proc . hydra-jobs)
+    (#:arguments (subset . "hello"))
+    (#:branch . "master")))
+
+(list hello-master)

examples/hello-subset.scm

@@ -0,0 +1,43 @@
+;;; hello-subset.scm -- job specification test for hello subset
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define (local-file file)
+  ;; In the common case jobs will be defined relative to the repository.
+  ;; However for testing purpose use local gnu-system.scm instead.
+  (string-append (dirname (current-filename)) "/" file))
+
+(define job-base
+  `((#:name . "guix")
+    (#:url . "git://git.savannah.gnu.org/guix.git")
+    (#:load-path . ".")
+    (#:file . ,(local-file "gnu-system.scm"))
+    (#:proc . hydra-jobs)
+    (#:arguments (subset . "hello"))))
+
+(define guix-master
+  (acons #:branch "master" job-base))
+
+(define guix-core-updates
+  (acons #:branch "core-updates" job-base))
+
+(define guix-0.10
+  (acons #:tag "v0.10.0" job-base))
+
+(list guix-master
+      guix-core-updates
+      guix-0.10)

src/cuirass.scm

@@ -0,0 +1,34 @@
+;;;; cuirass.scm -- Cuirass public interface.
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+;;;; Commentary:
+;;;
+;;; This composite module re-exports everything from the public submodules.
+;;;
+;;;; Code:
+
+(define-module (cuirass))
+
+;;; Module usages and exports need to be done at expansion time.
+(eval-when (eval load expand)
+  (let ((i (module-public-interface (current-module))))
+    (for-each (λ (m) (module-use! i (resolve-interface m)))
+              ;; Public modules.
+              '((cuirass base)
+                (cuirass database)
+                (cuirass http)))))

src/cuirass/base.scm

@@ -1,16 +1,17 @@
-;;;; base.scm - Cuirass base module
-;;;
-;;; Copyright © 2012, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; base.scm -- Cuirass base module
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
-;;; Cuirass 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.
+;;; Cuirass 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.
 ;;;
-;;; Cuirass is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; Cuirass 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.
 ;;;
@@ -18,30 +19,44 @@
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (cuirass base)
+  #:use-module (cuirass database)
+  #:use-module (cuirass utils)
+  #:use-module (gnu packages)
+  #:use-module (guix derivations)
+  #:use-module (guix store)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-19)
-  #:export (guix-variable
-            with-directory-excursion
-            call-with-time-display))
+  #:use-module (srfi srfi-34)
+  #:export (;; Procedures.
+            call-with-time-display
+            fetch-repository
+            compile
+            evaluate
+            build-packages
+            process-specs
+            set-guix-package-path!
+            ;; Parameters.
+            %guix-package-path
+            %package-cachedir
+            %use-substitutes?))
 
-(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."
-  (let ((m (resolve-interface `(guix ,module))))
-    (module-ref m name)))
+(define %use-substitutes?
+  ;; Define whether to use substitutes
+  (make-parameter #f))
 
-(define-syntax-rule (with-directory-excursion dir body ...)
-  "Run BODY with DIR as the process's current directory."
-  (let ((init (getcwd)))
-    (dynamic-wind
-      (lambda ()
-        (chdir dir))
-      (lambda ()
-        body ...)
-      (lambda ()
-        (chdir init)))))
+(define %package-cachedir
+  ;; Define to location of cache directory of this package.
+  (make-parameter (or (getenv "CUIRASS_CACHEDIR")
+                      (string-append (or (getenv "HOME") ".")
+                                     "/.cache/cuirass"))
+    (λ (val)
+      (if (string? val)
+          val
+          (scm-error 'wrong-type-arg
+                     "%package-cachedir" "Not a string: ~S" (list #f) #f)))))
 
 (define (call-with-time thunk kont)
   "Call THUNK and pass KONT the elapsed time followed by THUNK's return
@@ -54,8 +69,144 @@ values."
 (define (call-with-time-display thunk)
   "Call THUNK and write to the current output port its duration."
   (call-with-time thunk
-    (lambda (time . results)
-      (format #t "~,3f seconds~%"
-              (+ (time-second time)
-                 (/ (time-nanosecond time) 1e9)))
-      (apply values results))))
+    (λ (time result)
+      (let ((duration (+ (time-second time)
+                         (/ (time-nanosecond time) 1e9))))
+        (format (current-error-port) "evaluate '~A': ~,3f seconds~%"
+                (assq-ref result #:job-name)
+                duration)
+        (acons #:duration duration result)))))
+
+(define (fetch-repository spec)
+  "Get the latest version of repository specified in SPEC.  Clone repository
+if required.  Return the last commit ID on success, #f otherwise."
+  (define (current-commit)
+    (let* ((pipe   (open-input-pipe "git log -n1"))
+           (log    (read-string pipe))
+           (commit (cadr (string-split log char-set:whitespace))))
+      (close-pipe pipe)
+      commit))
+
+  (let ((cachedir (%package-cachedir)))
+    (mkdir-p cachedir)
+    (with-directory-excursion cachedir
+      (let ((name   (assq-ref spec #:name))
+            (url    (assq-ref spec #:url))
+            (branch (assq-ref spec #:branch))
+            (commit (assq-ref spec #:commit))
+            (tag    (assq-ref spec #:tag)))
+        (and (or (file-exists? name)
+                 (zero? (system* "git" "clone" url name)))
+             (with-directory-excursion name
+               (and (zero? (system* "git" "fetch"))
+                    (zero? (system* "git" "reset" "--hard"
+                                    (or tag
+                                        commit
+                                        (string-append "origin/" branch))))
+                    (current-commit))))))))
+
+(define (compile dir)
+  ;; Required for fetching Guix bootstrap tarballs.
+  "Compile files in repository in directory DIR."
+  (with-directory-excursion dir
+    (or (file-exists? "configure") (system* "./bootstrap"))
+    (or (file-exists? "Makefile")
+        (system* "./configure" "--localstatedir=/var"))
+    (zero? (system* "make" "-j" (number->string (current-processor-count))))))
+
+(define (evaluate store db spec)
+  "Evaluate and build package derivations.  Return a list of jobs."
+  (let* ((port (open-pipe* OPEN_READ
+                           "evaluate"
+                           (string-append (%package-cachedir) "/"
+                                          (assq-ref spec #:name) "/"
+                                          (assq-ref spec #:load-path))
+                           (%guix-package-path)
+                           (%package-cachedir)
+                           (object->string spec)
+                           (%package-database)))
+         (jobs (read port)))
+    (close-pipe port)
+    jobs))
+
+(define (build-packages store db jobs)
+  "Build JOBS and return a list of Build results."
+  (define (register job)
+    (let* ((name     (assq-ref job #:job-name))
+           (drv      (assq-ref job #:derivation))
+           (eval-id  (assq-ref job #:eval-id))
+           ;; XXX: How to keep logs from several attempts?
+           (log      (log-file store drv))
+           (outputs  (match (derivation-path->output-paths drv)
+                       (((names . items) ...)
+                        (filter (λ (item)
+                                  (valid-path? store item))
+                                items)))))
+      (for-each (λ (output)
+                  (let ((build `((#:derivation . ,drv)
+                                 (#:eval-id . ,eval-id)
+                                 (#:log . ,log)
+                                 (#:output . ,output))))
+                    (db-add-build db build)))
+                outputs)
+      (format #t "~{~A ~}\n" outputs)
+      build))
+
+  ;; Pass all the jobs at once so we benefit from as much parallelism as
+  ;; possible (we must be using #:keep-going? #t).  Swallow build errors.
+  (guard (c ((nix-protocol-error? c) #t))
+    (format #t "building ~a derivations...~%" (length jobs))
+    (build-derivations store (map (λ (job)
+                                    (assq-ref job #:derivation))
+                                  jobs)))
+
+  ;; Register the results in the database.
+  ;; XXX: The 'build-derivations' call is blocking so we end updating the
+  ;; database potentially long after things have been built.
+  (map register jobs))
+
+(define (process-specs db jobspecs)
+  "Evaluate and build JOBSPECS and store results in DB."
+  (define (process spec)
+    (let ((commit (fetch-repository spec))
+          (stamp  (db-get-stamp db spec)))
+      (when commit
+        (unless (string=? commit stamp)
+          (unless (assq-ref spec #:no-compile?)
+            (compile (string-append (%package-cachedir) "/"
+                                    (assq-ref spec #:name))))
+          (with-store store
+            ;; Always set #:keep-going? so we don't stop on the first build
+            ;; failure.
+            (set-build-options store
+                               #:use-substitutes? (%use-substitutes?)
+                               #:keep-going? #t)
+
+            (let* ((spec* (acons #:current-commit commit spec))
+                   (jobs  (evaluate store db spec*)))
+              (build-packages store db jobs))))
+        (db-add-stamp db spec commit))))
+
+  (for-each process jobspecs))
+
+
+;;;
+;;; Guix package path.
+;;;
+
+(define %guix-package-path
+  ;; Extension of package modules search path.
+  (make-parameter ""))
+
+(define (set-guix-package-path! path)
+  "Use PATH to find custom packages not defined in (gnu packages ...)
+namespace or not already present in current Guile load paths.  PATH is
+expected to be a colon-separated string of directories."
+  (define (set-paths! dir)
+    (%package-module-path (cons dir (%package-module-path)))
+    (%patch-path (cons dir (%patch-path)))
+    (set! %load-path (cons dir %load-path))
+    (set! %load-compiled-path (cons dir %load-compiled-path)))
+
+  (let ((dirs (parse-path path)))
+    (for-each set-paths! dirs)))

src/cuirass/config.scm.in

@@ -0,0 +1,58 @@
+;;;; config.scm -- constants defined by the build system.
+;;; @configure_input@
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass config))
+
+(define-public %package
+  ;; Name of package
+  "@PACKAGE@")
+
+(define-public %package-bugreport
+  ;; Define to the address where bug reports for this package should be sent.
+  "@PACKAGE_BUGREPORT@")
+
+(define-public %package-name
+  ;; Define to the full name of this package.
+  "@PACKAGE_NAME@")
+
+(define-public %package-string
+  ;; Define to the full name and version of this package.
+  "@PACKAGE_STRING@")
+
+(define-public %package-tarname
+  ;; Define to the one symbol short name of this package.
+  "@PACKAGE_TARNAME@")
+
+(define-public %package-url
+  ;; Define to the home page for this package.
+  "@PACKAGE_URL@")
+
+(define-public %package-version
+  ;; Define to the version of this package.
+  "@PACKAGE_VERSION@")
+
+(define-public %datadir
+  ;; Define to 'PREFIX/share' which is a read-only architecture-independent
+  ;; data directory.
+  "@datadir@")
+
+(define-public %localstatedir
+  ;; Define to 'PREFIX/var' which is a modifiable single-machine data
+  ;; directory.
+  "@localstatedir@")

src/cuirass/database.scm

@@ -0,0 +1,213 @@
+;;; database.scm -- store evaluation and build results
+;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass database)
+  #:use-module (cuirass config)
+  #:use-module (cuirass utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (sqlite3)
+  #:export (;; Procedures.
+            assq-refs
+            db-init
+            db-open
+            db-close
+            db-add-specification
+            db-get-specifications
+            db-add-stamp
+            db-get-stamp
+            db-add-evaluation
+            db-add-derivation
+            db-get-derivation
+            db-add-build
+            read-sql-file
+            read-quoted-string
+            sqlite-exec
+            ;; Parameters.
+            %package-database
+            %package-schema-file
+            ;; Macros.
+            with-database))
+
+(define (sqlite-exec db msg . args)
+  "Wrap 'sqlite-prepare', 'sqlite-step', and 'sqlite-finalize'. Send message
+MSG to database DB.  MSG can contain '~A' and '~S' escape characters which
+will be replaced by ARGS."
+  (let* ((sql  (apply simple-format #f msg args))
+         (stmt (sqlite-prepare db sql))
+         (res  (let loop ((res '()))
+                 (let ((row (sqlite-step stmt)))
+                   (if (not row)
+                       (reverse! res)
+                       (loop (cons row res)))))))
+    (sqlite-finalize stmt)
+    res))
+
+(define %package-database
+  ;; Define to the database file name of this package.
+  (make-parameter (string-append %localstatedir "/" %package ".db")))
+
+(define %package-schema-file
+  ;; Define to the database schema file of this package.
+  (make-parameter (string-append (or (getenv "CUIRASS_DATADIR")
+                                     (string-append %datadir "/" %package))
+                                 "/schema.sql")))
+
+(define (read-sql-file file-name)
+  "Return a list of string containing SQL instructions from FILE-NAME."
+  (call-with-input-file file-name
+    (λ (port)
+      (let loop ((insts '()))
+        (let ((inst (read-delimited ";" port 'concat)))
+          (if (or (eof-object? inst)
+                  ;; Don't cons the spaces after the last instructions.
+                  (string-every char-whitespace? inst))
+              (reverse! insts)
+              (loop (cons inst insts))))))))
+
+(define* (db-init #:optional (db-name (%package-database))
+                  #:key (schema (%package-schema-file)))
+  "Open the database to store and read jobs and builds informations.  Return a
+database object."
+  (when (file-exists? db-name)
+    (format (current-error-port) "Removing leftover database ~a~%" db-name)
+    (delete-file db-name))
+  (let ((db (sqlite-open db-name (logior SQLITE_OPEN_CREATE
+                                         SQLITE_OPEN_READWRITE))))
+    (for-each (λ (sql) (sqlite-exec db sql))
+              (read-sql-file schema))
+    db))
+
+(define* (db-open #:optional (db (%package-database)))
+  "Open database to store or read jobs and builds informations.  Return a
+database object."
+  (if (file-exists? db)
+      (sqlite-open db SQLITE_OPEN_READWRITE)
+      (db-init db)))
+
+(define (db-close db)
+  "Close database object DB."
+  (sqlite-close db))
+
+(define* (assq-refs alst keys #:optional default-value)
+  (map (λ (key) (or (assq-ref alst key) default-value))
+       keys))
+
+(define (last-insert-rowid db)
+  (vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
+              0))
+
+(define (db-add-specification db spec)
+  "Store specification SPEC in database DB and return its ID."
+  (apply sqlite-exec db "\
+INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \
+                  proc, arguments, branch, tag, revision, no_compile_p) \
+  VALUES ('~A', '~A', '~A', '~A', '~S', '~S', '~A', '~A', '~A', ~A);"
+         (append
+          (assq-refs spec '(#:name #:url #:load-path #:file #:proc #:arguments))
+          (assq-refs spec '(#:branch #:tag #:commit) "NULL")
+          (list (if (assq-ref spec #:no-compile?) "1" "0"))))
+  (last-insert-rowid db))
+
+(define (db-get-specifications db)
+  (let loop ((rows  (sqlite-exec db "SELECT * FROM Specifications;"))
+             (specs '()))
+    (match rows
+      (() specs)
+      ((#(name url load-path file proc args branch tag rev no-compile?)
+        . rest)
+       (loop rest
+             (cons `((#:name . ,name)
+                     (#:url . ,url)
+                     (#:load-path . ,load-path)
+                     (#:file . ,file)
+                     (#:proc . ,(with-input-from-string proc read))
+                     (#:arguments . ,(with-input-from-string args read))
+                     (#:branch . ,branch)
+                     (#:tag . ,(if (string=? tag "NULL") #f tag))
+                     (#:commit . ,(if (string=? rev "NULL") #f rev))
+                     (#:no-compile? . ,(positive? no-compile?)))
+                   specs))))))
+
+(define (db-add-derivation db job)
+  "Store a derivation result in database DB and return its ID."
+  (sqlite-exec db "\
+INSERT OR IGNORE INTO Derivations (derivation, job_name, evaluation)\
+  VALUES ('~A', '~A', '~A');"
+               (assq-ref job #:derivation)
+               (assq-ref job #:job-name)
+               (assq-ref job #:eval-id)))
+
+(define (db-get-derivation db id)
+  "Retrieve a job in database DB which corresponds to ID."
+  (car (sqlite-exec db "SELECT * FROM Derivations WHERE derivation='~A';" id)))
+
+(define (db-add-evaluation db eval)
+  (sqlite-exec db "\
+INSERT INTO Evaluations (specification, revision) VALUES ('~A', '~A');"
+               (assq-ref eval #:specification)
+               (assq-ref eval #:revision))
+  (last-insert-rowid db))
+
+(define-syntax-rule (with-database db body ...)
+  "Run BODY with a connection to the database which is bound to DB in BODY."
+  (let ((db (db-open)))
+    (dynamic-wind
+      (const #t)
+      (λ () body ...)
+      (λ () (db-close db)))))
+
+(define* (read-quoted-string #:optional (port (current-input-port)))
+  "Read all of the characters out of PORT and return them as a SQL quoted
+string."
+  (let loop ((chars '()))
+    (let ((char (read-char port)))
+      (cond ((eof-object? char) (list->string (reverse! chars)))
+            ((char=? char #\')  (loop (cons* char char chars)))
+            (else (loop (cons char chars)))))))
+
+(define (db-add-build db build)
+  "Store BUILD in database DB."
+  (sqlite-exec db "\
+INSERT INTO Builds (derivation, evaluation, log, output)\
+  VALUES ('~A', '~A', '~A', '~A');"
+               (assq-ref build #:derivation)
+               (assq-ref build #:eval-id)
+               (assq-ref build #:log)
+               (assq-ref build #:output))
+  (last-insert-rowid db))
+
+(define (db-get-stamp db spec)
+  "Return a stamp corresponding to specification SPEC in database DB."
+  (let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification='~A';"
+                          (assq-ref spec #:id))))
+    (match res
+      (() "")
+      ((#(spec commit)) commit))))
+
+(define (db-add-stamp db spec commit)
+  "Associate stamp COMMIT to specification SPEC in database DB."
+  (if (string-null? (db-get-stamp db spec))
+      (sqlite-exec db "\
+INSERT INTO Stamps (specification, stamp) VALUES ('~A', '~A');"
+                   (assq-ref spec #:id)
+                   commit)
+      (sqlite-exec db "\
+UPDATE Stamps SET stamp='~A' WHERE specification='~A';"
+                   commit
+                   (assq-ref spec #:id))))

src/cuirass/http.scm

@@ -0,0 +1,78 @@
+;;;; http.scm -- HTTP API
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass http)
+  #:use-module (cuirass database)
+  #:use-module (cuirass utils)
+  #:use-module (ice-9 hash-table)
+  #:use-module (ice-9 match)
+  #:use-module (json)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:use-module (web uri)
+  #:export (spec->json-string
+            run-cuirass-server))
+
+;;;
+;;; JSON format.
+;;;
+
+(define (object->json-scm obj)
+  "Prepare OBJ for JSON usage."
+  (cond ((string? obj)  obj)
+        ((number? obj)  obj)
+        ((boolean? obj) obj)
+        ((null? obj)    obj)
+        ((symbol? obj)  (symbol->string obj))
+        ((keyword? obj) (object->json-scm (keyword->symbol obj)))
+        ((alist? obj)   (alist->hash-table (map object->json-scm obj)))
+        ((pair? obj)    (cons (object->json-scm (car obj))
+                              (object->json-scm (cdr obj))))
+        (else           (object->string obj))))
+
+(define* (spec->json-string spec #:key pretty)
+  "Return SPEC as a JSON object."
+  (scm->json-string (object->json-scm spec) #:pretty pretty))
+
+
+;;;
+;;; Web server.
+;;;
+
+(define (request-path-components request)
+  (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (url-handler request body db)
+  (define* (respond response #:key body (db db))
+    (values response body db))
+  (match (request-path-components request)
+    (((or "jobsets" "specifications") . rest)
+     (respond '((content-type . (application/json)))
+              #:body (spec->json-string (car (db-get-specifications db)))))
+    (_
+     (respond (build-response #:code 404)
+              #:body (string-append "Resource not found: "
+                                    (uri->string (request-uri request)))))))
+
+(define* (run-cuirass-server db #:key (port 8080))
+  (format (current-error-port) "listening on port ~A~%" port)
+  (run-server url-handler
+              'http                     ;server implementation
+              `(#:port ,port)           ;implementation parameters
+              db))                      ;state

src/cuirass/repo.scm

@@ -0,0 +1,116 @@
+;;;; repo.scm -- manage code repositories
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass repo)
+  #:use-module (cuirass utils)
+  #:use-module (guix store)
+  #:use-module (srfi srfi-9 gnu)
+  #:export (repo
+            repo?
+            repo-id
+            repo-url
+            repo-location
+            repo-reference
+            repo-snapshoter
+            repo-snapshot
+            repo-updater
+            repo-update
+            file-repo
+            git-repo))
+
+(define-immutable-record-type <repo>
+  ;; An Abstract repository.  Use "repo" as a shortname for "repository".
+  (make-repo id url location ref snapshoter updater)
+  repo?
+  (id         repo-id)                  ;string
+  (url        repo-url)                 ;string
+  (location   repo-location)            ;string
+  (ref        repo-reference)           ;string
+  (snapshoter repo-snapshoter)          ;method
+  (updater    repo-updater))            ;method
+
+(define* (repo #:key id url location ref snapshoter updater)
+  ;; Convenient <repo> constructor using keyword arguments.
+  (make-repo id url location ref snapshoter updater))
+
+(define (repo-snapshot repo store)
+  "Send a snapshot of REPO to the STORE."
+  ((repo-snapshoter repo) repo store))
+
+(define* (repo-update repo #:optional ref)
+  "Pull changes from REPO according to reference REF."
+  ((repo-updater repo) repo ref))
+
+;;;
+;;; Concrete repositories.
+;;;
+
+(define file-repo
+  (let ((hash-algo "sha256"))
+    (define (file-repo-snapshot this store)
+      ;; Send file to the STORE.
+      (let* ((basename   (repo-id this))
+             (file       (repo-location this))
+             (directory? (eq? 'directory (stat:type (stat file)))))
+        (add-to-store store basename directory? hash-algo file)))
+
+    (define (file-repo-update this ref)
+      ;; Ensure that file still exists.
+      (stat (repo-location this)))
+
+    (λ* (file-name #:key id)
+      "Basic repository that handles a local file or directory."
+      (repo #:id (or id file-name)
+            #:location file-name
+            #:snapshoter file-repo-snapshot
+            #:updater file-repo-update))))
+
+(define git-repo
+  (let ((git       "git")
+        (hash-algo "sha256"))
+    (define (git-repo-snapshot this store)
+      "Add a snapshot of URL to STORE. "
+      (let ((dir (repo-location this))
+            (id  (repo-id this)))
+        (call-with-temporary-directory
+         (λ (tmpdir)
+           (let ((tmp-repo (string-append tmpdir "/" dir)))
+             (and (zero? (system* "cp" "-R" dir tmpdir))
+                  (with-directory-excursion tmp-repo
+                    (zero? (system* "rm" "-rf" ".git")))
+                  (add-to-store store id #t hash-algo tmp-repo)))))))
+
+    (define (git-repo-update this ref)
+      (let ((url (repo-url this))
+            (dir (repo-location this)))
+        (and
+         (or (file-exists? dir)
+             (zero? (system* git "clone" url dir))
+             (error "file not found"))
+         (with-directory-excursion dir
+           (and (zero? (system* git "pull"))
+                (zero? (system* git "reset" "--hard" ref)))))))
+
+    (λ* (#:key url dir)
+      "Create a Git repository.  URL is the location of the remote repository.
+REF is the identifier that is tracked."
+      (repo #:id dir
+            #:url url
+            #:location dir
+            #:snapshoter git-repo-snapshot
+            #:updater git-repo-update))))

src/cuirass/ui.scm

@@ -0,0 +1,52 @@
+;;; ui.scm -- user interface facilities for command-line tools
+;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass ui)
+  #:use-module (cuirass config)
+  #:export (;; Procedures.
+            show-version
+            show-package-information
+            ;; Parameters.
+            %program-name))
+
+(define %program-name
+  ;; Similar in spirit to Gnulib 'progname' module.
+  (make-parameter ""
+    (λ (val)
+      (cond ((not (string? val))
+             (scm-error 'wrong-type-arg
+                        "%program-name" "Not a string: ~S" (list #f) #f))
+            ((string-rindex val #\/) => (λ (idx) (substring val (1+ idx))))
+            (else val)))))
+
+(define (show-version)
+  "Display version information for COMMAND."
+  (simple-format #t "~a (~a) ~a~%"
+                 (%program-name) %package-name %package-version)
+  (display "Copyright (C) 2016 the Cuirass authors
+License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.")
+  (newline))
+
+(define (show-package-information)
+  (newline)
+  (format #t "Report bugs to: ~a." %package-bugreport)
+  (newline)
+  (format #t "~A home page: <~A>" %package-name %package-url)
+  (newline))

src/cuirass/utils.scm

@@ -0,0 +1,102 @@
+;;; utils.scm -- helper procedures
+;;; Copyright © 2012, 2013, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass utils)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (;; Procedures
+            alist?
+            mkdir-p
+            make-user-module
+            call-with-temporary-directory
+            ;; Macros.
+            λ*
+            with-directory-excursion))
+
+(define-syntax-rule (λ* formals body ...)
+  (lambda* formals body ...))
+
+(define (alist? obj)
+  "Return #t if OBJ is an alist."
+  (and (list? obj)
+       (every pair? obj)))
+
+(define mkdir-p
+  (let ((not-slash (char-set-complement (char-set #\/))))
+    (λ* (dir #:optional mode)
+      "Create directory DIR and all its ancestors."
+      (let ((absolute? (string-prefix? "/" dir)))
+        (let loop ((components (string-tokenize dir not-slash))
+                   (root       (if absolute? "" ".")))
+          (match components
+            ((head tail ...)
+             (let ((dir-name (string-append root "/" head)))
+               (catch 'system-error
+                 (λ ()
+                   (if mode
+                       (mkdir dir-name mode)
+                       (mkdir dir-name))
+                   (loop tail dir-name))
+                 (λ args
+                   ;; On GNU/Hurd we can get EROFS instead of EEXIST here.
+                   ;; Thus, if we get something other than EEXIST, check
+                   ;; whether DIR-NAME exists.  See
+                   ;; <https://lists.gnu.org/archive/html/guix-devel/2016-02/msg00049.html>.
+                   (if (or (= EEXIST (system-error-errno args))
+                           (let ((st (stat dir-name #f)))
+                             (and st (eq? 'directory (stat:type st)))))
+                       (loop tail dir-name)
+                       (apply throw args))))))
+            (() #t)))))))
+
+(define-syntax-rule (with-directory-excursion dir body ...)
+  "Run BODY with DIR as the process's current directory."
+  (let ((init (getcwd)))
+    (dynamic-wind
+      (λ () (chdir dir))
+      (λ () body ...)
+      (λ () (chdir init)))))
+
+(define* (make-user-module #:optional (modules '()))
+  "Return a new user module with the additional MODULES loaded."
+  ;; Module in which the machine description file is loaded.
+  (let ((module (make-fresh-user-module)))
+    (for-each (lambda (iface)
+                (module-use! module (resolve-interface iface)))
+              modules)
+    module))
+
+
+;;;
+;;; Temporary files.
+;;;
+
+(define (call-with-temporary-directory proc)
+  "Call PROC with a name of a temporary directory; close the directory and
+delete it when leaving the dynamic extent of this call."
+  (let* ((parent  (or (getenv "TMPDIR") "/tmp"))
+         (tmp-dir (string-append parent "/" (basename (tmpnam)))))
+    (mkdir-p tmp-dir)
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (proc tmp-dir))
+      (lambda ()
+        (false-if-exception (rmdir tmp-dir))))))

src/schema.sql

@@ -0,0 +1,50 @@
+BEGIN TRANSACTION;
+
+CREATE TABLE Specifications (
+  repo_name     TEXT NOT NULL PRIMARY KEY,
+  url           TEXT NOT NULL,
+  load_path     TEXT NOT NULL,
+  file          TEXT NOT NULL,
+  proc          TEXT NOT NULL,
+  arguments     TEXT NOT NULL,
+  -- The following columns are optional.
+  branch        TEXT,
+  tag           TEXT,
+  revision      TEXT,
+  no_compile_p  INTEGER
+);
+
+CREATE TABLE Stamps (
+  specification TEXT NOT NULL PRIMARY KEY,
+  stamp         TEXT NOT NULL,
+  FOREIGN KEY (specification) REFERENCES Specifications (repo_name)
+);
+
+CREATE TABLE Evaluations (
+  id            INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
+  specification TEXT NOT NULL,
+  revision      TEXT NOT NULL,
+  FOREIGN KEY (specification) REFERENCES Specifications (repo_name)
+);
+
+CREATE TABLE Derivations (
+  derivation    TEXT NOT NULL,
+  evaluation    INTEGER NOT NULL,
+  job_name      TEXT NOT NULL,
+  PRIMARY KEY (derivation, evaluation),
+  FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
+);
+
+-- Builds are not in a one to one relationship with derivations in order to
+-- keep track of non deterministic compilations.
+CREATE TABLE Builds (
+  derivation    TEXT NOT NULL,
+  evaluation    INTEGER NOT NULL,
+  log           TEXT NOT NULL,
+  output        TEXT,		-- NULL if build failed
+  PRIMARY KEY (derivation, evaluation, output),
+  FOREIGN KEY (derivation) REFERENCES Derivations (derivation),
+  FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
+);
+
+COMMIT;

tests/base.scm

@@ -1,16 +1,15 @@
-;;;; base.scm - tests for (cuirass base) module
-;;;
+;;; base.scm -- tests for (cuirass base) module
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
-;;; Cuirass 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.
+;;; Cuirass 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.
 ;;;
-;;; Cuirass is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; Cuirass 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.
 ;;;
@@ -19,3 +18,11 @@
 
 (use-modules (cuirass base)
              (srfi srfi-64))
+
+(test-begin "base")
+
+(test-error "invalid cache directory"
+  'wrong-type-arg
+  (%package-cachedir #f))
+
+(test-end)

tests/basic.sh

@@ -0,0 +1,24 @@
+# basic.sh -- check cuirass basic behavior
+# Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+
+# This file is part of Cuirass.
+
+# Cuirass 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.
+
+# Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+db_file=${testbuilddir}/test.db
+spec_file=${testsrcdir}/hello-subset.scm
+
+trap 'rm -f "$db_file"' EXIT
+
+cuirass --database $db_file --one-shot $spec_file

tests/database.scm

@@ -0,0 +1,84 @@
+;;;; database.scm - tests for (cuirass database) module
+;;;
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (cuirass database)
+             (srfi srfi-64))
+
+(define example-spec
+  '((#:name . "guix")
+    (#:url . "git://git.savannah.gnu.org/guix.git")
+    (#:load-path . ".")
+    (#:file . "/tmp/gnu-system.scm")
+    (#:proc . hydra-jobs)
+    (#:arguments (subset . "hello"))
+    (#:branch . "master")
+    (#:tag . #f)
+    (#:commit . #f)
+    (#:no-compile? . #f)))
+
+(define* (make-dummy-job #:optional (name "foo"))
+  `((#:name . ,name)
+    (#:derivation . ,(string-append name ".drv"))
+    (#:specification 0)))
+
+(define %db
+  ;; Global Slot for a database object.
+  (make-parameter #t))
+
+(define %id
+  ;; Global Slot for a job ID in the database.
+  (make-parameter #t))
+
+(define database-name
+  ;; Use an empty and temporary database for the tests.
+  (string-append (getcwd) "/" (number->string (getpid)) "-tmp.db"))
+
+(test-group-with-cleanup "database"
+  (test-assert "db-init"
+    (%db (db-init database-name)))
+
+  (test-assert "sqlite-exec"
+    (begin
+      (sqlite-exec (%db) "\
+INSERT INTO Evaluations (specification, revision) VALUES (1, 1);")
+      (sqlite-exec (%db) "\
+INSERT INTO Evaluations (specification, revision) VALUES (2, 2);")
+      (sqlite-exec (%db) "\
+INSERT INTO Evaluations (specification, revision) VALUES (3, 3);")
+      (sqlite-exec (%db) "SELECT * FROM Evaluations;")))
+
+  (test-equal "db-add-specification"
+    example-spec
+    (begin
+      (db-add-specification (%db) example-spec)
+      (car (db-get-specifications (%db)))))
+
+  (test-assert "db-add-derivation"
+    (let* ((job (make-dummy-job))
+           (key (assq-ref job #:derivation)))
+      (db-add-derivation (%db) job)
+      (%id key)))
+
+  (test-assert "db-get-derivation"
+    (db-get-derivation (%db) (%id)))
+
+  (test-assert "db-close"
+    (db-close (%db)))
+
+  (delete-file database-name))

tests/http.scm

@@ -0,0 +1,40 @@
+;;; http.scm -- tests for (cuirass http) module
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (cuirass http)
+             (srfi srfi-64))
+
+(test-begin "http")
+
+(test-equal "spec->json-string"
+  (string-append "{"
+                 "\"boolean\" : false,"
+                 "\"string\" : \"guix\","
+                 "\"alist\" : {\"subset\" : \"hello\"},"
+                 "\"list\" : [1, \"2\", \"three\"],"
+                 "\"symbol\" : \"hydra-jobs\","
+                 "\"number\" : 1"
+                 "}")
+  (spec->json-string '((#:number . 1)
+                       (string . "guix")
+                       ("symbol" . hydra-jobs)
+                       (#:alist (subset . "hello"))
+                       (list 1 "2" #:three)
+                       ("boolean" . #f))))
+
+(test-end)

tests/repo.scm

@@ -0,0 +1,113 @@
+;;;; repo.scm -- tests for (cuirass repo) module
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (cuirass repo)
+             (cuirass utils)
+             (guix store)
+             (srfi srfi-64))
+
+(test-begin "repo")
+
+(test-equal "<repo> datatype"
+  ;; Check that all the procedures for manipulating <repo> objects are
+  ;; exported and that the keywords of the constructor matches their slot.
+  '(1 2 3 4 5 6)
+  (let ((obj (repo #:id 1 #:url 2 #:location 3 #:ref 4
+                   #:snapshoter 5 #:updater 6)))
+    (and (repo? obj)
+         (list (repo-id obj)
+               (repo-url obj)
+               (repo-location obj)
+               (repo-reference obj)
+               (repo-snapshoter obj)
+               (repo-updater obj)))))
+
+(define file-name
+  (pk (simple-format #f "tmp-~S" (getpid))))
+
+(define store
+  (open-connection))
+
+(define (create-file name)
+  "Create a dummy file in current directory."
+  (with-output-to-file name
+    (λ () (display "test!\n"))))
+
+(define (in-store? file-name)
+  "Check if FILE-NAME is in the store.  FILE-NAME must be an absolute file
+name."
+  (string-prefix? "/gnu/store" file-name))
+
+;;;
+;;; File repository.
+;;;
+
+(test-group-with-cleanup "file-repo"
+  (define rpt (pk (file-repo file-name)))
+
+  ;; Since file doesn't exist yet, 'repo-update' should throw an error.
+  (test-error "file-repo-update: file not found"
+    'system-error
+    (repo-update rpt))
+
+  (create-file file-name)
+
+  (test-assert "file-repo-update"
+    (repo-update rpt))
+
+  (test-assert "file-repo-snapshot"
+    (in-store? (repo-snapshot rpt store)))
+
+  ;; Cleanup.
+  (delete-file file-name))
+
+;;;
+;;; Git repository.
+;;;
+
+(define (create-git-repository name)
+  (let ((git "git"))
+    (system* git "init" name)
+    (with-directory-excursion name
+      (create-file "foo")
+      (system* git "add" "foo")
+      (system* git "commit" "-m" "'foo'"))))
+
+(test-group-with-cleanup "git-repo"
+  (define rpt (git-repo #:url file-name
+                        #:dir "git-example"))
+
+  ;; Since repository doesn't exist yet, 'repo-update' should throw an error.
+  (test-error "git-repo-update: file not found"
+    'system-error
+    (repo-update rpt "master"))
+
+  (create-git-repository file-name)
+
+  (test-assert "git-repo-update"
+    (repo-update rpt "master"))
+
+  (test-assert "git-repo-snapshot"
+    (in-store? (repo-snapshot rpt store)))
+
+  ;; Cleanup.
+  (system* "rm" "-rf" file-name "git-example"))
+
+(close-connection store)
+
+(test-end)

tests/ui.scm

@@ -0,0 +1,28 @@
+;;; ui.scm -- tests for (cuirass ui) module
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (cuirass ui)
+             (srfi srfi-64))
+
+(test-begin "ui")
+
+(test-error "invalid program name"
+  'wrong-type-arg
+  (%program-name #f))
+
+(test-end)

tests/utils.scm

@@ -0,0 +1,53 @@
+;;;; utils.scm -- tests for (cuirass utils) module
+;;;
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (cuirass utils)
+             (srfi srfi-64))
+
+(define dir-1 (make-parameter ""))
+(define dir-2 (make-parameter ""))
+
+(test-begin "utils")
+
+(test-assert "alist?"
+  (and (alist? '())
+       (alist? '(("foo" 1 2)))
+       (alist? '(("foo" . 1)
+                 ("bar" . 2)))
+       (not (alist? 3))
+       (not (alist? '(1 2 3)))
+       (not (alist? 'foo))
+       (not (alist? #:bar))))
+
+(test-assert "with-directory-excursion"
+  (let ((old (getcwd))
+        (tmp (tmpnam)))
+    (dynamic-wind
+      (λ ()
+        (mkdir tmp))
+      (λ ()
+        (with-directory-excursion tmp
+          (dir-1 (getcwd)))
+        (dir-2 (getcwd))
+        (and (string=? (dir-1) tmp)
+             (string=? (dir-2) old)))
+      (λ ()
+        (rmdir tmp)))))
+
+(test-end)