mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-31 06:46:50 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

ci: Update to the last version.

Browse source 
* gnu/ci.scm: Update to the master version.
This commit is contained in:
Mathieu Othacehe 2021-06-14 08:58:41 +02:00
parent 6110751b53
commit aa34d4d28d
No known key found for this signature in database
GPG key ID: 8354763531769CA6
1 changed files with 60 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

94
gnu/ci.scm
View file

@ -66,9 +66,14 @@ (define-module (gnu ci)
#: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
arguments->systems
cuirass-jobs)) cuirass-jobs))
;;; Commentary: ;;; Commentary:
@ -87,6 +92,9 @@ (define* (derivation->job name drv
building the derivation." building the derivation."
`((#:job-name . ,name) `((#:job-name . ,name)
(#:derivation . ,(derivation-file-name drv)) (#:derivation . ,(derivation-file-name drv))
(#:inputs . ,(map (compose derivation-file-name
derivation-input-derivation)
(derivation-inputs drv)))
(#:outputs . ,(filter-map (#:outputs . ,(filter-map
(lambda (res) (lambda (res)
(match res (match res
@ -232,43 +240,48 @@ (define %guix-system-images
(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)
'())) '()))
'())) '()))
@ -435,6 +448,13 @@ (define (load-manifest manifest)
load-manifest) load-manifest)
manifests)))) 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. ;;; Cuirass entry point.
@ -446,10 +466,7 @@ (define subset
(assoc-ref arguments 'subset)) (assoc-ref arguments 'subset))
(define systems (define systems
(match (assoc-ref arguments 'systems) (arguments->systems arguments))
(#f %cuirass-supported-systems)
((lst ...) lst)
((? string? str) (call-with-input-string str read))))
(define channels (define channels
(let ((channels (assq-ref arguments 'channels))) (let ((channels (assq-ref arguments 'channels)))
@ -514,6 +531,15 @@ (define source
('tarball ('tarball
;; Build Guix tarball only. ;; Build Guix tarball only.
(tarball-jobs store system)) (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) (('channels . channels)
;; Build only the packages from CHANNELS. ;; Build only the packages from CHANNELS.
(let ((all (all-packages))) (let ((all (all-packages)))