diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | bin/cuirass.in | 109 | ||||
| -rw-r--r-- | bin/evaluate.in | 96 | ||||
| -rw-r--r-- | configure.ac | 1 | ||||
| -rw-r--r-- | src/cuirass/database.scm | 6 | ||||
| -rw-r--r-- | tests/database.scm | 13 | ||||
| -rw-r--r-- | tests/gnu-system.scm | 88 | ||||
| -rw-r--r-- | tests/guix-jobs.scm | 32 | ||||
| -rw-r--r-- | tests/hello-subset.scm | 51 |
10 files changed, 237 insertions, 164 deletions
@@ -6,6 +6,7 @@ /aclocal.m4 /autom4te.cache/ /bin/cuirass +/bin/evaluate /build-aux/config.guess /build-aux/config.sub /build-aux/install-sh diff --git a/Makefile.am b/Makefile.am index 38e2442..aa01e88 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 diff --git a/bin/cuirass.in b/bin/cuirass.in index 04d439b..8b3f05d 100644 --- a/bin/cuirass.in +++ b/bin/cuirass.in @@ -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." diff --git a/bin/evaluate.in b/bin/evaluate.in new file mode 100644 index 0000000..8152e85 --- /dev/null +++ b/bin/evaluate.in @@ -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)))) diff --git a/configure.ac b/configure.ac index b8de869..945260c 100644 --- a/configure.ac +++ b/configure.ac @@ -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 diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 2ab5d32..505ef4c 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -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) diff --git a/tests/database.scm b/tests/database.scm index 232eab4..869d73c 100644 --- a/tests/database.scm +++ b/tests/database.scm @@ -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)))) diff --git a/tests/gnu-system.scm b/tests/gnu-system.scm index 520c33d..fc7c15f 100644 --- a/tests/gnu-system.scm +++ b/tests/gnu-system.scm @@ -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. diff --git a/tests/guix-jobs.scm b/tests/guix-jobs.scm index 9196147..470305f 100644 --- a/tests/guix-jobs.scm +++ b/tests/guix-jobs.scm @@ -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))) diff --git a/tests/hello-subset.scm b/tests/hello-subset.scm index f904782..76136ef 100644 --- a/tests/hello-subset.scm +++ b/tests/hello-subset.scm @@ -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")))) |