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
parent
e66e545b69
commit
4612a3a70f
|
|
@ -12,7 +12,8 @@
|
|||
(eval put 'call-with-time 'scheme-indent-function 1)
|
||||
(eval put 'test-error '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)))
|
||||
(texinfo-mode
|
||||
(indent-tabs-mode)
|
||||
|
|
|
|||
|
|
@ -115,19 +115,19 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|||
(log-message "running Fibers on ~a kernel threads" threads)
|
||||
(run-fibers
|
||||
(lambda ()
|
||||
(with-database db
|
||||
(with-database
|
||||
(and specfile
|
||||
(let ((new-specs (save-module-excursion
|
||||
(lambda ()
|
||||
(set-current-module (make-user-module '()))
|
||||
(primitive-load specfile)))))
|
||||
(for-each (lambda (spec) (db-add-specification db spec))
|
||||
(for-each (lambda (spec) (db-add-specification spec))
|
||||
new-specs)))
|
||||
(if one-shot?
|
||||
(process-specs db (db-get-specifications db))
|
||||
(process-specs (db-get-specifications))
|
||||
(let ((exit-channel (make-channel)))
|
||||
|
||||
(clear-build-queue db)
|
||||
(clear-build-queue)
|
||||
|
||||
;; First off, restart builds that had not completed or
|
||||
;; were not even started on a previous run.
|
||||
|
|
@ -135,25 +135,22 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|||
(essential-task
|
||||
'restart-builds exit-channel
|
||||
(lambda ()
|
||||
(with-database db
|
||||
(restart-builds db)))))
|
||||
(restart-builds))))
|
||||
|
||||
(spawn-fiber
|
||||
(essential-task
|
||||
'build exit-channel
|
||||
(lambda ()
|
||||
(with-database db
|
||||
(while #t
|
||||
(process-specs db (db-get-specifications db))
|
||||
(log-message "next evaluation in ~a seconds" interval)
|
||||
(sleep interval))))))
|
||||
(while #t
|
||||
(process-specs (db-get-specifications))
|
||||
(log-message "next evaluation in ~a seconds" interval)
|
||||
(sleep interval)))))
|
||||
|
||||
(spawn-fiber
|
||||
(essential-task
|
||||
'web-server exit-channel
|
||||
(lambda ()
|
||||
(with-database db
|
||||
(run-cuirass-server db #:host host #:port port))))
|
||||
(run-cuirass-server #:host host #:port port)))
|
||||
#:parallel? #t)
|
||||
|
||||
(spawn-fiber
|
||||
|
|
|
|||
|
|
@ -248,7 +248,7 @@ fibers."
|
|||
(logior (@ (fibers epoll) EPOLLERR)
|
||||
(@ (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.
|
||||
Return a list of jobs."
|
||||
(define (augment-job job eval-id)
|
||||
|
|
@ -277,8 +277,8 @@ Return a list of jobs."
|
|||
(('evaluation jobs)
|
||||
(let* ((spec-name (assq-ref spec #:name))
|
||||
(eval-id (db-add-evaluation
|
||||
db `((#:specification . ,spec-name)
|
||||
(#:commits . ,commits)))))
|
||||
`((#:specification . ,spec-name)
|
||||
(#:commits . ,commits)))))
|
||||
(log-message "created evaluation ~a for '~a'" eval-id spec-name)
|
||||
(map (lambda (job)
|
||||
(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. :-)
|
||||
(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
|
||||
been passed to 'build-derivations' (meaning that we can assume that, if their
|
||||
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)
|
||||
(((_ . outputs) ...)
|
||||
(if (any (cut valid-path? store <>) outputs)
|
||||
(db-update-build-status! db drv (build-status succeeded))
|
||||
(db-update-build-status! db drv (build-status failed))))))
|
||||
(db-update-build-status! drv (build-status succeeded))
|
||||
(db-update-build-status! drv (build-status failed))))))
|
||||
|
||||
(for-each update! lst))
|
||||
|
||||
|
|
@ -393,10 +393,11 @@ and returns the values RESULTS."
|
|||
(print-exception (current-error-port) frame key args)
|
||||
(apply values results)))))
|
||||
|
||||
(define* (spawn-builds store db drv
|
||||
(define* (spawn-builds store drv
|
||||
#:key (max-batch-size 200))
|
||||
"Build the derivations listed in DRV, updating DB as builds complete.
|
||||
Derivations are submitted in batches of at most MAX-BATCH-SIZE items."
|
||||
"Build the derivations listed in DRV, updating the database as builds
|
||||
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
|
||||
;; we benefit from as much parallelism as possible (we must be using
|
||||
;; #: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.
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(handle-build-event db event))
|
||||
(handle-build-event event))
|
||||
(exception-reporter state)))
|
||||
#t)
|
||||
(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
|
||||
;; 'build-derivations' doesn't actually do anything and
|
||||
;; 'handle-build-event' doesn't see any event. Because of that,
|
||||
;; adjust DB here.
|
||||
(update-build-statuses! store db batch)
|
||||
;; adjust the database here.
|
||||
(update-build-statuses! store batch)
|
||||
|
||||
(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',
|
||||
updating DB accordingly."
|
||||
updating the database accordingly."
|
||||
(define (valid? file)
|
||||
;; FIXME: Sometimes we might get bogus events due to the interleaving of
|
||||
;; build messages. This procedure prevents us from propagating the bogus
|
||||
|
|
@ -475,7 +476,7 @@ updating DB accordingly."
|
|||
(if (valid? drv)
|
||||
(begin
|
||||
(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)))
|
||||
(('build-remote drv host _ ...)
|
||||
(log-message "'~a' offloaded to '~a'" drv host))
|
||||
|
|
@ -483,13 +484,13 @@ updating DB accordingly."
|
|||
(if (valid? drv)
|
||||
(begin
|
||||
(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)))
|
||||
(('build-failed drv _ ...)
|
||||
(if (valid? drv)
|
||||
(begin
|
||||
(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)))
|
||||
(('substituter-started item _ ...)
|
||||
(log-message "substituter started: '~a'" item))
|
||||
|
|
@ -503,42 +504,42 @@ updating DB accordingly."
|
|||
(string=? (assq-ref build1 #:derivation)
|
||||
(assq-ref build2 #:derivation)))
|
||||
|
||||
(define (clear-build-queue db)
|
||||
"Reset the status of builds in DB that are marked as \"started\". This
|
||||
procedure is meant to be called at startup."
|
||||
(define (clear-build-queue)
|
||||
"Reset the status of builds in the database that are marked as \"started\".
|
||||
This procedure is meant to be called at startup."
|
||||
(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."
|
||||
(log-message "canceling builds older than ~a seconds..." age)
|
||||
(sqlite-exec db
|
||||
"UPDATE Builds SET status = 4 WHERE status = -2 AND timestamp < "
|
||||
(- (time-second (current-time time-utc)) age)
|
||||
";"))
|
||||
(with-db-critical-section db
|
||||
(sqlite-exec
|
||||
db "UPDATE Builds SET status = 4 WHERE status = -2 AND timestamp < "
|
||||
(- (time-second (current-time time-utc)) age) ";")))
|
||||
|
||||
(define (restart-builds db)
|
||||
"Restart builds whose status in DB is \"pending\" (scheduled or started)."
|
||||
(define (restart-builds)
|
||||
"Restart builds whose status in the database is \"pending\" (scheduled or
|
||||
started)."
|
||||
(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...")
|
||||
(let*-values (((valid stale)
|
||||
(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.
|
||||
(log-message "canceling ~a stale builds" (length stale))
|
||||
(for-each (lambda (drv)
|
||||
(db-update-build-status! db drv (build-status canceled)))
|
||||
(db-update-build-status! drv (build-status canceled)))
|
||||
stale)
|
||||
|
||||
;; 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.
|
||||
(log-message "restarting ~a pending builds" (length valid))
|
||||
(spawn-builds store db valid)
|
||||
(spawn-builds store valid)
|
||||
(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."
|
||||
(define (register job)
|
||||
(let* ((name (assq-ref job #:job-name))
|
||||
|
|
@ -570,14 +571,14 @@ procedure is meant to be called at startup."
|
|||
(#:timestamp . ,cur-time)
|
||||
(#:starttime . 0)
|
||||
(#:stoptime . 0))))
|
||||
(db-add-build db build))))
|
||||
(db-add-build build))))
|
||||
|
||||
(define derivations
|
||||
(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))
|
||||
(success (count (lambda (status)
|
||||
(= status (build-status succeeded)))
|
||||
|
|
@ -651,11 +652,11 @@ procedure is meant to be called at startup."
|
|||
checkout)
|
||||
results)))
|
||||
|
||||
(define (process-specs db jobspecs)
|
||||
"Evaluate and build JOBSPECS and store results in DB."
|
||||
(define (process-specs jobspecs)
|
||||
"Evaluate and build JOBSPECS and store results in the database."
|
||||
(define (process spec)
|
||||
(with-store store
|
||||
(let* ((stamp (db-get-stamp db spec))
|
||||
(let* ((stamp (db-get-stamp spec))
|
||||
(name (assoc-ref spec #:name))
|
||||
(checkouts (fetch-inputs spec))
|
||||
(commits (map (cut assq-ref <> #:commit) checkouts))
|
||||
|
|
@ -663,7 +664,7 @@ procedure is meant to be called at startup."
|
|||
(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 db spec commits-str)
|
||||
(db-add-stamp spec commits-str)
|
||||
(compile-checkouts spec (filter compile? checkouts))
|
||||
(spawn-fiber
|
||||
(lambda ()
|
||||
|
|
@ -674,11 +675,10 @@ procedure is meant to be called at startup."
|
|||
(log-message "evaluating spec '~a': stamp ~s different from ~s"
|
||||
name commits-str stamp)
|
||||
(with-store store
|
||||
(with-database db
|
||||
(let ((jobs (evaluate store db spec checkouts commits)))
|
||||
(log-message "building ~a jobs for '~a'"
|
||||
(length jobs) name)
|
||||
(build-packages store db jobs)))))))
|
||||
(let ((jobs (evaluate store spec checkouts commits)))
|
||||
(log-message "building ~a jobs for '~a'"
|
||||
(length jobs) name)
|
||||
(build-packages store jobs))))))
|
||||
|
||||
;; 'spawn-fiber' returns zero values but we need one.
|
||||
*unspecified*))))
|
||||
|
|
|
|||
|
|
@ -59,7 +59,9 @@
|
|||
;; Parameters.
|
||||
%package-database
|
||||
%package-schema-file
|
||||
%db-channel
|
||||
;; Macros.
|
||||
with-db-critical-section
|
||||
with-database))
|
||||
|
||||
(define (%sqlite-exec db sql . args)
|
||||
|
|
@ -139,6 +141,16 @@ question marks matches the number of arguments to bind."
|
|||
(string-append %datadir "/" %package))
|
||||
"/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)
|
||||
"Return a list of string containing SQL instructions from FILE-NAME."
|
||||
(call-with-input-file file-name
|
||||
|
|
@ -238,92 +250,111 @@ database object."
|
|||
(vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
|
||||
0))
|
||||
|
||||
(define (db-add-input db spec-name input)
|
||||
(sqlite-exec db "\
|
||||
(define (db-add-input spec-name input)
|
||||
(with-db-critical-section db
|
||||
(sqlite-exec db "\
|
||||
INSERT OR IGNORE INTO Inputs (specification, name, url, load_path, branch, \
|
||||
tag, revision, no_compile_p) VALUES ("
|
||||
spec-name ", "
|
||||
(assq-ref input #:name) ", "
|
||||
(assq-ref input #:url) ", "
|
||||
(assq-ref input #:load-path) ", "
|
||||
(assq-ref input #:branch) ", "
|
||||
(assq-ref input #:tag) ", "
|
||||
(assq-ref input #:commit) ", "
|
||||
(if (assq-ref input #:no-compile?) 1 0) ");")
|
||||
(last-insert-rowid db))
|
||||
spec-name ", "
|
||||
(assq-ref input #:name) ", "
|
||||
(assq-ref input #:url) ", "
|
||||
(assq-ref input #:load-path) ", "
|
||||
(assq-ref input #:branch) ", "
|
||||
(assq-ref input #:tag) ", "
|
||||
(assq-ref input #:commit) ", "
|
||||
(if (assq-ref input #:no-compile?) 1 0) ");")
|
||||
(last-insert-rowid db)))
|
||||
|
||||
(define (db-add-specification db spec)
|
||||
"Store SPEC in database DB. SPEC inputs are stored in the INPUTS table."
|
||||
(sqlite-exec db "\
|
||||
(define (db-add-specification spec)
|
||||
"Store SPEC in database the database. SPEC inputs are stored in the INPUTS
|
||||
table."
|
||||
(with-db-critical-section db
|
||||
(sqlite-exec db "\
|
||||
INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \
|
||||
package_path_inputs, proc_input, proc_file, proc, proc_args) \
|
||||
VALUES ("
|
||||
(assq-ref spec #:name) ", "
|
||||
(assq-ref spec #:load-path-inputs) ", "
|
||||
(assq-ref spec #:package-path-inputs)", "
|
||||
(assq-ref spec #:proc-input) ", "
|
||||
(assq-ref spec #:proc-file) ", "
|
||||
(symbol->string (assq-ref spec #:proc)) ", "
|
||||
(assq-ref spec #:proc-args) ");")
|
||||
(let ((spec-id (last-insert-rowid db)))
|
||||
(for-each (lambda (input)
|
||||
(db-add-input db (assq-ref spec #:name) input))
|
||||
(assq-ref spec #:inputs))
|
||||
spec-id))
|
||||
(assq-ref spec #:name) ", "
|
||||
(assq-ref spec #:load-path-inputs) ", "
|
||||
(assq-ref spec #:package-path-inputs) ", "
|
||||
(assq-ref spec #:proc-input) ", "
|
||||
(assq-ref spec #:proc-file) ", "
|
||||
(symbol->string (assq-ref spec #:proc)) ", "
|
||||
(assq-ref spec #:proc-args) ");")
|
||||
(let ((spec-id (last-insert-rowid db)))
|
||||
(for-each (lambda (input)
|
||||
(db-add-input (assq-ref spec #:name) input))
|
||||
(assq-ref spec #:inputs))
|
||||
spec-id)))
|
||||
|
||||
(define (db-get-inputs db spec-name)
|
||||
(let loop ((rows (sqlite-exec db "SELECT * FROM Inputs WHERE specification="
|
||||
spec-name ";"))
|
||||
(inputs '()))
|
||||
(match rows
|
||||
(() inputs)
|
||||
((#(specification name url load-path branch tag revision no-compile-p)
|
||||
. rest)
|
||||
(loop rest
|
||||
(cons `((#:name . ,name)
|
||||
(#:url . ,url)
|
||||
(#:load-path . ,load-path)
|
||||
(#:branch . ,branch)
|
||||
(#:tag . ,tag)
|
||||
(#:commit . ,revision)
|
||||
(#:no-compile? . ,(positive? no-compile-p)))
|
||||
inputs))))))
|
||||
(define (db-get-inputs spec-name)
|
||||
(with-db-critical-section db
|
||||
(let loop ((rows (sqlite-exec
|
||||
db "SELECT * FROM Inputs WHERE specification="
|
||||
spec-name ";"))
|
||||
(inputs '()))
|
||||
(match rows
|
||||
(() inputs)
|
||||
((#(specification name url load-path branch tag revision no-compile-p)
|
||||
. rest)
|
||||
(loop rest
|
||||
(cons `((#:name . ,name)
|
||||
(#:url . ,url)
|
||||
(#:load-path . ,load-path)
|
||||
(#:branch . ,branch)
|
||||
(#:tag . ,tag)
|
||||
(#:commit . ,revision)
|
||||
(#:no-compile? . ,(positive? no-compile-p)))
|
||||
inputs)))))))
|
||||
|
||||
(define (db-get-specifications db)
|
||||
(let loop ((rows (sqlite-exec db "SELECT * FROM Specifications;"))
|
||||
(specs '()))
|
||||
(match rows
|
||||
(() specs)
|
||||
((#(name load-path-inputs package-path-inputs proc-input proc-file proc
|
||||
proc-args)
|
||||
. rest)
|
||||
(loop rest
|
||||
(cons `((#:name . ,name)
|
||||
(#:load-path-inputs .
|
||||
,(with-input-from-string load-path-inputs read))
|
||||
(#:package-path-inputs .
|
||||
,(with-input-from-string package-path-inputs read))
|
||||
(#:proc-input . ,proc-input)
|
||||
(#:proc-file . ,proc-file)
|
||||
(#:proc . ,(with-input-from-string proc read))
|
||||
(#:proc-args . ,(with-input-from-string proc-args read))
|
||||
(#:inputs . ,(db-get-inputs db name)))
|
||||
specs))))))
|
||||
(define (db-get-specifications)
|
||||
(with-db-critical-section db
|
||||
(let loop ((rows (sqlite-exec db "SELECT * FROM Specifications;"))
|
||||
(specs '()))
|
||||
(match rows
|
||||
(() specs)
|
||||
((#(name load-path-inputs package-path-inputs proc-input proc-file proc
|
||||
proc-args)
|
||||
. rest)
|
||||
(loop rest
|
||||
(cons `((#:name . ,name)
|
||||
(#:load-path-inputs .
|
||||
,(with-input-from-string load-path-inputs read))
|
||||
(#:package-path-inputs .
|
||||
,(with-input-from-string package-path-inputs read))
|
||||
(#:proc-input . ,proc-input)
|
||||
(#:proc-file . ,proc-file)
|
||||
(#:proc . ,(with-input-from-string proc read))
|
||||
(#:proc-args . ,(with-input-from-string proc-args read))
|
||||
(#:inputs . ,(db-get-inputs name)))
|
||||
specs)))))))
|
||||
|
||||
(define (db-add-evaluation db eval)
|
||||
(sqlite-exec db "\
|
||||
(define (db-add-evaluation eval)
|
||||
(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))
|
||||
(assq-ref eval #:specification) ", "
|
||||
(string-join (assq-ref eval #:commits)) ");")
|
||||
(last-insert-rowid db)))
|
||||
|
||||
(define-syntax-rule (with-database db body ...)
|
||||
"Run BODY with a connection to the database which is bound to DB in BODY."
|
||||
(define-syntax-rule (with-database 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
|
||||
;; continuations and fibers. But as a consequence, we leak DB when BODY
|
||||
;; raises an exception.
|
||||
(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)))
|
||||
"Read all of the characters out of PORT and return them as a SQL quoted
|
||||
|
|
@ -353,79 +384,84 @@ string."
|
|||
(failed-other 3)
|
||||
(canceled 4))
|
||||
|
||||
(define (db-add-build db build)
|
||||
"Store BUILD in database DB. BUILD eventual outputs are stored
|
||||
in the OUTPUTS table."
|
||||
(catch 'sqlite-error
|
||||
(lambda ()
|
||||
(sqlite-exec db "
|
||||
(define (db-add-build build)
|
||||
"Store BUILD in database the database. BUILD eventual outputs are stored in
|
||||
the OUTPUTS table."
|
||||
(with-db-critical-section db
|
||||
(catch 'sqlite-error
|
||||
(lambda ()
|
||||
(sqlite-exec db "
|
||||
INSERT INTO Builds (derivation, evaluation, job_name, system, nix_name, log,
|
||||
status, timestamp, starttime, stoptime)
|
||||
VALUES ("
|
||||
(assq-ref build #:derivation) ", "
|
||||
(assq-ref build #:eval-id) ", "
|
||||
(assq-ref build #:job-name) ", "
|
||||
(assq-ref build #:system) ", "
|
||||
(assq-ref build #:nix-name) ", "
|
||||
(assq-ref build #:log) ", "
|
||||
(or (assq-ref build #:status)
|
||||
(build-status scheduled)) ", "
|
||||
(or (assq-ref build #:timestamp) 0) ", "
|
||||
(or (assq-ref build #:starttime) 0) ", "
|
||||
(or (assq-ref build #:stoptime) 0) ");")
|
||||
(let ((derivation (assq-ref build #:derivation)))
|
||||
(for-each (lambda (output)
|
||||
(match output
|
||||
((name . path)
|
||||
(sqlite-exec db "\
|
||||
(assq-ref build #:derivation) ", "
|
||||
(assq-ref build #:eval-id) ", "
|
||||
(assq-ref build #:job-name) ", "
|
||||
(assq-ref build #:system) ", "
|
||||
(assq-ref build #:nix-name) ", "
|
||||
(assq-ref build #:log) ", "
|
||||
(or (assq-ref build #:status)
|
||||
(build-status scheduled)) ", "
|
||||
(or (assq-ref build #:timestamp) 0) ", "
|
||||
(or (assq-ref build #:starttime) 0) ", "
|
||||
(or (assq-ref build #:stoptime) 0) ");")
|
||||
(let ((derivation (assq-ref build #:derivation)))
|
||||
(for-each (lambda (output)
|
||||
(match output
|
||||
((name . path)
|
||||
(sqlite-exec db "\
|
||||
INSERT INTO Outputs (derivation, name, path) VALUES ("
|
||||
derivation ", " name ", " path ");"))))
|
||||
(assq-ref build #:outputs))
|
||||
derivation))
|
||||
(lambda (key who code message . rest)
|
||||
;; If we get a unique-constraint-failed error, that means we have
|
||||
;; already inserted the same build. That happens when several jobs
|
||||
;; produce the same derivation, and we can ignore it.
|
||||
(if (= code SQLITE_CONSTRAINT_PRIMARYKEY)
|
||||
#f
|
||||
(apply throw key who code rest)))))
|
||||
derivation ", " name ", " path ");"))))
|
||||
(assq-ref build #:outputs))
|
||||
derivation))
|
||||
(lambda (key who code message . rest)
|
||||
;; If we get a unique-constraint-failed error, that means we have
|
||||
;; already inserted the same build. That happens when several jobs
|
||||
;; produce the same derivation, and we can ignore it.
|
||||
(if (= code SQLITE_CONSTRAINT_PRIMARYKEY)
|
||||
#f
|
||||
(apply throw key who code rest))))))
|
||||
|
||||
(define* (db-update-build-status! db drv status #:key log-file)
|
||||
"Update DB so that DRV's status is STATUS. This also updates the
|
||||
(define* (db-update-build-status! drv status #:key log-file)
|
||||
"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
|
||||
log file for DRV."
|
||||
(define now
|
||||
(time-second (current-time time-utc)))
|
||||
|
||||
(if (= status (build-status started))
|
||||
(sqlite-exec db "UPDATE Builds SET starttime=" now ", status="
|
||||
status "WHERE derivation=" drv ";")
|
||||
(with-db-critical-section db
|
||||
(if (= status (build-status started))
|
||||
(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
|
||||
;; things unchanged. This ensures that 'stoptime' remains valid and
|
||||
;; doesn't change every time we mark DRV as 'succeeded' several times in
|
||||
;; a row, for instance.
|
||||
(if log-file
|
||||
(sqlite-exec db "UPDATE Builds SET stoptime=" now
|
||||
", status=" status ", log=" log-file
|
||||
"WHERE derivation=" drv "AND status != " status ";")
|
||||
(sqlite-exec db "UPDATE Builds SET stoptime=" now
|
||||
", status=" status
|
||||
"WHERE derivation=" drv " AND status != " status ";"))))
|
||||
;; Update only if we're switching to a different status; otherwise
|
||||
;; leave things unchanged. This ensures that 'stoptime' remains valid
|
||||
;; and doesn't change every time we mark DRV as 'succeeded' several
|
||||
;; times in a row, for instance.
|
||||
(if log-file
|
||||
(sqlite-exec db "UPDATE Builds SET stoptime=" now
|
||||
", status=" status ", log=" log-file
|
||||
"WHERE derivation=" drv "AND status != " status ";")
|
||||
(sqlite-exec db "UPDATE Builds SET stoptime=" now
|
||||
", status=" status
|
||||
"WHERE derivation=" drv " AND status != " status
|
||||
";")))))
|
||||
|
||||
(define (db-get-outputs db derivation)
|
||||
"Retrieve the OUTPUTS of the build identified by DERIVATION in DB database."
|
||||
(let loop ((rows
|
||||
(sqlite-exec db "SELECT name, path FROM Outputs
|
||||
(define (db-get-outputs derivation)
|
||||
"Retrieve the OUTPUTS of the build identified by DERIVATION in the
|
||||
database."
|
||||
(with-db-critical-section db
|
||||
(let loop ((rows
|
||||
(sqlite-exec db "SELECT name, path FROM Outputs
|
||||
WHERE derivation =" derivation ";"))
|
||||
(outputs '()))
|
||||
(match rows
|
||||
(() outputs)
|
||||
((#(name path)
|
||||
. rest)
|
||||
(loop rest
|
||||
(cons `(,name . ((#:path . ,path)))
|
||||
outputs))))))
|
||||
(outputs '()))
|
||||
(match rows
|
||||
(() outputs)
|
||||
((#(name path)
|
||||
. rest)
|
||||
(loop rest
|
||||
(cons `(,name . ((#:path . ,path)))
|
||||
outputs)))))))
|
||||
|
||||
(define (filters->order filters)
|
||||
(match (assq 'order filters)
|
||||
|
|
@ -440,12 +476,13 @@ WHERE derivation =" derivation ";"))
|
|||
(('order . 'status+submission-time) "status DESC, timestamp DESC")
|
||||
(_ "rowid DESC")))
|
||||
|
||||
(define (db-get-builds db filters)
|
||||
"Retrieve all builds in database DB which are matched by given FILTERS.
|
||||
(define (db-get-builds 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 |
|
||||
'job | 'system | 'nr | 'order | 'status | 'evaluation."
|
||||
(let* ((order (filters->order filters))
|
||||
(stmt-text (format #f "SELECT * FROM (
|
||||
(with-db-critical-section db
|
||||
(let* ((order (filters->order filters))
|
||||
(stmt-text (format #f "SELECT * FROM (
|
||||
SELECT Builds.derivation, Builds.rowid, Builds.timestamp, Builds.starttime,
|
||||
Builds.stoptime, Builds.log, Builds.status, Builds.job_name, Builds.system,
|
||||
Builds.nix_name, Specifications.name
|
||||
|
|
@ -475,93 +512,99 @@ CASE WHEN :borderlowtime IS NULL
|
|||
END DESC
|
||||
LIMIT :nr)
|
||||
ORDER BY ~a, rowid ASC;" order))
|
||||
(stmt (sqlite-prepare db stmt-text #:cache? #t)))
|
||||
(sqlite-bind-arguments
|
||||
stmt
|
||||
#:derivation (assq-ref filters 'derivation)
|
||||
#:id (assq-ref filters 'id)
|
||||
#:jobset (assq-ref filters 'jobset)
|
||||
#:job (assq-ref filters 'job)
|
||||
#:evaluation (assq-ref filters 'evaluation)
|
||||
#:system (assq-ref filters 'system)
|
||||
#:status (and=> (assq-ref filters 'status) object->string)
|
||||
#:borderlowid (assq-ref filters 'border-low-id)
|
||||
#:borderhighid (assq-ref filters 'border-high-id)
|
||||
#:borderlowtime (assq-ref filters 'border-low-time)
|
||||
#:borderhightime (assq-ref filters 'border-high-time)
|
||||
#:nr (match (assq-ref filters 'nr)
|
||||
(#f -1)
|
||||
(x x)))
|
||||
(sqlite-reset stmt)
|
||||
(let loop ((rows (sqlite-fold-right cons '() stmt))
|
||||
(builds '()))
|
||||
(match rows
|
||||
(() (reverse builds))
|
||||
((#(derivation id timestamp starttime stoptime log status job-name
|
||||
system nix-name specification) . rest)
|
||||
(loop rest
|
||||
(cons `((#:derivation . ,derivation)
|
||||
(#:id . ,id)
|
||||
(#:timestamp . ,timestamp)
|
||||
(#:starttime . ,starttime)
|
||||
(#:stoptime . ,stoptime)
|
||||
(#:log . ,log)
|
||||
(#:status . ,status)
|
||||
(#:job-name . ,job-name)
|
||||
(#:system . ,system)
|
||||
(#:nix-name . ,nix-name)
|
||||
(#:specification . ,specification)
|
||||
(#:outputs . ,(db-get-outputs db derivation)))
|
||||
builds)))))))
|
||||
(stmt (sqlite-prepare db stmt-text #:cache? #t)))
|
||||
(sqlite-bind-arguments
|
||||
stmt
|
||||
#:derivation (assq-ref filters 'derivation)
|
||||
#:id (assq-ref filters 'id)
|
||||
#:jobset (assq-ref filters 'jobset)
|
||||
#:job (assq-ref filters 'job)
|
||||
#:evaluation (assq-ref filters 'evaluation)
|
||||
#:system (assq-ref filters 'system)
|
||||
#:status (and=> (assq-ref filters 'status) object->string)
|
||||
#:borderlowid (assq-ref filters 'border-low-id)
|
||||
#:borderhighid (assq-ref filters 'border-high-id)
|
||||
#:borderlowtime (assq-ref filters 'border-low-time)
|
||||
#:borderhightime (assq-ref filters 'border-high-time)
|
||||
#:nr (match (assq-ref filters 'nr)
|
||||
(#f -1)
|
||||
(x x)))
|
||||
(sqlite-reset stmt)
|
||||
(let loop ((rows (sqlite-fold-right cons '() stmt))
|
||||
(builds '()))
|
||||
(match rows
|
||||
(() (reverse builds))
|
||||
((#(derivation id timestamp starttime stoptime log status job-name
|
||||
system nix-name specification) . rest)
|
||||
(loop rest
|
||||
(cons `((#:derivation . ,derivation)
|
||||
(#:id . ,id)
|
||||
(#:timestamp . ,timestamp)
|
||||
(#:starttime . ,starttime)
|
||||
(#:stoptime . ,stoptime)
|
||||
(#:log . ,log)
|
||||
(#:status . ,status)
|
||||
(#:job-name . ,job-name)
|
||||
(#:system . ,system)
|
||||
(#:nix-name . ,nix-name)
|
||||
(#:specification . ,specification)
|
||||
(#:outputs . ,(db-get-outputs derivation)))
|
||||
builds))))))))
|
||||
|
||||
(define (db-get-build db derivation-or-id)
|
||||
"Retrieve a build in database DB which corresponds to DERIVATION-OR-ID."
|
||||
(let ((key (if (number? derivation-or-id) 'id 'derivation)))
|
||||
(match (db-get-builds db `((,key . ,derivation-or-id)))
|
||||
((build)
|
||||
build)
|
||||
(() #f))))
|
||||
(define (db-get-build derivation-or-id)
|
||||
"Retrieve a build in the database which corresponds to DERIVATION-OR-ID."
|
||||
(with-db-critical-section db
|
||||
(let ((key (if (number? derivation-or-id) 'id 'derivation)))
|
||||
(match (db-get-builds `((,key . ,derivation-or-id)))
|
||||
((build)
|
||||
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
|
||||
DB. The returned list is guaranteed to not have any duplicates."
|
||||
(map (match-lambda (#(drv) drv))
|
||||
(sqlite-exec db "
|
||||
SELECT derivation FROM Builds WHERE Builds.status < 0;")))
|
||||
the database. The returned list is guaranteed to not have any duplicates."
|
||||
(with-db-critical-section db
|
||||
(map (match-lambda (#(drv) drv))
|
||||
(sqlite-exec db "
|
||||
SELECT derivation FROM Builds WHERE Builds.status < 0;"))))
|
||||
|
||||
(define (db-get-stamp db spec)
|
||||
"Return a stamp corresponding to specification SPEC in database DB."
|
||||
(let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification="
|
||||
(assq-ref spec #:name) ";")))
|
||||
(match res
|
||||
(() #f)
|
||||
((#(spec stamp)) stamp))))
|
||||
(define (db-get-stamp spec)
|
||||
"Return a stamp corresponding to specification SPEC in the database."
|
||||
(with-db-critical-section db
|
||||
(let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification="
|
||||
(assq-ref spec #:name) ";")))
|
||||
(match res
|
||||
(() #f)
|
||||
((#(spec stamp)) stamp)))))
|
||||
|
||||
(define (db-add-stamp db spec stamp)
|
||||
"Associate STAMP to specification SPEC in database DB."
|
||||
(if (db-get-stamp db spec)
|
||||
(sqlite-exec db "UPDATE Stamps SET stamp=" stamp
|
||||
"WHERE specification=" (assq-ref spec #:name) ";")
|
||||
(sqlite-exec db "\
|
||||
(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 ");")))
|
||||
(assq-ref spec #:name) ", " stamp ");"))))
|
||||
|
||||
(define (db-get-evaluations db limit)
|
||||
(let loop ((rows (sqlite-exec db "SELECT id, specification, commits
|
||||
(define (db-get-evaluations limit)
|
||||
(with-db-critical-section db
|
||||
(let loop ((rows (sqlite-exec db "SELECT id, specification, commits
|
||||
FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
|
||||
(evaluations '()))
|
||||
(match rows
|
||||
(() (reverse evaluations))
|
||||
((#(id specification commits)
|
||||
. rest)
|
||||
(loop rest
|
||||
(cons `((#:id . ,id)
|
||||
(#:specification . ,specification)
|
||||
(#:commits . ,(string-tokenize commits)))
|
||||
evaluations))))))
|
||||
(evaluations '()))
|
||||
(match rows
|
||||
(() (reverse evaluations))
|
||||
((#(id specification commits)
|
||||
. rest)
|
||||
(loop rest
|
||||
(cons `((#:id . ,id)
|
||||
(#:specification . ,specification)
|
||||
(#:commits . ,(string-tokenize commits)))
|
||||
evaluations)))))))
|
||||
|
||||
(define (db-get-evaluations-build-summary db spec limit border-low border-high)
|
||||
(let loop ((rows (sqlite-exec db "
|
||||
(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
|
||||
FROM
|
||||
(SELECT id, commits
|
||||
|
|
@ -578,50 +621,54 @@ FROM Builds
|
|||
GROUP BY evaluation) B
|
||||
ON B.evaluation=E.id
|
||||
ORDER BY E.id ASC;"))
|
||||
(evaluations '()))
|
||||
(match rows
|
||||
(() evaluations)
|
||||
((#(id commits succeeded failed scheduled) . rest)
|
||||
(loop rest
|
||||
(cons `((#:id . ,id)
|
||||
(#:commits . ,commits)
|
||||
(#:succeeded . ,(or succeeded 0))
|
||||
(#:failed . ,(or failed 0))
|
||||
(#:scheduled . ,(or scheduled 0)))
|
||||
evaluations))))))
|
||||
(evaluations '()))
|
||||
(match rows
|
||||
(() evaluations)
|
||||
((#(id commits succeeded failed scheduled) . rest)
|
||||
(loop rest
|
||||
(cons `((#:id . ,id)
|
||||
(#:commits . ,commits)
|
||||
(#:succeeded . ,(or succeeded 0))
|
||||
(#:failed . ,(or failed 0))
|
||||
(#:scheduled . ,(or scheduled 0)))
|
||||
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."
|
||||
(let ((rows (sqlite-exec db "
|
||||
(with-db-critical-section db
|
||||
(let ((rows (sqlite-exec db "
|
||||
SELECT MIN(id) FROM Evaluations
|
||||
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."
|
||||
(let ((rows (sqlite-exec db "
|
||||
(with-db-critical-section db
|
||||
(let ((rows (sqlite-exec db "
|
||||
SELECT MAX(id) FROM Evaluations
|
||||
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
|
||||
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 rowid, stoptime FROM Builds
|
||||
WHERE evaluation=" eval " AND
|
||||
stoptime = (SELECT MIN(stoptime)
|
||||
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
|
||||
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 rowid, stoptime FROM Builds
|
||||
WHERE evaluation=" eval " AND
|
||||
stoptime = (SELECT MAX(stoptime)
|
||||
FROM Builds WHERE evaluation=" eval "))")))
|
||||
(vector->list (car rows))))
|
||||
(vector->list (car rows)))))
|
||||
|
|
|
|||
|
|
@ -103,17 +103,17 @@
|
|||
(#:releasename . #nil)
|
||||
(#:buildinputs_builds . #nil)))
|
||||
|
||||
(define (handle-build-request db build-id)
|
||||
"Retrieve build identified by BUILD-ID over DB and convert it
|
||||
to hydra format. Return #f is not build was found."
|
||||
(let ((build (db-get-build db build-id)))
|
||||
(define (handle-build-request build-id)
|
||||
"Retrieve build identified by BUILD-ID over the database and convert it to
|
||||
hydra format. Return #f is not build was found."
|
||||
(let ((build (db-get-build build-id)))
|
||||
(and=> build build->hydra-build)))
|
||||
|
||||
(define (handle-builds-request db filters)
|
||||
"Retrieve all builds matched by FILTERS in DB and convert them
|
||||
to Hydra format."
|
||||
(define (handle-builds-request filters)
|
||||
"Retrieve all builds matched by FILTERS in the database and convert them to
|
||||
Hydra format."
|
||||
(let ((builds (with-time-logging "builds request"
|
||||
(db-get-builds db filters))))
|
||||
(db-get-builds filters))))
|
||||
(map build->hydra-build builds)))
|
||||
|
||||
(define (request-parameters request)
|
||||
|
|
@ -146,10 +146,10 @@
|
|||
(define (request-path-components 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))
|
||||
(values response body db-channel))
|
||||
(define* (respond response #:key body)
|
||||
(values response body #f))
|
||||
|
||||
(define-syntax-rule (respond-json body ...)
|
||||
(respond '((content-type . (application/json)))
|
||||
|
|
@ -213,19 +213,14 @@
|
|||
(request-path-components request)
|
||||
'method-not-allowed)
|
||||
(((or "jobsets" "specifications") . rest)
|
||||
(respond-json (object->json-string
|
||||
(with-critical-section db-channel (db)
|
||||
(db-get-specifications db)))))
|
||||
(respond-json (object->json-string (db-get-specifications))))
|
||||
(("build" build-id)
|
||||
(let ((hydra-build
|
||||
(with-critical-section db-channel (db)
|
||||
(handle-build-request db (string->number build-id)))))
|
||||
(let ((hydra-build (handle-build-request (string->number build-id))))
|
||||
(if hydra-build
|
||||
(respond-json (object->json-string hydra-build))
|
||||
(respond-build-not-found build-id))))
|
||||
(("build" build-id "log" "raw")
|
||||
(let ((build (with-critical-section db-channel (db)
|
||||
(db-get-build db (string->number build-id)))))
|
||||
(let ((build (db-get-build (string->number build-id))))
|
||||
(if build
|
||||
(match (assq-ref build #:outputs)
|
||||
(((_ (#:path . (? string? output))) _ ...)
|
||||
|
|
@ -250,9 +245,7 @@
|
|||
;; 'nr parameter is mandatory to limit query size.
|
||||
(nr (assq-ref params 'nr)))
|
||||
(if nr
|
||||
(respond-json (object->json-string
|
||||
(with-critical-section db-channel (db)
|
||||
(db-get-evaluations db nr))))
|
||||
(respond-json (object->json-string (db-get-evaluations nr)))
|
||||
(respond-json-with-error 500 "Parameter not defined!"))))
|
||||
(("api" "latestbuilds")
|
||||
(let* ((params (request-parameters request))
|
||||
|
|
@ -262,10 +255,9 @@
|
|||
;; Limit results to builds that are "done".
|
||||
(respond-json
|
||||
(object->json-string
|
||||
(with-critical-section db-channel (db)
|
||||
(handle-builds-request db `((status . done)
|
||||
,@params
|
||||
(order . finish-time))))))
|
||||
(handle-builds-request `((status . done)
|
||||
,@params
|
||||
(order . finish-time)))))
|
||||
(respond-json-with-error 500 "Parameter not defined!"))))
|
||||
(("api" "queue")
|
||||
(let* ((params (request-parameters request))
|
||||
|
|
@ -276,77 +268,65 @@
|
|||
(object->json-string
|
||||
;; Use the 'status+submission-time' order so that builds in
|
||||
;; 'running' state appear before builds in 'scheduled' state.
|
||||
(with-critical-section db-channel (db)
|
||||
(handle-builds-request db `((status . pending)
|
||||
,@params
|
||||
(order . status+submission-time))))))
|
||||
(handle-builds-request `((status . pending)
|
||||
,@params
|
||||
(order . status+submission-time)))))
|
||||
(respond-json-with-error 500 "Parameter not defined!"))))
|
||||
('()
|
||||
(respond-html (html-page
|
||||
"Cuirass"
|
||||
(specifications-table
|
||||
(with-critical-section db-channel (db)
|
||||
(db-get-specifications db))))))
|
||||
(specifications-table (db-get-specifications)))))
|
||||
|
||||
(("jobset" name)
|
||||
(respond-html
|
||||
(with-critical-section db-channel (db)
|
||||
(let* ((evaluation-id-max (db-get-evaluations-id-max db name))
|
||||
(evaluation-id-min (db-get-evaluations-id-min db name))
|
||||
(params (request-parameters request))
|
||||
(border-high (assq-ref params 'border-high))
|
||||
(border-low (assq-ref params 'border-low))
|
||||
(evaluations (db-get-evaluations-build-summary db
|
||||
name
|
||||
%page-size
|
||||
border-low
|
||||
border-high)))
|
||||
(html-page name (evaluation-info-table name
|
||||
evaluations
|
||||
evaluation-id-min
|
||||
evaluation-id-max))))))
|
||||
(let* ((evaluation-id-max (db-get-evaluations-id-max name))
|
||||
(evaluation-id-min (db-get-evaluations-id-min name))
|
||||
(params (request-parameters request))
|
||||
(border-high (assq-ref params 'border-high))
|
||||
(border-low (assq-ref params 'border-low))
|
||||
(evaluations (db-get-evaluations-build-summary name
|
||||
%page-size
|
||||
border-low
|
||||
border-high)))
|
||||
(html-page name (evaluation-info-table name
|
||||
evaluations
|
||||
evaluation-id-min
|
||||
evaluation-id-max)))))
|
||||
|
||||
(("eval" id)
|
||||
(respond-html
|
||||
(with-critical-section db-channel (db)
|
||||
(let* ((builds-id-max (db-get-builds-max db id))
|
||||
(builds-id-min (db-get-builds-min db id))
|
||||
(params (request-parameters request))
|
||||
(border-high-time (assq-ref params 'border-high-time))
|
||||
(border-low-time (assq-ref params 'border-low-time))
|
||||
(border-high-id (assq-ref params 'border-high-id))
|
||||
(border-low-id (assq-ref params 'border-low-id)))
|
||||
(html-page
|
||||
"Evaluation"
|
||||
(build-eval-table
|
||||
(handle-builds-request db `((evaluation . ,id)
|
||||
(nr . ,%page-size)
|
||||
(order . finish-time+build-id)
|
||||
(border-high-time . ,border-high-time)
|
||||
(border-low-time . ,border-low-time)
|
||||
(border-high-id . ,border-high-id)
|
||||
(border-low-id . ,border-low-id)))
|
||||
builds-id-min
|
||||
builds-id-max))))))
|
||||
(let* ((builds-id-max (db-get-builds-max id))
|
||||
(builds-id-min (db-get-builds-min id))
|
||||
(params (request-parameters request))
|
||||
(border-high-time (assq-ref params 'border-high-time))
|
||||
(border-low-time (assq-ref params 'border-low-time))
|
||||
(border-high-id (assq-ref params 'border-high-id))
|
||||
(border-low-id (assq-ref params 'border-low-id)))
|
||||
(html-page
|
||||
"Evaluation"
|
||||
(build-eval-table
|
||||
(handle-builds-request `((evaluation . ,id)
|
||||
(nr . ,%page-size)
|
||||
(order . finish-time+build-id)
|
||||
(border-high-time . ,border-high-time)
|
||||
(border-low-time . ,border-low-time)
|
||||
(border-high-id . ,border-high-id)
|
||||
(border-low-id . ,border-low-id)))
|
||||
builds-id-min
|
||||
builds-id-max)))))
|
||||
|
||||
(("static" path ...)
|
||||
(respond-static-file path))
|
||||
('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))))))
|
||||
|
||||
(define* (run-cuirass-server db #:key (host "localhost") (port 8080))
|
||||
(define* (run-cuirass-server #:key (host "localhost") (port 8080))
|
||||
(let* ((host-info (gethostbyname host))
|
||||
(address (inet-ntop (hostent:addrtype 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)))
|
||||
(car (hostent:addr-list host-info)))))
|
||||
(log-message "listening on ~A:~A" address port)
|
||||
|
||||
;; Here we use our own web backend, call 'fiberized'. We cannot use the
|
||||
|
|
@ -371,7 +351,7 @@
|
|||
(spawn-fiber
|
||||
(lambda ()
|
||||
(let-values (((response body state)
|
||||
(handle-request (cut url-handler <> <> db-channel)
|
||||
(handle-request (cut url-handler <> <>)
|
||||
request body '())))
|
||||
(write-client impl server client response body)))))
|
||||
(loop)))))
|
||||
|
|
|
|||
|
|
@ -103,17 +103,18 @@ then be passed to 'join-critical-section', which will ensure sequential
|
|||
ordering. ARGS are the arguments of the critical section.
|
||||
|
||||
Critical sections are implemented by passing the procedure to execute to a
|
||||
dedicated fiber."
|
||||
(let ((channel (make-channel)))
|
||||
(spawn-fiber
|
||||
(lambda ()
|
||||
(parameterize ((%critical-section-args args))
|
||||
(let loop ()
|
||||
(match (get-message channel)
|
||||
(((? channel? reply) . (? procedure? proc))
|
||||
(put-message reply (apply proc args))))
|
||||
(loop)))))
|
||||
channel))
|
||||
dedicated thread."
|
||||
(parameterize (((@@ (fibers internal) current-fiber) #f))
|
||||
(let ((channel (make-channel)))
|
||||
(call-with-new-thread
|
||||
(lambda ()
|
||||
(parameterize ((%critical-section-args args))
|
||||
(let loop ()
|
||||
(match (get-message channel)
|
||||
(((? channel? reply) . (? procedure? proc))
|
||||
(put-message reply (apply proc args))))
|
||||
(loop)))))
|
||||
channel)))
|
||||
|
||||
(define (call-with-critical-section channel proc)
|
||||
"Send PROC to the critical section through CHANNEL. Return the result of
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@
|
|||
|
||||
(use-modules (cuirass database)
|
||||
((guix utils) #:select (call-with-temporary-output-file))
|
||||
(cuirass utils)
|
||||
(srfi srfi-64))
|
||||
|
||||
(define example-spec
|
||||
|
|
@ -61,12 +62,12 @@
|
|||
(#:log . "log")
|
||||
(#:outputs . (("foo" . "/foo")))))
|
||||
|
||||
(define-syntax-rule (with-temporary-database db body ...)
|
||||
(define-syntax-rule (with-temporary-database body ...)
|
||||
(call-with-temporary-output-file
|
||||
(lambda (file port)
|
||||
(parameterize ((%package-database file))
|
||||
(db-init file)
|
||||
(with-database db
|
||||
(with-database
|
||||
body ...)))))
|
||||
|
||||
(define %db
|
||||
|
|
@ -79,7 +80,10 @@
|
|||
|
||||
(test-group-with-cleanup "database"
|
||||
(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"
|
||||
(begin
|
||||
|
|
@ -94,41 +98,40 @@ INSERT INTO Evaluations (specification, commits) VALUES (3, 3);")
|
|||
(test-equal "db-add-specification"
|
||||
example-spec
|
||||
(begin
|
||||
(db-add-specification (%db) example-spec)
|
||||
(car (db-get-specifications (%db)))))
|
||||
(db-add-specification example-spec)
|
||||
(car (db-get-specifications))))
|
||||
|
||||
(test-equal "db-add-build"
|
||||
#f
|
||||
(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
|
||||
;; there, see <https://bugs.gnu.org/28094>.
|
||||
(db-add-build (%db) build)))
|
||||
(db-add-build build)))
|
||||
|
||||
(test-equal "db-update-build-status!"
|
||||
(list (build-status scheduled)
|
||||
(build-status started)
|
||||
(build-status succeeded)
|
||||
"/foo.drv.log")
|
||||
(with-temporary-database db
|
||||
(with-temporary-database
|
||||
(let* ((derivation (db-add-build
|
||||
db
|
||||
(make-dummy-build "/foo.drv" 1
|
||||
#:outputs '(("out" . "/foo")))))
|
||||
(get-status (lambda* (#:optional (key #:status))
|
||||
(assq-ref (db-get-build db derivation) key))))
|
||||
(db-add-evaluation db (make-dummy-eval))
|
||||
(db-add-specification db example-spec)
|
||||
(assq-ref (db-get-build derivation) key))))
|
||||
(db-add-evaluation (make-dummy-eval))
|
||||
(db-add-specification example-spec)
|
||||
|
||||
(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)))
|
||||
(db-update-build-status! db "/foo.drv" (build-status succeeded)
|
||||
(db-update-build-status! "/foo.drv" (build-status succeeded)
|
||||
#:log-file "/foo.drv.log")
|
||||
|
||||
;; 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")
|
||||
|
||||
(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")) ;nr = 1
|
||||
((2 "/bar.drv") (1 "/foo.drv") (3 "/baz.drv"))) ;status+submission-time
|
||||
(with-temporary-database db
|
||||
(with-temporary-database
|
||||
;; Populate the 'Builds'', 'Evaluations', and
|
||||
;; 'Specifications' tables in a consistent way, as expected by the
|
||||
;; 'db-get-builds' query.
|
||||
(db-add-build db (make-dummy-build "/foo.drv" 1
|
||||
#:outputs `(("out" . "/foo"))))
|
||||
(db-add-build db (make-dummy-build "/bar.drv" 2
|
||||
#:outputs `(("out" . "/bar"))))
|
||||
(db-add-build db (make-dummy-build "/baz.drv" 3
|
||||
#:outputs `(("out" . "/baz"))))
|
||||
(db-add-evaluation db (make-dummy-eval))
|
||||
(db-add-evaluation db (make-dummy-eval))
|
||||
(db-add-evaluation db (make-dummy-eval))
|
||||
(db-add-specification db example-spec)
|
||||
(db-add-build (make-dummy-build "/foo.drv" 1
|
||||
#:outputs `(("out" . "/foo"))))
|
||||
(db-add-build (make-dummy-build "/bar.drv" 2
|
||||
#: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-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")
|
||||
|
||||
(let ((summarize (lambda (alist)
|
||||
(list (assq-ref alist #:id)
|
||||
(assq-ref alist #:derivation)))))
|
||||
(vector (map summarize (db-get-builds db '((nr . 3)
|
||||
(order . build-id))))
|
||||
(map summarize (db-get-builds db '()))
|
||||
(map summarize (db-get-builds db '((jobset . "guix"))))
|
||||
(map summarize (db-get-builds db '((nr . 1))))
|
||||
(vector (map summarize (db-get-builds '((nr . 3) (order . build-id))))
|
||||
(map summarize (db-get-builds '()))
|
||||
(map summarize (db-get-builds '((jobset . "guix"))))
|
||||
(map summarize (db-get-builds '((nr . 1))))
|
||||
(map summarize
|
||||
(db-get-builds
|
||||
db '((order . status+submission-time))))))))
|
||||
(db-get-builds '((order . status+submission-time))))))))
|
||||
|
||||
(test-equal "db-get-pending-derivations"
|
||||
'("/bar.drv" "/foo.drv")
|
||||
(with-temporary-database db
|
||||
(with-temporary-database
|
||||
;; Populate the 'Builds', 'Evaluations', and
|
||||
;; 'Specifications' tables. Here, two builds map to the same derivation
|
||||
;; but the result of 'db-get-pending-derivations' must not contain any
|
||||
;; duplicate.
|
||||
(db-add-build db (make-dummy-build "/foo.drv" 1
|
||||
#:outputs `(("out" . "/foo"))))
|
||||
(db-add-build db (make-dummy-build "/bar.drv" 2
|
||||
#:outputs `(("out" . "/bar"))))
|
||||
(db-add-build db (make-dummy-build "/foo.drv" 3
|
||||
#:outputs `(("out" . "/foo"))))
|
||||
(db-add-evaluation db (make-dummy-eval))
|
||||
(db-add-evaluation db (make-dummy-eval))
|
||||
(db-add-evaluation db (make-dummy-eval))
|
||||
(db-add-specification db example-spec)
|
||||
(db-add-build (make-dummy-build "/foo.drv" 1
|
||||
#:outputs `(("out" . "/foo"))))
|
||||
(db-add-build (make-dummy-build "/bar.drv" 2
|
||||
#: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-specification example-spec)
|
||||
|
||||
(sort (db-get-pending-derivations db) string<?)))
|
||||
(sort (db-get-pending-derivations) string<?)))
|
||||
|
||||
(test-assert "db-close"
|
||||
(db-close (%db)))
|
||||
|
||||
(delete-file database-name))
|
||||
(begin
|
||||
(%db-channel #f)
|
||||
(delete-file database-name)))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'with-temporary-database 'scheme-indent-function 1)
|
||||
;;; eval: (put 'with-temporary-database 'scheme-indent-function 0)
|
||||
;;; End:
|
||||
|
|
|
|||
|
|
@ -125,14 +125,17 @@
|
|||
json->scm)))
|
||||
|
||||
(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"
|
||||
(call-with-new-thread
|
||||
(lambda ()
|
||||
(run-fibers
|
||||
(lambda ()
|
||||
(run-cuirass-server (%db) #:port 6688))
|
||||
(run-cuirass-server #:port 6688))
|
||||
#:drain? #t))))
|
||||
|
||||
(test-assert "wait-server"
|
||||
|
|
@ -184,11 +187,11 @@
|
|||
(evaluation2
|
||||
'((#:specification . "guix")
|
||||
(#:commits . ("fakesha2" "fakesha3")))))
|
||||
(db-add-build (%db) build1)
|
||||
(db-add-build (%db) build2)
|
||||
(db-add-specification (%db) specification)
|
||||
(db-add-evaluation (%db) evaluation1)
|
||||
(db-add-evaluation (%db) evaluation2)))
|
||||
(db-add-build build1)
|
||||
(db-add-build build2)
|
||||
(db-add-specification specification)
|
||||
(db-add-evaluation evaluation1)
|
||||
(db-add-evaluation evaluation2)))
|
||||
|
||||
(test-assert "/build/1"
|
||||
(hash-table=?
|
||||
|
|
@ -275,4 +278,6 @@
|
|||
(test-assert "db-close"
|
||||
(db-close (%db)))
|
||||
|
||||
(delete-file database-name))
|
||||
(begin
|
||||
(%db-channel #f)
|
||||
(delete-file database-name)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue