* [bug#32424] [PATCH] database: Add a Checkouts table.
@ 2018-08-11 22:26 Clément Lassieur
2018-08-11 22:39 ` Clément Lassieur
2018-08-20 20:53 ` Ludovic Courtès
0 siblings, 2 replies; 4+ messages in thread
From: Clément Lassieur @ 2018-08-11 22:26 UTC (permalink / raw)
To: 32424
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/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-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/evaluate.in | 4 +-
doc/cuirass.texi | 33 ++++++++++---
src/cuirass/base.scm | 49 ++++++++-----------
src/cuirass/database.scm | 100 ++++++++++++++++++++++++++------------
src/cuirass/templates.scm | 35 ++++++++-----
src/schema.sql | 16 ++++--
src/sql/upgrade-3.sql | 46 ++++++++++++++++++
tests/database.scm | 31 +++++++-----
tests/http.scm | 55 ++++++++++++++-------
10 files changed, 255 insertions(+), 117 deletions(-)
create mode 100644 src/sql/upgrade-3.sql
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/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 abbdb7b..52cd595 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))))))
\f
;;;
@@ -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 2cd3c1f..6987bf0 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -38,9 +38,8 @@
db-close
db-add-specification
db-get-specifications
- db-add-stamp
- db-get-stamp
db-add-evaluation
+ db-set-evaluation-done
db-get-pending-derivations
build-status
db-add-build
@@ -265,6 +264,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 +350,27 @@ 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-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 +604,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."
+(define (db-get-checkouts eval-id)
(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."
- (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 +658,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..ebe32ec 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 INTEGER NOT NULL,
+ evaluation TEXT 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..8123190
--- /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 INTEGER NOT NULL,
+ evaluation TEXT 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"
@@ -175,23 +181,38 @@
(#:proc . hydra-jobs)
(#: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 . "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)))
--
2.18.0
^ permalink raw reply related [flat|nested] 4+ messages in thread
* [bug#32424] [PATCH] database: Add a Checkouts table.
2018-08-11 22:26 [bug#32424] [PATCH] database: Add a Checkouts table Clément Lassieur
@ 2018-08-11 22:39 ` Clément Lassieur
2018-08-20 20:53 ` Ludovic Courtès
1 sibling, 0 replies; 4+ messages in thread
From: Clément Lassieur @ 2018-08-11 22:39 UTC (permalink / raw)
To: 32424
Clément Lassieur <clement@lassieur.org> writes:
> Makefile.am | 3 +-
> bin/evaluate.in | 4 +-
> doc/cuirass.texi | 33 ++++++++++---
> src/cuirass/base.scm | 49 ++++++++-----------
> src/cuirass/database.scm | 100 ++++++++++++++++++++++++++------------
> src/cuirass/templates.scm | 35 ++++++++-----
> src/schema.sql | 16 ++++--
> src/sql/upgrade-3.sql | 46 ++++++++++++++++++
> tests/database.scm | 31 +++++++-----
> tests/http.scm | 55 ++++++++++++++-------
> 10 files changed, 255 insertions(+), 117 deletions(-)
> create mode 100644 src/sql/upgrade-3.sql
It would now look like this:
https://upload.lassieur.org/upload/SN75cuH1u2riCZR2/2018-08-11-235825_1279x799_scrot.png
(expires in one week).
The evaluation is now added sooner: when the new checkout is detected.
So an "In progress..." message is displayed until it's completed.
All evaluations that were done before that patch have "unknown" inputs,
because the input name wasn't associated with the commit change.
Clément
^ permalink raw reply [flat|nested] 4+ messages in thread
* [bug#32424] [PATCH] database: Add a Checkouts table.
2018-08-11 22:26 [bug#32424] [PATCH] database: Add a Checkouts table Clément Lassieur
2018-08-11 22:39 ` Clément Lassieur
@ 2018-08-20 20:53 ` Ludovic Courtès
2018-08-27 13:47 ` bug#32424: " Clément Lassieur
1 sibling, 1 reply; 4+ messages in thread
From: Ludovic Courtès @ 2018-08-20 20:53 UTC (permalink / raw)
To: Clément Lassieur; +Cc: 32424
Hello,
Clément Lassieur <clement@lassieur.org> skribis:
> 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/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-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=?.
Woow! I really like the result (nice screenshot ;-)). I took only a
cursory look at the code, but you’re the expert now anyway, so if it
works for you, got for it! The new ‘Checkouts’ table make sense to me.
> + (log-message "Evaluation ~a for '~a' completed" eval-id spec-name)
Nitpick: I prefer not to capitalize log messages because these are not
full sentences. (No big deal though.)
Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 4+ messages in thread
* bug#32424: [PATCH] database: Add a Checkouts table.
2018-08-20 20:53 ` Ludovic Courtès
@ 2018-08-27 13:47 ` Clément Lassieur
0 siblings, 0 replies; 4+ messages in thread
From: Clément Lassieur @ 2018-08-27 13:47 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 32424-done
Ludovic Courtès <ludo@gnu.org> writes:
> Hello,
>
> Clément Lassieur <clement@lassieur.org> skribis:
>
>> 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/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-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=?.
>
> Woow! I really like the result (nice screenshot ;-)). I took only a
> cursory look at the code, but you’re the expert now anyway, so if it
> works for you, got for it! The new ‘Checkouts’ table make sense to me.
>
>> + (log-message "Evaluation ~a for '~a' completed" eval-id spec-name)
>
> Nitpick: I prefer not to capitalize log messages because these are not
> full sentences. (No big deal though.)
>
> Thank you!
>
> Ludo’.
Pushed with that change. Thanks!
^ permalink raw reply [flat|nested] 4+ messages in thread
end of thread, other threads:[~2018-08-27 14:02 UTC | newest]
Thread overview: 4+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2018-08-11 22:26 [bug#32424] [PATCH] database: Add a Checkouts table Clément Lassieur
2018-08-11 22:39 ` Clément Lassieur
2018-08-20 20:53 ` Ludovic Courtès
2018-08-27 13:47 ` bug#32424: " Clément Lassieur
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).