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)
(set! %load-path (cons guixdir %load-path)))
(primitive-load spec)))
(match ((module-ref %user-module 'hydra-jobs) store '())
(((names . thunks) ...)
(map (lambda (job thunk)
(format (current-error-port) "evaluating '~a'... " job)
(let ((job-specs ((module-ref %user-module 'hydra-jobs) store '())))
(map (match-lambda
(($ <job-spec> name thunk metadata)
(format (current-error-port) "evaluating '~a'... " name)
(force-output (current-error-port))
(make-job (symbol->string job)
(assoc-ref (call-with-time-display thunk)
'derivation)))
names thunks))))
(make-job name (call-with-time-display thunk) metadata)))
job-specs)))
;;;

18
src/cuirass/job.scm
View File

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