diff options
| -rw-r--r-- | .dir-locals.el | 3 | ||||
| -rw-r--r-- | bin/cuirass.in | 23 | ||||
| -rw-r--r-- | src/cuirass/base.scm | 94 | ||||
| -rw-r--r-- | src/cuirass/database.scm | 545 | ||||
| -rw-r--r-- | src/cuirass/http.scm | 136 | ||||
| -rw-r--r-- | src/cuirass/utils.scm | 23 | ||||
| -rw-r--r-- | tests/database.scm | 103 | ||||
| -rw-r--r-- | tests/http.scm | 21 |
8 files changed, 491 insertions, 457 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 9a065ae..465aa58 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -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) diff --git a/bin/cuirass.in b/bin/cuirass.in index 11eb975..d30f788 100644 --- a/bin/cuirass.in +++ b/bin/cuirass.in @@ -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 diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index ab1ad31..1ec122c 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -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) - ";")) - -(define (restart-builds db) - "Restart builds whose status in DB is \"pending\" (scheduled or started)." + (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) + "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*)))) diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 138da22..912039e 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -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)) - -(define (db-add-specification db spec) - "Store SPEC in database DB. SPEC inputs are stored in the INPUTS table." - (sqlite-exec 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 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)) - -(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-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-add-evaluation db eval) - (sqlite-exec db "\ + (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 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) + (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 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))))) - -(define* (db-update-build-status! db drv status #:key log-file) - "Update DB so that DRV's status is STATUS. This also updates the + 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! 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 ";") - - ;; 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 + (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 + ";"))))) + +(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))))))) - -(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-pending-derivations db) + (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 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) "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;"))) - -(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-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 "\ +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 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 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)))))) - -(define (db-get-evaluations-build-summary db spec limit border-low border-high) - (let loop ((rows (sqlite-exec db " + (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 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)))))) - -(define (db-get-evaluations-id-min db spec) + (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 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))))) diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm index 16bbda0..d70517b 100644 --- a/src/cuirass/http.scm +++ b/src/cuirass/http.scm @@ -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))))) diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm index 6083890..48e797c 100644 --- a/src/cuirass/utils.scm +++ b/src/cuirass/utils.scm @@ -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 diff --git a/tests/database.scm b/tests/database.scm index af518bd..cdc7872 100644 --- a/tests/database.scm +++ b/tests/database.scm @@ -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-update-build-status! db "/bar.drv" (build-status started) + (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! "/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) - - (sort (db-get-pending-derivations db) string<?))) + (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) 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: diff --git a/tests/http.scm b/tests/http.scm index a9fc3ef..38e4175 100644 --- a/tests/http.scm +++ b/tests/http.scm @@ -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))) |