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

database: Serialize all database accesses in a thread. 

Fixes <https://bugs.gnu.org/32234>.

* bin/cuirass.in (main): Keep only one WITH-DATABASE call around all fibers.
Remove all DB arguments.
* src/cuirass/base.scm (evaluate, update-build-statuses!, spawn-builds,
handle-build-event, build-packages): Remove all DB arguments.
(clear-build-queue, cancel-old-builds): Wrap in WITH-DB-CRITICAL-SECTION,
remove all DB arguments.
(restart-builds): Remove the NON-BLOCKING call, remove all DB arguments.
(process-specs): Remove all DB arguments, remove the WITH-DATABASE call.
* src/cuirass/database.scm (%db-channel): New parameter.
(with-db-critical-section): New macro.
(db-add-input, db-add-specification, db-get-inputs, db-get-specifications,
db-add-evaluation, db-add-build, db-update-build-status!, db-get-outputs,
db-get-builds, db-get-build, db-get-pending-derivations, db-get-stamp,
db-add-stamp, db-get-evaluations, db-get-evaluations-build-summary,
db-get-evaluations-id-min, db-get-evaluations-id-max, db-get-builds-min,
db-get-builds-max): Wrap in WITH-DB-CRITICAL-SECTION, remove all DB arguments.
(with-database): Wrap BODY in PARAMETERIZE form that sets %DB-CHANNEL to the
channel returned by MAKE-CRITICAL-SECTION.
* src/cuirass/http.scm (handle-build-request, handle-builds-request): Remove
all DB arguments.
(url-handler): Remove all DB arguments, remove the DB-CHANNEL state, remove
the WITH-CRITICAL-SECTION calls.
(run-cuirass-server): Remove the DB arguments, remove the
MAKE-CRITICAL-SECTION call.
* src/cuirass/utils.scm (make-critical-section): Replace SPAWN-FIBER with
CALL-WITH-NEW-THREAD.  Wrap body in PARAMETERIZE form that clears
CURRENT-FIBER.
* tests/database.scm (with-temporary-database, "db-add-specification",
"db-add-build", "db-update-build-status!", "db-get-builds",
"db-get-pending-derivations"): Remove the DB arguments.
("db-init"): Set the %DB-CHANNEL parameter to the channel returned by
MAKE-CRITICAL-SECTION, and return #t.
("database"): Set %DB-CHANNEL to #f during cleanup.
* tests/http.scm ("db-init"): Set the %DB-CHANNEL parameter to the channel
returned by MAKE-CRITICAL-SECTION, and return #t.
("cuirass-run", "fill-db"): Remove the DB arguments.
("http"): Set %DB-CHANNEL to #f during cleanup.
This commit is contained in:
Clément Lassieur 2018-08-05 13:14:44 +02:00
parent e66e545b69
commit 4612a3a70f
No known key found for this signature in database
GPG Key ID: 89F96D4808F359C7
8 changed files with 475 additions and 441 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.dir-locals.el
View File

