diff options
| -rw-r--r-- | bin/evaluate.in | 14 | ||||
| -rw-r--r-- | doc/cuirass.texi | 59 | ||||
| -rw-r--r-- | examples/gnu-system.scm | 3 | ||||
| -rw-r--r-- | examples/govuk-jobs.scm | 34 | ||||
| -rw-r--r-- | examples/govuk-packages.scm | 132 | ||||
| -rw-r--r-- | src/cuirass/base.scm | 65 | ||||
| -rw-r--r-- | src/cuirass/database.scm | 9 | ||||
| -rw-r--r-- | src/schema.sql | 1 |
8 files changed, 283 insertions, 34 deletions
diff --git a/bin/evaluate.in b/bin/evaluate.in index d1d0767..3918681 100644 --- a/bin/evaluate.in +++ b/bin/evaluate.in @@ -32,7 +32,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (guix store)) (define* (main #:optional (args (command-line))) - (match args + (match (peek "args" args) ((command load-path guix-package-path cachedir specstr database) ;; Load FILE, a Scheme file that defines Hydra jobs. (let ((%user-module (make-fresh-user-module)) @@ -43,7 +43,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (lambda () (set-current-module %user-module) (with-directory-excursion - (string-append cachedir "/" (assq-ref spec #:name)) + (string-append cachedir "/" (assq-ref (peek "spec" spec) #:name)) (primitive-load (assq-ref spec #:file))))) (with-store store (unless (assoc-ref spec #:use-substitutes?) @@ -60,11 +60,15 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (parameterize ((%package-database database) (%use-substitutes? (assoc-ref spec #:use-substitutes?))) (unless (string-null? guix-package-path) - (set-guix-package-path! guix-package-path)) + (set-guix-package-path! guix-package-path)) + ;; Call the entry point of FILE and print the resulting job sexp. (let* ((proc-name (assq-ref spec #:proc)) - (proc (module-ref %user-module proc-name)) - (thunks (proc store (assq-ref spec #:arguments))) + (proc (module-ref %user-module proc-name)) + (thunks (with-directory-excursion + (string-append cachedir "/" (assq-ref (peek "spec" spec) #:name)) + + (proc store (assq-ref spec #:arguments)))) (db (db-open)) (commit (assq-ref spec #:current-commit)) (eval `((#:specification . ,(assq-ref spec #:name)) diff --git a/doc/cuirass.texi b/doc/cuirass.texi index 2899ffb..a8d2af7 100644 --- a/doc/cuirass.texi +++ b/doc/cuirass.texi @@ -339,6 +339,65 @@ This text field holds the absolute directory name of the build output or @code{NULL} if the build failed. @end table +@section Database State Machine + + + -> Read in and store @code{Specifications} + + -> Main loop + + -> Fetch @code{Specifications} + + -> For each @code{Specification} + + -> If a @code{Stamp} does not exist? + + -> Create and store an @code{Evaluation} + + -> For each job + + -> Create a @code{Derivation} + + -> Build all derivations for jobs + + -> For each job + + -> Create a @code{Build} + + +Specification part + + -> Loop + + -> Read in and store @code{Specifications} + + -> Trigger creating a @code{Evaluation} / @code{Stamp} ??? + +Evaluation part + + -> Check if an @code{Evaluation} / @code{Stamp} exists? + + -> Create an @code{Evaluation} / @code{Stamp} + + ... + + -> Build all derivations for jobs + + -> Trigger storing results + +Build results part + + -> Check if the derivation has build? + + -> Create a @code{Build} + + + +The database contains the following tables: @code{Specifications}, +@code{Stamps}, @code{Evaluations}, @code{Derivations}, and +@code{Builds}. The purpose of each of these tables is explained below. + + @c ********************************************************************* @node Contributing diff --git a/examples/gnu-system.scm b/examples/gnu-system.scm index 4076786..bc20f25 100644 --- a/examples/gnu-system.scm +++ b/examples/gnu-system.scm @@ -200,7 +200,8 @@ valid." (case subset ((all) ;; Build everything, including replacements. - (let ((pkgs (fold-packages + (let ((pkgs (fold-packages-in-modules + (all-modules "") (lambda (package result) (if (package-replacement package) (cons* package diff --git a/examples/govuk-jobs.scm b/examples/govuk-jobs.scm new file mode 100644 index 0000000..8010e5d --- /dev/null +++ b/examples/govuk-jobs.scm @@ -0,0 +1,34 @@ +;;; guix-jobs.scm -- job specification test for Guix +;;; 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/>. + +(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 + `((#:name . "govuk-guix") + (;;#:url . "https://github.com/alphagov/govuk-guix.git") + #:url . "/home/chris/Projects/GDS/govuk/govuk-guix") + ;;(#:load-path . ".") + (;;#:file . ,(local-file "govuk-packages.scm")) + #:evaluate . "./guix-pre-inst-env guile ./bin/cuirass-jobs") + ;;(#:proc . gov.uk-jobs) + (#:branch . "dev") + (#:one-shot? . #t) + (#:no-compile? . #t))) diff --git a/examples/govuk-packages.scm b/examples/govuk-packages.scm new file mode 100644 index 0000000..31cb2ee --- /dev/null +++ b/examples/govuk-packages.scm @@ -0,0 +1,132 @@ +;;;; gnu-system.scm - build jobs for Guix +;;; +;;; Copyright © 2012, 2013, 2014, 2015, 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/>. + +;; Attempt to use Guix modules from git repository. +(eval-when (compile load eval) + ;; Ignore any available .go, and force recompilation. This is because our + ;; checkout in the store has mtime set to the epoch, and thus .go files look + ;; newer, even though they may not correspond. + (set! %fresh-auto-compile #t)) + +(use-modules (guix config) + (guix store) + (guix grafts) + (guix packages) + (guix derivations) + (guix discovery) + (guix monads) + ((guix licenses) + #:select (gpl3+ license-name license-uri license-comment)) + ((guix utils) #:select (%current-system)) + ((guix scripts system) #:select (read-operating-system)) + (gnu packages) + (gnu packages commencement) + (gnu packages guile) + (gnu packages make-bootstrap) + (gnu system) + (gnu system vm) + (gnu system install) + (srfi srfi-1) + (ice-9 match)) + +(define (license->alist lcs) + "Return LCS <license> object as an alist." + ;; Sometimes 'license' field is a list of licenses. + (if (list? lcs) + (map license->alist lcs) + `((name . ,(license-name lcs)) + (uri . ,(license-uri lcs)) + (comment . ,(license-comment lcs))))) + +(define (package-metadata package) + "Convert PACKAGE to an alist suitable for Hydra." + `((#:description . ,(package-synopsis package)) + (#:long-description . ,(package-description package)) + (#:license . ,(license->alist (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." + (lambda () + `((#: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 %job-name + ;; Return the name of a package's job. + (compose string->symbol package-full-name)) + +(define package->job + (let ((base-packages + (delete-duplicates + (append-map (match-lambda + ((_ package _ ...) + (match (package-transitive-inputs package) + (((_ inputs _ ...) ...) + inputs)))) + %final-inputs)))) + (lambda (store package system) + "Return a job for PACKAGE on SYSTEM, or #f if this combination is not +valid." + (cond ((member package base-packages) + #f) + ((supported-package? package system) + (package-job store (%job-name package) package system)) + (else + #f))))) + +(define (fold-packages-in-modules modules proc init) + "Call (PROC PACKAGE RESULT) for each available package within any of the +modules in MODULES, using INIT as the initial value of RESULT. It is +guaranteed to never traverse the same package twice." + (fold-module-public-variables (lambda (object result) + (if (and (package? object) + (not (hidden-package? object))) + (proc object result) + result)) + init + modules)) + +(define (gov.uk-jobs store arguments) + (peek "getcwd" (getcwd)) + (parameterize ((%graft? #f)) + (let ((pkgs (fold-packages-in-modules + (all-modules (list + (string-append + (getcwd) + "/.guix-package-path"))) + cons + '()))) + (peek "getcwd" (getcwd)) + (peek "pkgs" pkgs) + (exit 1) + (filter-map (lambda (pkg) + (package->job store pkg system)) + (peek "pkgs" pkgs))))) + diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index 00b58f6..c986d37 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -129,6 +129,7 @@ directory and the sha1 of the top level commit in this directory." (tag (and=> (assq-ref spec #:tag) (lambda (t) `(tag . ,t))))) + (peek "FETCHING LATEST " url) (latest-repository-commit store url #:cache-directory (%package-cachedir) #:ref (or branch commit tag)))) @@ -159,26 +160,32 @@ directory and the sha1 of the top level commit in this directory." (define (evaluate store db spec) "Evaluate and build package derivations. Return a list of jobs." - (let* ((port (open-pipe* OPEN_READ - "evaluate" - (string-append (%package-cachedir) "/" - (assq-ref spec #:name) "/" - (assq-ref spec #:load-path)) - (%guix-package-path) - (%package-cachedir) - (object->string spec) - (%package-database))) - (jobs (match (read port) - ;; If an error occured during evaluation report it, - ;; otherwise, suppose that data read from port are - ;; correct and keep things going. - ((? eof-object?) - (raise (condition - (&evaluation-error - (name (assq-ref spec #:name)))))) - (data data)))) - (close-pipe port) - jobs)) + (with-directory-excursion + (string-append (%package-cachedir) "/" + (assq-ref spec #:name)) + (let* ((command (or (string-split + (assq-ref (peek "spec" spec) #:evaluate) + #\space) + (list "evaluate" + (string-append (%package-cachedir) "/" + (assq-ref spec #:name) "/" + (assq-ref spec #:load-path)) + (%guix-package-path) + (%package-cachedir) + (object->string spec) + (%package-database)))) + (port (apply open-pipe* OPEN_READ command)) + (jobs (match (peek "RESULT: " (read port)) + ;; If an error occured during evaluation report it, + ;; otherwise, suppose that data read from port are + ;; correct and keep things going. + ((? eof-object?) + (raise (condition + (&evaluation-error + (name (assq-ref spec #:name)))))) + (data data)))) + (close-pipe port) + jobs))) (define (build-packages store db jobs) "Build JOBS and return a list of Build results." @@ -219,6 +226,14 @@ directory and the sha1 of the top level commit in this directory." ;; database potentially long after things have been built. (map register jobs)) +(define (store-jobs db jobs) + (for-each (lambda (job) + (eval-id (db-add-evaluation db eval))) + + ) + jobs)) + + (define (process-specs db jobspecs) "Evaluate and build JOBSPECS and store results in DB." (define (process spec) @@ -232,8 +247,8 @@ directory and the sha1 of the top level commit in this directory." (set-tls-certificate-locations! certs))) (receive (checkout commit) (fetch-repository store spec) - (when commit - (unless (string=? commit stamp) + (when (peek "COMMIT " commit) + (unless (string=? commit (peek "STAMP" stamp)) (copy-repository-cache checkout spec) (unless (assq-ref spec #:no-compile?) @@ -250,10 +265,12 @@ directory and the sha1 of the top level commit in this directory." (format #t "Failed to evaluate ~s specification.~%" (evaluation-error-spec-name c)) #f)) - (let* ((spec* (acons #:current-commit commit spec)) + (let* ((spec* (peek "spec*" (acons #:current-commit commit spec))) (jobs (evaluate store db spec*))) + (eval-id (db-add-evaluation db eval))) + (build-packages store db jobs)))) - (db-add-stamp db spec commit))))))) + (db-add-stamp db spec commit)) (for-each process jobspecs)) diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 31f78b1..f58a788 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -115,11 +115,11 @@ database object." (define (db-add-specification db spec) "Store specification SPEC in database DB and return its ID." (apply sqlite-exec db "\ -INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \ +INSERT OR IGNORE INTO Specifications (repo_name, url, evaluate, load_path, file, \ proc, arguments, branch, tag, revision, no_compile_p) \ - VALUES ('~A', '~A', '~A', '~A', '~S', '~S', '~A', '~A', '~A', ~A);" + VALUES ('~A', '~A', '~A', '~A', '~A', '~S', '~S', '~A', '~A', '~A', ~A);" (append - (assq-refs spec '(#:name #:url #:load-path #:file #:proc #:arguments)) + (assq-refs spec '(#:name #:url #:evaluate #:load-path #:file #:proc #:arguments)) (assq-refs spec '(#:branch #:tag #:commit) "NULL") (list (if (assq-ref spec #:no-compile?) "1" "0")))) (last-insert-rowid db)) @@ -129,11 +129,12 @@ INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \ (specs '())) (match rows (() specs) - ((#(name url load-path file proc args branch tag rev no-compile?) + ((#(name url evaluate load-path file proc args branch tag rev no-compile?) . rest) (loop rest (cons `((#:name . ,name) (#:url . ,url) + (#:evaluate . ,evaluate) (#:load-path . ,load-path) (#:file . ,file) (#:proc . ,(with-input-from-string proc read)) diff --git a/src/schema.sql b/src/schema.sql index 329d89d..5cdd8c6 100644 --- a/src/schema.sql +++ b/src/schema.sql @@ -3,6 +3,7 @@ BEGIN TRANSACTION; CREATE TABLE Specifications ( repo_name TEXT NOT NULL PRIMARY KEY, url TEXT NOT NULL, + evaluate TEXT NOT NULL, load_path TEXT NOT NULL, file TEXT NOT NULL, proc TEXT NOT NULL, |