database: Handle binding directly in 'sqlite-exec'.
The new macro automatically takes care of inserting question marks in the SQL queries, which in turn guarantees that there are always as many question marks and arguments. * src/cuirass/database.scm (sqlite-exec): Rename to... (%sqlite-exec): ... this. (sqlite-exec/bind, sqlite-exec): New macros. (assq-refs): Remove. (db-add-specification): Use the new 'sqlite-exec' form. (db-get-specifications): Correctly deal with REV or TAG being #f. (db-add-derivation, db-get-derivation, db-add-evaluation) (db-add-build, db-update-build-status!, db-get-outputs) (db-get-build, db-get-stamp, db-add-stamp): Adjust to the new 'sqlite-exec' form.
This commit is contained in:
Ludovic Courtès
parent
5425639271
commit
b0c39b31f6
|
|
@ -28,7 +28,6 @@
|
|||
#:use-module (srfi srfi-19)
|
||||
#:use-module (sqlite3)
|
||||
#:export (;; Procedures.
|
||||
assq-refs
|
||||
db-init
|
||||
db-open
|
||||
db-close
|
||||
|
|
@ -53,7 +52,7 @@
|
|||
;; Macros.
|
||||
with-database))
|
||||
|
||||
(define (sqlite-exec db sql . args)
|
||||
(define (%sqlite-exec db sql . args)
|
||||
"Evaluate the given SQL query with the given ARGS. Return the list of
|
||||
rows."
|
||||
(define (normalize arg)
|
||||
|
|
@ -70,6 +69,49 @@ rows."
|
|||
(sqlite-finalize stmt)
|
||||
result)))
|
||||
|
||||
(define-syntax sqlite-exec/bind
|
||||
(lambda (s)
|
||||
;; Expand to an '%sqlite-exec' call where the query string has
|
||||
;; interspersed question marks and the argument list is separate.
|
||||
(define (string-literal? s)
|
||||
(string? (syntax->datum s)))
|
||||
|
||||
(syntax-case s ()
|
||||
((_ db (bindings ...) tail str arg rest ...)
|
||||
#'(sqlite-exec/bind db
|
||||
(bindings ... (str arg))
|
||||
tail
|
||||
rest ...))
|
||||
((_ db (bindings ...) tail str)
|
||||
#'(sqlite-exec/bind db (bindings ...) str))
|
||||
((_ db ((strings args) ...) tail)
|
||||
(and (every string-literal? #'(strings ...))
|
||||
(string-literal? #'tail))
|
||||
;; Optimized case: only string literals.
|
||||
(with-syntax ((query (string-join
|
||||
(append (syntax->datum #'(strings ...))
|
||||
(list (syntax->datum #'tail)))
|
||||
"? ")))
|
||||
#'(%sqlite-exec db query args ...)))
|
||||
((_ db ((strings args) ...) tail)
|
||||
;; Fallback case: some of the strings aren't literals.
|
||||
#'(%sqlite-exec db (string-join (list strings ... tail) "? ")
|
||||
args ...)))))
|
||||
|
||||
(define-syntax-rule (sqlite-exec db query args ...)
|
||||
"Execute the specific QUERY with the given ARGS. Uses of 'sqlite-exec'
|
||||
typically look like this:
|
||||
|
||||
(sqlite-exec db \"SELECT * FROM Foo WHERE x = \"
|
||||
x \"AND Y=\" y \";\")
|
||||
|
||||
References to variables 'x' and 'y' here are replaced by question marks in the
|
||||
SQL query, and then 'sqlite-bind' is used to bind them.
|
||||
|
||||
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 %package-database
|
||||
;; Define to the database file name of this package.
|
||||
(make-parameter (string-append %localstatedir "/run/" %package
|
||||
|
|
@ -125,26 +167,27 @@ database object."
|
|||
"Close database object DB."
|
||||
(sqlite-close db))
|
||||
|
||||
(define* (assq-refs alst keys #:optional default-value)
|
||||
(map (lambda (key) (or (assq-ref alst key) default-value))
|
||||
keys))
|
||||
|
||||
(define (last-insert-rowid db)
|
||||
(vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
|
||||
0))
|
||||
|
||||
(define (db-add-specification db spec)
|
||||
"Store specification SPEC in database DB and return its ID."
|
||||
(apply sqlite-exec db "\
|
||||
(sqlite-exec db "\
|
||||
INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \
|
||||
proc, arguments, branch, tag, revision, no_compile_p) \
|
||||
VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?);"
|
||||
(append
|
||||
(assq-refs spec '(#:name #:url #:load-path #:file))
|
||||
(map symbol->string (assq-refs spec '(#:proc)))
|
||||
(map object->string (assq-refs spec '(#:arguments)))
|
||||
(assq-refs spec '(#:branch #:tag #:commit) "NULL")
|
||||
(list (if (assq-ref spec #:no-compile?) "1" "0"))))
|
||||
VALUES ("
|
||||
(assq-ref spec #:name) ", "
|
||||
(assq-ref spec #:url) ", "
|
||||
(assq-ref spec #:load-path) ", "
|
||||
(assq-ref spec #:file) ", "
|
||||
(symbol->string (assq-ref spec #:proc)) ", "
|
||||
(assq-ref spec #:arguments) ", "
|
||||
(assq-ref spec #:branch) ", "
|
||||
(assq-ref spec #:tag) ", "
|
||||
(assq-ref spec #:commit) ", "
|
||||
(if (assq-ref spec #:no-compile?) 1 0)
|
||||
");")
|
||||
(last-insert-rowid db))
|
||||
|
||||
(define (db-get-specifications db)
|
||||
|
|
@ -162,8 +205,12 @@ INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \
|
|||
(#:proc . ,(with-input-from-string proc read))
|
||||
(#:arguments . ,(with-input-from-string args read))
|
||||
(#:branch . ,branch)
|
||||
(#:tag . ,(if (string=? tag "NULL") #f tag))
|
||||
(#:commit . ,(if (string=? rev "NULL") #f rev))
|
||||
(#:tag . ,(match tag
|
||||
("NULL" #f)
|
||||
(_ tag)))
|
||||
(#:commit . ,(match rev
|
||||
("NULL" #f)
|
||||
(_ rev)))
|
||||
(#:no-compile? . ,(positive? no-compile?)))
|
||||
specs))))))
|
||||
|
||||
|
|
@ -171,23 +218,23 @@ 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 INTO Derivations (derivation, job_name, system, nix_name, evaluation)\
|
||||
VALUES (?, ?, ?, ?, ?);"
|
||||
(assq-ref job #:derivation)
|
||||
(assq-ref job #:job-name)
|
||||
(assq-ref job #:system)
|
||||
(assq-ref job #:nix-name)
|
||||
(assq-ref job #:eval-id))
|
||||
VALUES ("
|
||||
(assq-ref job #:derivation) ", "
|
||||
(assq-ref job #:job-name) ", "
|
||||
(assq-ref job #:system) ", "
|
||||
(assq-ref job #:nix-name) ", "
|
||||
(assq-ref job #:eval-id) ");")
|
||||
(last-insert-rowid db))
|
||||
|
||||
(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=?;" 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 (?, ?);"
|
||||
(assq-ref eval #:specification)
|
||||
(assq-ref eval #:revision))
|
||||
INSERT INTO Evaluations (specification, revision) VALUES ("
|
||||
(assq-ref eval #:specification) ", "
|
||||
(assq-ref eval #:revision) ");")
|
||||
(last-insert-rowid db))
|
||||
|
||||
(define-syntax-rule (with-database db body ...)
|
||||
|
|
@ -232,22 +279,22 @@ in the OUTPUTS table."
|
|||
(let* ((build-exec
|
||||
(sqlite-exec db "\
|
||||
INSERT INTO Builds (derivation, evaluation, log, status, timestamp, starttime, stoptime)\
|
||||
VALUES (?, ?, ?, ?, ?, ?, ?);"
|
||||
(assq-ref build #:derivation)
|
||||
(assq-ref build #:eval-id)
|
||||
(assq-ref build #:log)
|
||||
VALUES ("
|
||||
(assq-ref build #:derivation) ", "
|
||||
(assq-ref build #:eval-id) ", "
|
||||
(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)))
|
||||
(build-status scheduled)) ", "
|
||||
(or (assq-ref build #:timestamp) 0) ", "
|
||||
(or (assq-ref build #:starttime) 0) ", "
|
||||
(or (assq-ref build #:stoptime) 0) ");"))
|
||||
(build-id (last-insert-rowid db)))
|
||||
(for-each (lambda (output)
|
||||
(match output
|
||||
((name . path)
|
||||
(sqlite-exec db "\
|
||||
INSERT INTO Outputs (build, name, path) VALUES (?, ?, ?);"
|
||||
build-id name path))))
|
||||
INSERT INTO Outputs (build, name, path) VALUES ("
|
||||
build-id ", " name ", " path ");"))))
|
||||
(assq-ref build #:outputs))
|
||||
build-id))
|
||||
|
||||
|
|
@ -259,27 +306,26 @@ log file for DRV."
|
|||
(time-second (current-time time-utc)))
|
||||
|
||||
(if (= status (build-status started))
|
||||
(sqlite-exec db "UPDATE Builds SET starttime=?, status=? \
|
||||
WHERE derivation=?;"
|
||||
now status drv)
|
||||
(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=?, status=?, log=? \
|
||||
WHERE derivation=? AND status != ?;"
|
||||
now status log-file drv status)
|
||||
(sqlite-exec db "UPDATE Builds SET stoptime=?, status=? \
|
||||
WHERE derivation=? AND status != ?;"
|
||||
now status drv status))))
|
||||
(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 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=?;"
|
||||
build-id))
|
||||
(sqlite-exec db "SELECT name, path FROM Outputs WHERE build="
|
||||
build-id ";"))
|
||||
(outputs '()))
|
||||
(match rows
|
||||
(() outputs)
|
||||
|
|
@ -319,7 +365,8 @@ 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=?;") id)))
|
||||
" WHERE Builds.id=")
|
||||
id ";")))
|
||||
(match res
|
||||
((build)
|
||||
(db-format-build db build))
|
||||
|
|
@ -403,8 +450,8 @@ 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=?;"
|
||||
(assq-ref spec #:name))))
|
||||
(let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification="
|
||||
(assq-ref spec #:name) ";")))
|
||||
(match res
|
||||
(() "")
|
||||
((#(spec commit)) commit))))
|
||||
|
|
@ -413,10 +460,7 @@ 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 (?, ?);"
|
||||
(assq-ref spec #:name)
|
||||
commit)
|
||||
(sqlite-exec db "\
|
||||
UPDATE Stamps SET stamp=? WHERE specification=?;"
|
||||
commit
|
||||
(assq-ref spec #:name))))
|
||||
INSERT INTO Stamps (specification, stamp) VALUES ("
|
||||
(assq-ref spec #:name) ", " commit ");")
|
||||
(sqlite-exec db "UPDATE Stamps SET stamp=" commit
|
||||
"WHERE specification=" (assq-ref spec #:name) ";")))
|
||||
|
|
|
|||
Loading…
Reference in New Issue