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

Change <job-spec> and <job> semantics.

pull/3/head
Mathieu Lirzin 2016-06-15 15:30:15 +02:00
parent 7d7251a974
commit b103ab7eae
4 changed files with 146 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
bin/cuirass.in
View File

@ -33,7 +33,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
Run Guix job from a git repository cloned in CACHEDIR.
-f --use-file=FILE Use FILE which defines the job to evaluate
--subset=SET Evaluate SET which is a subset of Guix packages
-I, --interval=N Wait N seconds between each evaluation
-V, --version Display version
-h, --help Display this help message")
@ -42,40 +41,41 @@ Run Guix job from a git repository cloned in CACHEDIR.
(define %options
`((file (single-char #\f) (value #t))
(subset (value #t))
(interval (single-char #\I) (value #t))
(version (single-char #\V) (value #f))
(help (single-char #\h) (value #f))))
(define %guix-repository
(make-parameter "git://git.savannah.gnu.org/guix.git"))
(define* (pull-changes dir)
"Get the latest version of Guix repository. Clone repository in directory
DIR if required."
(or (file-exists? dir) (mkdir dir))
(with-directory-excursion dir
(let ((guixdir "guix"))
(or (file-exists? guixdir)
(system* "git" "clone" (%guix-repository) guixdir))
(with-directory-excursion guixdir
(and (zero? (system* "git" "fetch")) ;no 'git pull' to avoid merges
(zero? (system* "git" "reset" "--hard" "origin/master")))))))
(define (compile dir)
"Compile files in Guix cloned repository in directory DIR."
(with-directory-excursion (string-append dir "/guix")
(or (file-exists? "configure") (system* "./bootstrap"))
(or (file-exists? "Makefile")
(system* "./configure" "--localstatedir=/var"))
(zero? (system* "make" "-j" (number->string (current-processor-count))))))
(define %user-module
;; Cuirass user module.
(let ((m (make-module)))
(beautify-user-module! m)
m))
(define (fetch-repository cachedir spec)
"Get the latest version of Guix repository. Clone repository in directory
DIR if required."
(or (file-exists? cachedir) (mkdir cachedir))
(with-directory-excursion cachedir
(match spec
(($ <job-spec> name url branch)
(or (file-exists? name) (system* "git" "clone" url name))
(with-directory-excursion name
(and (zero? (system* "git" "fetch"))
(zero? (system* "git" "reset" "--hard"
(string-append "origin/" branch)))))))))
(define (evaluate store cachedir spec)
"Evaluate and build package derivations."
(save-module-excursion
(lambda ()
(set-current-module %user-module)
(let ((dir (string-append cachedir "/" (job-spec-name spec))))
(format #t "prepending ~s to the load path~%" dir)
(set! %load-path (cons dir %load-path)))
(primitive-load (job-spec-file spec))))
(let ((proc (module-ref %user-module (job-spec-proc spec))))
(proc store (job-spec-arguments spec))))
(define (build-packages store jobs)
"Build JOBS which is a list of <job> objects."
(map (match-lambda
@ -88,23 +88,6 @@ DIR if required."
'derivation-path->output-path) drv))))
jobs))
(define (evaluate store dir spec args)
"Evaluate and build package derivations in directory DIR."
(save-module-excursion
(lambda ()
(set-current-module %user-module)
(let ((guixdir (string-append dir "/guix")))
(format #t "prepending ~s to the load path~%" guixdir)
(set! %load-path (cons guixdir %load-path)))
(primitive-load spec)))
(let ((job-specs ((module-ref %user-module 'hydra-jobs) store args)))
(map (match-lambda
(($ <job-spec> name thunk metadata)
(format (current-error-port) "evaluating '~a'... " name)
(force-output (current-error-port))
(make-job name (call-with-time-display thunk) metadata)))
job-specs)))
;;;
;;; Entry point.
@ -121,24 +104,23 @@ DIR if required."
(show-version progname)
(exit 0))
(else
(let* ((store ((guix-variable 'store 'open-connection)))
(jobfile (option-ref opts 'file "tests/gnu-system.scm"))
(subset (option-ref opts 'subset "all"))
(let* ((specfile (option-ref opts 'file "tests/hello-subset.scm"))
(spec (primitive-load specfile))
(args (option-ref opts '() #f))
(cachedir (if (null? args)
(getenv "CUIRASS_CACHEDIR")
(car args))))
(dynamic-wind
(const #t)
(lambda ()
(while #t
(pull-changes cachedir)
(compile cachedir)
(let ((jobs (evaluate store cachedir jobfile
(acons 'subset subset '()))))
((guix-variable 'store 'set-build-options) store
#:use-substitutes? #f)
(build-packages store jobs))
(sleep (string->number (option-ref opts 'interval "60")))))
(lambda ()
((guix-variable 'store 'close-connection) store))))))))
(while #t
(fetch-repository cachedir spec)
(let ((store ((guix-variable 'store 'open-connection))))
(dynamic-wind
(const #t)
(lambda ()
(let* ((jobs (evaluate store cachedir spec))
(set-build-options
(guix-variable 'store 'set-build-options)))
(set-build-options store #:use-substitutes? #f)
(build-packages store jobs)))
(lambda ()
((guix-variable 'store 'close-connection) store))))
(sleep (string->number (option-ref opts 'interval "60")))))))))

34
src/cuirass/job.scm
View File

@ -18,6 +18,7 @@
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(define-module (cuirass job)
#:use-module (cuirass base)
#:use-module (srfi srfi-9)
#:export (<job>
make-job
@ -28,9 +29,13 @@
<job-spec>
make-job-spec
job-spec?
job-spec-name
job-spec-url
job-spec-branch
job-spec-file
job-spec-proc
job-spec-metadata))
job-spec-arguments))
(define-record-type <job>
(%make-job name derivation metadata)
@ -39,15 +44,26 @@
(derivation job-derivation) ;string
(metadata job-metadata)) ;alist
(define* (make-job name drv #:optional (metadata '()))
(%make-job name drv metadata))
(define-syntax make-job
(syntax-rules ()
;; XXX: Different orders for keyword/argument pairs should be allowed.
((make-job #:name name #:derivation filename #:metadata metadata)
(begin
(format (current-error-port) "evaluating '~a'... " name)
(force-output (current-error-port))
(%make-job name
(call-with-time-display (λ () filename))
metadata)))))
(define-record-type <job-spec>
(%make-job-spec name proc metadata)
(%make-job-spec name url branch file proc arguments)
job-spec?
(name job-spec-name) ;string
(proc job-spec-proc) ;thunk
(metadata job-spec-metadata)) ;alist
(name job-spec-name) ;string
(url job-spec-url) ;string
(branch job-spec-branch) ;string
(file job-spec-file) ;string
(proc job-spec-proc) ;symbol
(arguments job-spec-arguments)) ;alist
(define* (make-job-spec #:key name procedure metadata)
(%make-job-spec name procedure metadata))
(define* (make-job-spec #:key name url branch file proc arguments)
(%make-job-spec name url branch file proc arguments))

105
tests/gnu-system.scm
View File

@ -66,33 +66,25 @@
(timeout . ,(or (assoc-ref (package-properties package) 'timeout)
72000)))) ;20 hours by default
(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-job store job-name package system)
"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
(make-job
#:name (string-append (symbol->string job-name) "." system)
#:derivation (derivation-file-name
(parameterize ((%graft? #f))
(package-derivation store package system #:graft? #f)))
#:metadata (package-metadata package)))
(define (package-cross-job-spec store job-name package target system)
"Return a non evaluated job called TARGET.JOB-NAME that cross-builds 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."
(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)))
(make-job
#:name (string-append target "." (symbol->string job-name) "." system)
#:derivation (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
@ -115,21 +107,18 @@ for TARGET on SYSTEM."
'("mips64el-linux-gnu"
"mips64el-linux-gnuabi64"))
(define (tarball-job-specs store system)
(define (tarball-jobs store system)
"Return Hydra jobs to build the self-contained Guix binary 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))))
(make-job
#:name (string-append "binary-tarball." system)
#:derivation (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
@ -138,11 +127,11 @@ all its dependencies, and ready to be installed on non-GuixSD distributions.")
(home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org"))))))
(define job-name
(define %job-name
;; Return the name of a package's job.
(compose string->symbol package-full-name))
(define package->job-spec
(define package->job
(let ((base-packages
(delete-duplicates
(append-map (match-lambda
@ -157,7 +146,7 @@ valid."
(cond ((member package base-packages)
#f)
((supported-package? package system)
(package-job-spec store (job-name package) package system))
(package-job store (%job-name package) package system))
(else
#f)))))
@ -195,8 +184,8 @@ valid."
(append-map (lambda (target)
(map (lambda (package)
(package-cross-job-spec store (job-name package)
package target system))
(package-cross-job store (job-name package)
package target system))
%packages-to-cross-build))
(remove (either from-32-to-64? same?) %cross-targets)))
@ -207,30 +196,30 @@ valid."
(case subset
((all)
;; Build everything, including replacements.
(let ((all (fold-packages
(lambda (package result)
(if (package-replacement package)
(cons* package
(package-replacement package)
result)
(cons package result)))
'()))
(job (lambda (package)
(package->job-spec store package system))))
(append (filter-map job all)
(tarball-job-specs store system)
(let ((pkgs (fold-packages
(lambda (package result)
(if (package-replacement package)
(cons* package
(package-replacement package)
result)
(cons package result)))
'())))
(append (filter-map (lambda (pkg)
(package->job store pkg system))
pkgs)
(tarball-jobs store system)
(cross-jobs system))))
((core)
;; Build core packages only.
(append (map (lambda (package)
(package-job-spec store (job-name package)
package system))
(package-job store (job-name package)
package system))
%core-packages)
(cross-jobs system)))
((hello)
;; Build hello package only.
(if (string=? system (%current-system))
(list (package-job-spec store (job-name hello) hello system))
(list (package-job store (%job-name hello) hello system))
'()))
(else
(error "unknown subset" subset))))

33
tests/hello-subset.scm Normal file
View File

@ -0,0 +1,33 @@
;;;; hello-subset.scm - job specification test for hello subset.
;;;
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of Cuirass.
;;;
;;; Cuirass is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Cuirass is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(use-modules (cuirass job))
;; In the common case jobs will be defined relative to the repository.
;; However for testing purpose use local gnu-system.scm instead.
(define (local-file file)
(string-append (dirname (current-filename)) "/" file))
(make-job-spec
#:name "guix"
#:url "git://git.savannah.gnu.org/guix.git"
#:branch "master"
#:file (local-file "gnu-system.scm")
#:proc 'hydra-jobs
#:arguments '((subset . "hello")))