#: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:
(define* (derivation->job name drv
#:key
- period
(max-silent-time 3600)
(timeout 3600))
- "Return a Cuirass job called NAME and describing DRV. PERIOD is the minimal
-duration that must separate two evaluations of the same job. If PERIOD is
-false, then the job will be evaluated as soon as possible.
+ "Return a Cuirass job called NAME and describing DRV.
MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
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
(derivation->output-paths drv)))
(#:nix-name . ,(derivation-name drv))
(#:system . ,(derivation-system drv))
- (#:period . ,period)
(#:max-silent-time . ,max-silent-time)
(#:timeout . ,timeout)))
"arm-linux-gnueabihf"
"aarch64-linux-gnu"
"powerpc-linux-gnu"
+ "powerpc64le-linux-gnu"
"riscv64-linux-gnu"
"i586-pc-gnu" ;aka. GNU/Hurd
"i686-w64-mingw32"
(define (hours hours)
(* 3600 hours))
-(define (image-jobs store system)
- "Return a list of jobs that build images for SYSTEM. Those jobs are
-expensive in storage and I/O operations, hence their periodicity is limited by
-passing the PERIOD argument."
- (define (->job name drv)
- (let ((name (string-append name "." system)))
- (parameterize ((%graft? #f))
- (derivation->job name drv
- #:period (hours 48)))))
-
- (define (build-image image)
- (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (lower-object (system-image image)))))
+(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 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)
'()))
'()))
#:key source commit)
"Return a list of jobs for the system tests."
(define (->job test)
- (parameterize ((current-guix-package
- (channel-source->package source #:commit commit)))
- (let ((name (string-append "test." (system-test-name test)
- "." system))
- (drv (run-with-store store
- (mbegin %store-monad
- (set-current-system system)
- (set-grafting #f)
- (set-guile-for-build (default-guile))
- (system-test-value test)))))
-
- ;; Those tests are extremely expensive in I/O operations and storage
- ;; size, use the "period" attribute to run them with a period of at
- ;; least 48 hours.
- (derivation->job name drv
- #:period (hours 24)))))
+ (let ((name (string-append "test." (system-test-name test)
+ "." system))
+ (drv (run-with-store store
+ (mbegin %store-monad
+ (set-current-system system)
+ (set-grafting #f)
+ (set-guile-for-build (default-guile))
+ (system-test-value test)))))
+
+ (derivation->job name drv)))
(if (member system %guix-system-supported-systems)
;; Override the value of 'current-guix' used by system tests. Using a
;; channel instance makes tests that rely on 'current-guix' less
;; expensive. It also makes sure we get a valid Guix package when this
;; code is not running from a checkout.
- (map ->job (all-system-tests))
+ (parameterize ((current-guix-package
+ (channel-source->package source #:commit commit)))
+ (map ->job (all-system-tests)))
'()))
(define (tarball-jobs store system)
(define (->job name drv)
(let ((name (string-append name "." system)))
(parameterize ((%graft? #f))
- (derivation->job name drv
- #:period (hours 24)))))
+ (derivation->job name drv))))
;; XXX: Add a job for the stable Guix?
(list
(>>= (profile-derivation (packages->manifest (list guix)))
(lambda (profile)
(self-contained-tarball "guix-binary" profile
+ #:profile-name "current-guix"
#:localstatedir? #t
#:compressor
(lookup-compressor "xz")))))
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))))
+
\f
;;;
;;; Cuirass entry point.
(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)))
(package->job store package system))))
(append
(filter-map job all)
- (image-jobs store system)
- (system-test-jobs store system
- #:source source
- #:commit commit)
- (tarball-jobs store system)
(cross-jobs store system))))
('core
;; Build core packages only.
(let ((hello (specification->package "hello")))
(list (package-job store (job-name hello)
hello system))))
+ ('images
+ ;; Build Guix System images only.
+ (image-jobs store system))
+ ('system-tests
+ ;; Build Guix System tests only.
+ (system-test-jobs store system
+ #:source source
+ #:commit commit))
+ ('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)))
HCoop / jackhill / guix / guix.git / blobdiff