>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))))