From 09afb02528e378a75d275bea68a756adabca614a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 16 Nov 2018 21:47:18 +0100 Subject: database: Factorize 'sqlite-error' handling. * src/cuirass/database.scm (catch-sqlite-error): New macro. (db-add-checkout, db-add-output, db-add-build): Use it instead of custom 'catch' block'. --- src/cuirass/database.scm | 129 ++++++++++++++++++++++++----------------------- 1 file changed, 67 insertions(+), 62 deletions(-) diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 8b83c18..37bedf6 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -125,6 +125,19 @@ This ensures that (1) SQL injection is impossible, and (2) the number of question marks matches the number of arguments to bind." (sqlite-exec/bind db () "" query args ...)) +(define-syntax catch-sqlite-error + (syntax-rules (on =>) + "Run EXP..., catching SQLite error and handling the given code as +specified." + ((_ exp ... (on error => handle ...)) + (catch 'sqlite-error + (lambda () + exp ...) + (lambda (key who code message . rest) + (if (= code error) + (begin handle ...) + (apply throw key who code rest))))))) + (define %package-database ;; Define to the database file name of this package. (make-parameter (string-append %localstatedir "/lib/" %package @@ -277,24 +290,21 @@ tag, revision, no_compile_p) VALUES (" "Insert CHECKOUT associated with SPEC-NAME and EVAL-ID. If a checkout with the same revision already exists for SPEC-NAME, return #f." (with-db-critical-section db - (catch 'sqlite-error - (lambda () - (sqlite-exec db "\ + (catch-sqlite-error + (sqlite-exec db "\ INSERT INTO Checkouts (specification, revision, evaluation, input, directory) VALUES (" - spec-name ", " - (assq-ref checkout #:commit) ", " - eval-id ", " - (assq-ref checkout #:input) ", " - (assq-ref checkout #:directory) ");") - (last-insert-rowid db)) - (lambda (key who code message . rest) - ;; If we get a unique-constraint-failed error, that means we have - ;; already inserted the same checkout. That happens for each input - ;; that doesn't change between two evaluations. - (if (= code SQLITE_CONSTRAINT_PRIMARYKEY) - #f - (apply throw key who code rest)))))) + spec-name ", " + (assq-ref checkout #:commit) ", " + eval-id ", " + (assq-ref checkout #:input) ", " + (assq-ref checkout #:directory) ");") + (last-insert-rowid db) + + ;; If we get a unique-constraint-failed error, that means we have + ;; already inserted the same checkout. That happens for each input + ;; that doesn't change between two evaluations. + (on SQLITE_CONSTRAINT_PRIMARYKEY => #f)))) (define (db-add-specification spec) "Store SPEC in database the database. SPEC inputs are stored in the INPUTS @@ -437,61 +447,56 @@ string." "Insert OUTPUT associated with DERIVATION. If an output with the same path already exists, return #f." (with-db-critical-section db - (catch 'sqlite-error - (lambda () - (match output - ((name . path) - (sqlite-exec db "\ + (catch-sqlite-error + (match output + ((name . path) + (sqlite-exec db "\ INSERT INTO Outputs (derivation, name, path) VALUES (" - derivation ", " name ", " path ");"))) - (last-insert-rowid db)) - (lambda (key who code message . rest) - ;; If we get a unique-constraint-failed error, that means we have - ;; already inserted the same output. That happens with fixed-output - ;; derivations. - (if (= code SQLITE_CONSTRAINT_PRIMARYKEY) - #f - (apply throw key who code rest)))))) + derivation ", " name ", " path ");"))) + (last-insert-rowid db) + + ;; If we get a unique-constraint-failed error, that means we have + ;; already inserted the same output. That happens with fixed-output + ;; derivations. + (on SQLITE_CONSTRAINT_PRIMARYKEY => #f)))) (define (db-add-build build) "Store BUILD in database the database only if one of its outputs is new. Return #f otherwise. BUILD outputs are stored in the OUTPUTS table." (with-db-critical-section db - (catch 'sqlite-error - (lambda () - (sqlite-exec db "BEGIN TRANSACTION;") - (sqlite-exec db " + (catch-sqlite-error + (sqlite-exec db "BEGIN TRANSACTION;") + (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)) - (outputs (assq-ref build #:outputs)) - (new-outputs (filter-map (cut db-add-output derivation <>) - outputs))) - (if (null? new-outputs) - (begin (sqlite-exec db "ROLLBACK;") - #f) - (begin (sqlite-exec db "COMMIT;") - 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) - (begin (sqlite-exec db "ROLLBACK;") - #f) - (apply throw key who code rest)))))) + (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)) + (outputs (assq-ref build #:outputs)) + (new-outputs (filter-map (cut db-add-output derivation <>) + outputs))) + (if (null? new-outputs) + (begin (sqlite-exec db "ROLLBACK;") + #f) + (begin (sqlite-exec db "COMMIT;") + derivation))) + + ;; 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. + (on SQLITE_CONSTRAINT_PRIMARYKEY + => + (sqlite-exec db "ROLLBACK;") #f)))) (define* (db-update-build-status! drv status #:key log-file) "Update the database so that DRV's status is STATUS. This also updates the -- cgit v1.2.3