guix
/
guix-cuirass
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git
2
0
Fork 0
Code Issues Releases Wiki Activity

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:
Clément Lassieur 2018-08-11 20:30:11 +02:00
parent 4612a3a70f
commit 8d40c49170
No known key found for this signature in database
GPG Key ID: 89F96D4808F359C7
11 changed files with 266 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile.am
View File

@ -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 \

6
bin/cuirass.in
View File

@ -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

4
bin/evaluate.in
View File

@ -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))

33
doc/cuirass.texi
View File

@ -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

49
src/cuirass/base.scm
View File

@ -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*))))

105
src/cuirass/database.scm
View File

@ -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)))

35
src/cuirass/templates.scm
View File

@ -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 "" "" "" "")

16
src/schema.sql
View File

@ -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
View 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;

31
tests/database.scm
View File

@ -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<?)))

55
tests/http.scm
View File

@ -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)))