Evaluate derivations in a separate process.

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

2 files changed, 143 insertions, 62 deletions

diff --git a/bin/cuirass.in b/bin/cuirass.in
index 04d439b..8b3f05d 100644
--- a/bin/cuirass.in
+++ b/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))
-            (url    (job-spec-url spec))
-            (branch (job-spec-branch spec))
-            (commit (job-spec-commit spec))
-            (tag    (job-spec-tag spec)))
+      (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)))
         (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)
-  "Set %LOAD-PATH to match what is specified in SPEC."
-  (let* ((name (job-spec-name spec))
-         (path (job-spec-load-path spec))
-         (dir  (string-join (list (%package-cachedir) name path) "/")))
-    (format #t "prepending ~s to the load path~%" dir)
-    (set! %load-path (cons dir %load-path))))
+(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 a jobs."
-  (let ((mod (make-user-module)))
-    (save-module-excursion
-     (λ ()
-       (set-current-module mod)
-       ;; Handle both relative and absolute file names for SPEC-FILE.
-       (with-directory-excursion
-           (string-append (%package-cachedir) "/" (job-spec-name spec))
-         (primitive-load (job-spec-file spec)))))
-    (let* ((proc (module-ref mod (job-spec-proc spec)))
-           (jobs (proc store (job-spec-arguments spec))))
-      (map (λ (job)
-             (let ((id (db-add-evaluation db job)))
-               (make-job #:name (job-name job)
-                         #:derivation (job-derivation job)
-                         #:metadata (acons 'id id (job-metadata job)))))
-           jobs))))
+  "Evaluate and build package derivations.  Return a job alist."
+  (let* ((port (open-pipe* OPEN_READ
+                           "evaluate"
+                           (string-append (%package-cachedir) "/"
+                                          (assq-ref spec #:name) "/"
+                                          (assq-ref spec #:load-path))
+                           (%package-cachedir)
+                           (string-append "'" (object->string spec))))
+         (jobs (read port)))
+    (close-pipe port)
+    (map (λ (job)
+           (acons #:id (db-add-evaluation db job) 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))
-        (current-build-output-port
-         (guix-variable 'store 'current-build-output-port))
-        (derivation-path->output-path
-         (guix-variable 'derivations 'derivation-path->output-path)))
-    (map (λ (job)
-           (let ((log-port (tmpfile))
-                 (name     (job-name job))
-                 (drv      (job-derivation job)))
-             (setvbuf log-port _IOLBF)
-             (format #t "building ~A...~%" drv)
-             (parameterize ((current-build-output-port log-port))
-               (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)))
+  (map (λ (job)
+         (let ((log-port (tmpfile))
+               (name     (assq-ref job #:job-name))
+               (drv      (assq-ref job #:derivation)))
+           (setvbuf log-port _IOLBF)
+           (format #t "building ~A...~%" drv)
+           (parameterize ((current-build-output-port log-port))
+             (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))
-    (when (job-spec-load-path spec)
-      (set-load-path! spec))
-    (let ((store ((guix-variable 'store 'open-connection))))
-      (dynamic-wind
-        (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))))))
+  (compile (string-append (%package-cachedir) "/" (assq-ref spec #:name)))
+  (with-store store
+    (let ((jobs (evaluate store db spec)))
+      (set-build-options store #:use-substitutes? #f)
+      (build-packages store db jobs))))
 
 (define (process-specs db jobspecs)
   "Evaluate and build JOBSPECS and store results in DB."
diff --git a/bin/evaluate.in b/bin/evaluate.in
new file mode 100644
index 0000000..8152e85
--- /dev/null
+++ b/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))))