* [bug#32121] [PATCH 4/5] database: Call a specification 'jobset' instead of 'project'.
2018-07-10 23:02 ` [bug#32121] [PATCH 1/5] base: Compile CHECKOUT in the fiber Clément Lassieur
2018-07-10 23:02 ` [bug#32121] [PATCH 2/5] utils: Reset the Fiber dynamic environment in %NON-BLOCKING Clément Lassieur
2018-07-10 23:02 ` [bug#32121] [PATCH 3/5] database: Add support for database upgrades Clément Lassieur
@ 2018-07-10 23:02 ` Clément Lassieur
2018-07-13 8:51 ` Ludovic Courtès
2018-07-10 23:02 ` [bug#32121] [PATCH 5/5] Add support for multiple inputs Clément Lassieur
2018-07-13 8:32 ` [bug#32121] [PATCH 1/5] base: Compile CHECKOUT in the fiber Ludovic Courtès
4 siblings, 1 reply; 25+ messages in thread
From: Clément Lassieur @ 2018-07-10 23:02 UTC (permalink / raw)
To: 32121
This removes the possibility to filter specifications by branch, because
branches were previously called 'jobset'. But it doesn't matter because later
on, specifications will have as many branches as inputs. And people should
filter by specification name instead.
* doc/cuirass.texi (Build Information, Latest builds): Remove 'jobset',
replace 'project' with 'jobset'.
* src/cuirass/http.scm (build->hydra-build): Idem.
* tests/database.scm (db-get-builds): Idem.
* tests/http.scm (build-query-result, /api/latestbuilds?nr=1&jobset=guix,
/api/latestbuilds?nr=1&jobset=gnu): Idem.
* src/cuirass/database.scm (db-format-build, db-get-builds): Don't associate
builds with branches (which were called 'jobset' afterwards).
(db-get-builds): Remove the #:project filter.
---
doc/cuirass.texi | 15 ++++-----------
src/cuirass/database.scm | 20 ++++++++------------
src/cuirass/http.scm | 4 ++--
tests/database.scm | 6 ++----
tests/http.scm | 12 ++++++------
5 files changed, 22 insertions(+), 35 deletions(-)
diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index 38eb0b0..5c8c23f 100644
--- a/doc/cuirass.texi
+++ b/doc/cuirass.texi
@@ -448,8 +448,7 @@ $ curl -s "http://localhost:8080/build/2" | jq
@{
"id": 2,
- "project": "guix",
- "jobset": "master",
+ "jobset": "guix",
"job": "acpica-20150410-job",
"timestamp": 1501347493,
"starttime": 1501347493,
@@ -487,11 +486,8 @@ hereafter.
@item id
The unique build id.
-@item project
-The associated specification name, as a string.
-
@item jobset
-The associated specification branch, as a string.
+The associated specification name, as a string.
@item job
The associated job-name, as a string.
@@ -586,9 +582,6 @@ This request accepts a mandatory parameter and multiple optional ones.
@item nr
Limit query result to nr elements. This parameter is @emph{mandatory}.
-@item project
-Filter query result to builds with the given @code{project}.
-
@item jobset
Filter query result to builds with the given @code{jobset}.
@@ -606,10 +599,10 @@ For example, to ask for the ten last builds:
$ curl "http://localhost:8080/api/latestbuilds?nr=10"
@end example
-or the five last builds where project is ``guix'' and jobset ``master'':
+or the five last builds where jobset ``guix'':
@example
-$ curl "http://localhost:8080/api/latestbuilds?nr=5&project=guix&jobset=master"
+$ curl "http://localhost:8080/api/latestbuilds?nr=5&jobset=guix"
@end example
If no builds matching given parameters are found, an empty JSON array is
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 188b9a8..f38dcd4 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -405,7 +405,7 @@ log file for DRV."
(define (db-format-build db build)
(match build
(#(id timestamp starttime stoptime log status derivation job-name system
- nix-name repo-name branch)
+ nix-name repo-name)
`((#:id . ,id)
(#:timestamp . ,timestamp)
(#:starttime . ,starttime)
@@ -417,13 +417,12 @@ log file for DRV."
(#:system . ,system)
(#:nix-name . ,nix-name)
(#:repo-name . ,repo-name)
- (#:outputs . ,(db-get-outputs db id))
- (#:branch . ,branch)))))
+ (#:outputs . ,(db-get-outputs db id))))))
(define (db-get-builds db filters)
"Retrieve all builds in database DB which are matched by given FILTERS.
-FILTERS is an assoc list which possible keys are 'project | 'jobset | 'job |
-'system | 'nr | 'order | 'status."
+FILTERS is an assoc list which possible keys are 'jobset | 'job | 'system |
+'nr | 'order | 'status."
;; XXX Change caller and remove
(define (assqx-ref filters key)
@@ -467,7 +466,7 @@ Assumes that if group id stays the same the group headers stay the same."
(define (finish-group)
(match repeated-row
(#(timestamp starttime stoptime log status derivation job-name system
- nix-name repo-name branch)
+ nix-name repo-name)
`((#:id . ,repeated-builds-id)
(#:timestamp . ,timestamp)
(#:starttime . ,starttime)
@@ -479,8 +478,7 @@ Assumes that if group id stays the same the group headers stay the same."
(#:system . ,system)
(#:nix-name . ,nix-name)
(#:repo-name . ,repo-name)
- (#:outputs . ,outputs)
- (#:branch . ,branch)))))
+ (#:outputs . ,outputs)))))
(define (same-group? builds-id)
(= builds-id repeated-builds-id))
@@ -520,22 +518,20 @@ Assumes that if group id stays the same the group headers stay the same."
(stmt-text (format #f "\
SELECT Builds.id, Outputs.name, Outputs.path, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.derivation,\
Derivations.job_name, Derivations.system, Derivations.nix_name,\
-Specifications.repo_name, Specifications.branch \
+Specifications.repo_name \
FROM Builds \
INNER JOIN Derivations ON Builds.derivation = Derivations.derivation AND Builds.evaluation = Derivations.evaluation \
INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_name \
LEFT JOIN Outputs ON Outputs.build = Builds.id \
WHERE (:id IS NULL OR (:id = Builds.id)) \
-AND (:project IS NULL OR (:project = Specifications.repo_name)) \
-AND (:jobset IS NULL OR (:jobset = Specifications.branch)) \
+AND (:jobset IS NULL OR (:jobset = Specifications.repo_name)) \
AND (:job IS NULL OR (:job = Derivations.job_name)) \
AND (:system IS NULL OR (:system = Derivations.system)) \
AND (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status = 'pending' AND Builds.status < 0)) \
ORDER BY ~a, Builds.id ASC LIMIT :nr;" order))
(stmt (sqlite-prepare db stmt-text #:cache? #t)))
(sqlite-bind-arguments stmt #:id (assqx-ref filters 'id)
- #:project (assqx-ref filters 'project)
#:jobset (assqx-ref filters 'jobset)
#:job (assqx-ref filters 'job)
#:system (assqx-ref filters 'system)
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index e911b9b..a45e6b1 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -45,8 +46,7 @@
(build-status started)))))
`((#:id . ,(assq-ref build #:id))
- (#:project . ,(assq-ref build #:repo-name))
- (#:jobset . ,(assq-ref build #:branch))
+ (#:jobset . ,(assq-ref build #:repo-name))
(#:job . ,(assq-ref build #:job-name))
;; Hydra's API uses "timestamp" as the time of the last useful event for
diff --git a/tests/database.scm b/tests/database.scm
index 847c8a6..e71c7f7 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -2,6 +2,7 @@
;;;
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -156,7 +157,6 @@ INSERT INTO Evaluations (specification, revision) VALUES (3, 3);")
#(((1 "/foo.drv") (2 "/bar.drv") (3 "/baz.drv")) ;ascending order
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;descending order
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto
- ((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto
((3 "/baz.drv")) ;nr = 1
((2 "/bar.drv") (1 "/foo.drv") (3 "/baz.drv"))) ;status+submission-time
(with-temporary-database db
@@ -185,9 +185,7 @@ INSERT INTO Evaluations (specification, revision) VALUES (3, 3);")
(assq-ref alist #:derivation)))))
(vector (map summarize (db-get-builds db '((nr 3) (order build-id))))
(map summarize (db-get-builds db '()))
- (map summarize (db-get-builds db '((project "guix"))))
- (map summarize (db-get-builds db '((project "guix")
- (jobset "master"))))
+ (map summarize (db-get-builds db '((jobset "guix"))))
(map summarize (db-get-builds db '((nr 1))))
(map summarize
(db-get-builds db '((order status+submission-time))))))))
diff --git a/tests/http.scm b/tests/http.scm
index 9d460b2..ba53887 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -76,8 +77,7 @@
(define build-query-result
'((#:id . 1)
- (#:project . "guix")
- (#:jobset . "master")
+ (#:jobset . "guix")
(#:job . "fake-job")
(#:timestamp . 1501347493)
(#:starttime . 1501347493)
@@ -226,13 +226,13 @@
500
(response-code (http-get (test-cuirass-uri "/api/latestbuilds"))))
- (test-assert "/api/latestbuilds?nr=1&project=guix&jobset=master"
+ (test-assert "/api/latestbuilds?nr=1&jobset=guix"
(let ((hash-list
(call-with-input-string
(utf8->string
(http-get-body
(test-cuirass-uri
- "/api/latestbuilds?nr=1&project=guix&jobset=master")))
+ "/api/latestbuilds?nr=1&jobset=guix")))
json->scm)))
(and (= (length hash-list) 1)
(hash-table=?
@@ -241,14 +241,14 @@
(object->json-string build-query-result)
json->scm)))))
- (test-assert "/api/latestbuilds?nr=1&project=gnu"
+ (test-assert "/api/latestbuilds?nr=1&jobset=gnu"
;; The result should be an empty JSON array.
(let ((hash-list
(call-with-input-string
(utf8->string
(http-get-body
(test-cuirass-uri
- "/api/latestbuilds?nr=1&project=gnu")))
+ "/api/latestbuilds?nr=1&jobset=gnu")))
json->scm)))
(= (length hash-list) 0)))
--
2.18.0
^ permalink raw reply related [flat|nested] 25+ messages in thread* [bug#32121] [PATCH 5/5] Add support for multiple inputs.
2018-07-10 23:02 ` [bug#32121] [PATCH 1/5] base: Compile CHECKOUT in the fiber Clément Lassieur
` (2 preceding siblings ...)
2018-07-10 23:02 ` [bug#32121] [PATCH 4/5] database: Call a specification 'jobset' instead of 'project' Clément Lassieur
@ 2018-07-10 23:02 ` Clément Lassieur
2018-07-13 9:28 ` Ludovic Courtès
2018-07-13 8:32 ` [bug#32121] [PATCH 1/5] base: Compile CHECKOUT in the fiber Ludovic Courtès
4 siblings, 1 reply; 25+ messages in thread
From: Clément Lassieur @ 2018-07-10 23:02 UTC (permalink / raw)
To: 32121
* bin/evaluate.in (absolutize, find-checkout, get-proc-source, get-load-path,
get-guix-package-path, format-checkouts, append-paths): New procedures.
(%not-colon): Remove variable.
(main): Take the load path, package path and PROC from the checkouts that
result from the inputs. Format the checkouts before sending them to the
procedure.
* doc/cuirass.texi (Overview, Database schema): Document the changes.
* examples/{guix-jobs.scm, hello-git.scm, hello-singleton.scm,
hello-subset.scm, random.scm}: Adapt to the new specification format.
* examples/guix-track-git.scm (package->spec): Rename to PACKAGE->INPUT.
(package->git-tracked): Replace FETCH-REPOSITORY with FETCH-INPUT and handle
the new format of its return value.
* examples/random-jobs.scm (make-random-jobs): Rename RANDOM to CHECKOUT.
Rename the checkout from 'random (which is a specification) to 'cuirass (which
is a checkout resulting from an input).
* src/cuirass/base.scm (fetch-repository): Rename to fetch-input. Rename SPEC
to INPUT. Return a checkout object instead of returning two values.
(evaluate): Take a list of CHECKOUTS and COMMITS as arguments, instead of
SOURCE. Remove TOKENIZE and LOAD-PATH. Pass the CHECKOUTS instead of the
SOURCE to "evaluate". Build the EVAL object instead of getting it from
"evaluate".
(compile?, fetch-inputs, compile-checkouts): New procedures.
(process-specs): Fetch all inputs instead of only fetching one repository.
The result of that fetching operation is a list of CHECKOUTS whose COMMITS are
used as a STAMP.
* src/cuirass/database.scm (db-add-input, db-get-inputs): New procedures.
(db-add-specification, db-get-specifications): Adapt to the new specification
format. Add/get all inputs as well.
(db-add-evaluation): Rename REVISION to COMMITS. Store COMMITS as space
separated commit hashes.
(db-get-builds): Rename REPO_NAME to NAME.
(db-get-stamp): Rename COMMIT to STAMP. Return #f when there is no STAMP.
(db-add-stamp): Rename COMMIT to STAMP. Deal with DB-GET-STAMP's new return
value.
(db-get-evaluations): Rename REVISION to COMMITS. Tokenize COMMITS.
* src/cuirass/utils.scm (%non-blocking): Export it.
* src/schema.sql (Inputs): New table that refers to the Specifications table.
(Specifications): Move input related fields to the Inputs table. Rename
REPO_NAME to NAME. Rename ARGUMENTS to PROC_ARGS. Rename FILE to PROC_PATH.
Add LOAD_PATH_INPUTS, PACKAGE_PATH_INPUTS and PROC_INPUT fields that refer to
the Inputs table.
(Stamps): Rename REPO_NAME to NAME.
(Evaluations): Rename REPO_NAME to NAME. Rename REVISION to COMMITS.
(Specifications_index): Replace with Inputs_index.
* src/sql/upgrade-2.sql: New file.
* tests/database.scm (example-spec, make-dummy-eval, sqlite-exec): Adapt to
the new specifications format. Rename REVISION to COMMITS.
* tests/http.scm (evaluations-query-result, fill-db): Idem.
---
bin/evaluate.in | 119 +++++++++++++++-------
doc/cuirass.texi | 147 +++++++++++++++++----------
examples/guix-jobs.scm | 38 ++++---
examples/guix-track-git.scm | 26 ++---
examples/hello-git.scm | 55 +++++------
examples/hello-singleton.scm | 28 +++---
examples/hello-subset.scm | 39 +++++---
examples/random-jobs.scm | 7 +-
examples/random.scm | 17 ++--
src/cuirass/base.scm | 186 ++++++++++++++++++++---------------
src/cuirass/database.scm | 115 ++++++++++++++--------
src/cuirass/utils.scm | 1 +
src/schema.sql | 28 ++++--
src/sql/upgrade-2.sql | 78 +++++++++++++++
tests/database.scm | 39 +++++---
tests/http.scm | 26 ++---
16 files changed, 613 insertions(+), 336 deletions(-)
create mode 100644 src/sql/upgrade-2.sql
diff --git a/bin/evaluate.in b/bin/evaluate.in
index 86d0e83..14ff52f 100644
--- a/bin/evaluate.in
+++ b/bin/evaluate.in
@@ -27,37 +27,99 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
;; Note: Do not use any Guix modules (see below).
(use-modules (ice-9 match)
- (ice-9 pretty-print))
+ (ice-9 pretty-print)
+ (srfi srfi-1)
+ (srfi srfi-26))
(define (ref module name)
"Dynamically link variable NAME under MODULE and return it."
(let ((m (resolve-interface module)))
(module-ref m name)))
-(define %not-colon
- (char-set-complement (char-set #\:)))
+(define (absolutize directory load-path)
+ (if (string-prefix? "/" load-path)
+ load-path
+ (string-append directory "/" load-path)))
+
+(define (find-checkout checkouts input-name)
+ (find (lambda (checkout)
+ (string=? (assq-ref checkout #:name)
+ input-name))
+ checkouts))
+
+(define (get-proc-source spec checkouts)
+ (let* ((input-name (assq-ref spec #:proc-input))
+ (checkout (find-checkout checkouts input-name)))
+ (assq-ref checkout #:directory)))
+
+(define (get-load-path spec checkouts)
+ (map (lambda (input-name)
+ (let* ((checkout (find-checkout checkouts input-name))
+ (directory (assq-ref checkout #:directory))
+ (load-path (assq-ref checkout #:load-path)))
+ (absolutize directory load-path)))
+ (assq-ref spec #:load-path-inputs)))
+
+(define (get-guix-package-path spec checkouts)
+ (let* ((input-names (assq-ref spec #:package-path-inputs))
+ (checkouts (map (cut find-checkout checkouts <>) input-names)))
+ (string-join
+ (map
+ (lambda (checkout)
+ (let ((directory (assq-ref checkout #:directory))
+ (load-path (assq-ref checkout #:load-path)))
+ (absolutize directory load-path)))
+ checkouts)
+ ":")))
+
+(define (format-checkouts checkouts)
+ "Format checkouts the way Hydra does: #:NAME becomes the key as a symbol,
+#:DIRECTORY becomes FILE-NAME and #:COMMIT becomes REVISION. The other
+entries are added because they could be useful during the evaluation."
+ (map
+ (lambda (checkout)
+ (let loop ((in checkout)
+ (out '())
+ (name #f))
+ (match in
+ (()
+ (cons name out))
+ (((#:name . val) . rest)
+ (loop rest out (string->symbol val)))
+ (((#:directory . val) . rest)
+ (loop rest (cons `(file-name . ,val) out) name))
+ (((#:commit . val) . rest)
+ (loop rest (cons `(revision . ,val) out) name))
+ (((keyword . val) . rest)
+ (loop rest (cons `(,(keyword->symbol keyword) . ,val) out) name)))))
+ checkouts))
+
+(define (append-paths . paths)
+ (string-join (delete "" paths) ":"))
(define* (main #:optional (args (command-line)))
(match args
- ((command load-path guix-package-path source specstr)
- ;; Load FILE, a Scheme file that defines Hydra jobs.
+ ((command static-guix-package-path specstr checkoutsstr)
+ ;; Load PROC-FILE, a Scheme file that defines Hydra jobs.
;;
- ;; Until FILE is loaded, we must *not* load any Guix module because
- ;; SOURCE may be providing its own, which could differ from ours--this is
- ;; the case when SOURCE is a Guix checkout. The 'ref' procedure helps us
- ;; achieve this.
- (let ((%user-module (make-fresh-user-module))
- (spec (with-input-from-string specstr read))
- (stdout (current-output-port))
- (stderr (current-error-port))
- (load-path (string-tokenize load-path %not-colon)))
- (unless (string-null? guix-package-path)
- (setenv "GUIX_PACKAGE_PATH" guix-package-path))
+ ;; Until PROC-FILE is loaded, we must *not* load any Guix module because
+ ;; the user may be providing its own with #:LOAD-PATH-INPUTS, which could
+ ;; differ from ours. The 'ref' procedure helps us achieve this.
+ (let* ((%user-module (make-fresh-user-module))
+ (spec (with-input-from-string specstr read))
+ (checkouts (with-input-from-string checkoutsstr read))
+ (proc-source (get-proc-source spec checkouts))
+ (load-path (get-load-path spec checkouts))
+ (guix-package-path (get-guix-package-path spec checkouts))
+ (stdout (current-output-port))
+ (stderr (current-error-port)))
+ (setenv "GUIX_PACKAGE_PATH"
+ (append-paths static-guix-package-path guix-package-path))
;; Since we have relative file name canonicalization by default, better
- ;; change to SOURCE to make sure things like 'include' with relative
- ;; file names work as expected.
- (chdir source)
+ ;; change to PROC-SOURCE to make sure things like 'include' with
+ ;; relative file names work as expected.
+ (chdir proc-source)
;; Change '%load-path' once and for all. We need it to be effective
;; both when we load SPEC's #:file and when we later call the thunks.
@@ -66,7 +128,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(save-module-excursion
(lambda ()
(set-current-module %user-module)
- (primitive-load (assq-ref spec #:file))))
+ (primitive-load (assq-ref spec #:proc-path))))
;; From there on we can access Guix modules.
@@ -93,22 +155,13 @@ building things during evaluation~%")
(apply real-build-things store args))))
;; Call the entry point of FILE and print the resulting job sexp.
- ;; Among the arguments, always pass 'file-name' and 'revision' like
- ;; Hydra does.
(let* ((proc-name (assq-ref spec #:proc))
(proc (module-ref %user-module proc-name))
- (commit (assq-ref spec #:current-commit))
- (name (assq-ref spec #:name))
- (args `((guix
- (revision . ,commit)
- (file-name . ,source))
- ,@(or (assq-ref spec #:arguments) '())))
- (thunks (proc store args))
- (eval `((#:specification . ,name)
- (#:revision . ,commit))))
+ (args `(,@(format-checkouts checkouts)
+ ,@(or (assq-ref spec #:proc-args) '())))
+ (thunks (proc store args)))
(pretty-print
- `(evaluation ,eval
- ,(map (lambda (thunk) (thunk))
+ `(evaluation ,(map (lambda (thunk) (thunk))
thunks))
stdout)))))
((command _ ...)
diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index 5c8c23f..308518e 100644
--- a/doc/cuirass.texi
+++ b/doc/cuirass.texi
@@ -105,10 +105,10 @@ basis of the @dfn{Continuous integration} practice.
@chapter Overview
@command{cuirass} acts as a daemon polling @acronym{VCS, version control
-system} repositories for changes, and evaluating a derivation when
-something has changed (@pxref{Derivations, Derivations,, guix, Guix}).
-As a final step the derivation is realized and the result of that build
-allows you to know if the job succeeded or not.
+system} repositories (called @code{inputs}) for changes, and evaluating a
+derivation when an @code{input} has changed (@pxref{Derivations, Derivations,,
+guix, Guix}). As a final step the derivation is realized and the result of
+that build allows you to know if the job succeeded or not.
What is actually done by @command{cuirass} is specified in a @dfn{job
specification} which is represented as an association list which is a
@@ -116,20 +116,40 @@ basic and traditional Scheme data structure. Here is an example of what
a specification might look like:
@lisp
- `((#:name . "hello")
- (#:url . "git://git.savannah.gnu.org/guix.git")
- (#:branch . "master")
- (#:no-compile? . #t)
- (#:load-path . ".")
+ '((#:name . "foo-master")
+ (#:load-path-inputs . ("guix"))
+ (#:package-path-inputs . ("packages"))
+ (#:proc-input . "conf")
+ (#:proc-path . "drv-list.scm")
(#:proc . cuirass-jobs)
- (#:file . "/tmp/drv-file.scm")
- (#:arguments (subset . "hello")))
+ (#:proc-args (subset . "foo"))
+ (#:inputs . (((#:name . "guix")
+ (#:url . "git://git.savannah.gnu.org/guix.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t))
+ ((#:name . "conf")
+ (#:url . "git://my-personal-conf.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t))
+ ((#:name . "packages")
+ (#:url . "git://my-custom-packages.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t)))))
@end lisp
In this specification the keys are Scheme keywords which have the nice
property of being self evaluating. This means that they can't refer to
another value like symbols do.
+There are three @code{inputs}: one tracking the Guix repository, one tracking
+the repository containing the @code{proc}, and one tracking the repository
+containing the custom packages (see @code{GUIX_PACKAGE_PATH}).
+@code{#:load-path-inputs}, @code{#:package-path-inputs} and
+@code{#:proc-input} refer to these inputs by their name.
+
@quotation Note
@c This refers to
@c <https://github.com/libgit2/libgit2sharp/issues/1094#issuecomment-112306072>.
@@ -229,47 +249,70 @@ Cuirass uses a SQLite database to store information about jobs and past
build results, but also to coordinate the execution of jobs.
The database contains the following tables: @code{Specifications},
-@code{Stamps}, @code{Evaluations}, @code{Derivations}, @code{Builds} and
-@code{SchemaVersion}. The purpose of each of these tables is explained below.
+@code{Inputs}, @code{Stamps}, @code{Evaluations}, @code{Derivations},
+@code{Builds} and @code{SchemaVersion}. The purpose of each of these tables
+is explained below.
@section Specifications
@cindex specifications, database
-This table stores specifications describing the repository from whence
+This table stores specifications describing the repositories from whence
Cuirass fetches code and the environment in which it will be processed.
Entries in this table must have values for the following text fields:
@table @code
-@item repo_name
-This field holds the name of the repository. This field is also the
-primary key of this table. Although this field is called
-@code{repo_name} in the database, it's called @code{name} in the
-specification itself.
-
-@item url
-The URL of the repository.
+@item name
+This field holds the name of the specification. This field is also the
+primary key of this table.
-@item load_path
-This field holds a colon-separated list of directories that are
-prepended to the Guile load path when evaluating @code{file} (see
-below.)
+@item load_path_inputs
+This field holds a list of input names whose load path is prepended to Guile's
+@code{%load-path} when evaluating @code{proc_path}.
-Each entry that is not an absolute file name is interpreted relative to
-the source code checkout. Often, @code{load_path} has just one entry,
-@code{"."}.
+@item package_path_inputs
+This field holds a list of input names whose load path is prepended to
+@code{GUIX_PACKAGE_PATH} when evaluating @code{proc_path}.
-When @code{load_path} is empty, the load path is left unchanged.
+@item proc_input
+The name of the input containing @code{proc}.
-@item file
-The absolute name of the Scheme file containing PROC.
+@item proc_path
+The path of the Scheme file containing @code{proc}, relative to
+@code{proc_input}.
@item proc
-This text field holds the name of the procedure in the Scheme file FILE
-that produces a list of jobs.
+This text field holds the name of the procedure in the Scheme file
+@code{proc_path} that produces a list of jobs.
+
+@item proc_args
+A list of arguments to be passed to @code{proc}. This can be used to produce
+a different set of jobs using the same @code{proc}.
+@end table
+
+@section Inputs
+@cindex inputs, database
+
+This table stores the data related to the repositories that are periodically
+fetched by Cuirass. Entries in this table must have values for the following
+text fields:
+
+@table @code
+@item specification
+This field holds the name of the specification from the @code{Specifications}
+table associated with the input. Every input belongs to a specification, and
+that specification can refer to its inputs.
+
+@item name
+This field holds the name of the input. That name can be used as a key by the
+@code{proc} if it needs access to its resulting checkout.
+
+@item url
+The URL of the repository.
+
+@item load_path
+Used by a specification when it refers to an input's load path. See
+@code{load_path_inputs} and @code{package_path_inputs}.
-@item arguments
-A list of arguments to be passed to PROC. This can be used to produce a
-different set of jobs using the same PROC.
@end table
The following columns are optional:
@@ -280,13 +323,12 @@ This text field determines which branch of the repository Cuirass should
check out.
@item tag
-This text field is an alternative to using BRANCH or REVISION. It tells
-Cuirass to check out the repository at the specified tag.
+This text field is an alternative to using @code{branch} or @code{revision}.
+It tells Cuirass to check out the repository at the specified tag.
@item revision
-This text field is an alternative to using BRANCH or TAG. It tells
-Cuirass to check out the repository at a particular revision. In the
-case of a git repository this would be a commit hash.
+This text field is an alternative to using @code{branch} or @code{tag}. It
+tells Cuirass to check out the repository at a particular commit.
@item no_compile_p
When this integer field holds the value @code{1} Cuirass will skip
@@ -296,14 +338,13 @@ compilation for the specified repository.
@section Stamps
@cindex stamps, database
-When a specification is processed, the repository must be downloaded at
-a certain revision as specified. The @code{Stamps} table stores the
-current revision for every specification when it is being processed.
+When a specification is processed, the repositories must be downloaded at a
+certain revision as specified. The @code{Stamps} table stores the current
+revisions for every specification when it is being processed.
-The table only has two text columns: @code{specification}, which
-references a specification from the @code{Specifications} table via the
-field @code{repo_name}, and @code{stamp}, which holds the revision
-(e.g. a commit hash).
+The table only has two text columns: @code{specification}, which references a
+specification from the @code{Specifications} table via the field @code{name},
+and @code{stamp}, which holds the revisions (space separated commit hashes).
@section Evaluations
@cindex evaluations, database
@@ -319,12 +360,12 @@ The @code{Evaluations} table has the following columns:
This is an automatically incrementing numeric identifier.
@item specification
-This field holds the @code{repo_name} of a specification from the
+This field holds the @code{name} of a specification from the
@code{Specifications} table.
-@item revision
-This text field holds the revision string (e.g. a git commit) of the
-repository specified in the related specification.
+@item commits
+This text field holds the revisions (space separated commit hashes) of the
+repositories specified as inputs of the related specification.
@end table
@section Derivations
diff --git a/examples/guix-jobs.scm b/examples/guix-jobs.scm
index 862cff7..4a01b66 100644
--- a/examples/guix-jobs.scm
+++ b/examples/guix-jobs.scm
@@ -1,5 +1,6 @@
;;; guix-jobs.scm -- job specification test for Guix
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -16,22 +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/>.
-(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))
-
-(define job-base
- `((#:name . "guix")
- (#:url . "git://git.savannah.gnu.org/guix.git")
- (#:load-path . ".")
- (#:file . ,(local-file "gnu-system.scm"))
- (#:proc . hydra-jobs)))
+(define (job-base key value)
+ `((#:name . ,(string-append "guix-" value))
+ (#:load-path-inputs . ("guix"))
+ (#:package-path-inputs . ())
+ (#:proc-input . "cuirass")
+ (#:proc-path . "examples/gnu-system.scm")
+ (#:proc . hydra-jobs)
+ (#:proc-args (subset . "hello"))
+ (#:inputs . (,(acons key value
+ '((#:name . "guix")
+ (#:url . "git://git.savannah.gnu.org/guix.git")
+ (#:load-path . ".")
+ (#:no-compile? . #t)))
+ ((#:name . "cuirass")
+ (#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t))))))
(define guix-master
- (acons #:branch "master" job-base))
+ (job-base #:branch "master"))
-(define guix-0.10
- (acons #:tag "v0.10.0" job-base))
+(define guix-0.15
+ (job-base #:tag "v0.15.0"))
-(list guix-master guix-0.10)
+(list guix-master guix-0.15)
diff --git a/examples/guix-track-git.scm b/examples/guix-track-git.scm
index 2a538fa..ab8abaa 100644
--- a/examples/guix-track-git.scm
+++ b/examples/guix-track-git.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -154,7 +155,7 @@ valid."
(string-map (lambda (c) (if (memq c (string->list ":/")) #\- c)) url)
#\-))
-(define* (package->spec pkg #:key (branch "master") commit url)
+(define* (package->input pkg #:key (branch "master") commit url)
(let ((url (or url ((compose git-reference-url origin-uri package-source) pkg))))
`((#:name . ,(url->file-name url))
(#:url . ,url)
@@ -195,17 +196,18 @@ valid."
(uri (origin-uri source)))
(if (not branch)
pkg
- (let* ((spec (package->spec pkg #:branch branch #:commit commit #:url url)))
- (let-values (((checkout commit)
- (fetch-repository store spec)))
- (let* ((url (or url (git-reference-url uri)))
- ; maybe (string-append (%package-cachedir) "/" (url->file-name url))
- (git-dir checkout)
- (hash (bytevector->nix-base32-string (file-hash git-dir)))
- (source (origin (uri (git-reference (url url) (commit commit)))
- (method git-fetch)
- (sha256 (base32 hash)))))
- (set-fields pkg ((package-source) source))))))))
+ (let* ((input (package->input pkg #:branch branch #:commit commit #:url url))
+ (checkout (fetch-input store input))
+ (url (or url (git-reference-url uri)))
+ ;; maybe (string-append (%package-cachedir) "/" (url->file-name url))
+ (git-dir (assq-ref checkout #:directory))
+ (hash (bytevector->nix-base32-string (file-hash git-dir)))
+ (source (origin (uri (git-reference
+ (url url)
+ (commit (assq-ref checkout #:commit))))
+ (method git-fetch)
+ (sha256 (base32 hash)))))
+ (set-fields pkg ((package-source) source))))))
\f
;;;
diff --git a/examples/hello-git.scm b/examples/hello-git.scm
index f6df99c..e9867ec 100644
--- a/examples/hello-git.scm
+++ b/examples/hello-git.scm
@@ -1,6 +1,7 @@
;;; hello-git.scm -- job specification test for hello git repository
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -17,37 +18,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 (srfi srfi-1))
-
-(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))
-
-(define (url->file-name url)
- (string-trim
- (string-map (lambda (c) (if (memq c (string->list ":/")) #\- c)) url)
- #\-))
-
-(define vc
- ;; where your version-control checkouts live
- (string-append (getenv "HOME") "/src"))
-(define guix-checkout (string-append vc "/guix"))
-
;; building GNU hello from git is too much work
-;; (define hello-checkout (string-append vc "/hello"))
-;; (define hello-git "http://git.savannah.gnu.org/r/hello.git")
+(define cuirass-git "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
;; ... so let's track cuirass' git
-(define cuirass-checkout (string-append vc "/cuirass"))
-(define cuirass-git "https://notabug.org/mthl/cuirass")
-;;(define cuirass-git "https://gitlab.com/janneke/cuirass.git")
-(list
- `((#:name . ,(url->file-name cuirass-checkout))
- (#:url . ,cuirass-git)
- (#:branch . "master")
- (#:no-compile? . #t)
- (#:load-path . ,guix-checkout)
- (#:proc . guix-jobs)
- (#:file . ,(local-file "guix-track-git.scm"))
- (#:arguments (name . "cuirass") (url . ,cuirass-git))))
+;; This builds the Guix Cuirass package with its source replaced by the last
+;; commit of Cuirass' git repository.
+(let ((top-srcdir (canonicalize-path
+ (string-append (dirname (current-filename)) "/.."))))
+ (list
+ `((#:name . "cuirass")
+ (#:load-path-inputs . ("guix"))
+ (#:package-path-inputs . ())
+ (#:proc-input . "cuirass")
+ (#:proc-path . "examples/guix-track-git.scm")
+ (#:proc . guix-jobs)
+ (#:proc-args (name . "cuirass") (url . ,cuirass-git))
+ (#:inputs . (((#:name . "guix")
+ (#:url . "git://git.savannah.gnu.org/guix.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t))
+ ((#:name . "cuirass")
+ (#:url . ,(string-append "file://" top-srcdir))
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t)))))))
diff --git a/examples/hello-singleton.scm b/examples/hello-singleton.scm
index 5ff2e82..b0ae19e 100644
--- a/examples/hello-singleton.scm
+++ b/examples/hello-singleton.scm
@@ -1,5 +1,6 @@
;;; hello-singleton.scm -- job specification test for hello in master
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -16,18 +17,23 @@
;;; 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))
-
(define hello-master
- `((#:name . "guix")
- (#:url . "git://git.savannah.gnu.org/guix.git")
- (#:load-path . ".")
- (#:file . ,(local-file "gnu-system.scm"))
+ '((#:name . "guix-master")
+ (#:load-path-inputs . ("guix"))
+ (#:package-path-inputs . ())
+ (#:proc-input . "cuirass")
+ (#:proc-path . "examples/gnu-system.scm")
(#:proc . hydra-jobs)
- (#:arguments (subset . "hello"))
- (#:branch . "master")))
+ (#:proc-args (subset . "hello"))
+ (#:inputs . (((#:name . "guix")
+ (#:url . "git://git.savannah.gnu.org/guix.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t))
+ ((#:name . "cuirass")
+ (#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t))))))
(list hello-master)
diff --git a/examples/hello-subset.scm b/examples/hello-subset.scm
index 60764fc..d8ad645 100644
--- a/examples/hello-subset.scm
+++ b/examples/hello-subset.scm
@@ -1,5 +1,6 @@
;;; hello-subset.scm -- job specification test for hello subset
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -16,28 +17,34 @@
;;; 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))
-
-(define job-base
- `((#:name . "guix")
- (#:url . "git://git.savannah.gnu.org/guix.git")
- (#:load-path . ".")
- (#:file . ,(local-file "gnu-system.scm"))
+(define (job-base key value)
+ `((#:name . ,(string-append "guix-" value))
+ (#:load-path-inputs . ("guix"))
+ (#:package-path-inputs . ())
+ (#:proc-input . "cuirass")
+ (#:proc-path . "examples/gnu-system.scm")
(#:proc . hydra-jobs)
- (#:arguments (subset . "hello"))))
+ (#:proc-args (subset . "hello"))
+ (#:inputs . (,(acons key value
+ '((#:name . "guix")
+ (#:url . "git://git.savannah.gnu.org/guix.git")
+ (#:load-path . ".")
+ (#:no-compile? . #t)))
+ ((#:name . "cuirass")
+ (#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t))))))
(define guix-master
- (acons #:branch "master" job-base))
+ (job-base #:branch "master"))
(define guix-core-updates
- (acons #:branch "core-updates" job-base))
+ (job-base #:branch "core-updates"))
-(define guix-0.10
- (acons #:tag "v0.10.0" job-base))
+(define guix-0.15
+ (job-base #:tag "v0.15.0"))
(list guix-master
guix-core-updates
- guix-0.10)
+ guix-0.15)
diff --git a/examples/random-jobs.scm b/examples/random-jobs.scm
index 78a09f4..6521734 100644
--- a/examples/random-jobs.scm
+++ b/examples/random-jobs.scm
@@ -1,5 +1,6 @@
;;; random.scm -- Definition of the random build jobs
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -42,11 +43,11 @@
(mkdir #$output))))))
(define (make-random-jobs store arguments)
- (let ((random (assq-ref arguments 'random)))
+ (let ((checkout (assq-ref arguments 'cuirass)))
(format (current-error-port)
"evaluating random jobs from directory ~s, commit ~s~%"
- (assq-ref random 'file-name)
- (assq-ref random 'revision)))
+ (assq-ref checkout 'file-name)
+ (assq-ref checkout 'revision)))
(unfold (cut > <> 10)
(lambda (i)
diff --git a/examples/random.scm b/examples/random.scm
index 820ac8d..d2e1a1b 100644
--- a/examples/random.scm
+++ b/examples/random.scm
@@ -1,5 +1,6 @@
;;; random.scm -- Job specification that creates random build jobs
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -20,10 +21,14 @@
(string-append (dirname (current-filename)) "/.."))))
(list
`((#:name . "random")
- (#:url . ,(string-append "file://" top-srcdir))
- (#:branch . "master")
- (#:no-compile? . #t)
- (#:load-path . ".")
+ (#:load-path-inputs . ()) ;use the Guix shipped with Cuirass
+ (#:package-path-inputs . ())
+ (#:proc-input . "cuirass")
+ (#:proc-path . "examples/random-jobs.scm")
(#:proc . make-random-jobs)
- (#:file . "examples/random-jobs.scm")
- (#:arguments . ()))))
+ (#:proc-args . ())
+ (#:inputs . (((#:name . "cuirass")
+ (#:url . ,(string-append "file://" top-srcdir))
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t)))))))
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index de54f72..c602308 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -39,6 +39,7 @@
#:use-module (ice-9 receive)
#:use-module (ice-9 atomic)
#:use-module (ice-9 ftw)
+ #:use-module (ice-9 threads)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
@@ -48,7 +49,8 @@
#:use-module (rnrs bytevectors)
#:export (;; Procedures.
call-with-time-display
- fetch-repository
+ fetch-input
+ fetch-inputs
compile
evaluate
clear-build-queue
@@ -140,10 +142,11 @@ values."
(lambda (key err)
(report-git-error err))))
-(define* (fetch-repository store spec #:key writable-copy?)
- "Get the latest version of repository specified in SPEC. Return two
-values: the content of the git repository at URL copied into a store
-directory and the sha1 of the top level commit in this directory.
+(define* (fetch-input store input #:key writable-copy?) ;TODO fix desc
+ "Get the latest version of repository inputified in INPUT. Return an
+association list containing the input name, the content of the git repository
+at URL copied into a store directory and the sha1 of the top level commit in
+this directory.
When WRITABLE-COPY? is true, return a writable copy; otherwise, return a
read-only directory."
@@ -154,15 +157,15 @@ read-only directory."
branch
(string-append "origin/" branch)))
- (let ((name (assq-ref spec #:name))
- (url (assq-ref spec #:url))
- (branch (and=> (assq-ref spec #:branch)
+ (let ((name (assq-ref input #:name))
+ (url (assq-ref input #:url))
+ (branch (and=> (assq-ref input #:branch)
(lambda (b)
`(branch . ,(add-origin b)))))
- (commit (and=> (assq-ref spec #:commit)
+ (commit (and=> (assq-ref input #:commit)
(lambda (c)
`(commit . ,c))))
- (tag (and=> (assq-ref spec #:tag)
+ (tag (and=> (assq-ref input #:tag)
(lambda (t)
`(tag . ,t)))))
(let-values (((directory commit)
@@ -172,12 +175,16 @@ read-only directory."
;; TODO: When WRITABLE-COPY? is true, we could directly copy the
;; checkout directly in a writable location instead of copying it to the
;; store first.
- (values (if writable-copy?
- (make-writable-copy directory
- (string-append (%package-cachedir)
- "/" (assq-ref spec #:name)))
- directory)
- commit))))
+ (let ((directory (if writable-copy?
+ (make-writable-copy directory
+ (string-append
+ (%package-cachedir) "/" name))
+ directory)))
+ `((#:name . ,name)
+ (#:directory . ,directory)
+ (#:commit . ,commit)
+ (#:load-path . ,(assq-ref input #:load-path))
+ (#:no-compile? . ,(assq-ref input #:no-compile?)))))))
(define (make-writable-copy source target)
"Create TARGET and make it a writable copy of directory SOURCE; delete
@@ -243,9 +250,9 @@ fibers."
(logior (@ (fibers epoll) EPOLLERR)
(@ (fibers epoll) EPOLLHUP)))))
-(define (evaluate store db spec source)
- "Evaluate and build package derivations defined in SPEC, using the checkout
-in SOURCE directory. Return a list of jobs."
+(define (evaluate store db spec checkouts commits)
+ "Evaluate and build package derivations defined in SPEC, using CHECKOUTS.
+Return a list of jobs."
(define (augment-job job eval-id)
(let ((drv (read-derivation-from-file
(assq-ref job #:derivation))))
@@ -254,26 +261,11 @@ in SOURCE directory. Return a list of jobs."
(#:system . ,(derivation-system drv))
,@job)))
- (define (tokenize str)
- (string-tokenize str (char-set-complement (char-set #\:))))
-
- (define load-path
- (match (assq-ref spec #:load-path)
- (#f
- "")
- ((= tokenize path)
- (string-join (map (lambda (entry)
- (if (string-prefix? "/" entry)
- entry
- (string-append source "/" entry)))
- path)
- ":"))))
-
(let* ((port (non-blocking-port
(open-pipe* OPEN_READ "evaluate"
- load-path
(%guix-package-path)
- source (object->string spec))))
+ (object->string spec)
+ (object->string checkouts))))
(result (match (read/non-blocking port)
;; If an error occured during evaluation report it,
;; otherwise, suppose that data read from port are
@@ -285,11 +277,12 @@ in SOURCE directory. Return a list of jobs."
(data data))))
(close-pipe port)
(match result
- (('evaluation eval jobs)
- (let ((eval-id (db-add-evaluation db eval)))
- (log-message "created evaluation ~a for ~a, commit ~a" eval-id
- (assq-ref eval #:specification)
- (assq-ref eval #:revision))
+ (('evaluation jobs)
+ (let* ((spec-name (assq-ref spec #:name))
+ (eval-id (db-add-evaluation
+ db `((#:specification . ,spec-name)
+ (#:commits . ,commits)))))
+ (log-message "created evaluation ~a for '~a'" eval-id spec-name)
(let ((jobs (map (lambda (job)
(augment-job job eval-id))
jobs)))
@@ -611,48 +604,83 @@ procedure is meant to be called at startup."
(when (or directory file)
(set-tls-certificate-locations! directory file)))))
+(define (compile? checkout)
+ (not (assq-ref checkout #:no-compile?)))
+
+(define (fetch-inputs spec)
+ (let* ((inputs (assq-ref spec #:inputs))
+ (thunks
+ (map
+ (lambda (input)
+ (lambda ()
+ (with-store store
+ (log-message "fetching input '~a' of spec '~a'"
+ (assq-ref input #:name)
+ (assq-ref spec #:name))
+ (fetch-input store input
+ #:writable-copy? (compile? input)))))
+ inputs))
+ (results (par-map %non-blocking thunks)))
+ (map (lambda (checkout)
+ (log-message "fetched input '~a' of spec '~a' (commit ~s)"
+ (assq-ref checkout #:name)
+ (assq-ref spec #:name)
+ (assq-ref checkout #:commit))
+ checkout)
+ results)))
+
+(define (compile-checkouts spec all-checkouts)
+ (let* ((checkouts (filter compile? all-checkouts))
+ (thunks
+ (map
+ (lambda (checkout)
+ (lambda ()
+ (log-message "compiling input '~a' of spec '~a' (commit ~s)"
+ (assq-ref checkout #:name)
+ (assq-ref spec #:name)
+ (assq-ref checkout #:commit))
+ (compile checkout)))
+ checkouts))
+ (results (par-map %non-blocking thunks)))
+ (map (lambda (checkout)
+ (log-message "compiled input '~a' of spec '~a' (commit ~s)"
+ (assq-ref checkout #:name)
+ (assq-ref spec #:name)
+ (assq-ref checkout #:commit))
+ checkout)
+ results)))
+
(define (process-specs db jobspecs)
"Evaluate and build JOBSPECS and store results in DB."
(define (process spec)
- (define compile?
- (not (assq-ref spec #:no-compile?)))
-
(with-store store
- (let ((stamp (db-get-stamp db spec))
- (name (assoc-ref spec #:name)))
- (log-message "considering spec '~a', URL '~a'"
- name (assoc-ref spec #:url))
- (receive (checkout commit)
- (non-blocking (fetch-repository store spec
- #:writable-copy? compile?))
- (log-message "spec '~a': fetched commit ~s (stamp was ~s)"
- name commit stamp)
- (when commit
- (unless (string=? commit stamp)
- ;; Immediately mark COMMIT as being processed so we don't spawn
- ;; a concurrent evaluation of that same commit.
- (db-add-stamp db spec commit)
- (spawn-fiber
- (lambda ()
- (when compile?
- (log-message "compiling '~a' with commit ~s" name commit)
- (non-blocking (compile checkout)))
- (guard (c ((evaluation-error? c)
- (log-message "failed to evaluate spec '~s'"
- (evaluation-error-spec-name c))
- #f))
- (log-message "evaluating '~a' with commit ~s"
- name commit)
- (with-store store
- (with-database db
- (let* ((spec* (acons #:current-commit commit spec))
- (jobs (evaluate store db spec* checkout)))
- (log-message "building ~a jobs for '~a'"
- (length jobs) name)
- (build-packages store db jobs)))))))
-
- ;; 'spawn-fiber' returns zero values but we need one.
- *unspecified*))))))
+ (let* ((stamp (db-get-stamp db spec))
+ (name (assoc-ref spec #:name))
+ (checkouts (fetch-inputs spec))
+ (commits (map (cut assq-ref <> #:commit) checkouts))
+ (commits-str (string-join commits)))
+ (unless (equal? commits-str stamp)
+ ;; Immediately mark SPEC's INPUTS as being processed so we don't
+ ;; spawn a concurrent evaluation of that same commit.
+ (db-add-stamp db spec commits-str)
+ (spawn-fiber
+ (lambda ()
+ (compile-checkouts spec checkouts)
+ (guard (c ((evaluation-error? c)
+ (log-message "failed to evaluate spec '~a'"
+ (evaluation-error-spec-name c))
+ #f))
+ (log-message "evaluating spec '~a': stamp ~s different from ~s"
+ name commits-str stamp)
+ (with-store store
+ (with-database db
+ (let ((jobs (evaluate store db spec checkouts commits)))
+ (log-message "building ~a jobs for '~a'"
+ (length jobs) name)
+ (build-packages store db jobs)))))))
+
+ ;; 'spawn-fiber' returns zero values but we need one.
+ *unspecified*))))
(for-each process jobspecs))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index f38dcd4..b241838 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -228,47 +228,76 @@ database object."
(vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
0))
+(define (db-add-input db spec-name input)
+ (sqlite-exec db "\
+INSERT OR IGNORE INTO Inputs (specification, name, url, load_path, branch, \
+tag, revision, no_compile_p) VALUES ("
+ spec-name ", "
+ (assq-ref input #:name) ", "
+ (assq-ref input #:url) ", "
+ (assq-ref input #:load-path) ", "
+ (assq-ref input #:branch) ", "
+ (assq-ref input #:tag) ", "
+ (assq-ref input #:commit) ", "
+ (if (assq-ref input #:no-compile?) 1 0) ");")
+ (last-insert-rowid db))
+
(define (db-add-specification db spec)
- "Store specification SPEC in database DB and return its ID."
+ "Store SPEC in database DB. SPEC inputs are stored in the INPUTS table."
(sqlite-exec db "\
-INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \
- proc, arguments, branch, tag, revision, no_compile_p) \
+INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \
+package_path_inputs, proc_input, proc_path, proc, proc_args) \
VALUES ("
(assq-ref spec #:name) ", "
- (assq-ref spec #:url) ", "
- (assq-ref spec #:load-path) ", "
- (assq-ref spec #:file) ", "
+ (assq-ref spec #:load-path-inputs) ", "
+ (assq-ref spec #:package-path-inputs)", "
+ (assq-ref spec #:proc-input) ", "
+ (assq-ref spec #:proc-path) ", "
(symbol->string (assq-ref spec #:proc)) ", "
- (assq-ref spec #:arguments) ", "
- (assq-ref spec #:branch) ", "
- (assq-ref spec #:tag) ", "
- (assq-ref spec #:commit) ", "
- (if (assq-ref spec #:no-compile?) 1 0)
- ");")
- (last-insert-rowid db))
+ (assq-ref spec #:proc-args) ");")
+ (let ((spec-id (last-insert-rowid db)))
+ (for-each (lambda (input)
+ (db-add-input db (assq-ref spec #:name) input))
+ (assq-ref spec #:inputs))
+ spec-id))
+
+(define (db-get-inputs db spec-name)
+ (let loop ((rows (sqlite-exec db "SELECT * FROM Inputs WHERE specification="
+ spec-name ";"))
+ (inputs '()))
+ (match rows
+ (() inputs)
+ ((#(specification name url load-path branch tag revision no-compile-p)
+ . rest)
+ (loop rest
+ (cons `((#:name . ,name)
+ (#:url . ,url)
+ (#:load-path . ,load-path)
+ (#:branch . ,branch)
+ (#:tag . ,tag)
+ (#:commit . ,revision)
+ (#:no-compile? . ,(positive? no-compile-p)))
+ inputs))))))
(define (db-get-specifications db)
(let loop ((rows (sqlite-exec db "SELECT * FROM Specifications;"))
(specs '()))
(match rows
(() specs)
- ((#(name url load-path file proc args branch tag rev no-compile?)
+ ((#(name load-path-inputs package-path-inputs proc-input proc-path proc
+ proc-args)
. rest)
(loop rest
(cons `((#:name . ,name)
- (#:url . ,url)
- (#:load-path . ,load-path)
- (#:file . ,file)
+ (#:load-path-inputs .
+ ,(with-input-from-string load-path-inputs read))
+ (#:package-path-inputs .
+ ,(with-input-from-string package-path-inputs read))
+ (#:proc-input . ,proc-input)
+ (#:proc-path . ,proc-path)
(#:proc . ,(with-input-from-string proc read))
- (#:arguments . ,(with-input-from-string args read))
- (#:branch . ,branch)
- (#:tag . ,(match tag
- ("NULL" #f)
- (_ tag)))
- (#:commit . ,(match rev
- ("NULL" #f)
- (_ rev)))
- (#:no-compile? . ,(positive? no-compile?)))
+ (#:proc-args . ,(with-input-from-string proc-args read))
+ (#:inputs . ,(db-get-inputs db name)))
specs))))))
(define (db-add-derivation db job)
@@ -299,9 +328,9 @@ INSERT INTO Derivations (derivation, job_name, system, nix_name, evaluation)\
(define (db-add-evaluation db eval)
(sqlite-exec db "\
-INSERT INTO Evaluations (specification, revision) VALUES ("
+INSERT INTO Evaluations (specification, commits) VALUES ("
(assq-ref eval #:specification) ", "
- (assq-ref eval #:revision) ");")
+ (string-join (assq-ref eval #:commits)) ");")
(last-insert-rowid db))
(define-syntax-rule (with-database db body ...)
@@ -518,14 +547,14 @@ Assumes that if group id stays the same the group headers stay the same."
(stmt-text (format #f "\
SELECT Builds.id, Outputs.name, Outputs.path, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.derivation,\
Derivations.job_name, Derivations.system, Derivations.nix_name,\
-Specifications.repo_name \
+Specifications.name \
FROM Builds \
INNER JOIN Derivations ON Builds.derivation = Derivations.derivation AND Builds.evaluation = Derivations.evaluation \
INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
-INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_name \
+INNER JOIN Specifications ON Evaluations.specification = Specifications.name \
LEFT JOIN Outputs ON Outputs.build = Builds.id \
WHERE (:id IS NULL OR (:id = Builds.id)) \
-AND (:jobset IS NULL OR (:jobset = Specifications.repo_name)) \
+AND (:jobset IS NULL OR (:jobset = Specifications.name)) \
AND (:job IS NULL OR (:job = Derivations.job_name)) \
AND (:system IS NULL OR (:system = Derivations.system)) \
AND (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status = 'pending' AND Builds.status < 0)) \
@@ -571,28 +600,28 @@ SELECT DISTINCT derivation FROM (
(let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification="
(assq-ref spec #:name) ";")))
(match res
- (() "")
- ((#(spec commit)) commit))))
-
-(define (db-add-stamp db spec commit)
- "Associate stamp COMMIT to specification SPEC in database DB."
- (if (string-null? (db-get-stamp db spec))
+ (() #f)
+ ((#(spec stamp)) stamp))))
+
+(define (db-add-stamp db spec stamp)
+ "Associate STAMP to specification SPEC in database DB."
+ (if (db-get-stamp db spec)
+ (sqlite-exec db "UPDATE Stamps SET stamp=" stamp
+ "WHERE specification=" (assq-ref spec #:name) ";")
(sqlite-exec db "\
INSERT INTO Stamps (specification, stamp) VALUES ("
- (assq-ref spec #:name) ", " commit ");")
- (sqlite-exec db "UPDATE Stamps SET stamp=" commit
- "WHERE specification=" (assq-ref spec #:name) ";")))
+ (assq-ref spec #:name) ", " stamp ");")))
(define (db-get-evaluations db limit)
- (let loop ((rows (sqlite-exec db "SELECT id, specification, revision
+ (let loop ((rows (sqlite-exec db "SELECT id, specification, commits
FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
(evaluations '()))
(match rows
(() (reverse evaluations))
- ((#(id specification revision)
+ ((#(id specification commits)
. rest)
(loop rest
(cons `((#:id . ,id)
(#:specification . ,specification)
- (#:revision . ,revision))
+ (#:commits . ,(string-tokenize commits)))
evaluations))))))
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index d219a3e..6629bc1 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -39,6 +39,7 @@
call-with-critical-section
with-critical-section
+ %non-blocking
non-blocking
essential-task
bytevector-range))
diff --git a/src/schema.sql b/src/schema.sql
index a3f14eb..f61bd57 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -6,30 +6,40 @@ CREATE TABLE SchemaVersion (
);
CREATE TABLE Specifications (
- repo_name TEXT NOT NULL PRIMARY KEY,
+ name TEXT NOT NULL PRIMARY KEY,
+ load_path_inputs TEXT NOT NULL, -- list of input names whose load path will be in Guile's %load-path
+ package_path_inputs TEXT NOT NULL, -- list of input names whose load paths will be in GUIX_PACKAGE_PATH
+ proc_input TEXT NOT NULL, -- name of the input containing the proc that does the evaluation
+ proc_path TEXT NOT NULL, -- procedure that does the evaluation, relative to proc_input
+ proc TEXT NOT NULL, -- defined in proc_path
+ proc_args TEXT NOT NULL -- passed to proc
+);
+
+CREATE TABLE Inputs (
+ specification TEXT NOT NULL,
+ name TEXT NOT NULL,
url TEXT NOT NULL,
load_path TEXT NOT NULL,
- file TEXT NOT NULL,
- proc TEXT NOT NULL,
- arguments TEXT NOT NULL,
-- The following columns are optional.
branch TEXT,
tag TEXT,
revision TEXT,
- no_compile_p INTEGER
+ no_compile_p INTEGER,
+ PRIMARY KEY (specification, name),
+ FOREIGN KEY (specification) REFERENCES Specifications (name)
);
CREATE TABLE Stamps (
specification TEXT NOT NULL PRIMARY KEY,
stamp TEXT NOT NULL,
- FOREIGN KEY (specification) REFERENCES Specifications (repo_name)
+ FOREIGN KEY (specification) REFERENCES Specifications (name)
);
CREATE TABLE Evaluations (
id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
specification TEXT NOT NULL,
- revision TEXT NOT NULL,
- FOREIGN KEY (specification) REFERENCES Specifications (repo_name)
+ commits TEXT NOT NULL,
+ FOREIGN KEY (specification) REFERENCES Specifications (name)
);
CREATE TABLE Derivations (
@@ -68,7 +78,7 @@ CREATE TABLE Builds (
-- Create indexes to speed up common queries, in particular those
-- corresponding to /api/latestbuilds and /api/queue HTTP requests.
CREATE INDEX Builds_Derivations_index ON Builds(status ASC, timestamp ASC, id, derivation, evaluation, stoptime DESC);
-CREATE INDEX Specifications_index ON Specifications(repo_name, branch);
+CREATE INDEX Inputs_index ON Inputs(specification, name, branch);
CREATE INDEX Derivations_index ON Derivations(derivation, evaluation, job_name, system);
COMMIT;
diff --git a/src/sql/upgrade-2.sql b/src/sql/upgrade-2.sql
new file mode 100644
index 0000000..35cff95
--- /dev/null
+++ b/src/sql/upgrade-2.sql
@@ -0,0 +1,78 @@
+BEGIN TRANSACTION;
+
+DROP INDEX Specifications_index;
+
+ALTER TABLE Specifications RENAME TO tmp_Specifications;
+ALTER TABLE Stamps RENAME TO tmp_Stamps;
+ALTER TABLE Evaluations RENAME TO tmp_Evaluations;
+
+CREATE TABLE Specifications (
+ name TEXT NOT NULL PRIMARY KEY,
+ load_path_inputs TEXT NOT NULL, -- list of input names whose load path will be in Guile's %load-path
+ package_path_inputs TEXT NOT NULL, -- list of input names whose load paths will be in GUIX_PACKAGE_PATH
+ proc_input TEXT NOT NULL, -- name of the input containing the proc that does the evaluation
+ proc_path TEXT NOT NULL, -- procedure that does the evaluation, relative to proc_input
+ proc TEXT NOT NULL, -- defined in proc_path
+ proc_args TEXT NOT NULL -- passed to proc
+);
+
+CREATE TABLE Inputs (
+ specification TEXT NOT NULL,
+ name TEXT NOT NULL,
+ url TEXT NOT NULL,
+ load_path TEXT NOT NULL,
+ -- The following columns are optional.
+ branch TEXT,
+ tag TEXT,
+ revision TEXT,
+ no_compile_p INTEGER,
+ PRIMARY KEY (specification, name),
+ FOREIGN KEY (specification) REFERENCES Specifications (name)
+);
+
+CREATE TABLE Stamps (
+ specification TEXT NOT NULL PRIMARY KEY,
+ stamp TEXT NOT NULL,
+ FOREIGN KEY (specification) REFERENCES Specifications (name)
+);
+
+CREATE TABLE Evaluations (
+ id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
+ specification TEXT NOT NULL,
+ commits TEXT NOT NULL,
+ FOREIGN KEY (specification) REFERENCES Specifications (name)
+);
+
+INSERT INTO Specifications (name, load_path_inputs, package_path_inputs, proc_input, proc_path, proc, proc_args)
+SELECT printf('%s-%s', repo_name, branch) AS name,
+ printf('("%s")', repo_name) AS load_path_inputs,
+ '()' AS package_path_inputs,
+ repo_name AS proc_input,
+ file AS proc_path,
+ proc,
+ arguments AS proc_args
+FROM tmp_Specifications;
+
+INSERT INTO Inputs (specification, name, url, load_path, branch, tag, revision, no_compile_p)
+SELECT printf('%s-%s', repo_name, branch) AS specification,
+ repo_name AS name,
+ url, load_path, branch, tag, revision, no_compile_p
+FROM tmp_Specifications;
+
+INSERT INTO Stamps (specification, stamp)
+SELECT Specifications.name AS specification, stamp
+FROM tmp_Stamps
+LEFT JOIN Specifications ON Specifications.proc_input = tmp_Stamps.specification;
+
+INSERT INTO Evaluations (id, specification, commits)
+SELECT id, Specifications.name AS specification, revision
+FROM tmp_Evaluations
+LEFT JOIN Specifications ON Specifications.proc_input = tmp_Evaluations.specification;
+
+CREATE INDEX Inputs_index ON Inputs(specification, name, branch);
+
+DROP TABLE tmp_Specifications;
+DROP TABLE tmp_Stamps;
+DROP TABLE tmp_Evaluations;
+
+COMMIT;
diff --git a/tests/database.scm b/tests/database.scm
index e71c7f7..674ed9a 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -25,19 +25,30 @@
(define example-spec
'((#:name . "guix")
- (#:url . "git://git.savannah.gnu.org/guix.git")
- (#:load-path . ".")
- (#:file . "/tmp/gnu-system.scm")
+ (#:load-path-inputs . ("savannah"))
+ (#:package-path-inputs . ())
+ (#:proc-input . "savannah")
+ (#:proc-path . "/tmp/gnu-system.scm")
(#:proc . hydra-jobs)
- (#:arguments (subset . "hello"))
- (#:branch . "master")
- (#:tag . #f)
- (#:commit . #f)
- (#:no-compile? . #f)))
-
-(define* (make-dummy-eval #:optional (revision "cabba3e"))
+ (#:proc-args (subset . "hello"))
+ (#:inputs . (((#:name . "savannah")
+ (#:url . "git://git.savannah.gnu.org/guix.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:tag . #f)
+ (#:commit . #f)
+ (#:no-compile? . #f))
+ ((#:name . "maintenance")
+ (#:url . "git://git.savannah.gnu.org/guix/maintenance.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:tag . #f)
+ (#:commit . #f)
+ (#:no-compile? . #f))))))
+
+(define* (make-dummy-eval #:optional (commits '("cabba3e 61730ea")))
`((#:specification . "guix")
- (#:revision . ,revision)))
+ (#:commits . ,commits)))
(define* (make-dummy-job #:optional (name "foo"))
`((#:name . ,name)
@@ -90,11 +101,11 @@
(test-assert "sqlite-exec"
(begin
(sqlite-exec (%db) "\
-INSERT INTO Evaluations (specification, revision) VALUES (1, 1);")
+INSERT INTO Evaluations (specification, commits) VALUES (1, 1);")
(sqlite-exec (%db) "\
-INSERT INTO Evaluations (specification, revision) VALUES (2, 2);")
+INSERT INTO Evaluations (specification, commits) VALUES (2, 2);")
(sqlite-exec (%db) "\
-INSERT INTO Evaluations (specification, revision) VALUES (3, 3);")
+INSERT INTO Evaluations (specification, commits) VALUES (3, 3);")
(sqlite-exec (%db) "SELECT * FROM Evaluations;")))
(test-equal "db-add-specification"
diff --git a/tests/http.scm b/tests/http.scm
index ba53887..b5af782 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -97,7 +97,7 @@
(define evaluations-query-result
'((#:id . 2)
(#:specification . "guix")
- (#:revision . "fakesha2")))
+ (#:commits . ("fakesha2" "fakesha3"))))
(test-group-with-cleanup "http"
(test-assert "object->json-string"
@@ -171,21 +171,25 @@
(#:eval-id . 1)))
(specification
'((#:name . "guix")
- (#:url . "git://git.savannah.gnu.org/guix.git")
- (#:load-path . ".")
- (#:file . "/tmp/gnu-system.scm")
+ (#:load-path-inputs . ("savannah"))
+ (#:package-path-inputs . ())
+ (#:proc-input . "savannah")
+ (#:proc-path . "/tmp/gnu-system.scm")
(#:proc . hydra-jobs)
- (#:arguments (subset . "hello"))
- (#:branch . "master")
- (#:tag . #f)
- (#:commit . #f)
- (#:no-compile? . #f)))
+ (#:proc-args (subset . "hello"))
+ (#:inputs . (((#:name . "savannah")
+ (#:url . "git://git.savannah.gnu.org/guix.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:tag . #f)
+ (#:commit . #f)
+ (#:no-compile? . #f))))))
(evaluation1
'((#:specification . "guix")
- (#:revision . "fakesha1")))
+ (#:commits . ("fakesha1" "fakesha3"))))
(evaluation2
'((#:specification . "guix")
- (#:revision . "fakesha2"))))
+ (#:commits . ("fakesha2" "fakesha3")))))
(db-add-build (%db) build1)
(db-add-build (%db) build2)
(db-add-derivation (%db) derivation1)
--
2.18.0
^ permalink raw reply related [flat|nested] 25+ messages in thread