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

Evaluate derivations in a separate process. 

This fixes a bug where different Guix branches gave the same
derivations.
pull/3/head
Mathieu Lirzin 2016-07-12 11:42:20 +02:00
parent 92f5d0dfe4
commit 53c12be409
10 changed files with 237 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -6,6 +6,7 @@
/aclocal.m4
/autom4te.cache/
/bin/cuirass
/bin/evaluate
/build-aux/config.guess
/build-aux/config.sub
/build-aux/install-sh

4
Makefile.am
View File

@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
bin_SCRIPTS = bin/cuirass
bin_SCRIPTS = bin/cuirass bin/evaluate
noinst_SCRIPTS = pre-inst-env
dist_pkgmodule_DATA = \
@ -30,7 +30,7 @@ AM_SH_LOG_FLAGS = -x -e
TESTS = \
tests/base.scm \
tests/basic.sh \
## tests/basic.sh # takes too long to execute
tests/database.scm \
tests/utils.scm

109
bin/cuirass.in
View File

@ -27,7 +27,10 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(cuirass job)
(cuirass ui)
(cuirass utils)
(ice-9 getopt-long))
(guix derivations)
(guix store)
(ice-9 getopt-long)
(ice-9 popen))
(define* (show-help)
(simple-format #t "Usage: ~a [OPTIONS] SPECFILE~%" (%program-name))
@ -56,11 +59,11 @@ if required."
(let ((cachedir (%package-cachedir)))
(or (file-exists? cachedir) (mkdir cachedir))
(with-directory-excursion cachedir
(let ((name (job-spec-name spec))
(url (job-spec-url spec))
(branch (job-spec-branch spec))
(commit (job-spec-commit spec))
(tag (job-spec-tag spec)))
(let ((name (assq-ref spec #:name))
(url (assq-ref spec #:url))
(branch (assq-ref spec #:branch))
(commit (assq-ref spec #:commit))
(tag (assq-ref spec #:tag)))
(or (file-exists? name) (system* "git" "clone" url name))
(with-directory-excursion name
(and (zero? (system* "git" "fetch"))
@ -69,71 +72,53 @@ if required."
commit
(string-append "origin/" branch))))))))))
(define (set-load-path! spec)
"Set %LOAD-PATH to match what is specified in SPEC."
(let* ((name (job-spec-name spec))
(path (job-spec-load-path spec))
(dir (string-join (list (%package-cachedir) name path) "/")))
(format #t "prepending ~s to the load path~%" dir)
(set! %load-path (cons dir %load-path))))
(define (compile dir)
;; Required for fetching Guix bootstrap tarballs.
"Compile files in repository in directory DIR."
(with-directory-excursion dir
(or (file-exists? "configure") (system* "./bootstrap"))
(or (file-exists? "Makefile")
(system* "./configure" "--localstatedir=/var"))
(zero? (system* "make" "-j" (number->string (current-processor-count))))))
(define (evaluate store db spec)
"Evaluate and build package derivations. Return a list a jobs."
(let ((mod (make-user-module)))
(save-module-excursion
(λ ()
(set-current-module mod)
;; Handle both relative and absolute file names for SPEC-FILE.
(with-directory-excursion
(string-append (%package-cachedir) "/" (job-spec-name spec))
(primitive-load (job-spec-file spec)))))
(let* ((proc (module-ref mod (job-spec-proc spec)))
(jobs (proc store (job-spec-arguments spec))))
(map (λ (job)
(let ((id (db-add-evaluation db job)))
(make-job #:name (job-name job)
#:derivation (job-derivation job)
#:metadata (acons 'id id (job-metadata job)))))
jobs))))
"Evaluate and build package derivations. Return a job alist."
(let* ((port (open-pipe* OPEN_READ
"evaluate"
(string-append (%package-cachedir) "/"
(assq-ref spec #:name) "/"
(assq-ref spec #:load-path))
(%package-cachedir)
(string-append "'" (object->string spec))))
(jobs (read port)))
(close-pipe port)
(map (λ (job)
(acons #:id (db-add-evaluation db job) job))
jobs)))
(define (build-packages store db jobs)
"Build JOBS which is a list of <job> objects."
(let ((build-derivations (guix-variable 'derivations 'build-derivations))
(current-build-output-port
(guix-variable 'store 'current-build-output-port))
(derivation-path->output-path
(guix-variable 'derivations 'derivation-path->output-path)))
(map (λ (job)
(let ((log-port (tmpfile))
(name (job-name job))
(drv (job-derivation job)))
(setvbuf log-port _IOLBF)
(format #t "building ~A...~%" drv)
(parameterize ((current-build-output-port log-port))
(build-derivations store (list drv))
(db-add-build-log db job log-port)
(close-port log-port))
(format #t "~A~%" (derivation-path->output-path drv))))
jobs)))
(map (λ (job)
(let ((log-port (tmpfile))
(name (assq-ref job #:job-name))
(drv (assq-ref job #:derivation)))
(setvbuf log-port _IOLBF)
(format #t "building ~A...~%" drv)
(parameterize ((current-build-output-port log-port))
(build-derivations store (list drv))
(db-add-build-log db job log-port)
(close-port log-port))
(format #t "~A~%" (derivation-path->output-path drv))))
jobs))
(define (process-spec db spec)
"Evaluate and build SPEC"
(fetch-repository spec)
(let ((old-path %load-path))
(when (job-spec-load-path spec)
(set-load-path! spec))
(let ((store ((guix-variable 'store 'open-connection))))
(dynamic-wind
(const #t)
(λ ()
(let ((jobs (evaluate store db spec))
(set-build-options
(guix-variable 'store 'set-build-options)))
(set-build-options store #:use-substitutes? #f)
(build-packages store db jobs)))
(λ ()
((guix-variable 'store 'close-connection) store)
(set! %load-path old-path))))))
(compile (string-append (%package-cachedir) "/" (assq-ref spec #:name)))
(with-store store
(let ((jobs (evaluate store db spec)))
(set-build-options store #:use-substitutes? #f)
(build-packages store db jobs))))
(define (process-specs db jobspecs)
"Evaluate and build JOBSPECS and store results in DB."

96
bin/evaluate.in Normal file
View File

@ -0,0 +1,96 @@
#!/bin/sh
# -*- scheme -*-
GUILE_LOAD_PATH="$1"
export GUILE_LOAD_PATH
exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
!#
;;;; evaluate - convert a specification to a job list
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
;;; 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 (ice-9 format)
(ice-9 match)
(ice-9 pretty-print)
(guix store)
(srfi srfi-19))
(define-syntax-rule (with-directory-excursion dir body ...)
"Run BODY with DIR as the process's current directory."
(let ((init (getcwd)))
(dynamic-wind
(λ () (chdir dir))
(λ () body ...)
(λ () (chdir init)))))
(define (call-with-time thunk kont)
"Call THUNK and pass KONT the elapsed time followed by THUNK's return
value."
(let* ((start (current-time time-monotonic))
(result (thunk))
(end (current-time time-monotonic)))
(kont (time-difference end start) result)))
(define (call-with-time-display thunk)
"Call THUNK and write to the current output port its duration."
(call-with-time thunk
(λ (time result)
(let ((duration (+ (time-second time)
(/ (time-nanosecond time) 1e9))))
(format (current-error-port) "evaluate '~A': ~,3f seconds~%"
(assq-ref result #:job-name)
duration)
(acons #:duration duration result)))))
(define* (main #:optional (args (command-line)))
(match args
((command load-path cachedir specstr)
;; Load FILE, a Scheme file that defines Hydra jobs.
(let* ((%user-module (make-fresh-user-module))
(spec (eval-string specstr %user-module))
(stdout (current-output-port))
(stderr (current-error-port)))
(save-module-excursion
(λ ()
(set-current-module %user-module)
(with-directory-excursion
(string-append cachedir "/" (assq-ref spec #:name))
(primitive-load (assq-ref spec #:file)))))
(with-store store
;; Make sure we don't resort to substitutes.
(set-build-options store #:use-substitutes? #f #:substitute-urls '())
;; Grafts can trigger early builds. We do not want that to happen
;; during evaluation, so use a sledgehammer to catch such problems.
(set! build-things
(λ (store . args)
(display "error: trying to build things during evaluation!~%"
stderr)
(format stderr "'build-things' arguments: ~S~%" args)
(exit 1)))
;; Call the entry point of FILE and print the resulting job sexp.
(pretty-print
(let* ((proc (module-ref %user-module 'hydra-jobs) )
(thunks (proc store (assq-ref spec #:arguments))))
(map (λ (thunk)
(call-with-time-display thunk))
thunks))
stdout))))
((command _ ...)
(format (current-error-port) "Usage: ~A FILE
Evaluate the Hydra jobs defined in FILE.~%"
command)
(exit 1))))

1
configure.ac
View File

@ -28,6 +28,7 @@ AC_SUBST([pkgmoduledir])
AC_CONFIG_FILES([Makefile
src/cuirass/config.scm])
AC_CONFIG_FILES([bin/cuirass], [chmod +x bin/cuirass])
AC_CONFIG_FILES([bin/evaluate], [chmod +x bin/evaluate])
AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in],
[chmod +x pre-inst-env])
AC_OUTPUT

6
src/cuirass/database.scm
View File

@ -93,8 +93,8 @@ database object."
(sqlite-exec
db
(format #f "insert into build (job_spec, drv) values ('~A', '~A');"
(job-name job)
(job-derivation job)))
(assq-ref job #:job-name)
(assq-ref job #:derivation)))
(let* ((stmt (sqlite-prepare db "select last_insert_rowid() from build;"))
(res (sqlite-step stmt)))
(sqlite-finalize stmt)
@ -133,7 +133,7 @@ string."
(define (db-add-build-log db job log)
"Store a build LOG corresponding to JOB in database DB."
(let ((id (assoc-ref (job-metadata job) 'id))
(let ((id (assq-ref job #:id))
(log* (cond ((string? log) log)
((port? log)
(seek log 0 SEEK_SET)

13
tests/database.scm
View File

@ -21,10 +21,9 @@
(cuirass job)
(srfi srfi-64))
(define* (make-dummy-job #:optional (name "foo") #:key (metadata '()))
(make-job #:name name
#:derivation (string-append name ".drv")
#:metadata metadata))
(define* (make-dummy-job #:optional (name "foo"))
`((#:name . ,name)
(#:derivation . ,(string-append name ".drv"))))
(define %db
;; Global Slot for a database object.
@ -51,11 +50,11 @@
(db-get-evaluation (%db) (%id)))
(test-equal "db-add-build-log"
(let ((job (make-dummy-job #:metadata `((id . ,(%id)))))
"foo log"
(let ((job (acons #:id (%id) (make-dummy-job)))
(log-column 3))
(db-add-build-log (%db) job "foo log")
(vector-ref (db-get-evaluation (%db) (%id)) log-column))
"foo log")
(vector-ref (db-get-evaluation (%db) (%id)) log-column)))
(test-assert "db-close"
(db-close (%db))))

88
tests/gnu-system.scm
View File

@ -25,8 +25,7 @@
;; newer, even though they may not correspond.
(set! %fresh-auto-compile #t))
(use-modules (cuirass job)
(guix config)
(use-modules (guix config)
(guix store)
(guix grafts)
(guix packages)
@ -55,36 +54,38 @@
(define (package-metadata package)
"Convert PACKAGE to an alist suitable for Hydra."
`((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."
(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)))
(λ ()
`((#:job-name . ,(string-append (symbol->string job-name) "." system))
(#:derivation . ,(derivation-file-name
(parameterize ((%graft? #f))
(package-derivation store package system
#:graft? #f))))
,@(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."
(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)))
(λ ()
`((#:job-name . ,(string-join (list target (symbol->string job-name) system)
"."))
(#:derivation . ,(derivation-file-name
(parameterize ((%graft? #f))
(package-cross-derivation store package target system
#:graft? #f))))
,@(package-metadata package))))
(define %core-packages
;; Note: Don't put the '-final' package variants because (1) that's
@ -107,25 +108,24 @@ for TARGET on SYSTEM."
'("mips64el-linux-gnu"
"mips64el-linux-gnuabi64"))
(define (tarball-jobs store system)
(define (tarball-job store system)
"Return Hydra jobs to build the self-contained Guix binary tarball."
(list
(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
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"))))))
(λ ()
`((#: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))))
(#: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
;; Return the name of a package's job.
@ -207,7 +207,7 @@ valid."
(append (filter-map (lambda (pkg)
(package->job store pkg system))
pkgs)
(tarball-jobs store system)
(list (tarball-job store system))
(cross-jobs system))))
((core)
;; Build core packages only.

32
tests/guix-jobs.scm
View File

@ -17,24 +17,20 @@
;;; 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)
;; In the common case jobs will be defined relative to the repository.
;; However for testing purpose use local gnu-system.scm instead.
(string-append (dirname (current-filename)) "/" file))
(list (make-job-spec
#:name "guix"
#:url "git://git.savannah.gnu.org/guix.git"
#:load-path "."
#:branch "master"
#:file (local-file "gnu-system.scm")
#:proc 'hydra-jobs)
(make-job-spec
#:name "guix"
#:url "git://git.savannah.gnu.org/guix.git"
#:load-path "."
#:tag "v0.10.0"
#:file (local-file "gnu-system.scm")
#:proc 'hydra-jobs))
`(((#:name . "guix")
(#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".")
(#:branch . "master")
(#:file . ,(local-file "gnu-system.scm"))
(#:proc . hydra-jobs))
((#:name . "guix")
(#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".")
(#:tag . "v0.10.0")
(#:file . ,(local-file "gnu-system.scm"))
(#:proc . hydra-jobs)))

51
tests/hello-subset.scm
View File

@ -17,34 +17,29 @@
;;; 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)
;; In the common case jobs will be defined relative to the repository.
;; However for testing purpose use local gnu-system.scm instead.
(string-append (dirname (current-filename)) "/" file))
(list (make-job-spec
#:name "guix"
#:url "git://git.savannah.gnu.org/guix.git"
#:load-path "."
#:branch "master"
#:file (local-file "gnu-system.scm")
#:proc 'hydra-jobs
#:arguments '((subset . "hello")))
(make-job-spec
#:name "guix"
#:url "git://git.savannah.gnu.org/guix.git"
#:load-path "."
#:branch "core-updates"
#:file (local-file "gnu-system.scm")
#:proc 'hydra-jobs
#:arguments '((subset . "hello")))
(make-job-spec
#:name "guix"
#:url "git://git.savannah.gnu.org/guix.git"
#:load-path "."
#:tag "v0.9.0"
#:file (local-file "gnu-system.scm")
#:proc 'hydra-jobs
#:arguments '((subset . "hello"))))
`(((#:name . "guix")
(#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".")
(#:branch . "master")
(#:file . ,(local-file "gnu-system.scm"))
(#:proc . hydra-jobs)
(#:arguments (subset . "hello")))
((#:name . "guix")
(#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".")
(#:branch . "core-updates")
(#:file . ,(local-file "gnu-system.scm"))
(#:proc . hydra-jobs)
(#:arguments (subset . "hello")))
((#:name . "guix")
(#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".")
(#:tag . "v0.9.0")
(#:file . ,(local-file "gnu-system.scm"))
(#:proc . hydra-jobs)
(#:arguments (subset . "hello"))))