aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile.am5
-rw-r--r--bin/cuirass.in5
-rw-r--r--bin/evaluate.in120
-rw-r--r--doc/cuirass.texi144
-rw-r--r--examples/guix-jobs.scm38
-rw-r--r--examples/guix-track-git.scm26
-rw-r--r--examples/hello-git.scm55
-rw-r--r--examples/hello-singleton.scm28
-rw-r--r--examples/hello-subset.scm39
-rw-r--r--examples/random-jobs.scm7
-rw-r--r--examples/random.scm17
-rw-r--r--src/cuirass/base.scm214
-rw-r--r--src/cuirass/database.scm115
-rw-r--r--src/cuirass/utils.scm1
-rw-r--r--src/schema.sql28
-rw-r--r--src/sql/upgrade-1.sql78
-rw-r--r--tests/database.scm39
-rw-r--r--tests/http.scm26
18 files changed, 620 insertions, 365 deletions
diff --git a/Makefile.am b/Makefile.am
index d372b9e..4f6c089 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -3,6 +3,7 @@
# Copyright © 1995-2016 Free Software Foundation, Inc.
# Copyright © 2016, 2017 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.
#
@@ -32,6 +33,7 @@ pkgmoduledir = $(guilesitedir)/$(PACKAGE)
pkgobjectdir = $(guileobjectdir)/$(PACKAGE)
webmoduledir = $(guilesitedir)/web/server
webobjectdir = $(guileobjectdir)/web/server
+sqldir = $(pkgdatadir)/sql
dist_pkgmodule_DATA = \
src/cuirass/base.scm \
@@ -56,6 +58,9 @@ nodist_webobject_DATA = \
dist_pkgdata_DATA = src/schema.sql
+dist_sql_DATA = \
+ src/sql/upgrade-1.sql
+
TEST_EXTENSIONS = .scm .sh
AM_TESTS_ENVIRONMENT = \
env GUILE_AUTO_COMPILE='0' \
diff --git a/bin/cuirass.in b/bin/cuirass.in
index b7c9144..11eb975 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -9,6 +9,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
;;; 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.
;;;
@@ -42,7 +43,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
--one-shot Evaluate and build jobs only once
--cache-directory=DIR Use DIR for storing repository data
--fallback Fall back to building when the substituter fails.
- -L --load-path=DIR Prepend DIR to Guix package module search path.
-S --specifications=SPECFILE
Add specifications from SPECFILE to database.
-D --database=DB Use DB to store build results.
@@ -59,7 +59,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(define %options
'((one-shot (value #f))
(cache-directory (value #t))
- (load-path (single-char #\L) (value #t))
(specifications (single-char #\S) (value #t))
(database (single-char #\D) (value #t))
(port (single-char #\p) (value #t))
@@ -88,8 +87,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(%package-database (option-ref opts 'database (%package-database)))
(%package-cachedir
(option-ref opts 'cache-directory (%package-cachedir)))
- (%guix-package-path
- (option-ref opts 'load-path (%guix-package-path)))
(%use-substitutes? (option-ref opts 'use-substitutes #f))
(%fallback? (option-ref opts 'fallback #f)))
(cond
diff --git a/bin/evaluate.in b/bin/evaluate.in
index 86d0e83..3f08b92 100644
--- a/bin/evaluate.in
+++ b/bin/evaluate.in
@@ -27,32 +27,96 @@ 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 (input-checkout checkouts input-name)
+ "Find in CHECKOUTS the CHECKOUT corresponding to INPUT-NAME, and return it."
+ (find (lambda (checkout)
+ (string=? (assq-ref checkout #:name)
+ input-name))
+ checkouts))
+
+(define (spec-source spec checkouts)
+ "Find in CHECKOUTS the directory where the #:PROC-INPUT repository of SPEC
+has been checked out, and return it."
+ (let* ((input-name (assq-ref spec #:proc-input))
+ (checkout (input-checkout checkouts input-name)))
+ (assq-ref checkout #:directory)))
+
+(define (spec-load-path spec checkouts)
+ "Find in CHECKOUTS the load paths of each SPEC's #:LOAD-PATH-INPUTS and
+return them as a list."
+ (map (lambda (input-name)
+ (let* ((checkout (input-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 (spec-package-path spec checkouts)
+ "Find in CHECKOUTS the package paths of each SPEC's #:PACKAGE-PATH-INPUTS
+and return them as a colon separated string."
+ (let* ((input-names (assq-ref spec #:package-path-inputs))
+ (checkouts (map (cut input-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* (main #:optional (args (command-line)))
(match args
- ((command load-path guix-package-path source specstr)
+ ((command spec-str checkouts-str)
;; Load 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 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 spec-str read))
+ (checkouts (with-input-from-string checkouts-str read))
+ (source (spec-source spec checkouts))
+ (file (assq-ref spec #:proc-file))
+ (stdout (current-output-port))
+ (stderr (current-error-port)))
+ (setenv "GUIX_PACKAGE_PATH" (spec-package-path spec checkouts))
;; Since we have relative file name canonicalization by default, better
;; change to SOURCE to make sure things like 'include' with relative
@@ -60,13 +124,13 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(chdir 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.
- (set! %load-path (append load-path %load-path))
+ ;; both when we load FILE and when we later call the thunks.
+ (set! %load-path (append (spec-load-path spec checkouts) %load-path))
(save-module-excursion
(lambda ()
(set-current-module %user-module)
- (primitive-load (assq-ref spec #:file))))
+ (primitive-load file)))
;; From there on we can access Guix modules.
@@ -93,22 +157,12 @@ 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))))
+ (let* ((proc (module-ref %user-module (assq-ref spec #:proc)))
+ (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 4dbb723..6cf82ba 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 @dfn{inputs}) for changes, and evaluating a
+derivation when an 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-file . "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 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,69 @@ 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}, and
+@code{Inputs}, @code{Stamps}, @code{Evaluations}, @code{Derivations} and
@code{Builds}. 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_file}.
-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_file}.
-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_file
+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_file} 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 +322,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 +337,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 +359,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..963c7ff 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-file . "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))))))
;;;
diff --git a/examples/hello-git.scm b/examples/hello-git.scm
index f6df99c..6468452 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-file . "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..a39191f 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-file . "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..8c0d990 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-file . "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..37b97a2 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-file . "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 9985fd6..82f49a4 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -38,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)
@@ -47,7 +49,8 @@
#:use-module (rnrs bytevectors)
#:export (;; Procedures.
call-with-time-display
- fetch-repository
+ fetch-input
+ fetch-inputs
compile
evaluate
clear-build-queue
@@ -56,9 +59,7 @@
build-packages
prepare-git
process-specs
- set-guix-package-path!
;; Parameters.
- %guix-package-path
%package-cachedir
%use-substitutes?
%fallback?))
@@ -139,10 +140,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."
@@ -153,15 +155,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)
@@ -171,12 +173,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
@@ -242,9 +248,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))))
@@ -253,26 +259,10 @@ 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
@@ -284,11 +274,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)))
@@ -610,70 +601,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)
+ "Fetch all inputs of SPEC in parallel."
+ (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 checkouts)
+ "Compile CHECKOUTS in parallel."
+ (let* ((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)
-
- (when compile?
- (non-blocking (compile checkout)))
-
- (spawn-fiber
- (lambda ()
- (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)
+ (compile-checkouts spec (filter compile? checkouts))
+ (spawn-fiber
+ (lambda ()
+ (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))
-
-
-;;;
-;;; Guix package path.
-;;;
-
-(define %guix-package-path
- ;; Extension of package modules search path.
- (make-parameter ""))
-
-(define (set-guix-package-path! path)
- "Use PATH to find custom packages not defined in (gnu packages ...)
-namespace or not already present in current Guile load paths. PATH is
-expected to be a colon-separated string of directories."
- (define (set-paths! dir)
- (%package-module-path (cons dir (%package-module-path)))
- (%patch-path (cons dir (%patch-path)))
- (set! %load-path (cons dir %load-path))
- (set! %load-compiled-path (cons dir %load-compiled-path)))
-
- (let ((dirs (parse-path path)))
- (for-each set-paths! dirs)))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 3627d2e..72acb15 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -227,47 +227,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_file, 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-file) ", "
(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-file 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-file . ,proc-file)
(#: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)
@@ -298,9 +327,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 ...)
@@ -517,14 +546,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)) \
@@ -570,28 +599,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 65aebbd..eb0f7e9 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -1,30 +1,40 @@
BEGIN TRANSACTION;
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_file TEXT NOT NULL, -- file containing the procedure that does the evaluation, relative to proc_input
+ proc TEXT NOT NULL, -- defined in proc_file
+ 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 (
@@ -63,7 +73,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-1.sql b/src/sql/upgrade-1.sql
new file mode 100644
index 0000000..7874f94
--- /dev/null
+++ b/src/sql/upgrade-1.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_file TEXT NOT NULL, -- file containing the procedure that does the evaluation, relative to proc_input
+ proc TEXT NOT NULL, -- defined in proc_file
+ 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_file, 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_file,
+ 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..6ca9d1c 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-file . "/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..e05fdc5 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-file . "/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)
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-26 13:10:19 +0000