From aa34d4d28dfe25ba47d5800d05000fb7221788c0 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Mon, 14 Jun 2021 08:58:41 +0200
Subject: ci: Update to the last version.

* gnu/ci.scm: Update to the master version.
---
 gnu/ci.scm | 94 +++++++++++++++++++++++++++++++++++++++-----------------------
 1 file changed, 60 insertions(+), 34 deletions(-)

diff --git a/gnu/ci.scm b/gnu/ci.scm
index babbb60f81..c5de25e70e 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -66,9 +66,14 @@ (define-module (gnu ci)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
-  #:export (%core-packages
+  #:export (derivation->job
+            image->job
+
+            %core-packages
             %cross-targets
             channel-source->package
+
+            arguments->systems
             cuirass-jobs))
 
 ;;; Commentary:
@@ -87,6 +92,9 @@ (define* (derivation->job name drv
 building the derivation."
   `((#:job-name . ,name)
     (#:derivation . ,(derivation-file-name drv))
+    (#:inputs . ,(map (compose derivation-file-name
+                               derivation-input-derivation)
+                      (derivation-inputs drv)))
     (#:outputs . ,(filter-map
                    (lambda (res)
                      (match res
@@ -232,43 +240,48 @@ (define %guix-system-images
 (define (hours hours)
   (* 3600 hours))
 
+(define* (image->job store image
+                     #:key name system)
+  "Return the job for IMAGE on SYSTEM.  If NAME is passed, use it as job name,
+otherwise use the IMAGE name."
+  (let* ((image-name (or name
+                         (symbol->string (image-name image))))
+         (name (string-append image-name "." system))
+         (drv (run-with-store store
+                (mbegin %store-monad
+                  (set-guile-for-build (default-guile))
+                  (lower-object (system-image image))))))
+    (parameterize ((%graft? #f))
+      (derivation->job name drv))))
+
 (define (image-jobs store system)
   "Return a list of jobs that build images for SYSTEM."
-  (define (->job name drv)
-    (let ((name (string-append name "." system)))
-      (parameterize ((%graft? #f))
-        (derivation->job name drv))))
-
-  (define (build-image image)
-    (run-with-store store
-      (mbegin %store-monad
-        (set-guile-for-build (default-guile))
-        (lower-object (system-image image)))))
-
   (define MiB
     (expt 2 20))
 
   (if (member system %guix-system-supported-systems)
-      `(,(->job "usb-image"
-                (build-image
-                 (image
-                  (inherit efi-disk-image)
-                  (operating-system installation-os))))
-        ,(->job "iso9660-image"
-                (build-image
-                 (image
-                  (inherit (image-with-label
-                            iso9660-image
-                            (string-append "GUIX_" system "_"
-                                           (if (> (string-length %guix-version) 7)
-                                               (substring %guix-version 0 7)
-                                               %guix-version))))
-                  (operating-system installation-os))))
+      `(,(image->job store
+                     (image
+                      (inherit efi-disk-image)
+                      (operating-system installation-os))
+                     #:name "usb-image"
+                     #:system system)
+        ,(image->job
+          store
+          (image
+           (inherit (image-with-label
+                     iso9660-image
+                     (string-append "GUIX_" system "_"
+                                    (if (> (string-length %guix-version) 7)
+                                        (substring %guix-version 0 7)
+                                        %guix-version))))
+           (operating-system installation-os))
+          #:name "iso9660-image"
+          #:system system)
         ;; Only cross-compile Guix System images from x86_64-linux for now.
         ,@(if (string=? system "x86_64-linux")
-              (map (lambda (image)
-                     (->job (symbol->string (image-name image))
-                            (build-image image)))
+              (map (cut image->job store <>
+                        #:system system)
                    %guix-system-images)
               '()))
       '()))
@@ -435,6 +448,13 @@ (define (load-manifest manifest)
                              load-manifest)
                     manifests))))
 
+(define (arguments->systems arguments)
+  "Return the systems list from ARGUMENTS."
+  (match (assoc-ref arguments 'systems)
+    (#f              %cuirass-supported-systems)
+    ((lst ...)       lst)
+    ((? string? str) (call-with-input-string str read))))
+
 
 ;;;
 ;;; Cuirass entry point.
@@ -446,10 +466,7 @@ (define subset
     (assoc-ref arguments 'subset))
 
   (define systems
-    (match (assoc-ref arguments 'systems)
-      (#f              %cuirass-supported-systems)
-      ((lst ...)       lst)
-      ((? string? str) (call-with-input-string str read))))
+    (arguments->systems arguments))
 
   (define channels
     (let ((channels (assq-ref arguments 'channels)))
@@ -514,6 +531,15 @@ (define source
          ('tarball
           ;; Build Guix tarball only.
           (tarball-jobs store system))
+         (('custom . modules)
+          ;; Build custom modules jobs only.
+          (append-map
+           (lambda (module)
+             (let ((proc (module-ref
+                          (resolve-interface module)
+                          'cuirass-jobs)))
+               (proc store arguments)))
+           modules))
          (('channels . channels)
           ;; Build only the packages from CHANNELS.
           (let ((all (all-packages)))
-- 
cgit v1.2.3