mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 13:36:36 +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-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)))