@ -12,7 +12,8 @@
(eval put 'call-with-time 'scheme-indent-function 1) (eval put 'call-with-time 'scheme-indent-function 1)
(eval put 'test-error 'scheme-indent-function 1) (eval put 'test-error 'scheme-indent-function 1)
(eval put 'make-parameter 'scheme-indent-function 1) (eval put 'make-parameter 'scheme-indent-function 1)
(eval put 'with-database 'scheme-indent-function 1) (eval put 'with-database 'scheme-indent-function 0)
(eval put 'with-db-critical-section 'scheme-indent-function 1)
(eval . (put 'with-critical-section 'scheme-indent-function 2))) (eval . (put 'with-critical-section 'scheme-indent-function 2)))
(texinfo-mode (texinfo-mode
(indent-tabs-mode) (indent-tabs-mode)

23
bin/cuirass.in
View File

@ -115,19 +115,19 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(log-message "running Fibers on ~a kernel threads" threads) (log-message "running Fibers on ~a kernel threads" threads)
(run-fibers (run-fibers
(lambda () (lambda ()
(with-database db (with-database
(and specfile (and specfile
(let ((new-specs (save-module-excursion (let ((new-specs (save-module-excursion
(lambda () (lambda ()
(set-current-module (make-user-module '())) (set-current-module (make-user-module '()))
(primitive-load specfile))))) (primitive-load specfile)))))
(for-each (lambda (spec) (db-add-specification db spec)) (for-each (lambda (spec) (db-add-specification spec))
new-specs))) new-specs)))
(if one-shot? (if one-shot?
(process-specs db (db-get-specifications db)) (process-specs (db-get-specifications))
(let ((exit-channel (make-channel))) (let ((exit-channel (make-channel)))
(clear-build-queue db) (clear-build-queue)
;; First off, restart builds that had not completed or ;; First off, restart builds that had not completed or
;; were not even started on a previous run. ;; were not even started on a previous run.
@ -135,25 +135,22 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(essential-task (essential-task
'restart-builds exit-channel 'restart-builds exit-channel
(lambda () (lambda ()
(with-database db (restart-builds))))
(restart-builds db)))))
(spawn-fiber (spawn-fiber
(essential-task (essential-task
'build exit-channel 'build exit-channel
(lambda () (lambda ()
(with-database db (while #t
(while #t (process-specs (db-get-specifications))
(process-specs db (db-get-specifications db)) (log-message "next evaluation in ~a seconds" interval)
(log-message "next evaluation in ~a seconds" interval) (sleep interval)))))
(sleep interval))))))
(spawn-fiber (spawn-fiber
(essential-task (essential-task
'web-server exit-channel 'web-server exit-channel
(lambda () (lambda ()
(with-database db (run-cuirass-server #:host host #:port port)))
(run-cuirass-server db #:host host #:port port))))
#:parallel? #t) #:parallel? #t)
(spawn-fiber (spawn-fiber

92
src/cuirass/base.scm
View File

@ -248,7 +248,7 @@ fibers."
(logior (@ (fibers epoll) EPOLLERR) (logior (@ (fibers epoll) EPOLLERR)
(@ (fibers epoll) EPOLLHUP))))) (@ (fibers epoll) EPOLLHUP)))))
(define (evaluate store db spec checkouts commits) (define (evaluate store spec checkouts commits)
"Evaluate and build package derivations defined in SPEC, using CHECKOUTS. "Evaluate and build package derivations defined in SPEC, using CHECKOUTS.
Return a list of jobs." Return a list of jobs."
(define (augment-job job eval-id) (define (augment-job job eval-id)
@ -277,8 +277,8 @@ Return a list of jobs."
(('evaluation jobs) (('evaluation jobs)
(let* ((spec-name (assq-ref spec #:name)) (let* ((spec-name (assq-ref spec #:name))
(eval-id (db-add-evaluation (eval-id (db-add-evaluation
db `((#:specification . ,spec-name) `((#:specification . ,spec-name)
(#:commits . ,commits))))) (#:commits . ,commits)))))
(log-message "created evaluation ~a for '~a'" eval-id spec-name) (log-message "created evaluation ~a for '~a'" eval-id spec-name)
(map (lambda (job) (map (lambda (job)
(augment-job job eval-id)) (augment-job job eval-id))
@ -368,7 +368,7 @@ Essentially this procedure inverts the inversion-of-control that
;; Our shuffling algorithm is simple: we sort by .drv file name. :-) ;; Our shuffling algorithm is simple: we sort by .drv file name. :-)
(sort drv string<?)) (sort drv string<?))
(define (update-build-statuses! store db lst) (define (update-build-statuses! store lst)
"Update the build status of the derivations listed in LST, which have just "Update the build status of the derivations listed in LST, which have just
been passed to 'build-derivations' (meaning that we can assume that, if their been passed to 'build-derivations' (meaning that we can assume that, if their
outputs are invalid, that they failed to build.)" outputs are invalid, that they failed to build.)"
@ -376,8 +376,8 @@ outputs are invalid, that they failed to build.)"
(match (derivation-path->output-paths drv) (match (derivation-path->output-paths drv)
(((_ . outputs) ...) (((_ . outputs) ...)
(if (any (cut valid-path? store <>) outputs) (if (any (cut valid-path? store <>) outputs)
(db-update-build-status! db drv (build-status succeeded)) (db-update-build-status! drv (build-status succeeded))
(db-update-build-status! db drv (build-status failed)))))) (db-update-build-status! drv (build-status failed))))))
(for-each update! lst)) (for-each update! lst))
@ -393,10 +393,11 @@ and returns the values RESULTS."
(print-exception (current-error-port) frame key args) (print-exception (current-error-port) frame key args)
(apply values results))))) (apply values results)))))
(define* (spawn-builds store db drv (define* (spawn-builds store drv
#:key (max-batch-size 200)) #:key (max-batch-size 200))
"Build the derivations listed in DRV, updating DB as builds complete. "Build the derivations listed in DRV, updating the database as builds
Derivations are submitted in batches of at most MAX-BATCH-SIZE items." complete. Derivations are submitted in batches of at most MAX-BATCH-SIZE
items."
;; XXX: We want to pass 'build-derivations' as many derivations at once so ;; XXX: We want to pass 'build-derivations' as many derivations at once so
;; we benefit from as much parallelism as possible (we must be using ;; we benefit from as much parallelism as possible (we must be using
;; #:keep-going? #t). ;; #:keep-going? #t).
@ -444,7 +445,7 @@ Derivations are submitted in batches of at most MAX-BATCH-SIZE items."
;; from PORT and eventually close it. ;; from PORT and eventually close it.
(catch #t (catch #t
(lambda () (lambda ()
(handle-build-event db event)) (handle-build-event event))
(exception-reporter state))) (exception-reporter state)))
#t) #t)
(close-port port) (close-port port)
@ -455,14 +456,14 @@ Derivations are submitted in batches of at most MAX-BATCH-SIZE items."
;; derivations were built "behind our back", in which case ;; derivations were built "behind our back", in which case
;; 'build-derivations' doesn't actually do anything and ;; 'build-derivations' doesn't actually do anything and
;; 'handle-build-event' doesn't see any event. Because of that, ;; 'handle-build-event' doesn't see any event. Because of that,
;; adjust DB here. ;; adjust the database here.
(update-build-statuses! store db batch) (update-build-statuses! store batch)
(loop rest (max (- count max-batch-size) 0)))))) (loop rest (max (- count max-batch-size) 0))))))
(define* (handle-build-event db event) (define* (handle-build-event event)
"Handle EVENT, a build event sexp as produced by 'build-event-output-port', "Handle EVENT, a build event sexp as produced by 'build-event-output-port',
updating DB accordingly." updating the database accordingly."
(define (valid? file) (define (valid? file)
;; FIXME: Sometimes we might get bogus events due to the interleaving of ;; FIXME: Sometimes we might get bogus events due to the interleaving of
;; build messages. This procedure prevents us from propagating the bogus ;; build messages. This procedure prevents us from propagating the bogus
@ -475,7 +476,7 @@ updating DB accordingly."
(if (valid? drv) (if (valid? drv)
(begin (begin
(log-message "build started: '~a'" drv) (log-message "build started: '~a'" drv)
(db-update-build-status! db drv (build-status started))) (db-update-build-status! drv (build-status started)))
(log-message "bogus build-started event for '~a'" drv))) (log-message "bogus build-started event for '~a'" drv)))
(('build-remote drv host _ ...) (('build-remote drv host _ ...)
(log-message "'~a' offloaded to '~a'" drv host)) (log-message "'~a' offloaded to '~a'" drv host))
@ -483,13 +484,13 @@ updating DB accordingly."
(if (valid? drv) (if (valid? drv)
(begin (begin
(log-message "build succeeded: '~a'" drv) (log-message "build succeeded: '~a'" drv)
(db-update-build-status! db drv (build-status succeeded))) (db-update-build-status! drv (build-status succeeded)))
(log-message "bogus build-succeeded event for '~a'" drv))) (log-message "bogus build-succeeded event for '~a'" drv)))
(('build-failed drv _ ...) (('build-failed drv _ ...)
(if (valid? drv) (if (valid? drv)
(begin (begin
(log-message "build failed: '~a'" drv) (log-message "build failed: '~a'" drv)
(db-update-build-status! db drv (build-status failed))) (db-update-build-status! drv (build-status failed)))
(log-message "bogus build-failed event for '~a'" drv))) (log-message "bogus build-failed event for '~a'" drv)))
(('substituter-started item _ ...) (('substituter-started item _ ...)
(log-message "substituter started: '~a'" item)) (log-message "substituter started: '~a'" item))
@ -503,42 +504,42 @@ updating DB accordingly."
(string=? (assq-ref build1 #:derivation) (string=? (assq-ref build1 #:derivation)
(assq-ref build2 #:derivation))) (assq-ref build2 #:derivation)))
(define (clear-build-queue db) (define (clear-build-queue)
"Reset the status of builds in DB that are marked as \"started\". This "Reset the status of builds in the database that are marked as \"started\".
procedure is meant to be called at startup." This procedure is meant to be called at startup."
(log-message "marking stale builds as \"scheduled\"...") (log-message "marking stale builds as \"scheduled\"...")
(sqlite-exec db "UPDATE Builds SET status = -2 WHERE status = -1;")) (with-db-critical-section db
(sqlite-exec db "UPDATE Builds SET status = -2 WHERE status = -1;")))
(define (cancel-old-builds db age) (define (cancel-old-builds age)
"Cancel builds older than AGE seconds." "Cancel builds older than AGE seconds."
(log-message "canceling builds older than ~a seconds..." age) (log-message "canceling builds older than ~a seconds..." age)
(sqlite-exec db (with-db-critical-section db
"UPDATE Builds SET status = 4 WHERE status = -2 AND timestamp < " (sqlite-exec
(- (time-second (current-time time-utc)) age) db "UPDATE Builds SET status = 4 WHERE status = -2 AND timestamp < "
";")) (- (time-second (current-time time-utc)) age) ";")))
(define (restart-builds db) (define (restart-builds)
"Restart builds whose status in DB is \"pending\" (scheduled or started)." "Restart builds whose status in the database is \"pending\" (scheduled or
started)."
(with-store store (with-store store
;; Note: On a big database, 'db-get-pending-derivations' can take a couple
;; of minutes, hence 'non-blocking'.
(log-message "retrieving list of pending builds...") (log-message "retrieving list of pending builds...")
(let*-values (((valid stale) (let*-values (((valid stale)
(partition (cut valid-path? store <>) (partition (cut valid-path? store <>)
(non-blocking (db-get-pending-derivations db))))) (db-get-pending-derivations))))
;; We cannot restart builds listed in STALE, so mark them as canceled. ;; We cannot restart builds listed in STALE, so mark them as canceled.
(log-message "canceling ~a stale builds" (length stale)) (log-message "canceling ~a stale builds" (length stale))
(for-each (lambda (drv) (for-each (lambda (drv)
(db-update-build-status! db drv (build-status canceled))) (db-update-build-status! drv (build-status canceled)))
stale) stale)
;; Those in VALID can be restarted. If some of them were built in the ;; Those in VALID can be restarted. If some of them were built in the
;; meantime behind our back, that's fine: 'spawn-builds' will DTRT. ;; meantime behind our back, that's fine: 'spawn-builds' will DTRT.
(log-message "restarting ~a pending builds" (length valid)) (log-message "restarting ~a pending builds" (length valid))
(spawn-builds store db valid) (spawn-builds store valid)
(log-message "done with restarted builds")))) (log-message "done with restarted builds"))))
(define (build-packages store db jobs) (define (build-packages store jobs)
"Build JOBS and return a list of Build results." "Build JOBS and return a list of Build results."
(define (register job) (define (register job)
(let* ((name (assq-ref job #:job-name)) (let* ((name (assq-ref job #:job-name))
@ -570,14 +571,14 @@ procedure is meant to be called at startup."
(#:timestamp . ,cur-time) (#:timestamp . ,cur-time)
(#:starttime . 0) (#:starttime . 0)
(#:stoptime . 0)))) (#:stoptime . 0))))
(db-add-build db build)))) (db-add-build build))))
(define derivations (define derivations
(filter-map register jobs)) (filter-map register jobs))
(spawn-builds store db derivations) (spawn-builds store derivations)
(let* ((results (filter-map (cut db-get-build db <>) derivations)) (let* ((results (filter-map (cut db-get-build <>) derivations))
(status (map (cut assq-ref <> #:status) results)) (status (map (cut assq-ref <> #:status) results))
(success (count (lambda (status) (success (count (lambda (status)
(= status (build-status succeeded))) (= status (build-status succeeded)))
@ -651,11 +652,11 @@ procedure is meant to be called at startup."
checkout) checkout)
results))) results)))
(define (process-specs db jobspecs) (define (process-specs jobspecs)
"Evaluate and build JOBSPECS and store results in DB." "Evaluate and build JOBSPECS and store results in the database."
(define (process spec) (define (process spec)
(with-store store (with-store store
(let* ((stamp (db-get-stamp db spec)) (let* ((stamp (db-get-stamp spec))
(name (assoc-ref spec #:name)) (name (assoc-ref spec #:name))
(checkouts (fetch-inputs spec)) (checkouts (fetch-inputs spec))
(commits (map (cut assq-ref <> #:commit) checkouts)) (commits (map (cut assq-ref <> #:commit) checkouts))
@ -663,7 +664,7 @@ procedure is meant to be called at startup."
(unless (equal? commits-str stamp) (unless (equal? commits-str stamp)
;; Immediately mark SPEC's INPUTS as being processed so we don't ;; Immediately mark SPEC's INPUTS as being processed so we don't
;; spawn a concurrent evaluation of that same commit. ;; spawn a concurrent evaluation of that same commit.
(db-add-stamp db spec commits-str) (db-add-stamp spec commits-str)
(compile-checkouts spec (filter compile? checkouts)) (compile-checkouts spec (filter compile? checkouts))
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
@ -674,11 +675,10 @@ procedure is meant to be called at startup."
(log-message "evaluating spec '~a': stamp ~s different from ~s" (log-message "evaluating spec '~a': stamp ~s different from ~s"
name commits-str stamp) name commits-str stamp)
(with-store store (with-store store
(with-database db (let ((jobs (evaluate store spec checkouts commits)))
(let ((jobs (evaluate store db spec checkouts commits))) (log-message "building ~a jobs for '~a'"
(log-message "building ~a jobs for '~a'" (length jobs) name)
(length jobs) name) (build-packages store jobs))))))
(build-packages store db jobs)))))))
;; 'spawn-fiber' returns zero values but we need one. ;; 'spawn-fiber' returns zero values but we need one.
*unspecified*)))) *unspecified*))))

519
src/cuirass/database.scm
View File

@ -59,7 +59,9 @@
;; Parameters. ;; Parameters.
%package-database %package-database
%package-schema-file %package-schema-file
%db-channel
;; Macros. ;; Macros.
with-db-critical-section
with-database)) with-database))
(define (%sqlite-exec db sql . args) (define (%sqlite-exec db sql . args)
@ -139,6 +141,16 @@ question marks matches the number of arguments to bind."
(string-append %datadir "/" %package)) (string-append %datadir "/" %package))
"/sql"))) "/sql")))
(define %db-channel
(make-parameter #f))
(define-syntax-rule (with-db-critical-section db exp ...)
"Evaluate EXP... in the critical section corresponding to %DB-CHANNEL.
DB is bound to the argument of that critical section: the database
connection."
(call-with-critical-section (%db-channel)
(lambda (db) exp ...)))
(define (read-sql-file file-name) (define (read-sql-file file-name)
"Return a list of string containing SQL instructions from FILE-NAME." "Return a list of string containing SQL instructions from FILE-NAME."
(call-with-input-file file-name (call-with-input-file file-name
@ -238,92 +250,111 @@ database object."
(vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();")) (vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
0)) 0))
(define (db-add-input db spec-name input) (define (db-add-input spec-name input)
(sqlite-exec db "\ (with-db-critical-section db
(sqlite-exec db "\
INSERT OR IGNORE INTO Inputs (specification, name, url, load_path, branch, \ INSERT OR IGNORE INTO Inputs (specification, name, url, load_path, branch, \
tag, revision, no_compile_p) VALUES (" tag, revision, no_compile_p) VALUES ("
spec-name ", " spec-name ", "
(assq-ref input #:name) ", " (assq-ref input #:name) ", "
(assq-ref input #:url) ", " (assq-ref input #:url) ", "
(assq-ref input #:load-path) ", " (assq-ref input #:load-path) ", "
(assq-ref input #:branch) ", " (assq-ref input #:branch) ", "
(assq-ref input #:tag) ", " (assq-ref input #:tag) ", "
(assq-ref input #:commit) ", " (assq-ref input #:commit) ", "
(if (assq-ref input #:no-compile?) 1 0) ");") (if (assq-ref input #:no-compile?) 1 0) ");")
(last-insert-rowid db)) (last-insert-rowid db)))
(define (db-add-specification db spec) (define (db-add-specification spec)
"Store SPEC in database DB. SPEC inputs are stored in the INPUTS table." "Store SPEC in database the database. SPEC inputs are stored in the INPUTS
(sqlite-exec db "\ table."
(with-db-critical-section db
(sqlite-exec db "\
INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \ INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \
package_path_inputs, proc_input, proc_file, proc, proc_args) \ package_path_inputs, proc_input, proc_file, proc, proc_args) \
VALUES (" VALUES ("
(assq-ref spec #:name) ", " (assq-ref spec #:name) ", "
(assq-ref spec #:load-path-inputs) ", " (assq-ref spec #:load-path-inputs) ", "
(assq-ref spec #:package-path-inputs)", " (assq-ref spec #:package-path-inputs) ", "
(assq-ref spec #:proc-input) ", " (assq-ref spec #:proc-input) ", "
(assq-ref spec #:proc-file) ", " (assq-ref spec #:proc-file) ", "
(symbol->string (assq-ref spec #:proc)) ", " (symbol->string (assq-ref spec #:proc)) ", "
(assq-ref spec #:proc-args) ");") (assq-ref spec #:proc-args) ");")
(let ((spec-id (last-insert-rowid db))) (let ((spec-id (last-insert-rowid db)))
(for-each (lambda (input) (for-each (lambda (input)
(db-add-input db (assq-ref spec #:name) input)) (db-add-input (assq-ref spec #:name) input))
(assq-ref spec #:inputs)) (assq-ref spec #:inputs))
spec-id)) spec-id)))
(define (db-get-inputs db spec-name) (define (db-get-inputs spec-name)
(let loop ((rows (sqlite-exec db "SELECT * FROM Inputs WHERE specification=" (with-db-critical-section db
spec-name ";")) (let loop ((rows (sqlite-exec
(inputs '())) db "SELECT * FROM Inputs WHERE specification="
(match rows spec-name ";"))
(() inputs) (inputs '()))
((#(specification name url load-path branch tag revision no-compile-p) (match rows
. rest) (() inputs)
(loop rest ((#(specification name url load-path branch tag revision no-compile-p)
(cons `((#:name . ,name) . rest)
(#:url . ,url) (loop rest
(#:load-path . ,load-path) (cons `((#:name . ,name)
(#:branch . ,branch) (#:url . ,url)
(#:tag . ,tag) (#:load-path . ,load-path)
(#:commit . ,revision) (#:branch . ,branch)
(#:no-compile? . ,(positive? no-compile-p))) (#:tag . ,tag)
inputs)))))) (#:commit . ,revision)
(#:no-compile? . ,(positive? no-compile-p)))
inputs)))))))
(define (db-get-specifications db) (define (db-get-specifications)
(let loop ((rows (sqlite-exec db "SELECT * FROM Specifications;")) (with-db-critical-section db
(specs '())) (let loop ((rows (sqlite-exec db "SELECT * FROM Specifications;"))
(match rows (specs '()))
(() specs) (match rows
((#(name load-path-inputs package-path-inputs proc-input proc-file proc (() specs)
proc-args) ((#(name load-path-inputs package-path-inputs proc-input proc-file proc
. rest) proc-args)
(loop rest . rest)
(cons `((#:name . ,name) (loop rest
(#:load-path-inputs . (cons `((#:name . ,name)
,(with-input-from-string load-path-inputs read)) (#:load-path-inputs .
(#:package-path-inputs . ,(with-input-from-string load-path-inputs read))
,(with-input-from-string package-path-inputs read)) (#:package-path-inputs .
(#:proc-input . ,proc-input) ,(with-input-from-string package-path-inputs read))
(#:proc-file . ,proc-file) (#:proc-input . ,proc-input)
(#:proc . ,(with-input-from-string proc read)) (#:proc-file . ,proc-file)
(#:proc-args . ,(with-input-from-string proc-args read)) (#:proc . ,(with-input-from-string proc read))
(#:inputs . ,(db-get-inputs db name))) (#:proc-args . ,(with-input-from-string proc-args read))
specs)))))) (#:inputs . ,(db-get-inputs name)))
specs)))))))
(define (db-add-evaluation db eval) (define (db-add-evaluation eval)
(sqlite-exec db "\ (with-db-critical-section db
(sqlite-exec db "\
INSERT INTO Evaluations (specification, commits) VALUES (" INSERT INTO Evaluations (specification, commits) VALUES ("
(assq-ref eval #:specification) ", " (assq-ref eval #:specification) ", "
(string-join (assq-ref eval #:commits)) ");") (string-join (assq-ref eval #:commits)) ");")
(last-insert-rowid db)) (last-insert-rowid db)))
(define-syntax-rule (with-database db body ...) (define-syntax-rule (with-database body ...)
"Run BODY with a connection to the database which is bound to DB in BODY." "Run BODY with %DB-CHANNEL being dynamically bound to a channel implementing
a critical section that allows database operations to be serialized."
;; XXX: We don't install an unwind handler to play well with delimited ;; XXX: We don't install an unwind handler to play well with delimited
;; continuations and fibers. But as a consequence, we leak DB when BODY ;; continuations and fibers. But as a consequence, we leak DB when BODY
;; raises an exception. ;; raises an exception.
(let ((db (db-open))) (let ((db (db-open)))
(unwind-protect body ... (db-close db)))) (unwind-protect
;; Process database queries sequentially in a thread. We need this
;; because otherwise we would need to use the SQLite multithreading
;; feature for which it is required to wait until the database is
;; available, and the waiting would happen in non-cooperative and
;; non-resumable code that blocks the fibers scheduler. Now the database
;; access blocks on PUT-MESSAGE, which allows the scheduler to schedule
;; another fiber. Also, creating one new handle for each request would
;; be costly and may defeat statement caching.
(parameterize ((%db-channel (make-critical-section db)))
body ...)
(db-close db))))
(define* (read-quoted-string #:optional (port (current-input-port))) (define* (read-quoted-string #:optional (port (current-input-port)))
"Read all of the characters out of PORT and return them as a SQL quoted "Read all of the characters out of PORT and return them as a SQL quoted
@ -353,79 +384,84 @@ string."
(failed-other 3) (failed-other 3)
(canceled 4)) (canceled 4))
(define (db-add-build db build) (define (db-add-build build)
"Store BUILD in database DB. BUILD eventual outputs are stored "Store BUILD in database the database. BUILD eventual outputs are stored in
in the OUTPUTS table." the OUTPUTS table."
(catch 'sqlite-error (with-db-critical-section db
(lambda () (catch 'sqlite-error
(sqlite-exec db " (lambda ()
(sqlite-exec db "
INSERT INTO Builds (derivation, evaluation, job_name, system, nix_name, log, INSERT INTO Builds (derivation, evaluation, job_name, system, nix_name, log,
status, timestamp, starttime, stoptime) status, timestamp, starttime, stoptime)
VALUES (" VALUES ("
(assq-ref build #:derivation) ", " (assq-ref build #:derivation) ", "
(assq-ref build #:eval-id) ", " (assq-ref build #:eval-id) ", "
(assq-ref build #:job-name) ", " (assq-ref build #:job-name) ", "
(assq-ref build #:system) ", " (assq-ref build #:system) ", "
(assq-ref build #:nix-name) ", " (assq-ref build #:nix-name) ", "
(assq-ref build #:log) ", " (assq-ref build #:log) ", "
(or (assq-ref build #:status) (or (assq-ref build #:status)
(build-status scheduled)) ", " (build-status scheduled)) ", "
(or (assq-ref build #:timestamp) 0) ", " (or (assq-ref build #:timestamp) 0) ", "
(or (assq-ref build #:starttime) 0) ", " (or (assq-ref build #:starttime) 0) ", "
(or (assq-ref build #:stoptime) 0) ");") (or (assq-ref build #:stoptime) 0) ");")
(let ((derivation (assq-ref build #:derivation))) (let ((derivation (assq-ref build #:derivation)))
(for-each (lambda (output) (for-each (lambda (output)
(match output (match output
((name . path) ((name . path)
(sqlite-exec db "\ (sqlite-exec db "\
INSERT INTO Outputs (derivation, name, path) VALUES (" INSERT INTO Outputs (derivation, name, path) VALUES ("
derivation ", " name ", " path ");")))) derivation ", " name ", " path ");"))))
(assq-ref build #:outputs)) (assq-ref build #:outputs))
derivation)) derivation))
(lambda (key who code message . rest) (lambda (key who code message . rest)
;; If we get a unique-constraint-failed error, that means we have ;; If we get a unique-constraint-failed error, that means we have
;; already inserted the same build. That happens when several jobs ;; already inserted the same build. That happens when several jobs
;; produce the same derivation, and we can ignore it. ;; produce the same derivation, and we can ignore it.
(if (= code SQLITE_CONSTRAINT_PRIMARYKEY) (if (= code SQLITE_CONSTRAINT_PRIMARYKEY)
#f #f
(apply throw key who code rest))))) (apply throw key who code rest))))))
(define* (db-update-build-status! db drv status #:key log-file) (define* (db-update-build-status! drv status #:key log-file)
"Update DB so that DRV's status is STATUS. This also updates the "Update the database so that DRV's status is STATUS. This also updates the
'starttime' or 'stoptime' fields. If LOG-FILE is true, record it as the build 'starttime' or 'stoptime' fields. If LOG-FILE is true, record it as the build
log file for DRV." log file for DRV."
(define now (define now
(time-second (current-time time-utc))) (time-second (current-time time-utc)))
(if (= status (build-status started)) (with-db-critical-section db
(sqlite-exec db "UPDATE Builds SET starttime=" now ", status=" (if (= status (build-status started))
status "WHERE derivation=" drv ";") (sqlite-exec db "UPDATE Builds SET starttime=" now ", status="
status "WHERE derivation=" drv ";")
;; Update only if we're switching to a different status; otherwise leave ;; Update only if we're switching to a different status; otherwise
;; things unchanged. This ensures that 'stoptime' remains valid and ;; leave things unchanged. This ensures that 'stoptime' remains valid
;; doesn't change every time we mark DRV as 'succeeded' several times in ;; and doesn't change every time we mark DRV as 'succeeded' several
;; a row, for instance. ;; times in a row, for instance.
(if log-file (if log-file
(sqlite-exec db "UPDATE Builds SET stoptime=" now (sqlite-exec db "UPDATE Builds SET stoptime=" now
", status=" status ", log=" log-file ", status=" status ", log=" log-file
"WHERE derivation=" drv "AND status != " status ";") "WHERE derivation=" drv "AND status != " status ";")
(sqlite-exec db "UPDATE Builds SET stoptime=" now (sqlite-exec db "UPDATE Builds SET stoptime=" now
", status=" status ", status=" status
"WHERE derivation=" drv " AND status != " status ";")))) "WHERE derivation=" drv " AND status != " status
";")))))
(define (db-get-outputs db derivation) (define (db-get-outputs derivation)
"Retrieve the OUTPUTS of the build identified by DERIVATION in DB database." "Retrieve the OUTPUTS of the build identified by DERIVATION in the
(let loop ((rows database."
(sqlite-exec db "SELECT name, path FROM Outputs (with-db-critical-section db
(let loop ((rows
(sqlite-exec db "SELECT name, path FROM Outputs
WHERE derivation =" derivation ";")) WHERE derivation =" derivation ";"))
(outputs '())) (outputs '()))
(match rows (match rows
(() outputs) (() outputs)
((#(name path) ((#(name path)
. rest) . rest)
(loop rest (loop rest
(cons `(,name . ((#:path . ,path))) (cons `(,name . ((#:path . ,path)))
outputs)))))) outputs)))))))
(define (filters->order filters) (define (filters->order filters)
(match (assq 'order filters) (match (assq 'order filters)
@ -440,12 +476,13 @@ WHERE derivation =" derivation ";"))
(('order . 'status+submission-time) "status DESC, timestamp DESC") (('order . 'status+submission-time) "status DESC, timestamp DESC")
(_ "rowid DESC"))) (_ "rowid DESC")))
(define (db-get-builds db filters) (define (db-get-builds filters)
"Retrieve all builds in database DB which are matched by given FILTERS. "Retrieve all builds in the database which are matched by given FILTERS.
FILTERS is an assoc list whose possible keys are 'derivation | 'id | 'jobset | FILTERS is an assoc list whose possible keys are 'derivation | 'id | 'jobset |
'job | 'system | 'nr | 'order | 'status | 'evaluation." 'job | 'system | 'nr | 'order | 'status | 'evaluation."
(let* ((order (filters->order filters)) (with-db-critical-section db
(stmt-text (format #f "SELECT * FROM ( (let* ((order (filters->order filters))
(stmt-text (format #f "SELECT * FROM (
SELECT Builds.derivation, Builds.rowid, Builds.timestamp, Builds.starttime, SELECT Builds.derivation, Builds.rowid, Builds.timestamp, Builds.starttime,
Builds.stoptime, Builds.log, Builds.status, Builds.job_name, Builds.system, Builds.stoptime, Builds.log, Builds.status, Builds.job_name, Builds.system,
Builds.nix_name, Specifications.name Builds.nix_name, Specifications.name
@ -475,93 +512,99 @@ CASE WHEN :borderlowtime IS NULL
END DESC END DESC
LIMIT :nr) LIMIT :nr)
ORDER BY ~a, rowid ASC;" order)) ORDER BY ~a, rowid ASC;" order))
(stmt (sqlite-prepare db stmt-text #:cache? #t))) (stmt (sqlite-prepare db stmt-text #:cache? #t)))
(sqlite-bind-arguments (sqlite-bind-arguments
stmt stmt
#:derivation (assq-ref filters 'derivation) #:derivation (assq-ref filters 'derivation)
#:id (assq-ref filters 'id) #:id (assq-ref filters 'id)
#:jobset (assq-ref filters 'jobset) #:jobset (assq-ref filters 'jobset)
#:job (assq-ref filters 'job) #:job (assq-ref filters 'job)
#:evaluation (assq-ref filters 'evaluation) #:evaluation (assq-ref filters 'evaluation)
#:system (assq-ref filters 'system) #:system (assq-ref filters 'system)
#:status (and=> (assq-ref filters 'status) object->string) #:status (and=> (assq-ref filters 'status) object->string)
#:borderlowid (assq-ref filters 'border-low-id) #:borderlowid (assq-ref filters 'border-low-id)
#:borderhighid (assq-ref filters 'border-high-id) #:borderhighid (assq-ref filters 'border-high-id)
#:borderlowtime (assq-ref filters 'border-low-time) #:borderlowtime (assq-ref filters 'border-low-time)
#:borderhightime (assq-ref filters 'border-high-time) #:borderhightime (assq-ref filters 'border-high-time)
#:nr (match (assq-ref filters 'nr) #:nr (match (assq-ref filters 'nr)
(#f -1) (#f -1)
(x x))) (x x)))
(sqlite-reset stmt) (sqlite-reset stmt)
(let loop ((rows (sqlite-fold-right cons '() stmt)) (let loop ((rows (sqlite-fold-right cons '() stmt))
(builds '())) (builds '()))
(match rows (match rows
(() (reverse builds)) (() (reverse builds))
((#(derivation id timestamp starttime stoptime log status job-name ((#(derivation id timestamp starttime stoptime log status job-name
system nix-name specification) . rest) system nix-name specification) . rest)
(loop rest (loop rest
(cons `((#:derivation . ,derivation) (cons `((#:derivation . ,derivation)
(#:id . ,id) (#:id . ,id)
(#:timestamp . ,timestamp) (#:timestamp . ,timestamp)
(#:starttime . ,starttime) (#:starttime . ,starttime)
(#:stoptime . ,stoptime) (#:stoptime . ,stoptime)
(#:log . ,log) (#:log . ,log)
(#:status . ,status) (#:status . ,status)
(#:job-name . ,job-name) (#:job-name . ,job-name)
(#:system . ,system) (#:system . ,system)
(#:nix-name . ,nix-name) (#:nix-name . ,nix-name)
(#:specification . ,specification) (#:specification . ,specification)
(#:outputs . ,(db-get-outputs db derivation))) (#:outputs . ,(db-get-outputs derivation)))
builds))))))) builds))))))))
(define (db-get-build db derivation-or-id) (define (db-get-build derivation-or-id)
"Retrieve a build in database DB which corresponds to DERIVATION-OR-ID." "Retrieve a build in the database which corresponds to DERIVATION-OR-ID."
(let ((key (if (number? derivation-or-id) 'id 'derivation))) (with-db-critical-section db
(match (db-get-builds db `((,key . ,derivation-or-id))) (let ((key (if (number? derivation-or-id) 'id 'derivation)))
((build) (match (db-get-builds `((,key . ,derivation-or-id)))
build) ((build)
(() #f)))) build)
(() #f)))))
(define (db-get-pending-derivations db) (define (db-get-pending-derivations)
"Return the list of derivation file names corresponding to pending builds in "Return the list of derivation file names corresponding to pending builds in
DB. The returned list is guaranteed to not have any duplicates." the database. The returned list is guaranteed to not have any duplicates."
(map (match-lambda (#(drv) drv)) (with-db-critical-section db
(sqlite-exec db " (map (match-lambda (#(drv) drv))
SELECT derivation FROM Builds WHERE Builds.status < 0;"))) (sqlite-exec db "
SELECT derivation FROM Builds WHERE Builds.status < 0;"))))
(define (db-get-stamp db spec) (define (db-get-stamp spec)
"Return a stamp corresponding to specification SPEC in database DB." "Return a stamp corresponding to specification SPEC in the database."
(let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification=" (with-db-critical-section db
(assq-ref spec #:name) ";"))) (let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification="
(match res (assq-ref spec #:name) ";")))
(() #f) (match res
((#(spec stamp)) stamp)))) (() #f)
((#(spec stamp)) stamp)))))
(define (db-add-stamp db spec stamp) (define (db-add-stamp spec stamp)
"Associate STAMP to specification SPEC in database DB." "Associate STAMP to specification SPEC in the database."
(if (db-get-stamp db spec) (with-db-critical-section db
(sqlite-exec db "UPDATE Stamps SET stamp=" stamp (if (db-get-stamp spec)
"WHERE specification=" (assq-ref spec #:name) ";") (sqlite-exec db "UPDATE Stamps SET stamp=" stamp
(sqlite-exec db "\ "WHERE specification=" (assq-ref spec #:name) ";")
(sqlite-exec db "\
INSERT INTO Stamps (specification, stamp) VALUES (" INSERT INTO Stamps (specification, stamp) VALUES ("
(assq-ref spec #:name) ", " stamp ");"))) (assq-ref spec #:name) ", " stamp ");"))))
(define (db-get-evaluations db limit) (define (db-get-evaluations limit)
(let loop ((rows (sqlite-exec db "SELECT id, specification, commits (with-db-critical-section db
(let loop ((rows (sqlite-exec db "SELECT id, specification, commits
FROM Evaluations ORDER BY id DESC LIMIT " limit ";")) FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
(evaluations '())) (evaluations '()))
(match rows (match rows
(() (reverse evaluations)) (() (reverse evaluations))
((#(id specification commits) ((#(id specification commits)
. rest) . rest)
(loop rest (loop rest
(cons `((#:id . ,id) (cons `((#:id . ,id)
(#:specification . ,specification) (#:specification . ,specification)
(#:commits . ,(string-tokenize commits))) (#:commits . ,(string-tokenize commits)))
evaluations)))))) evaluations)))))))
(define (db-get-evaluations-build-summary db spec limit border-low border-high) (define (db-get-evaluations-build-summary spec limit border-low border-high)
(let loop ((rows (sqlite-exec db " (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.commits, B.succeeded, B.failed, B.scheduled
FROM FROM
(SELECT id, commits (SELECT id, commits
@ -578,50 +621,54 @@ FROM Builds
GROUP BY evaluation) B GROUP BY evaluation) B
ON B.evaluation=E.id ON B.evaluation=E.id
ORDER BY E.id ASC;")) ORDER BY E.id ASC;"))
(evaluations '())) (evaluations '()))
(match rows (match rows
(() evaluations) (() evaluations)
((#(id commits succeeded failed scheduled) . rest) ((#(id commits succeeded failed scheduled) . rest)
(loop rest (loop rest
(cons `((#:id . ,id) (cons `((#:id . ,id)
(#:commits . ,commits) (#:commits . ,commits)
(#:succeeded . ,(or succeeded 0)) (#:succeeded . ,(or succeeded 0))
(#:failed . ,(or failed 0)) (#:failed . ,(or failed 0))
(#:scheduled . ,(or scheduled 0))) (#:scheduled . ,(or scheduled 0)))
evaluations)))))) evaluations)))))))
(define (db-get-evaluations-id-min db spec) (define (db-get-evaluations-id-min spec)
"Return the min id of evaluations for the given specification SPEC." "Return the min id of evaluations for the given specification SPEC."
(let ((rows (sqlite-exec db " (with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT MIN(id) FROM Evaluations SELECT MIN(id) FROM Evaluations
WHERE specification=" spec))) WHERE specification=" spec)))
(vector-ref (car rows) 0))) (vector-ref (car rows) 0))))
(define (db-get-evaluations-id-max db spec) (define (db-get-evaluations-id-max spec)
"Return the max id of evaluations for the given specification SPEC." "Return the max id of evaluations for the given specification SPEC."
(let ((rows (sqlite-exec db " (with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT MAX(id) FROM Evaluations SELECT MAX(id) FROM Evaluations
WHERE specification=" spec))) WHERE specification=" spec)))
(vector-ref (car rows) 0))) (vector-ref (car rows) 0))))
(define (db-get-builds-min db eval) (define (db-get-builds-min eval)
"Return the min build (stoptime, id) pair for "Return the min build (stoptime, id) pair for
the given evaluation EVAL." the given evaluation EVAL."
(let ((rows (sqlite-exec db " (with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT stoptime, MIN(rowid) FROM SELECT stoptime, MIN(rowid) FROM
(SELECT rowid, stoptime FROM Builds (SELECT rowid, stoptime FROM Builds
WHERE evaluation=" eval " AND WHERE evaluation=" eval " AND
stoptime = (SELECT MIN(stoptime) stoptime = (SELECT MIN(stoptime)
FROM Builds WHERE evaluation=" eval "))"))) FROM Builds WHERE evaluation=" eval "))")))
(vector->list (car rows)))) (vector->list (car rows)))))
(define (db-get-builds-max db eval) (define (db-get-builds-max eval)
"Return the max build (stoptime, id) pair for "Return the max build (stoptime, id) pair for
the given evaluation EVAL." the given evaluation EVAL."
(let ((rows (sqlite-exec db " (with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT stoptime, MAX(rowid) FROM SELECT stoptime, MAX(rowid) FROM
(SELECT rowid, stoptime FROM Builds (SELECT rowid, stoptime FROM Builds
WHERE evaluation=" eval " AND WHERE evaluation=" eval " AND
stoptime = (SELECT MAX(stoptime) stoptime = (SELECT MAX(stoptime)
FROM Builds WHERE evaluation=" eval "))"))) FROM Builds WHERE evaluation=" eval "))")))
(vector->list (car rows)))) (vector->list (car rows)))))

136
src/cuirass/http.scm
View File

@ -103,17 +103,17 @@
(#:releasename . #nil) (#:releasename . #nil)
(#:buildinputs_builds . #nil))) (#:buildinputs_builds . #nil)))
(define (handle-build-request db build-id) (define (handle-build-request build-id)
"Retrieve build identified by BUILD-ID over DB and convert it "Retrieve build identified by BUILD-ID over the database and convert it to
to hydra format. Return #f is not build was found." hydra format. Return #f is not build was found."
(let ((build (db-get-build db build-id))) (let ((build (db-get-build build-id)))
(and=> build build->hydra-build))) (and=> build build->hydra-build)))
(define (handle-builds-request db filters) (define (handle-builds-request filters)
"Retrieve all builds matched by FILTERS in DB and convert them "Retrieve all builds matched by FILTERS in the database and convert them to
to Hydra format." Hydra format."
(let ((builds (with-time-logging "builds request" (let ((builds (with-time-logging "builds request"
(db-get-builds db filters)))) (db-get-builds filters))))
(map build->hydra-build builds))) (map build->hydra-build builds)))
(define (request-parameters request) (define (request-parameters request)
@ -146,10 +146,10 @@
(define (request-path-components request) (define (request-path-components request)
(split-and-decode-uri-path (uri-path (request-uri request)))) (split-and-decode-uri-path (uri-path (request-uri request))))
(define (url-handler request body db-channel) (define (url-handler request body)
(define* (respond response #:key body (db-channel db-channel)) (define* (respond response #:key body)
(values response body db-channel)) (values response body #f))
(define-syntax-rule (respond-json body ...) (define-syntax-rule (respond-json body ...)
(respond '((content-type . (application/json))) (respond '((content-type . (application/json)))
@ -213,19 +213,14 @@
(request-path-components request) (request-path-components request)
'method-not-allowed) 'method-not-allowed)
(((or "jobsets" "specifications") . rest) (((or "jobsets" "specifications") . rest)
(respond-json (object->json-string (respond-json (object->json-string (db-get-specifications))))
(with-critical-section db-channel (db)
(db-get-specifications db)))))
(("build" build-id) (("build" build-id)
(let ((hydra-build (let ((hydra-build (handle-build-request (string->number build-id))))
(with-critical-section db-channel (db)
(handle-build-request db (string->number build-id)))))
(if hydra-build (if hydra-build
(respond-json (object->json-string hydra-build)) (respond-json (object->json-string hydra-build))
(respond-build-not-found build-id)))) (respond-build-not-found build-id))))
(("build" build-id "log" "raw") (("build" build-id "log" "raw")
(let ((build (with-critical-section db-channel (db) (let ((build (db-get-build (string->number build-id))))
(db-get-build db (string->number build-id)))))
(if build (if build
(match (assq-ref build #:outputs) (match (assq-ref build #:outputs)
(((_ (#:path . (? string? output))) _ ...) (((_ (#:path . (? string? output))) _ ...)
@ -250,9 +245,7 @@
;; 'nr parameter is mandatory to limit query size. ;; 'nr parameter is mandatory to limit query size.
(nr (assq-ref params 'nr))) (nr (assq-ref params 'nr)))
(if nr (if nr
(respond-json (object->json-string (respond-json (object->json-string (db-get-evaluations nr)))
(with-critical-section db-channel (db)
(db-get-evaluations db nr))))
(respond-json-with-error 500 "Parameter not defined!")))) (respond-json-with-error 500 "Parameter not defined!"))))
(("api" "latestbuilds") (("api" "latestbuilds")
(let* ((params (request-parameters request)) (let* ((params (request-parameters request))
@ -262,10 +255,9 @@
;; Limit results to builds that are "done". ;; Limit results to builds that are "done".
(respond-json (respond-json
(object->json-string (object->json-string
(with-critical-section db-channel (db) (handle-builds-request `((status . done)
(handle-builds-request db `((status . done) ,@params
,@params (order . finish-time)))))
(order . finish-time))))))
(respond-json-with-error 500 "Parameter not defined!")))) (respond-json-with-error 500 "Parameter not defined!"))))
(("api" "queue") (("api" "queue")
(let* ((params (request-parameters request)) (let* ((params (request-parameters request))
@ -276,77 +268,65 @@
(object->json-string (object->json-string
;; Use the 'status+submission-time' order so that builds in ;; Use the 'status+submission-time' order so that builds in
;; 'running' state appear before builds in 'scheduled' state. ;; 'running' state appear before builds in 'scheduled' state.
(with-critical-section db-channel (db) (handle-builds-request `((status . pending)
(handle-builds-request db `((status . pending) ,@params
,@params (order . status+submission-time)))))
(order . status+submission-time))))))
(respond-json-with-error 500 "Parameter not defined!")))) (respond-json-with-error 500 "Parameter not defined!"))))
('() ('()
(respond-html (html-page (respond-html (html-page
"Cuirass" "Cuirass"
(specifications-table (specifications-table (db-get-specifications)))))
(with-critical-section db-channel (db)
(db-get-specifications db))))))
(("jobset" name) (("jobset" name)
(respond-html (respond-html
(with-critical-section db-channel (db) (let* ((evaluation-id-max (db-get-evaluations-id-max name))
(let* ((evaluation-id-max (db-get-evaluations-id-max db name)) (evaluation-id-min (db-get-evaluations-id-min name))
(evaluation-id-min (db-get-evaluations-id-min db name)) (params (request-parameters request))
(params (request-parameters request)) (border-high (assq-ref params 'border-high))
(border-high (assq-ref params 'border-high)) (border-low (assq-ref params 'border-low))
(border-low (assq-ref params 'border-low)) (evaluations (db-get-evaluations-build-summary name
(evaluations (db-get-evaluations-build-summary db %page-size
name border-low
%page-size border-high)))
border-low (html-page name (evaluation-info-table name
border-high))) evaluations
(html-page name (evaluation-info-table name evaluation-id-min
evaluations evaluation-id-max)))))
evaluation-id-min
evaluation-id-max))))))
(("eval" id) (("eval" id)
(respond-html (respond-html
(with-critical-section db-channel (db) (let* ((builds-id-max (db-get-builds-max id))
(let* ((builds-id-max (db-get-builds-max db id)) (builds-id-min (db-get-builds-min id))
(builds-id-min (db-get-builds-min db id)) (params (request-parameters request))
(params (request-parameters request)) (border-high-time (assq-ref params 'border-high-time))
(border-high-time (assq-ref params 'border-high-time)) (border-low-time (assq-ref params 'border-low-time))
(border-low-time (assq-ref params 'border-low-time)) (border-high-id (assq-ref params 'border-high-id))
(border-high-id (assq-ref params 'border-high-id)) (border-low-id (assq-ref params 'border-low-id)))
(border-low-id (assq-ref params 'border-low-id))) (html-page
(html-page "Evaluation"
"Evaluation" (build-eval-table
(build-eval-table (handle-builds-request `((evaluation . ,id)
(handle-builds-request db `((evaluation . ,id) (nr . ,%page-size)
(nr . ,%page-size) (order . finish-time+build-id)
(order . finish-time+build-id) (border-high-time . ,border-high-time)
(border-high-time . ,border-high-time) (border-low-time . ,border-low-time)
(border-low-time . ,border-low-time) (border-high-id . ,border-high-id)
(border-high-id . ,border-high-id) (border-low-id . ,border-low-id)))
(border-low-id . ,border-low-id))) builds-id-min
builds-id-min builds-id-max)))))
builds-id-max))))))
(("static" path ...) (("static" path ...)
(respond-static-file path)) (respond-static-file path))
('method-not-allowed ('method-not-allowed
;; 405 "Method Not Allowed" ;; 405 "Method Not Allowed"
(values (build-response #:code 405) #f db-channel)) (values (build-response #:code 405) #f #f))
(_ (_
(respond-not-found (uri->string (request-uri request)))))) (respond-not-found (uri->string (request-uri request))))))
(define* (run-cuirass-server db #:key (host "localhost") (port 8080)) (define* (run-cuirass-server #:key (host "localhost") (port 8080))
(let* ((host-info (gethostbyname host)) (let* ((host-info (gethostbyname host))
(address (inet-ntop (hostent:addrtype host-info) (address (inet-ntop (hostent:addrtype host-info)
(car (hostent:addr-list host-info)))) (car (hostent:addr-list host-info)))))
;; Spawn a fiber to process database queries sequentially. We need
;; this because guile-sqlite3 handles are not thread-safe (caching in
;; particular), and creating one new handle for each request would be
;; costly and may defeat statement caching.
(db-channel (make-critical-section db)))
(log-message "listening on ~A:~A" address port) (log-message "listening on ~A:~A" address port)
;; Here we use our own web backend, call 'fiberized'. We cannot use the ;; Here we use our own web backend, call 'fiberized'. We cannot use the
@ -371,7 +351,7 @@
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
(let-values (((response body state) (let-values (((response body state)
(handle-request (cut url-handler <> <> db-channel) (handle-request (cut url-handler <> <>)
request body '()))) request body '())))
(write-client impl server client response body))))) (write-client impl server client response body)))))
(loop))))) (loop)))))

23
src/cuirass/utils.scm
View File

@ -103,17 +103,18 @@ then be passed to 'join-critical-section', which will ensure sequential
ordering. ARGS are the arguments of the critical section. ordering. ARGS are the arguments of the critical section.
Critical sections are implemented by passing the procedure to execute to a Critical sections are implemented by passing the procedure to execute to a
dedicated fiber." dedicated thread."
(let ((channel (make-channel))) (parameterize (((@@ (fibers internal) current-fiber) #f))
(spawn-fiber (let ((channel (make-channel)))
(lambda () (call-with-new-thread
(parameterize ((%critical-section-args args)) (lambda ()
(let loop () (parameterize ((%critical-section-args args))
(match (get-message channel) (let loop ()
(((? channel? reply) . (? procedure? proc)) (match (get-message channel)
(put-message reply (apply proc args)))) (((? channel? reply) . (? procedure? proc))
(loop))))) (put-message reply (apply proc args))))
channel)) (loop)))))
channel)))
(define (call-with-critical-section channel proc) (define (call-with-critical-section channel proc)
"Send PROC to the critical section through CHANNEL. Return the result of "Send PROC to the critical section through CHANNEL. Return the result of

99
tests/database.scm
View File

@ -21,6 +21,7 @@
(use-modules (cuirass database) (use-modules (cuirass database)
((guix utils) #:select (call-with-temporary-output-file)) ((guix utils) #:select (call-with-temporary-output-file))
(cuirass utils)
(srfi srfi-64)) (srfi srfi-64))
(define example-spec (define example-spec
@ -61,12 +62,12 @@
(#:log . "log") (#:log . "log")
(#:outputs . (("foo" . "/foo"))))) (#:outputs . (("foo" . "/foo")))))
(define-syntax-rule (with-temporary-database db body ...) (define-syntax-rule (with-temporary-database body ...)
(call-with-temporary-output-file (call-with-temporary-output-file
(lambda (file port) (lambda (file port)
(parameterize ((%package-database file)) (parameterize ((%package-database file))
(db-init file) (db-init file)
(with-database db (with-database
body ...))))) body ...)))))
(define %db (define %db
@ -79,7 +80,10 @@
(test-group-with-cleanup "database" (test-group-with-cleanup "database"
(test-assert "db-init" (test-assert "db-init"
(%db (db-init database-name))) (begin
(%db (db-init database-name))
(%db-channel (make-critical-section (%db)))
#t))
(test-assert "sqlite-exec" (test-assert "sqlite-exec"
(begin (begin
@ -94,41 +98,40 @@ INSERT INTO Evaluations (specification, commits) VALUES (3, 3);")
(test-equal "db-add-specification" (test-equal "db-add-specification"
example-spec example-spec
(begin (begin
(db-add-specification (%db) example-spec) (db-add-specification example-spec)
(car (db-get-specifications (%db))))) (car (db-get-specifications))))
(test-equal "db-add-build" (test-equal "db-add-build"
#f #f
(let ((build (make-dummy-build "/foo.drv"))) (let ((build (make-dummy-build "/foo.drv")))
(db-add-build (%db) build) (db-add-build build)
;; Should return #f when adding a build whose derivation is already ;; Should return #f when adding a build whose derivation is already
;; there, see <https://bugs.gnu.org/28094>. ;; there, see <https://bugs.gnu.org/28094>.
(db-add-build (%db) build))) (db-add-build build)))
(test-equal "db-update-build-status!" (test-equal "db-update-build-status!"
(list (build-status scheduled) (list (build-status scheduled)
(build-status started) (build-status started)
(build-status succeeded) (build-status succeeded)
"/foo.drv.log") "/foo.drv.log")
(with-temporary-database db (with-temporary-database
(let* ((derivation (db-add-build (let* ((derivation (db-add-build
db
(make-dummy-build "/foo.drv" 1 (make-dummy-build "/foo.drv" 1
#:outputs '(("out" . "/foo"))))) #:outputs '(("out" . "/foo")))))
(get-status (lambda* (#:optional (key #:status)) (get-status (lambda* (#:optional (key #:status))
(assq-ref (db-get-build db derivation) key)))) (assq-ref (db-get-build derivation) key))))
(db-add-evaluation db (make-dummy-eval)) (db-add-evaluation (make-dummy-eval))
(db-add-specification db example-spec) (db-add-specification example-spec)
(let ((status0 (get-status))) (let ((status0 (get-status)))
(db-update-build-status! db "/foo.drv" (build-status started)) (db-update-build-status! "/foo.drv" (build-status started))
(let ((status1 (get-status))) (let ((status1 (get-status)))
(db-update-build-status! db "/foo.drv" (build-status succeeded) (db-update-build-status! "/foo.drv" (build-status succeeded)
#:log-file "/foo.drv.log") #:log-file "/foo.drv.log")
;; Second call shouldn't make any difference. ;; Second call shouldn't make any difference.
(db-update-build-status! db "/foo.drv" (build-status succeeded) (db-update-build-status! "/foo.drv" (build-status succeeded)
#:log-file "/foo.drv.log") #:log-file "/foo.drv.log")
(let ((status2 (get-status)) (let ((status2 (get-status))
@ -144,61 +147,61 @@ INSERT INTO Evaluations (specification, commits) VALUES (3, 3);")
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto ((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto
((3 "/baz.drv")) ;nr = 1 ((3 "/baz.drv")) ;nr = 1
((2 "/bar.drv") (1 "/foo.drv") (3 "/baz.drv"))) ;status+submission-time ((2 "/bar.drv") (1 "/foo.drv") (3 "/baz.drv"))) ;status+submission-time
(with-temporary-database db (with-temporary-database
;; Populate the 'Builds'', 'Evaluations', and ;; Populate the 'Builds'', 'Evaluations', and
;; 'Specifications' tables in a consistent way, as expected by the ;; 'Specifications' tables in a consistent way, as expected by the
;; 'db-get-builds' query. ;; 'db-get-builds' query.
(db-add-build db (make-dummy-build "/foo.drv" 1 (db-add-build (make-dummy-build "/foo.drv" 1
#:outputs `(("out" . "/foo")))) #:outputs `(("out" . "/foo"))))
(db-add-build db (make-dummy-build "/bar.drv" 2 (db-add-build (make-dummy-build "/bar.drv" 2
#:outputs `(("out" . "/bar")))) #:outputs `(("out" . "/bar"))))
(db-add-build db (make-dummy-build "/baz.drv" 3 (db-add-build (make-dummy-build "/baz.drv" 3
#:outputs `(("out" . "/baz")))) #:outputs `(("out" . "/baz"))))
(db-add-evaluation db (make-dummy-eval)) (db-add-evaluation (make-dummy-eval))
(db-add-evaluation db (make-dummy-eval)) (db-add-evaluation (make-dummy-eval))
(db-add-evaluation db (make-dummy-eval)) (db-add-evaluation (make-dummy-eval))
(db-add-specification db example-spec) (db-add-specification example-spec)
(db-update-build-status! db "/bar.drv" (build-status started) (db-update-build-status! "/bar.drv" (build-status started)
#:log-file "/bar.drv.log") #:log-file "/bar.drv.log")
(let ((summarize (lambda (alist) (let ((summarize (lambda (alist)
(list (assq-ref alist #:id) (list (assq-ref alist #:id)
(assq-ref alist #:derivation))))) (assq-ref alist #:derivation)))))
(vector (map summarize (db-get-builds db '((nr . 3) (vector (map summarize (db-get-builds '((nr . 3) (order . build-id))))
(order . build-id)))) (map summarize (db-get-builds '()))
(map summarize (db-get-builds db '())) (map summarize (db-get-builds '((jobset . "guix"))))
(map summarize (db-get-builds db '((jobset . "guix")))) (map summarize (db-get-builds '((nr . 1))))
(map summarize (db-get-builds db '((nr . 1))))
(map summarize (map summarize
(db-get-builds (db-get-builds '((order . status+submission-time))))))))
db '((order . status+submission-time))))))))
(test-equal "db-get-pending-derivations" (test-equal "db-get-pending-derivations"
'("/bar.drv" "/foo.drv") '("/bar.drv" "/foo.drv")
(with-temporary-database db (with-temporary-database
;; Populate the 'Builds', 'Evaluations', and ;; Populate the 'Builds', 'Evaluations', and
;; 'Specifications' tables. Here, two builds map to the same derivation ;; 'Specifications' tables. Here, two builds map to the same derivation
;; but the result of 'db-get-pending-derivations' must not contain any ;; but the result of 'db-get-pending-derivations' must not contain any
;; duplicate. ;; duplicate.
(db-add-build db (make-dummy-build "/foo.drv" 1 (db-add-build (make-dummy-build "/foo.drv" 1
#:outputs `(("out" . "/foo")))) #:outputs `(("out" . "/foo"))))
(db-add-build db (make-dummy-build "/bar.drv" 2 (db-add-build (make-dummy-build "/bar.drv" 2
#:outputs `(("out" . "/bar")))) #:outputs `(("out" . "/bar"))))
(db-add-build db (make-dummy-build "/foo.drv" 3 (db-add-build (make-dummy-build "/foo.drv" 3
#:outputs `(("out" . "/foo")))) #:outputs `(("out" . "/foo"))))
(db-add-evaluation db (make-dummy-eval)) (db-add-evaluation (make-dummy-eval))
(db-add-evaluation db (make-dummy-eval)) (db-add-evaluation (make-dummy-eval))
(db-add-evaluation db (make-dummy-eval)) (db-add-evaluation (make-dummy-eval))
(db-add-specification db example-spec) (db-add-specification example-spec)
(sort (db-get-pending-derivations db) string<?))) (sort (db-get-pending-derivations) string<?)))
(test-assert "db-close" (test-assert "db-close"
(db-close (%db))) (db-close (%db)))
(delete-file database-name)) (begin
(%db-channel #f)
(delete-file database-name)))
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'with-temporary-database 'scheme-indent-function 1) ;;; eval: (put 'with-temporary-database 'scheme-indent-function 0)
;;; End: ;;; End:

21
tests/http.scm
View File

@ -125,14 +125,17 @@
json->scm))) json->scm)))
(test-assert "db-init" (test-assert "db-init"
(%db (db-init database-name))) (begin
(%db (db-init database-name))
(%db-channel (make-critical-section (%db)))
#t))
(test-assert "cuirass-run" (test-assert "cuirass-run"
(call-with-new-thread (call-with-new-thread
(lambda () (lambda ()
(run-fibers (run-fibers
(lambda () (lambda ()
(run-cuirass-server (%db) #:port 6688)) (run-cuirass-server #:port 6688))
#:drain? #t)))) #:drain? #t))))
(test-assert "wait-server" (test-assert "wait-server"
@ -184,11 +187,11 @@
(evaluation2 (evaluation2
'((#:specification . "guix") '((#:specification . "guix")
(#:commits . ("fakesha2" "fakesha3"))))) (#:commits . ("fakesha2" "fakesha3")))))
(db-add-build (%db) build1) (db-add-build build1)
(db-add-build (%db) build2) (db-add-build build2)
(db-add-specification (%db) specification) (db-add-specification specification)
(db-add-evaluation (%db) evaluation1) (db-add-evaluation evaluation1)
(db-add-evaluation (%db) evaluation2))) (db-add-evaluation evaluation2)))
(test-assert "/build/1" (test-assert "/build/1"
(hash-table=? (hash-table=?
@ -275,4 +278,6 @@
(test-assert "db-close" (test-assert "db-close"
(db-close (%db))) (db-close (%db)))
(delete-file database-name)) (begin
(%db-channel #f)
(delete-file database-name)))