01/03: ci: Factorize image->job procedure.

[guix-commits]

mothacehe pushed a commit to branch master
in repository guix.

commit 996b5edf51c132764ca8122d401c5bb2b8d2e3c5
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Wed Apr 28 11:51:33 2021 +0200

    ci: Factorize image->job procedure.
    
    * gnu/ci.scm (image-jobs): Extract ->job procedure into ...
    (image->job): ... this new procedure.
---
 gnu/ci.scm | 68 +++++++++++++++++++++++++++++++++++---------------------------
 1 file changed, 38 insertions(+), 30 deletions(-)

diff --git a/gnu/ci.scm b/gnu/ci.scm
index babbb60..9e4f0a8 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -66,7 +66,10 @@
   #: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
             cuirass-jobs))
@@ -232,43 +235,48 @@ SYSTEM."
 (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)
               '()))
       '()))