amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

ci: Factorize image->job procedure.

Browse source 
* gnu/ci.scm (image-jobs): Extract ->job procedure into ...
(image->job): ... this new procedure.
This commit is contained in:
Mathieu Othacehe 2021-04-28 11:51:33 +02:00
parent 93242b54e4
commit 996b5edf51
No known key found for this signature in database
GPG key ID: 8354763531769CA6
1 changed files with 38 additions and 30 deletions
Download patch file Download diff file Expand all files Collapse all files

68
gnu/ci.scm
View file

@ -66,7 +66,10 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (%core-packages #:export (derivation->job
image->job
%core-packages
%cross-targets %cross-targets
channel-source->package channel-source->package
cuirass-jobs)) cuirass-jobs))
@ -232,43 +235,48 @@ SYSTEM."
(define (hours hours) (define (hours hours)
(* 3600 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) (define (image-jobs store system)
"Return a list of jobs that build images for 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 (define MiB
(expt 2 20)) (expt 2 20))
(if (member system %guix-system-supported-systems) (if (member system %guix-system-supported-systems)
`(,(->job "usb-image" `(,(image->job store
(build-image (image
(image (inherit efi-disk-image)
(inherit efi-disk-image) (operating-system installation-os))
(operating-system installation-os)))) #:name "usb-image"
,(->job "iso9660-image" #:system system)
(build-image ,(image->job
(image store
(inherit (image-with-label (image
iso9660-image (inherit (image-with-label
(string-append "GUIX_" system "_" iso9660-image
(if (> (string-length %guix-version) 7) (string-append "GUIX_" system "_"
(substring %guix-version 0 7) (if (> (string-length %guix-version) 7)
%guix-version)))) (substring %guix-version 0 7)
(operating-system installation-os)))) %guix-version))))
(operating-system installation-os))
#:name "iso9660-image"
#:system system)
;; Only cross-compile Guix System images from x86_64-linux for now. ;; Only cross-compile Guix System images from x86_64-linux for now.
,@(if (string=? system "x86_64-linux") ,@(if (string=? system "x86_64-linux")
(map (lambda (image) (map (cut image->job store <>
(->job (symbol->string (image-name image)) #:system system)
(build-image image)))
%guix-system-images) %guix-system-images)
'())) '()))
'())) '()))