branch: master
commit 8d40c49170971ad7bbf8b97336934dbb3d949fc1
Author: Clément Lassieur <clem...@lassieur.org>
Date: Sat Aug 11 20:30:11 2018 +0200
database: Add a Checkouts table.
It is used to know when a new evaluation must be triggered and to display
input changes.
* Makefile.am (dist_sql_DATA): Add 'src/sql/upgrade-3.sql'.
* bin/cuirass.in (main): Call DB-SET-EVALUATION-DONE at startup to clear
'in-progress' evaluations.
* bin/evaluate.in (input-checkout, format-checkouts): Rename '#:name' to
'#:input'.
* doc/cuirass.texi (Stamps): Remove section.
(Checkouts): New section.
* src/cuirass/base.scm (fetch-input, fetch-inputs, compile-checkouts):
Rename
'#:name' to '#:input'.
(evaluate): Remove the COMMITS argument. Add an EVAL-ID argument. Don't
call
DB-ADD-EVALUATION because it was called sooner. Remove the EVAL-ID argument
to AUGMENT-JOB because it's a closure.
(build-packages): Add an EVAL-ID argument. Call DB-SET-EVALUATION-DONE once
all the derivations are registered.
(process-specs): Replace the stamping mechanism by the primary key
constraint
of the Checkouts table: call "evaluate" only when DB-ADD-EVALUATION is true,
which means that at least one checkout was added. Change the EVALUATE and
BUILD-PACKAGES arguments accordingly.
* src/cuirass/database.scm (db-add-stamp, db-get-stamp): Remove procedures.
(db-set-evaluations-done, db-set-evaluation-done): New exported procedure.
(db-add-checkout): New procedure that returns #f if a checkout with the same
revision already exists.
(db-add-evaluation): Replace the EVAL argument with a SPEC-NAME and a
CHECKOUTS arguments. Insert the evaluation only if at least one checkout
was
inserted. Return #f otherwise.
(db-get-checkouts): New procedure.
(db-get-evaluations, db-get-evaluations-build-summary): Handle the
'in_progress' column, remove the 'commits' column. Return the result of
DB-GET-CHECKOUTS as part of the evaluation.
* src/cuirass/templates.scm (input-changes, evaluation-badges): New
procedures.
(evaluation-info-table): Rename "Commits" to "Input changes". Use
INPUT-CHANGES to display the input changes that triggered the evaluation.
Use
EVALUATION-BADGES to display a message indicating that the evaluation is in
progress.
* src/schema.sql (Stamps): Remove table.
(Checkouts): New table.
(Evaluations): Remove the 'commits' column. Add an 'in_progress' column.
* src/sql/upgrade-3.sql: New file with SQL queries to upgrade the database.
* tests/database.scm (make-dummy-eval): Remove procedure.
(make-dummy-checkouts): New procedure.
("sqlite-exec"): Remove the 'commits' column. Add the 'in_progress' column.
("db-update-build-status!", "db-get-builds", "db-get-pending-derivations"):
Update the arguments of DB-ADD-EVALUATION accordingly.
* tests/http.scm (hash-table=?): Add support for lists of hash tables.
(evaluations-query-result): Replace '#:commits' with '#:checkouts'. Return
a
list instead of returning one element, for symmetry.
("fill-db"): Add a new input so that the second checkout can refer to it.
Replace EVALUATION1 and EVALUATION2 with CHECKOUTS1 and CHECKOUTS2. Update
the arguments of DB-ADD-EVALUATION accordingly.
("/api/queue?nr=100"): Take the CAR of the EVALUATIONS-QUERY-RESULT list to
make it symmetrical with the other argument of HASH-TABLE=?.
---
Makefile.am | 3 +-
bin/cuirass.in | 6 +++
bin/evaluate.in | 4 +-
doc/cuirass.texi | 33 +++++++++++----
src/cuirass/base.scm | 49 ++++++++++------------
src/cuirass/database.scm | 105 ++++++++++++++++++++++++++++++++--------------
src/cuirass/templates.scm | 35 +++++++++++-----
src/schema.sql | 16 ++++---
src/sql/upgrade-3.sql | 46 ++++++++++++++++++++
tests/database.scm | 31 ++++++++------
tests/http.scm | 55 ++++++++++++++++--------
11 files changed, 266 insertions(+), 117 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index db56165..2f83659 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -66,7 +66,8 @@ dist_pkgdata_DATA = src/schema.sql
dist_sql_DATA = \
src/sql/upgrade-1.sql \
- src/sql/upgrade-2.sql
+ src/sql/upgrade-2.sql \
+ src/sql/upgrade-3.sql
dist_css_DATA = \
src/static/css/bootstrap.css \
diff --git a/bin/cuirass.in b/bin/cuirass.in
index d30f788..a7af5b2 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -129,6 +129,12 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(clear-build-queue)
+ ;; If Cuirass was stopped during an evaluation, consider
+ ;; it done. Builds that were not registered during this
+ ;; evaluation will be registered during the next
+ ;; evaluation.
+ (db-set-evaluations-done)
+
;; First off, restart builds that had not completed or
;; were not even started on a previous run.
(spawn-fiber
diff --git a/bin/evaluate.in b/bin/evaluate.in
index 3f08b92..19d0f12 100644
--- a/bin/evaluate.in
+++ b/bin/evaluate.in
@@ -44,7 +44,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(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)
+ (string=? (assq-ref checkout #:input)
input-name))
checkouts))
@@ -91,7 +91,7 @@ entries are added because they could be useful during the
evaluation."
(match in
(()
(cons name out))
- (((#:name . val) . rest)
+ (((#:input . val) . rest)
(loop rest out (string->symbol val)))
(((#:directory . val) . rest)
(loop rest (cons `(file-name . ,val) out) name))
diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index b51cfad..08ca832 100644
--- a/doc/cuirass.texi
+++ b/doc/cuirass.texi
@@ -249,7 +249,7 @@ 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{Inputs}, @code{Stamps}, @code{Evaluations}, @code{Builds} and
+@code{Inputs}, @code{Checkouts}, @code{Evaluations}, @code{Builds} and
@code{Outputs}. The purpose of each of these tables is explained below.
@section Specifications
@@ -334,16 +334,33 @@ When this integer field holds the value @code{1} Cuirass
will skip
compilation for the specified repository.
@end table
-@section Stamps
-@cindex stamps, database
+@section Checkouts
+@cindex checkouts, database
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.
+certain revision as specified. The download is called a checkout. The
+@code{Checkouts} table stores the new checkouts 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{name},
-and @code{stamp}, which holds the revisions (space separated commit hashes).
+The @code{Checkouts} table has the following columns:
+
+@table @code
+@item specification
+The specification associated with the checkout.
+
+@item revision
+The revision of the checkout. Within the same specification, two checkouts
+can't be identical: they can't have the same revision.
+
+@item evaluation
+The evaluation that was triggered by the addition of that new checkout.
+
+@item input
+The input associated with the checkout.
+
+@item directory
+The directory into which the checkout was extracted.
+@end table
@section Evaluations
@cindex evaluations, database
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 1ec122c..deee05b 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -178,7 +178,7 @@ read-only directory."
(string-append
(%package-cachedir) "/" name))
directory)))
- `((#:name . ,name)
+ `((#:input . ,name)
(#:directory . ,directory)
(#:commit . ,commit)
(#:load-path . ,(assq-ref input #:load-path))
@@ -248,10 +248,10 @@ fibers."
(logior (@ (fibers epoll) EPOLLERR)
(@ (fibers epoll) EPOLLHUP)))))
-(define (evaluate store spec checkouts commits)
+(define (evaluate store spec eval-id checkouts)
"Evaluate and build package derivations defined in SPEC, using CHECKOUTS.
-Return a list of jobs."
- (define (augment-job job eval-id)
+Return a list of jobs that are associated to EVAL-ID."
+ (define (augment-job job)
(let ((drv (read-derivation-from-file
(assq-ref job #:derivation))))
`((#:eval-id . ,eval-id)
@@ -275,14 +275,9 @@ Return a list of jobs."
(close-pipe port)
(match result
(('evaluation jobs)
- (let* ((spec-name (assq-ref spec #:name))
- (eval-id (db-add-evaluation
- `((#:specification . ,spec-name)
- (#:commits . ,commits)))))
- (log-message "created evaluation ~a for '~a'" eval-id spec-name)
- (map (lambda (job)
- (augment-job job eval-id))
- jobs))))))
+ (let* ((spec-name (assq-ref spec #:name)))
+ (log-message "evaluation ~a for '~a' completed" eval-id spec-name)
+ (map augment-job jobs))))))
;;;
@@ -539,7 +534,7 @@ started)."
(spawn-builds store valid)
(log-message "done with restarted builds"))))
-(define (build-packages store jobs)
+(define (build-packages store jobs eval-id)
"Build JOBS and return a list of Build results."
(define (register job)
(let* ((name (assq-ref job #:job-name))
@@ -576,6 +571,10 @@ started)."
(define derivations
(filter-map register jobs))
+ (log-message "evaluation ~a registered ~a new derivations"
+ eval-id (length derivations))
+ (db-set-evaluation-done eval-id)
+
(spawn-builds store derivations)
(let* ((results (filter-map (cut db-get-build <>) derivations))
@@ -625,7 +624,7 @@ started)."
(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 checkout #:input)
(assq-ref spec #:name)
(assq-ref checkout #:commit))
checkout)
@@ -638,7 +637,7 @@ started)."
(lambda (checkout)
(lambda ()
(log-message "compiling input '~a' of spec '~a' (commit ~s)"
- (assq-ref checkout #:name)
+ (assq-ref checkout #:input)
(assq-ref spec #:name)
(assq-ref checkout #:commit))
(compile checkout)))
@@ -646,7 +645,7 @@ started)."
(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 checkout #:input)
(assq-ref spec #:name)
(assq-ref checkout #:commit))
checkout)
@@ -656,15 +655,10 @@ started)."
"Evaluate and build JOBSPECS and store results in the database."
(define (process spec)
(with-store store
- (let* ((stamp (db-get-stamp spec))
- (name (assoc-ref spec #:name))
+ (let* ((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 spec commits-str)
+ (eval-id (db-add-evaluation name checkouts)))
+ (when eval-id
(compile-checkouts spec (filter compile? checkouts))
(spawn-fiber
(lambda ()
@@ -672,13 +666,12 @@ started)."
(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)
+ (log-message "evaluating spec '~a'" name)
(with-store store
- (let ((jobs (evaluate store spec checkouts commits)))
+ (let ((jobs (evaluate store spec eval-id checkouts)))
(log-message "building ~a jobs for '~a'"
(length jobs) name)
- (build-packages store jobs))))))
+ (build-packages store jobs eval-id))))))
;; 'spawn-fiber' returns zero values but we need one.
*unspecified*))))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 912039e..6777d28 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -38,9 +38,9 @@
db-close
db-add-specification
db-get-specifications
- db-add-stamp
- db-get-stamp
db-add-evaluation
+ db-set-evaluations-done
+ db-set-evaluation-done
db-get-pending-derivations
build-status
db-add-build
@@ -265,6 +265,29 @@ tag, revision, no_compile_p) VALUES ("
(if (assq-ref input #:no-compile?) 1 0) ");")
(last-insert-rowid db)))
+(define (db-add-checkout spec-name eval-id checkout)
+ "Insert CHECKOUT associated with SPEC-NAME and EVAL-ID. If a checkout with
+the same revision already exists for SPEC-NAME, return #f."
+ (with-db-critical-section db
+ (catch 'sqlite-error
+ (lambda ()
+ (sqlite-exec db "\
+INSERT INTO Checkouts (specification, revision, evaluation, input,
+directory) VALUES ("
+ spec-name ", "
+ (assq-ref checkout #:commit) ", "
+ eval-id ", "
+ (assq-ref checkout #:input) ", "
+ (assq-ref checkout #:directory) ");")
+ (last-insert-rowid db))
+ (lambda (key who code message . rest)
+ ;; If we get a unique-constraint-failed error, that means we have
+ ;; already inserted the same checkout. That happens for each input
+ ;; that doesn't change between two evaluations.
+ (if (= code SQLITE_CONSTRAINT_PRIMARYKEY)
+ #f
+ (apply throw key who code rest))))))
+
(define (db-add-specification spec)
"Store SPEC in database the database. SPEC inputs are stored in the INPUTS
table."
@@ -328,13 +351,31 @@ package_path_inputs, proc_input, proc_file, proc,
proc_args) \
(#:inputs . ,(db-get-inputs name)))
specs)))))))
-(define (db-add-evaluation eval)
+(define (db-add-evaluation spec-name checkouts)
+ "Add a new evaluation for SPEC-NAME only if one of the CHECKOUTS is new.
+Otherwise, return #f."
(with-db-critical-section db
- (sqlite-exec db "\
-INSERT INTO Evaluations (specification, commits) VALUES ("
- (assq-ref eval #:specification) ", "
- (string-join (assq-ref eval #:commits)) ");")
- (last-insert-rowid db)))
+ (sqlite-exec db "BEGIN TRANSACTION;")
+ (sqlite-exec db "INSERT INTO Evaluations (specification, in_progress)
+VALUES (" spec-name ", true);")
+ (let* ((eval-id (last-insert-rowid db))
+ (new-checkouts (filter-map
+ (cut db-add-checkout spec-name eval-id <>)
+ checkouts)))
+ (if (null? new-checkouts)
+ (begin (sqlite-exec db "ROLLBACK;")
+ #f)
+ (begin (sqlite-exec db "COMMIT;")
+ eval-id)))))
+
+(define (db-set-evaluations-done)
+ (with-db-critical-section db
+ (sqlite-exec db "UPDATE Evaluations SET in_progress = false;")))
+
+(define (db-set-evaluation-done eval-id)
+ (with-db-critical-section db
+ (sqlite-exec db "UPDATE Evaluations SET in_progress = false
+WHERE id = " eval-id ";")))
(define-syntax-rule (with-database body ...)
"Run BODY with %DB-CHANNEL being dynamically bound to a channel implementing
@@ -568,46 +609,44 @@ the database. The returned list is guaranteed to not
have any duplicates."
(sqlite-exec db "
SELECT derivation FROM Builds WHERE Builds.status < 0;"))))
-(define (db-get-stamp spec)
- "Return a stamp corresponding to specification SPEC in the database."
- (with-db-critical-section db
- (let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification="
- (assq-ref spec #:name) ";")))
- (match res
- (() #f)
- ((#(spec stamp)) stamp)))))
-
-(define (db-add-stamp spec stamp)
- "Associate STAMP to specification SPEC in the database."
+(define (db-get-checkouts eval-id)
(with-db-critical-section db
- (if (db-get-stamp 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) ", " stamp ");"))))
+ (let loop ((rows (sqlite-exec
+ db "SELECT revision, input, directory FROM Checkouts
+WHERE evaluation =" eval-id ";"))
+ (checkouts '()))
+ (match rows
+ (() checkouts)
+ ((#(revision input directory)
+ . rest)
+ (loop rest
+ (cons `((#:commit . ,revision)
+ (#:input . ,input)
+ (#:directory . ,directory))
+ checkouts)))))))
(define (db-get-evaluations limit)
(with-db-critical-section db
- (let loop ((rows (sqlite-exec db "SELECT id, specification, commits
+ (let loop ((rows (sqlite-exec db "SELECT id, specification, in_progress
FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
(evaluations '()))
(match rows
(() (reverse evaluations))
- ((#(id specification commits)
+ ((#(id specification in-progress)
. rest)
(loop rest
(cons `((#:id . ,id)
(#:specification . ,specification)
- (#:commits . ,(string-tokenize commits)))
+ (#:in-progress . ,in-progress)
+ (#:checkouts . ,(db-get-checkouts id)))
evaluations)))))))
(define (db-get-evaluations-build-summary spec limit border-low border-high)
(with-db-critical-section db
(let loop ((rows (sqlite-exec db "
-SELECT E.id, E.commits, B.succeeded, B.failed, B.scheduled
+SELECT E.id, E.in_progress, B.succeeded, B.failed, B.scheduled
FROM
-(SELECT id, commits
+(SELECT id, in_progress
FROM Evaluations
WHERE (specification=" spec ")
AND (" border-low "IS NULL OR (id >" border-low "))
@@ -624,10 +663,12 @@ ORDER BY E.id ASC;"))
(evaluations '()))
(match rows
(() evaluations)
- ((#(id commits succeeded failed scheduled) . rest)
+ ((#(id in-progress succeeded failed scheduled) . rest)
(loop rest
(cons `((#:id . ,id)
- (#:commits . ,commits)
+ (#:in-progress . ,in-progress)
+ (#:checkouts . ,(db-get-checkouts id))
+ (#:in-progress . ,in-progress)
(#:succeeded . ,(or succeeded 0))
(#:failed . ,(or failed 0))
(#:scheduled . ,(or scheduled 0)))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 6ba3a06..7ee579c 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -100,6 +100,27 @@
(href ,last-link))
"Last >>"))))))
+(define (input-changes checkouts)
+ (let ((changes
+ (string-join
+ (map (lambda (checkout)
+ (let ((input (assq-ref checkout #:input))
+ (commit (assq-ref checkout #:commit)))
+ (format #f "~a → ~a" input (substring commit 0 7))))
+ checkouts)
+ ", ")))
+ (if (string=? changes "") '(em "None") changes)))
+
+(define (evaluation-badges evaluation)
+ (if (zero? (assq-ref evaluation #:in-progress))
+ `((a (@ (href "#") (class "badge badge-success"))
+ ,(assq-ref evaluation #:succeeded))
+ (a (@ (href "#") (class "badge badge-danger"))
+ ,(assq-ref evaluation #:failed))
+ (a (@ (href "#") (class "badge badge-secondary"))
+ ,(assq-ref evaluation #:scheduled)))
+ '((em "In progress…"))))
+
(define (evaluation-info-table name evaluations id-min id-max)
"Return HTML for the EVALUATION table NAME. ID-MIN and ID-MAX are
global minimal and maximal id."
@@ -111,7 +132,7 @@
`((thead
(tr
(th (@ (scope "col")) "#")
- (th (@ (scope "col")) Commits)
+ (th (@ (scope "col")) "Input changes")
(th (@ (scope "col")) Success)))
(tbody
,@(map
@@ -119,16 +140,8 @@
`(tr (th (@ (scope "row"))
(a (@ (href "/eval/" ,(assq-ref row #:id)))
,(assq-ref row #:id)))
- (td ,(string-join
- (map (cut substring <> 0 7)
- (string-tokenize (assq-ref row #:commits)))
- ", "))
- (td (a (@ (href "#") (class "badge badge-success"))
- ,(assq-ref row #:succeeded))
- (a (@ (href "#") (class "badge badge-danger"))
- ,(assq-ref row #:failed))
- (a (@ (href "#") (class "badge badge-secondary"))
- ,(assq-ref row #:scheduled)))))
+ (td ,(input-changes (assq-ref row #:checkouts)))
+ (td ,@(evaluation-badges row))))
evaluations)))))
,(if (null? evaluations)
(pagination "" "" "" "")
diff --git a/src/schema.sql b/src/schema.sql
index 0452495..bfc9ca7 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -24,16 +24,22 @@ CREATE TABLE Inputs (
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 Checkouts (
+ specification TEXT NOT NULL,
+ revision TEXT NOT NULL,
+ evaluation INTEGER NOT NULL,
+ input TEXT NOT NULL,
+ directory TEXT NOT NULL,
+ PRIMARY KEY (specification, revision),
+ FOREIGN KEY (evaluation) REFERENCES Evaluations (id),
+ FOREIGN KEY (specification) REFERENCES Specifications (name),
+ FOREIGN KEY (input) REFERENCES Inputs (name)
);
CREATE TABLE Evaluations (
id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
specification TEXT NOT NULL,
- commits TEXT NOT NULL,
+ in_progress INTEGER NOT NULL,
FOREIGN KEY (specification) REFERENCES Specifications (name)
);
diff --git a/src/sql/upgrade-3.sql b/src/sql/upgrade-3.sql
new file mode 100644
index 0000000..8e4a1bd
--- /dev/null
+++ b/src/sql/upgrade-3.sql
@@ -0,0 +1,46 @@
+BEGIN TRANSACTION;
+
+ALTER TABLE Evaluations RENAME TO tmp_Evaluations;
+
+CREATE TABLE Evaluations (
+ id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
+ specification TEXT NOT NULL,
+ in_progress INTEGER NOT NULL,
+ FOREIGN KEY (specification) REFERENCES Specifications (name)
+);
+
+CREATE TABLE Checkouts (
+ specification TEXT NOT NULL,
+ revision TEXT NOT NULL,
+ evaluation INTEGER NOT NULL,
+ input TEXT NOT NULL,
+ directory TEXT NOT NULL,
+ PRIMARY KEY (specification, revision),
+ FOREIGN KEY (evaluation) REFERENCES Evaluations (id),
+ FOREIGN KEY (specification) REFERENCES Specifications (name),
+ FOREIGN KEY (input) REFERENCES Inputs (name)
+);
+
+INSERT INTO Evaluations (id, specification, in_progress)
+SELECT id, specification, false
+FROM tmp_Evaluations;
+
+-- Copied from https://www.samuelbosch.com/2018/02/split-into-rows-sqlite.html.
+INSERT OR IGNORE INTO Checkouts (specification, revision, evaluation, input,
directory)
+WITH RECURSIVE split(id, specification, revision, rest) AS (
+ SELECT id, specification, '', commits || ' ' FROM tmp_Evaluations
+ UNION ALL
+ SELECT id,
+ specification,
+ substr(rest, 0, instr(rest, ' ')),
+ substr(rest, instr(rest, ' ') + 1)
+ FROM split
+ WHERE rest <> '')
+SELECT specification, revision, id, 'unknown', 'unknown'
+ FROM split
+ WHERE revision <> '';
+
+DROP TABLE tmp_Evaluations;
+DROP TABLE Stamps;
+
+COMMIT;
diff --git a/tests/database.scm b/tests/database.scm
index cdc7872..21a12f4 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -47,9 +47,13 @@
(#:commit . #f)
(#:no-compile? . #f))))))
-(define* (make-dummy-eval #:optional (commits '("cabba3e 61730ea")))
- `((#:specification . "guix")
- (#:commits . ,commits)))
+(define (make-dummy-checkouts fakesha1 fakesha2)
+ `(((#:commit . ,fakesha1)
+ (#:input . "guix")
+ (#:directory . "foo"))
+ ((#:commit . ,fakesha2)
+ (#:input . "packages")
+ (#:directory . "bar"))))
(define* (make-dummy-build drv
#:optional (eval-id 42)
@@ -88,11 +92,11 @@
(test-assert "sqlite-exec"
(begin
(sqlite-exec (%db) "\
-INSERT INTO Evaluations (specification, commits) VALUES (1, 1);")
+INSERT INTO Evaluations (specification, in_progress) VALUES (1, false);")
(sqlite-exec (%db) "\
-INSERT INTO Evaluations (specification, commits) VALUES (2, 2);")
+INSERT INTO Evaluations (specification, in_progress) VALUES (2, false);")
(sqlite-exec (%db) "\
-INSERT INTO Evaluations (specification, commits) VALUES (3, 3);")
+INSERT INTO Evaluations (specification, in_progress) VALUES (3, false);")
(sqlite-exec (%db) "SELECT * FROM Evaluations;")))
(test-equal "db-add-specification"
@@ -121,7 +125,8 @@ INSERT INTO Evaluations (specification, commits) VALUES (3,
3);")
#:outputs '(("out" . "/foo")))))
(get-status (lambda* (#:optional (key #:status))
(assq-ref (db-get-build derivation) key))))
- (db-add-evaluation (make-dummy-eval))
+ (db-add-evaluation "guix" (make-dummy-checkouts "fakesha1"
+ "fakesha2"))
(db-add-specification example-spec)
(let ((status0 (get-status)))
@@ -157,9 +162,9 @@ INSERT INTO Evaluations (specification, commits) VALUES (3,
3);")
#:outputs `(("out" . "/bar"))))
(db-add-build (make-dummy-build "/baz.drv" 3
#:outputs `(("out" . "/baz"))))
- (db-add-evaluation (make-dummy-eval))
- (db-add-evaluation (make-dummy-eval))
- (db-add-evaluation (make-dummy-eval))
+ (db-add-evaluation "guix" (make-dummy-checkouts "fakesha1" "fakesha2"))
+ (db-add-evaluation "guix" (make-dummy-checkouts "fakesha1" "fakesha3"))
+ (db-add-evaluation "guix" (make-dummy-checkouts "fakssha2" "fakesha3"))
(db-add-specification example-spec)
(db-update-build-status! "/bar.drv" (build-status started)
@@ -188,9 +193,9 @@ INSERT INTO Evaluations (specification, commits) VALUES (3,
3);")
#:outputs `(("out" . "/bar"))))
(db-add-build (make-dummy-build "/foo.drv" 3
#:outputs `(("out" . "/foo"))))
- (db-add-evaluation (make-dummy-eval))
- (db-add-evaluation (make-dummy-eval))
- (db-add-evaluation (make-dummy-eval))
+ (db-add-evaluation "guix" (make-dummy-checkouts "fakesha1" "fakesha2"))
+ (db-add-evaluation "guix" (make-dummy-checkouts "fakesha1" "fakesha3"))
+ (db-add-evaluation "guix" (make-dummy-checkouts "fakssha2" "fakesha3"))
(db-add-specification example-spec)
(sort (db-get-pending-derivations) string<?)))
diff --git a/tests/http.scm b/tests/http.scm
index 38e4175..ae56356 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -44,9 +44,12 @@
(hash-table-keys t2))
(hash-fold (lambda (key value result)
(and result
- (let ((equal? (if (hash-table? value)
- hash-table=?
- equal?)))
+ (let ((equal?
+ (match value
+ ((? hash-table?) hash-table=?)
+ (((? hash-table?) ...)
+ (cut every hash-table=? <> <>))
+ (_ equal?))))
(equal? value
(hash-ref t2 key)))))
#t
@@ -95,9 +98,12 @@
(#:buildinputs_builds . #nil)))
(define evaluations-query-result
- '((#:id . 2)
- (#:specification . "guix")
- (#:commits . ("fakesha2" "fakesha3"))))
+ '(((#:id . 2)
+ (#:specification . "guix")
+ (#:in-progress . 1)
+ (#:checkouts . (((#:commit . "fakesha2")
+ (#:input . "savannah")
+ (#:directory . "dir3")))))))
(test-group-with-cleanup "http"
(test-assert "object->json-string"
@@ -180,18 +186,33 @@
(#:branch . "master")
(#:tag . #f)
(#:commit . #f)
+ (#:no-compile? . #f))
+ ((#:name . "packages")
+ (#:url . "git://git.savannah.gnu.org/guix.git")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:tag . #f)
+ (#:commit . #f)
(#:no-compile? . #f))))))
- (evaluation1
- '((#:specification . "guix")
- (#:commits . ("fakesha1" "fakesha3"))))
- (evaluation2
- '((#:specification . "guix")
- (#:commits . ("fakesha2" "fakesha3")))))
+ (checkouts1
+ '(((#:commit . "fakesha1")
+ (#:input . "savannah")
+ (#:directory . "dir1"))
+ ((#:commit . "fakesha3")
+ (#:input . "packages")
+ (#:directory . "dir2"))))
+ (checkouts2
+ '(((#:commit . "fakesha2")
+ (#:input . "savannah")
+ (#:directory . "dir3"))
+ ((#:commit . "fakesha3")
+ (#:input . "packages")
+ (#:directory . "dir4")))))
(db-add-build build1)
(db-add-build build2)
(db-add-specification specification)
- (db-add-evaluation evaluation1)
- (db-add-evaluation evaluation2)))
+ (db-add-evaluation "guix" checkouts1)
+ (db-add-evaluation "guix" checkouts2)))
(test-assert "/build/1"
(hash-table=?
@@ -271,9 +292,9 @@
(and (= (length hash-list) 1)
(hash-table=?
(car hash-list)
- (call-with-input-string
- (object->json-string evaluations-query-result)
- json->scm)))))
+ (car (call-with-input-string
+ (object->json-string evaluations-query-result)
+ json->scm))))))
(test-assert "db-close"
(db-close (%db)))
