>From b8fdd9c4e3a11f11c8d948ee07b2003fa4981f81 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 26 Jan 2018 15:16:04 +0100 Subject: [PATCH] database: Make 'sqlite-exec' reuse the prepared statement. Tags: patch * src/cuirass/database.scm (%sqlite-exec): Delete variable. (): New variable. (%wrap-db): New variable. (%sqlite-prepare): New variable. (%sqlite-bind-args): New variable. (%sqlite-fetch-all): New variable. (sqlite-exec): Modify. (db-init): Use %wrap-db. (db-open): Use %wrap-db. (db-close): Modify. (db-add-specification): Adjust for prepared statement parameters. (db-get-specifications): Adjust for prepared statement parameters. (db-add-derivation): Adjust for prepared statement parameters. (db-get-derivation): Adjust for prepared statement parameters. (db-add-evaluation): Adjust for prepared statement parameters. (db-add-build): Adjust for prepared statement parameters. (db-update-build-status!): Adjust for prepared statement parameters. (db-get-build): Adjust for prepared statement parameters. (db-get-builds): Adjust for prepared statement parameters. (db-get-stamp): Adjust for prepared statement parameters. (db-add-stamp): Adjust for prepared statement parameters. --- src/cuirass/database.scm | 125 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 86 insertions(+), 39 deletions(-) diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index f1d0118..2c923ec 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -24,8 +24,11 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 rdelim) + #:use-module (ice-9 threads) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-69) #:use-module (sqlite3) #:export (;; Procedures. assq-refs @@ -53,28 +56,68 @@ ;; Macros. with-database)) -(define (%sqlite-exec db sql) - (let* ((stmt (sqlite-prepare db sql)) - (res (let loop ((res '())) - (let ((row (sqlite-step stmt))) - (if (not row) - (reverse! res) - (loop (cons row res))))))) - (sqlite-finalize stmt) - res)) +(define-record-type + (db native-db lock stmts) + db? + (native-db db-native-db) + (lock db-lock) + (stmts db-stmts)) + +(define (%wrap-db native-db) + (db native-db (make-mutex) (make-weak-key-hash-table))) + +(define (%sqlite-prepare db sqlsym sqltext) + (with-mutex (db-lock db) + (let ((stmt (sqlite-prepare (db-native-db db) sqltext))) + (hashq-set! (db-stmts db) sqlsym stmt) + stmt))) + +(define (%sqlite-bind-args stmt args) + (let ((argsi (zip (iota (length args)) args))) + (for-each (match-lambda ((i arg) + (sqlite-bind stmt (1+ i) arg))) + argsi))) + +(define (%sqlite-fetch-all stmt) + (let loop ((res '())) + (let ((row (sqlite-step stmt))) + (if (not row) + (begin + (sqlite-reset stmt) + (reverse! res)) + (loop (cons row res)))))) (define-syntax sqlite-exec - ;; Note: Making it a macro so -Wformat can do its job. (lambda (s) - "Wrap 'sqlite-prepare', 'sqlite-step', and 'sqlite-finalize'. Send to given -SQL statement to DB. FMT and ARGS are passed to 'format'." (syntax-case s () - ((_ db fmt args ...) - #'(%sqlite-exec db (format #f fmt args ...))) - (id - (identifier? #'id) - #'(lambda (db fmt . args) - (%sqlite-exec db (apply format #f fmt args))))))) + ((_ db sqltext arg ...) (string? (syntax->datum #'sqltext)) + #`(let* ((sqlsym (quote #,(datum->syntax #'here (string->symbol (string-trim (syntax->datum #'sqltext)))))) + (stmt (or (hashq-ref (db-stmts db) sqlsym) + (%sqlite-prepare db sqlsym sqltext)))) + (with-mutex (db-lock db) + (%sqlite-bind-args stmt (list arg ...)) + (%sqlite-fetch-all stmt)))) + ((_ db sqltext) (string? (syntax->datum #'sqltext)) + #`(let* ((sqlsym (quote #,(datum->syntax #'here (string->symbol (string-trim (syntax->datum #'sqltext)))))) + (stmt (or (hashq-ref (db-stmts db) sqlsym) + (%sqlite-prepare db sqlsym sqltext)))) + (with-mutex (db-lock db) + (%sqlite-fetch-all stmt)))) + ((_ db sqltext arg ...) + #`(with-mutex (db-lock db) + (let ((stmt (sqlite-prepare (db-native-db db) sqltext))) + (%sqlite-bind-args stmt (list arg ...)) + (let ((result (%sqlite-fetch-all stmt))) + (sqlite-finalize stmt) + result)))) + (id (identifier? #'id) + #'(lambda (db sqltext . args) + (with-mutex (db-lock db) + (let ((stmt (sqlite-prepare (db-native-db db) sqltext))) + (%sqlite-bind-args stmt args) + (let ((result (%sqlite-fetch-all stmt))) + (sqlite-finalize stmt) + result)))))))) (define %package-database ;; Define to the database file name of this package. @@ -106,8 +149,8 @@ database object." (when (file-exists? db-name) (format (current-error-port) "Removing leftover database ~a~%" db-name) (delete-file db-name)) - (let ((db (sqlite-open db-name (logior SQLITE_OPEN_CREATE - SQLITE_OPEN_READWRITE)))) + (let ((db (%wrap-db (sqlite-open db-name (logior SQLITE_OPEN_CREATE + SQLITE_OPEN_READWRITE))))) (for-each (lambda (sql) (sqlite-exec db sql)) (read-sql-file schema)) db)) @@ -116,12 +159,12 @@ database object." "Open database to store or read jobs and builds informations. Return a database object." (if (file-exists? db) - (sqlite-open db SQLITE_OPEN_READWRITE) + (%wrap-db (sqlite-open db SQLITE_OPEN_READWRITE)) (db-init db))) (define (db-close db) "Close database object DB." - (sqlite-close db)) + (sqlite-close (db-native-db db))) (define* (assq-refs alst keys #:optional default-value) (map (lambda (key) (or (assq-ref alst key) default-value)) @@ -136,9 +179,13 @@ database object." (apply sqlite-exec db "\ INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \ proc, arguments, branch, tag, revision, no_compile_p) \ - VALUES ('~A', '~A', '~A', '~A', '~S', '~S', '~A', '~A', '~A', ~A);" + VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" (append - (assq-refs spec '(#:name #:url #:load-path #:file #:proc #:arguments)) + (assq-refs spec '(#:name #:url #:load-path #:file)) + (map symbol->string (assq-refs spec '(#:proc))) + (map (lambda (e) + (format #f "~A" e)) + (assq-refs spec '(#:arguments))) (assq-refs spec '(#:branch #:tag #:commit) "NULL") (list (if (assq-ref spec #:no-compile?) "1" "0")))) (last-insert-rowid db)) @@ -167,7 +214,7 @@ INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \ "Store a derivation result in database DB and return its ID." (sqlite-exec db "\ INSERT OR IGNORE INTO Derivations (derivation, job_name, system, nix_name, evaluation)\ - VALUES ('~A', '~A', '~A', '~A', '~A');" + VALUES (?, ?, ?, ?, ?);" (assq-ref job #:derivation) (assq-ref job #:job-name) (assq-ref job #:system) @@ -176,11 +223,11 @@ INSERT OR IGNORE INTO Derivations (derivation, job_name, system, nix_name, evalu (define (db-get-derivation db id) "Retrieve a job in database DB which corresponds to ID." - (car (sqlite-exec db "SELECT * FROM Derivations WHERE derivation='~A';" id))) + (car (sqlite-exec db "SELECT * FROM Derivations WHERE derivation=?;" id))) (define (db-add-evaluation db eval) (sqlite-exec db "\ -INSERT INTO Evaluations (specification, revision) VALUES ('~A', '~A');" +INSERT INTO Evaluations (specification, revision) VALUES (?, ?);" (assq-ref eval #:specification) (assq-ref eval #:revision)) (last-insert-rowid db)) @@ -227,7 +274,7 @@ in the OUTPUTS table." (let* ((build-exec (sqlite-exec db "\ INSERT INTO Builds (derivation, evaluation, log, status, timestamp, starttime, stoptime)\ - VALUES ('~A', '~A', '~A', '~A', '~A', '~A', '~A');" + VALUES (?, ?, ?, ?, ?, ?, ?);" (assq-ref build #:derivation) (assq-ref build #:eval-id) (assq-ref build #:log) @@ -241,7 +288,7 @@ INSERT INTO Builds (derivation, evaluation, log, status, timestamp, starttime, s (match output ((name . path) (sqlite-exec db "\ -INSERT INTO Outputs (build, name, path) VALUES ('~A', '~A', '~A');" +INSERT INTO Outputs (build, name, path) VALUES (?, ?, ?);" build-id name path)))) (assq-ref build #:outputs)) build-id)) @@ -254,17 +301,17 @@ log file for DRV." (time-second (current-time time-utc))) (if (= status (build-status started)) - (sqlite-exec db "UPDATE Builds SET starttime='~A', status='~A' \ -WHERE derivation='~A';" + (sqlite-exec db "UPDATE Builds SET starttime=?, status=? \ +WHERE derivation=?;" now status drv) - (sqlite-exec db "UPDATE Builds SET stoptime='~A', \ -status='~A'address@hidden, log='~A'~] WHERE derivation='~A';" - now status log-file drv))) + (if log-file + (sqlite-exec db "UPDATE Builds SET stoptime=?, status=?, log=? WHERE derivation=?;" now status log-file drv) + (sqlite-exec db "UPDATE Builds SET stoptime=?, status=? WHERE derivation=?;" now status drv)))) (define (db-get-outputs db build-id) "Retrieve the OUTPUTS of the build identified by BUILD-ID in DB database." (let loop ((rows - (sqlite-exec db "SELECT name, path FROM Outputs WHERE build='~A';" + (sqlite-exec db "SELECT name, path FROM Outputs WHERE build=?;" build-id)) (outputs '())) (match rows @@ -305,7 +352,7 @@ INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_nam (define (db-get-build db id) "Retrieve a build in database DB which corresponds to ID." (let ((res (sqlite-exec db (string-append db-build-request - " WHERE Builds.id='~A';") id))) + " WHERE Builds.id=?;") id))) (match res ((build) (db-format-build db build)) @@ -385,7 +432,7 @@ FILTERS is an assoc list which possible keys are 'project | 'jobset | 'job | (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='~A';" + (let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification=?;" (assq-ref spec #:name)))) (match res (() "") @@ -395,10 +442,10 @@ FILTERS is an assoc list which possible keys are 'project | 'jobset | 'job | "Associate stamp COMMIT to specification SPEC in database DB." (if (string-null? (db-get-stamp db spec)) (sqlite-exec db "\ -INSERT INTO Stamps (specification, stamp) VALUES ('~A', '~A');" +INSERT INTO Stamps (specification, stamp) VALUES (?, ?);" (assq-ref spec #:name) commit) (sqlite-exec db "\ -UPDATE Stamps SET stamp='~A' WHERE specification='~A';" +UPDATE Stamps SET stamp=? WHERE specification=?;" commit (assq-ref spec #:name))))