mirrors
/
cuirass
mirror of https://notabug.org/mthl/cuirass.git
1
0
Fork 0
Code Issues Releases Wiki Activity

job: Add <job-spec> record type. 

* src/cuirass/job.scm <job-spec>: New record type.
(%make-job-spec, make-job-spec, job-spec-name, job-spec-proc)
(job-spec-metadata): New procedures.
* tests/gnu-system.scm (package-job): Rename to ...
(package-job-spec): ... this.  Use 'make-job-spec'.
(package-cross-job): Rename to ...
(package-cross-job-spec): ... this.  Use 'make-job-spec'.
(tarball-jobs): Rename to ...
(tarball-job-specs): ... this.  Use 'make-job-spec'.
(package->alist): Rename to ...
(package-metadata): ... this.  Adapt.
(package->job): Rename to ...
(package->jobspec): ... this.  Adapt.
(hydra-jobs): Adapt.
pull/3/head
Mathieu Lirzin 2016-06-12 01:19:30 +02:00
parent 9f5896ccd2
commit 49ab3c8b0d
No known key found for this signature in database
GPG Key ID: 0ADEE10094604D37
3 changed files with 87 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
bin/cuirass.in
View File

@ -91,15 +91,13 @@ DIR if required."
(format #t "prepending ~s to the load path~%" guixdir) (format #t "prepending ~s to the load path~%" guixdir)
(set! %load-path (cons guixdir %load-path))) (set! %load-path (cons guixdir %load-path)))
(primitive-load spec))) (primitive-load spec)))
(match ((module-ref %user-module 'hydra-jobs) store '()) (let ((job-specs ((module-ref %user-module 'hydra-jobs) store '())))
(((names . thunks) ...) (map (match-lambda
(map (lambda (job thunk) (($ <job-spec> name thunk metadata)
(format (current-error-port) "evaluating '~a'... " job) (format (current-error-port) "evaluating '~a'... " name)
(force-output (current-error-port)) (force-output (current-error-port))
(make-job (symbol->string job) (make-job name (call-with-time-display thunk) metadata)))
(assoc-ref (call-with-time-display thunk) job-specs)))
'derivation)))
names thunks))))
;;; ;;;

18
src/cuirass/job.scm
View File

@ -24,7 +24,13 @@
job? job?
job-name job-name
job-derivation job-derivation
job-metadata)) job-metadata
<job-spec>
make-job-spec
job-spec-name
job-spec-proc
job-spec-metadata))
(define-record-type <job> (define-record-type <job>
(%make-job name derivation metadata) (%make-job name derivation metadata)
@ -35,3 +41,13 @@
(define* (make-job name drv #:optional (metadata '())) (define* (make-job name drv #:optional (metadata '()))
(%make-job name drv metadata)) (%make-job name drv metadata))
(define-record-type <job-spec>
(%make-job-spec name proc metadata)
job-spec?
(name job-spec-name) ;string
(proc job-spec-proc) ;thunk
(metadata job-spec-metadata)) ;alist
(define* (make-job-spec #:key name procedure metadata)
(%make-job-spec name procedure metadata))

124
tests/gnu-system.scm
View File

@ -25,7 +25,8 @@
;; newer, even though they may not correspond. ;; newer, even though they may not correspond.
(set! %fresh-auto-compile #t)) (set! %fresh-auto-compile #t))
(use-modules (guix config) (use-modules (cuirass job)
(guix config)
(guix store) (guix store)
(guix grafts) (guix grafts)
(guix packages) (guix packages)
@ -52,39 +53,46 @@
(srfi srfi-26) (srfi srfi-26)
(ice-9 match)) (ice-9 match))
(define* (package->alist store package system (define (package-metadata package)
#:optional (package-derivation package-derivation))
"Convert PACKAGE to an alist suitable for Hydra." "Convert PACKAGE to an alist suitable for Hydra."
(parameterize ((%graft? #f)) `((description . ,(package-synopsis package))
`((derivation . ,(derivation-file-name (long-description . ,(package-description package))
(package-derivation store package system (license . ,(package-license package))
#:graft? #f))) (home-page . ,(package-home-page package))
(description . ,(package-synopsis package)) (maintainers . ("bug-guix@gnu.org"))
(long-description . ,(package-description package)) (max-silent-time . ,(or (assoc-ref (package-properties package)
(license . ,(package-license package)) 'max-silent-time)
(home-page . ,(package-home-page package)) 3600)) ;1 hour by default
(maintainers . ("bug-guix@gnu.org")) (timeout . ,(or (assoc-ref (package-properties package) 'timeout)
(max-silent-time . ,(or (assoc-ref (package-properties package) 72000)))) ;20 hours by default
'max-silent-time)
3600)) ;1 hour by default
(timeout . ,(or (assoc-ref (package-properties package) 'timeout)
72000))))) ;20 hours by default
(define (package-job store job-name package system) (define (package-job-spec store job-name package system)
"Return a job called JOB-NAME that builds PACKAGE on SYSTEM." "Return a non evaluated job called JOB-NAME that builds PACKAGE on SYSTEM."
(let ((job-name (symbol-append job-name (string->symbol ".") (make-job-spec
(string->symbol system)))) #:name
`(,job-name . ,(cut package->alist store package system)))) (string-append (symbol->string job-name) "." system)
#:procedure
(λ ()
(derivation-file-name
(parameterize ((%graft? #f))
(package-derivation store package system #:graft? #f))))
#:metadata
(package-metadata package)))
(define (package-cross-job store job-name package target system) (define (package-cross-job-spec store job-name package target system)
"Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on "Return a non evaluated job called TARGET.JOB-NAME that cross-builds PACKAGE
SYSTEM." for TARGET on SYSTEM."
`(,(symbol-append (string->symbol target) (string->symbol ".") job-name (make-job-spec
(string->symbol ".") (string->symbol system)) . #:name
,(cute package->alist store package system (string-append target "." (symbol->string job-name) "." system)
(lambda* (store package system #:key graft?) #:procedure
(package-cross-derivation store package target system (λ ()
#:graft? graft?))))) (derivation-file-name
(parameterize ((%graft? #f))
(package-cross-derivation store package target system
#:graft? #f))))
#:metadata
(package-metadata package)))
(define %core-packages (define %core-packages
;; Note: Don't put the '-final' package variants because (1) that's ;; Note: Don't put the '-final' package variants because (1) that's
@ -107,37 +115,34 @@ SYSTEM."
'("mips64el-linux-gnu" '("mips64el-linux-gnu"
"mips64el-linux-gnuabi64")) "mips64el-linux-gnuabi64"))
(define (tarball-jobs store system) (define (tarball-job-specs store system)
"Return Hydra jobs to build the self-contained Guix binary tarball." "Return Hydra jobs to build the self-contained Guix binary tarball."
(define (->alist drv) (list
`((derivation . ,(derivation-file-name drv)) (make-job-spec
(description . "Stand-alone binary Guix tarball") #:name
(string-append "binary-tarball." system)
#:procedure
(λ ()
(derivation-file-name
(parameterize ((%graft? #f))
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(self-contained-tarball))
#:system system))))
#:metadata
`((description . "Stand-alone binary Guix tarball")
(long-description . "This is a tarball containing binaries of Guix and (long-description . "This is a tarball containing binaries of Guix and
all its dependencies, and ready to be installed on non-GuixSD distributions.") all its dependencies, and ready to be installed on non-GuixSD distributions.")
(license . ,gpl3+) (license . ,gpl3+)
(home-page . ,%guix-home-page-url) (home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org")))) (maintainers . ("bug-guix@gnu.org"))))))
(define (->job name drv)
(let ((name (symbol-append name (string->symbol ".")
(string->symbol system))))
`(,name . ,(lambda ()
(parameterize ((%graft? #f))
(->alist drv))))))
;; XXX: Add a job for the stable Guix?
(list (->job 'binary-tarball
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(self-contained-tarball))
#:system system))))
(define job-name (define job-name
;; Return the name of a package's job. ;; Return the name of a package's job.
(compose string->symbol package-full-name)) (compose string->symbol package-full-name))
(define package->job (define package->job-spec
(let ((base-packages (let ((base-packages
(delete-duplicates (delete-duplicates
(append-map (match-lambda (append-map (match-lambda
@ -152,7 +157,7 @@ valid."
(cond ((member package base-packages) (cond ((member package base-packages)
#f) #f)
((supported-package? package system) ((supported-package? package system)
(package-job store (job-name package) package system)) (package-job-spec store (job-name package) package system))
(else (else
#f))))) #f)))))
@ -189,8 +194,8 @@ valid."
(append-map (lambda (target) (append-map (lambda (target)
(map (lambda (package) (map (lambda (package)
(package-cross-job store (job-name package) (package-cross-job-spec store (job-name package)
package target system)) package target system))
%packages-to-cross-build)) %packages-to-cross-build))
(remove (either from-32-to-64? same?) %cross-targets))) (remove (either from-32-to-64? same?) %cross-targets)))
@ -210,16 +215,15 @@ valid."
(cons package result))) (cons package result)))
'())) '()))
(job (lambda (package) (job (lambda (package)
(package->job store package (package->job-spec store package system))))
system))))
(append (filter-map job all) (append (filter-map job all)
(tarball-jobs store system) (tarball-job-specs store system)
(cross-jobs system)))) (cross-jobs system))))
((core) ((core)
;; Build core packages only. ;; Build core packages only.
(append (map (lambda (package) (append (map (lambda (package)
(package-job store (job-name package) (package-job-spec store (job-name package)
package system)) package system))
%core-packages) %core-packages)
(cross-jobs system))) (cross-jobs system)))
(else (else