04/04: hydra: Compute jobs in an inferior.

[guix-commits]

civodul pushed a commit to branch wip-ci-inferior
in repository guix.

commit d2699836100450778e88f04ac0e507bbe12a5d0f
Author: Ludovic Courtès <address@hidden>
Date:   Mon Nov 26 17:17:45 2018 +0100

    hydra: Compute jobs in an inferior.
    
    Previously we would rely on auto-compilation of all the Guix modules.
    The complete evaluation would take ~15mn on berlin.guixsd.org and
    require lots of RAM.  This approach should be faster since potentially
    only part of the modules are rebuilt.  Furthermore, as a side-effect, it
    builds the derivations that 'guix pull' uses.
    
    * build-aux/hydra/gnu-system.scm: Remove 'eval-when' form.
    (hydra-jobs): New procedure.
    * gnu/ci.scm (package->alist, qemu-jobs, system-test-jobs)
    (tarball-jobs): Return strings for the 'license' field.
    * guix/self.scm (compiled-guix)[*cli-modules*]: Add (gnu ci).
---
 build-aux/hydra/gnu-system.scm | 73 ++++++++++++++++++++++++++----------------
 gnu/ci.scm                     | 20 +++++++++---
 guix/self.scm                  |  3 +-
 3 files changed, 62 insertions(+), 34 deletions(-)

diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm
index 150c2bd..775bbd9 100644
--- a/build-aux/hydra/gnu-system.scm
+++ b/build-aux/hydra/gnu-system.scm
@@ -23,39 +23,56 @@
 ;;; tool.
 ;;;
 
-(use-modules (system base compile))
+(use-modules (guix inferior) (guix channels)
+             (guix)
+             (guix ui)
+             (srfi srfi-1)
+             (ice-9 match))
 
-(eval-when (expand load eval)
+;; 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))
 
-  ;; Pre-load the compiler so we don't end up auto-compiling it.
-  (compile #t)
+(define (hydra-jobs store arguments)
+  "Return a list of jobs where each job is a NAME/THUNK pair."
+  (define checkout
+    ;; Extract metadata about the 'guix' checkout.  Its key in ARGUMENTS may
+    ;; vary, so pick up the first one that's neither 'subset' nor 'systems'.
+    (any (match-lambda
+           ((key . value)
+            (and (not (memq key '(systems subset)))
+                 value)))
+         arguments))
 
-  ;; Use our very own Guix modules.
-  (set! %fresh-auto-compile #t)
+  (define commit
+    (assq-ref checkout 'revision))
 
-  ;; Ignore .go files except for Guile's.  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.  Use 'reverse' so that /gnu/store/…-guile
-  ;; comes before /run/current-system/profile.
-  (set! %load-compiled-path
-    (list
-     (dirname (dirname (search-path (reverse %load-compiled-path)
-                                    "ice-9/boot-9.go")))))
+  (define source
+    (assq-ref checkout 'file-name))
 
-  (and=> (assoc-ref (current-source-location) 'filename)
-         (lambda (file)
-           (let ((dir (canonicalize-path
-                       (string-append (dirname file) "/../.."))))
-             (format (current-error-port) "prepending ~s to the load path~%"
-                     dir)
-             (set! %load-path (cons dir %load-path))))))
+  (define instance
+    (checkout->channel-instance source #:commit commit))
 
-(use-modules (gnu ci))
+  (define derivation
+    ;; Compute the derivation of Guix for COMMIT.
+    (run-with-store store
+      (channel-instances->derivation (list instance))))
 
-;; 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))
+  (show-what-to-build store (list derivation))
+  (build-derivations store (list derivation))
+
+  ;; Open an inferior for the just-built Guix.
+  (let ((inferior (open-inferior (derivation->output-path derivation))))
+    (inferior-eval '(use-modules (gnu ci) (ice-9 match)) inferior)
 
-;; Return the procedure from (gnu ci).
-hydra-jobs
+    (map (match-lambda
+           ((name . fields)
+            ;; Hydra expects a thunk, so here it is.
+            (cons name (lambda () fields))))
+         (inferior-eval-with-store inferior store
+                                   `(lambda (store)
+                                      (map (match-lambda
+                                             ((name . thunk)
+                                              (cons name (thunk))))
+                                           (hydra-jobs store ',arguments)))))))
diff --git a/gnu/ci.scm b/gnu/ci.scm
index 7db7e60..c071f21 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -27,7 +27,8 @@
   #:use-module (guix derivations)
   #:use-module (guix monads)
   #:use-module (guix ui)
-  #:use-module ((guix licenses) #:select (gpl3+))
+  #:use-module ((guix licenses)
+                #:select (gpl3+ license? license-name))
   #:use-module ((guix utils) #:select (%current-system))
   #:use-module ((guix scripts system) #:select (read-operating-system))
   #:use-module ((guix scripts pack)
@@ -69,7 +70,16 @@
                                           #:graft? #f)))
       (description . ,(package-synopsis package))
       (long-description . ,(package-description package))
-      (license . ,(package-license package))
+
+      ;; XXX: Hydra ignores licenses that are not a <license> structure or a
+      ;; list thereof.
+      (license . ,(let loop ((license (package-license package)))
+                    (match license
+                      ((? license?)
+                       (license-name license))
+                      ((lst ...)
+                       (map loop license)))))
+
       (home-page . ,(package-home-page package))
       (maintainers . ("address@hidden"))
       (max-silent-time . ,(or (assoc-ref (package-properties package)
@@ -133,7 +143,7 @@ SYSTEM."
       (description . "Stand-alone QEMU image of the GNU system")
       (long-description . "This is a demo stand-alone QEMU image of the GNU
 system.")
-      (license . ,gpl3+)
+      (license . ,(license-name gpl3+))
       (max-silent-time . 600)
       (timeout . 3600)
       (home-page . ,%guix-home-page-url)
@@ -194,7 +204,7 @@ system.")
         (description . ,(format #f "GuixSD '~a' system test"
                                 (system-test-name test)))
         (long-description . ,(system-test-description test))
-        (license . ,gpl3+)
+        (license . ,(license-name gpl3+))
         (max-silent-time . 600)
         (timeout . 3600)
         (home-page . ,%guix-home-page-url)
@@ -217,7 +227,7 @@ 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 . ,gpl3+)
+      (license . ,(license-name gpl3+))
       (home-page . ,%guix-home-page-url)
       (maintainers . ("address@hidden"))))
 
diff --git a/guix/self.scm b/guix/self.scm
index f2db3db..2664fd8 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -624,7 +624,8 @@ assumed to be part of MODULES."
 
   (define *cli-modules*
     (scheme-node "guix-cli"
-                 (scheme-modules* source "/guix/scripts")
+                 (append (scheme-modules* source "/guix/scripts")
+                         `((gnu ci)))
                  (list *core-modules* *extra-modules*
                        *core-package-modules* *package-modules*
                        *system-modules*)