Evaluate derivations in a separate process.

This fixes a bug where different Guix branches gave the same
derivations.

.gitignore

@@ -6,6 +6,7 @@
 /aclocal.m4
 /autom4te.cache/
 /bin/cuirass
+/bin/evaluate
 /build-aux/config.guess
 /build-aux/config.sub
 /build-aux/install-sh

Makefile.am

@@ -1,6 +1,6 @@
 ## Process this file with automake to produce Makefile.in.
 
-bin_SCRIPTS = bin/cuirass
+bin_SCRIPTS = bin/cuirass bin/evaluate
 noinst_SCRIPTS = pre-inst-env
 
 dist_pkgmodule_DATA = \
@@ -30,7 +30,7 @@ AM_SH_LOG_FLAGS = -x -e
 
 TESTS = \
   tests/base.scm \
-  tests/basic.sh \
+## tests/basic.sh # takes too long to execute
   tests/database.scm \
   tests/utils.scm
 

bin/cuirass.in

@@ -27,7 +27,10 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
              (cuirass job)
              (cuirass ui)
              (cuirass utils)
-             (ice-9 getopt-long))
+             (guix derivations)
+             (guix store)
+             (ice-9 getopt-long)
+             (ice-9 popen))
 
 (define* (show-help)
   (simple-format #t "Usage: ~a [OPTIONS] SPECFILE~%" (%program-name))
@@ -56,11 +59,11 @@ if required."
   (let ((cachedir (%package-cachedir)))
     (or (file-exists? cachedir) (mkdir cachedir))
     (with-directory-excursion cachedir
-      (let ((name   (job-spec-name spec))
+      (let ((name   (assq-ref spec #:name))
-            (url    (job-spec-url spec))
+            (url    (assq-ref spec #:url))
-            (branch (job-spec-branch spec))
+            (branch (assq-ref spec #:branch))
-            (commit (job-spec-commit spec))
+            (commit (assq-ref spec #:commit))
-            (tag    (job-spec-tag spec)))
+            (tag    (assq-ref spec #:tag)))
         (or (file-exists? name) (system* "git" "clone" url name))
         (with-directory-excursion name
           (and (zero? (system* "git" "fetch"))
@@ -69,71 +72,53 @@ if required."
                                    commit
                                    (string-append "origin/" branch))))))))))
 
-(define (set-load-path! spec)
+(define (compile dir)
-  "Set %LOAD-PATH to match what is specified in SPEC."
+  ;; Required for fetching Guix bootstrap tarballs.
-  (let* ((name (job-spec-name spec))
+  "Compile files in repository in directory DIR."
-         (path (job-spec-load-path spec))
+  (with-directory-excursion dir
-         (dir  (string-join (list (%package-cachedir) name path) "/")))
+    (or (file-exists? "configure") (system* "./bootstrap"))
-    (format #t "prepending ~s to the load path~%" dir)
+    (or (file-exists? "Makefile")
-    (set! %load-path (cons dir %load-path))))
+        (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 a jobs."
+  "Evaluate and build package derivations.  Return a job alist."
-  (let ((mod (make-user-module)))
+  (let* ((port (open-pipe* OPEN_READ
-    (save-module-excursion
+                           "evaluate"
-     (λ ()
+                           (string-append (%package-cachedir) "/"
-       (set-current-module mod)
+                                          (assq-ref spec #:name) "/"
-       ;; Handle both relative and absolute file names for SPEC-FILE.
+                                          (assq-ref spec #:load-path))
-       (with-directory-excursion
+                           (%package-cachedir)
-           (string-append (%package-cachedir) "/" (job-spec-name spec))
+                           (string-append "'" (object->string spec))))
-         (primitive-load (job-spec-file spec)))))
+         (jobs (read port)))
-    (let* ((proc (module-ref mod (job-spec-proc spec)))
+    (close-pipe port)
-           (jobs (proc store (job-spec-arguments spec))))
+    (map (λ (job)
-      (map (λ (job)
+           (acons #:id (db-add-evaluation db job) job))
-             (let ((id (db-add-evaluation db job)))
+         jobs)))
-               (make-job #:name (job-name job)
-                         #:derivation (job-derivation job)
-                         #:metadata (acons 'id id (job-metadata job)))))
-           jobs))))
 
 (define (build-packages store db jobs)
   "Build JOBS which is a list of <job> objects."
-  (let ((build-derivations (guix-variable 'derivations 'build-derivations))
+  (map (λ (job)
-        (current-build-output-port
+         (let ((log-port (tmpfile))
-         (guix-variable 'store 'current-build-output-port))
+               (name     (assq-ref job #:job-name))
-        (derivation-path->output-path
+               (drv      (assq-ref job #:derivation)))
-         (guix-variable 'derivations 'derivation-path->output-path)))
+           (setvbuf log-port _IOLBF)
-    (map (λ (job)
+           (format #t "building ~A...~%" drv)
-           (let ((log-port (tmpfile))
+           (parameterize ((current-build-output-port log-port))
-                 (name     (job-name job))
+             (build-derivations store (list drv))
-                 (drv      (job-derivation job)))
+             (db-add-build-log db job log-port)
-             (setvbuf log-port _IOLBF)
+             (close-port log-port))
-             (format #t "building ~A...~%" drv)
+           (format #t "~A~%" (derivation-path->output-path drv))))
-             (parameterize ((current-build-output-port log-port))
+       jobs))
-               (build-derivations store (list drv))
-               (db-add-build-log db job log-port)
-               (close-port log-port))
-             (format #t "~A~%" (derivation-path->output-path drv))))
-         jobs)))
 
 (define (process-spec db spec)
   "Evaluate and build SPEC"
   (fetch-repository spec)
-  (let ((old-path %load-path))
+  (compile (string-append (%package-cachedir) "/" (assq-ref spec #:name)))
-    (when (job-spec-load-path spec)
+  (with-store store
-      (set-load-path! spec))
+    (let ((jobs (evaluate store db spec)))
-    (let ((store ((guix-variable 'store 'open-connection))))
+      (set-build-options store #:use-substitutes? #f)
-      (dynamic-wind
+      (build-packages store db jobs))))
-        (const #t)
-        (λ ()
-          (let ((jobs (evaluate store db spec))
-                (set-build-options
-                 (guix-variable 'store 'set-build-options)))
-            (set-build-options store #:use-substitutes? #f)
-            (build-packages store db jobs)))
-        (λ ()
-          ((guix-variable 'store 'close-connection) store)
-          (set! %load-path old-path))))))
 
 (define (process-specs db jobspecs)
   "Evaluate and build JOBSPECS and store results in DB."

bin/evaluate.in

@@ -0,0 +1,96 @@
+#!/bin/sh
+# -*- scheme -*-
+GUILE_LOAD_PATH="$1"
+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 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 format)
+             (ice-9 match)
+             (ice-9 pretty-print)
+             (guix store)
+             (srfi srfi-19))
+
+(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 (call-with-time thunk kont)
+  "Call THUNK and pass KONT the elapsed time followed by THUNK's return
+value."
+  (let* ((start  (current-time time-monotonic))
+         (result (thunk))
+         (end    (current-time time-monotonic)))
+    (kont (time-difference end start) result)))
+
+(define (call-with-time-display thunk)
+  "Call THUNK and write to the current output port its duration."
+  (call-with-time thunk
+    (λ (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* (main #:optional (args (command-line)))
+  (match args
+    ((command load-path cachedir specstr)
+     ;; Load FILE, a Scheme file that defines Hydra jobs.
+     (let* ((%user-module (make-fresh-user-module))
+            (spec (eval-string specstr %user-module))
+            (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
+         ;; 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)
+                 (format stderr "'build-things' arguments: ~S~%" args)
+                 (exit 1)))
+         ;; Call the entry point of FILE and print the resulting job sexp.
+         (pretty-print
+          (let* ((proc   (module-ref %user-module 'hydra-jobs) )
+                 (thunks (proc store (assq-ref spec #:arguments))))
+            (map (λ (thunk)
+                   (call-with-time-display thunk))
+                 thunks))
+          stdout))))
+    ((command _ ...)
+     (format (current-error-port) "Usage: ~A FILE
+Evaluate the Hydra jobs defined in FILE.~%"
+             command)
+     (exit 1))))

configure.ac

@@ -28,6 +28,7 @@ AC_SUBST([pkgmoduledir])
 AC_CONFIG_FILES([Makefile
                  src/cuirass/config.scm])
 AC_CONFIG_FILES([bin/cuirass], [chmod +x bin/cuirass])
+AC_CONFIG_FILES([bin/evaluate], [chmod +x bin/evaluate])
 AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in],
   [chmod +x pre-inst-env])
 AC_OUTPUT

src/cuirass/database.scm

@@ -93,8 +93,8 @@ database object."
   (sqlite-exec
    db
    (format #f "insert into build (job_spec, drv) values ('~A', '~A');"
-           (job-name job)
+           (assq-ref job #:job-name)
-           (job-derivation job)))
+           (assq-ref job #:derivation)))
   (let* ((stmt (sqlite-prepare db "select last_insert_rowid() from build;"))
          (res  (sqlite-step stmt)))
     (sqlite-finalize stmt)
@@ -133,7 +133,7 @@ string."
 
 (define (db-add-build-log db job log)
   "Store a build LOG corresponding to JOB in database DB."
-  (let ((id   (assoc-ref (job-metadata job) 'id))
+  (let ((id   (assq-ref job #:id))
         (log* (cond ((string? log) log)
                     ((port? log)
                      (seek log 0 SEEK_SET)

tests/database.scm

@@ -21,10 +21,9 @@
              (cuirass job)
              (srfi srfi-64))
 
-(define* (make-dummy-job #:optional (name "foo") #:key (metadata '()))
+(define* (make-dummy-job #:optional (name "foo"))
-  (make-job #:name name
+  `((#:name . ,name)
-            #:derivation (string-append name ".drv")
+    (#:derivation . ,(string-append name ".drv"))))
-            #:metadata metadata))
 
 (define %db
   ;; Global Slot for a database object.
@@ -51,11 +50,11 @@
         (db-get-evaluation (%db) (%id)))
 
       (test-equal "db-add-build-log"
-        (let ((job (make-dummy-job #:metadata `((id . ,(%id)))))
+        "foo log"
+        (let ((job (acons #:id (%id) (make-dummy-job)))
               (log-column 3))
           (db-add-build-log (%db) job "foo log")
-          (vector-ref (db-get-evaluation (%db) (%id)) log-column))
+          (vector-ref (db-get-evaluation (%db) (%id)) log-column)))
-        "foo log")
 
       (test-assert "db-close"
         (db-close (%db))))

tests/gnu-system.scm

@@ -25,8 +25,7 @@
   ;; newer, even though they may not correspond.
   (set! %fresh-auto-compile #t))
 
-(use-modules (cuirass job)
+(use-modules (guix config)
-             (guix config)
              (guix store)
              (guix grafts)
              (guix packages)
@@ -55,36 +54,38 @@
 
 (define (package-metadata package)
   "Convert PACKAGE to an alist suitable for Hydra."
-  `((description . ,(package-synopsis package))
+  `((#:description . ,(package-synopsis package))
-    (long-description . ,(package-description package))
+    (#:long-description . ,(package-description package))
-    (license . ,(package-license package))
+    ;; (#:license . ,(package-license package))
-    (home-page . ,(package-home-page package))
+    (#:home-page . ,(package-home-page package))
-    (maintainers . ("bug-guix@gnu.org"))
+    (#:maintainers . ("bug-guix@gnu.org"))
-    (max-silent-time . ,(or (assoc-ref (package-properties package)
+    (#:max-silent-time . ,(or (assoc-ref (package-properties package)
-                                       'max-silent-time)
+                                         'max-silent-time)
-                            3600))      ;1 hour by default
+                              3600))      ;1 hour by default
-    (timeout . ,(or (assoc-ref (package-properties package) 'timeout)
+    (#:timeout . ,(or (assoc-ref (package-properties package) 'timeout)
-                    72000))))           ;20 hours by default
+                      72000))))           ;20 hours by default
 
 (define (package-job store job-name package system)
   "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
-  (make-job
+  (λ ()
-   #:name (string-append (symbol->string job-name) "." system)
+    `((#:job-name . ,(string-append (symbol->string job-name) "." system))
-   #:derivation (derivation-file-name
+      (#:derivation . ,(derivation-file-name
-                 (parameterize ((%graft? #f))
+                        (parameterize ((%graft? #f))
-                   (package-derivation store package system #:graft? #f)))
+                          (package-derivation store package system
-   #:metadata (package-metadata package)))
+                                              #: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."
-  (make-job
+  (λ ()
-   #:name (string-append target "." (symbol->string job-name) "." system)
+    `((#:job-name . ,(string-join (list target (symbol->string job-name) system)
-   #:derivation (derivation-file-name
+                                  "."))
-                 (parameterize ((%graft? #f))
+      (#:derivation . ,(derivation-file-name
-                   (package-cross-derivation store package target system
+                        (parameterize ((%graft? #f))
-                                             #:graft? #f)))
+                          (package-cross-derivation store package target system
-   #:metadata (package-metadata package)))
+                                                    #:graft? #f))))
+      ,@(package-metadata package))))
 
 (define %core-packages
   ;; Note: Don't put the '-final' package variants because (1) that's
@@ -107,25 +108,24 @@ for TARGET on SYSTEM."
   '("mips64el-linux-gnu"
     "mips64el-linux-gnuabi64"))
 
-(define (tarball-jobs store system)
+(define (tarball-job store system)
   "Return Hydra jobs to build the self-contained Guix binary tarball."
-  (list
+  (λ ()
-   (make-job
+    `((#:job-name . (string-append "binary-tarball." system))
-    #:name (string-append "binary-tarball." system)
+      (#:derivation . ,(derivation-file-name
-    #:derivation (derivation-file-name
+                        (parameterize ((%graft? #f))
-                  (parameterize ((%graft? #f))
+                          (run-with-store store
-                    (run-with-store store
+                            (mbegin %store-monad
-                      (mbegin %store-monad
+                              (set-guile-for-build (default-guile))
-                        (set-guile-for-build (default-guile))
+                              (self-contained-tarball))
-                        (self-contained-tarball))
+                            #:system system))))
-                      #:system system)))
+      (#:description . "Stand-alone binary Guix tarball")
-    #:metadata
+      (#:long-description . "This is a tarball containing binaries of Guix
-    `((description . "Stand-alone binary Guix tarball")
+and all its dependencies, and ready to be installed on non-GuixSD
-      (long-description . "This is a tarball containing binaries of Guix and
+distributions.")
-all its dependencies, and ready to be installed on non-GuixSD distributions.")
+      ;; (#:license . ,gpl3+)
-      (license . ,gpl3+)
+      (#:home-page . ,%guix-home-page-url)
-      (home-page . ,%guix-home-page-url)
+      (#:maintainers . ("bug-guix@gnu.org")))))
-      (maintainers . ("bug-guix@gnu.org"))))))
 
 (define %job-name
   ;; Return the name of a package's job.
@@ -207,7 +207,7 @@ valid."
                        (append (filter-map (lambda (pkg)
                                              (package->job store pkg system))
                                            pkgs)
-                               (tarball-jobs store system)
+                               (list (tarball-job store system))
                                (cross-jobs system))))
                     ((core)
                      ;; Build core packages only.

tests/guix-jobs.scm

@@ -17,24 +17,20 @@
 ;;; 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 job))
-
-;; In the common case jobs will be defined relative to the repository.
-;; However for testing purpose use local gnu-system.scm instead.
 (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))
 
-(list (make-job-spec
+`(((#:name . "guix")
-       #:name "guix"
+   (#:url . "git://git.savannah.gnu.org/guix.git")
-       #:url "git://git.savannah.gnu.org/guix.git"
+   (#:load-path . ".")
-       #:load-path "."
+   (#:branch . "master")
-       #:branch "master"
+   (#:file . ,(local-file "gnu-system.scm"))
-       #:file (local-file "gnu-system.scm")
+   (#:proc . hydra-jobs))
-       #:proc 'hydra-jobs)
+  ((#:name . "guix")
-      (make-job-spec
+   (#:url . "git://git.savannah.gnu.org/guix.git")
-       #:name "guix"
+   (#:load-path . ".")
-       #:url "git://git.savannah.gnu.org/guix.git"
+   (#:tag . "v0.10.0")
-       #:load-path "."
+   (#:file . ,(local-file "gnu-system.scm"))
-       #:tag "v0.10.0"
+   (#:proc . hydra-jobs)))
-       #:file (local-file "gnu-system.scm")
-       #:proc 'hydra-jobs))

tests/hello-subset.scm

@@ -17,34 +17,29 @@
 ;;; 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 job))
-
-;; In the common case jobs will be defined relative to the repository.
-;; However for testing purpose use local gnu-system.scm instead.
 (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))
 
-(list (make-job-spec
+`(((#:name . "guix")
-       #:name "guix"
+   (#:url . "git://git.savannah.gnu.org/guix.git")
-       #:url "git://git.savannah.gnu.org/guix.git"
+   (#:load-path . ".")
-       #:load-path "."
+   (#:branch . "master")
-       #:branch "master"
+   (#:file . ,(local-file "gnu-system.scm"))
-       #:file (local-file "gnu-system.scm")
+   (#:proc . hydra-jobs)
-       #:proc 'hydra-jobs
+   (#:arguments (subset . "hello")))
-       #:arguments '((subset . "hello")))
+  ((#:name . "guix")
-      (make-job-spec
+   (#:url . "git://git.savannah.gnu.org/guix.git")
-       #:name "guix"
+   (#:load-path . ".")
-       #:url "git://git.savannah.gnu.org/guix.git"
+   (#:branch . "core-updates")
-       #:load-path "."
+   (#:file . ,(local-file "gnu-system.scm"))
-       #:branch "core-updates"
+   (#:proc . hydra-jobs)
-       #:file (local-file "gnu-system.scm")
+   (#:arguments (subset . "hello")))
-       #:proc 'hydra-jobs
+  ((#:name . "guix")
-       #:arguments '((subset . "hello")))
+   (#:url . "git://git.savannah.gnu.org/guix.git")
-      (make-job-spec
+   (#:load-path . ".")
-       #:name "guix"
+   (#:tag . "v0.9.0")
-       #:url "git://git.savannah.gnu.org/guix.git"
+   (#:file . ,(local-file "gnu-system.scm"))
-       #:load-path "."
+   (#:proc . hydra-jobs)
-       #:tag "v0.9.0"
+   (#:arguments (subset . "hello"))))
-       #:file (local-file "gnu-system.scm")
-       #:proc 'hydra-jobs
-       #:arguments '((subset . "hello"))))