mirror of
git://git.savannah.gnu.org/guix/guix-cuirass.git
synced 2023-12-14 06:03:04 +01:00
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=?.
This commit is contained in:
parent
4612a3a70f
commit
8d40c49170
11 changed files with 266 additions and 117 deletions
|
@ -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 \
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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*))))
|
||||
|
|
|
@ -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."
|
||||
(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 +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)))
|
||||
|
|
|
@ -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 "" "" "" "")
|
||||
|
|
|
@ -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)
|
||||
);
|
||||
|
||||
|
|
46
src/sql/upgrade-3.sql
Normal file
46
src/sql/upgrade-3.sql
Normal file
|
@ -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;
|
|
@ -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<?)))
|
||||
|
|
|
@ -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)
|
||||
'(((#:id . 2)
|
||||
(#:specification . "guix")
|
||||
(#:commits . ("fakesha2" "fakesha3"))))
|
||||
(#: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
|
||||
(car (call-with-input-string
|
||||
(object->json-string evaluations-query-result)
|
||||
json->scm)))))
|
||||
json->scm))))))
|
||||
|
||||
(test-assert "db-close"
|
||||
(db-close (%db)))
|
||||
|
|
Loading…
Reference in a new issue