[PATCH cuirass] database: Prevent SQL injection.

  • Done
  • quality assurance status badge
Details
2 participants
  • Danny Milosavljevic
  • Ludovic Courtès
Owner
unassigned
Submitted by
Danny Milosavljevic
Severity
normal

Debbugs page

Danny Milosavljevic wrote 7 years ago
(address . guix-patches@gnu.org)(name . Danny Milosavljevic)(address . dannym@scratchpost.org)
20180207231258.31169-1-dannym@scratchpost.org
* src/cuirass/database.scm: Import (srfi srfi-26).
(sqlite-fetch-all): New variable.
(sqlite-bind-args): New variable.
(sqlite-exec): Use the above.
(db-add-specification): Prevent SQL injection.
(db-get-specifications): Modify it for consistency.
(db-add-derivation): Prevent SQL injection.
(db-get-derivation): Prevent SQL injection.
(db-add-evaluation): Prevent SQL injection.
(db-add-build): Prevent SQL injection.
(db-update-build-status!): Prevent SQL injection.
(db-get-outputs): Prevent SQL injection.
(db-build-request): Delete variable.
(db-get-builds): Prevent SQL injection.
(db-get-build): Use db-get-builds.
(db-get-stamp): Prevent SQL injection.
(db-add-stamp): Prevent SQL injection.
---
src/cuirass/database.scm | 238 +++++++++++++++++++++++------------------------
1 file changed, 116 insertions(+), 122 deletions(-)

Toggle diff (356 lines)
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 5ca3ad3..ca1e778 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -26,6 +26,7 @@
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
#:use-module (sqlite3)
#:export (;; Procedures.
assq-refs
@@ -46,35 +47,56 @@
db-get-builds
read-sql-file
read-quoted-string
- sqlite-exec
+ sqlite-exec ; for tests only
;; Parameters.
%package-database
%package-schema-file
;; 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 (sqlite-fetch-all stmt)
+ (reverse! (sqlite-fold cons '() stmt)))
+
+(define (sqlite-bind-args stmt . args)
+ "Bind STMT parameters, one after another, to ARGS.
+Also binds named parameters to the respective ones."
+ (let loop ((i 1)
+ (args args))
+ (if (null? args)
+ #f
+ (let ((arg (car args))
+ (rest (cdr args)))
+ (if (keyword? arg)
+ (begin
+ (sqlite-bind stmt (keyword->symbol arg) (car rest))
+ (loop i (cdr rest)))
+ (begin
+ (sqlite-bind stmt i arg)
+ (loop (1+ i) rest)))))))
(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* ((stmt (sqlite-prepare db sqltext #:cache? #t)))
+ (sqlite-bind-args stmt arg ...)
+ (sqlite-fetch-all stmt)))
+ ((_ db sqltext) (string? (syntax->datum #'sqltext))
+ #`(let* ((stmt (sqlite-prepare db sqltext #:cache? #t)))
+ (sqlite-fetch-all stmt)))
+ ((_ db sqltext arg ...)
+ #`(let ((stmt (sqlite-prepare db sqltext #:cache? #f)))
+ (sqlite-bind-args stmt arg ...)
+ (let ((result (sqlite-fetch-all stmt)))
+ (sqlite-finalize stmt)
+ result)))
+ (id (identifier? #'id)
+ #'(lambda (db sqltext . args)
+ (let ((stmt (sqlite-prepare db sqltext #:cache? #f)))
+ (apply 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.
@@ -144,10 +166,12 @@ 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 '(#:branch #:tag #:commit) "NULL")
+ (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) #f)
(list (if (assq-ref spec #:no-compile?) "1" "0"))))
(last-insert-rowid db))
@@ -166,8 +190,8 @@ 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 . ,tag)
+ (#:commit . ,rev)
(#:no-compile? . ,(positive? no-compile?)))
specs))))))
@@ -175,20 +199,21 @@ 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)
(assq-ref job #:nix-name)
- (assq-ref job #:eval-id)))
+ (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='~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))
@@ -235,7 +260,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)
@@ -249,7 +274,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))
@@ -262,17 +287,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'~@[, 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
@@ -283,15 +308,6 @@ status='~A'~@[, log='~A'~] WHERE derivation='~A';"
(cons `(,name . ((#:path . ,path)))
outputs))))))
-(define db-build-request "\
-SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.derivation,\
-Derivations.job_name, Derivations.system, Derivations.nix_name,\
-Specifications.repo_name, Specifications.branch \
-FROM Builds \
-INNER JOIN Derivations ON Builds.derivation = Derivations.derivation and Builds.evaluation = Derivations.evaluation \
-INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
-INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_name")
-
(define (db-format-build db build)
(match build
(#(id timestamp starttime stoptime log status derivation job-name system
@@ -310,90 +326,68 @@ INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_nam
(#:outputs . ,(db-get-outputs db id))
(#:branch . ,branch)))))
-(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)))
- (match res
- ((build)
- (db-format-build db build))
- (() #f))))
-
(define (db-get-builds db filters)
"Retrieve all builds in database DB which are matched by given FILTERS.
FILTERS is an assoc list which possible keys are 'project | 'jobset | 'job |
'system | 'nr | 'order | 'status."
- (define (format-where-clause filters)
- (let ((where-clause
- (filter-map
- (lambda (param)
- (match param
- (('project project)
- (format #f "Specifications.repo_name='~A'" project))
- (('jobset jobset)
- (format #f "Specifications.branch='~A'" jobset))
- (('job job)
- (format #f "Derivations.job_name='~A'" job))
- (('system system)
- (format #f "Derivations.system='~A'" system))
- (('status 'done)
- "Builds.status >= 0")
- (('status 'pending)
- "Builds.status < 0")
- (_ #f)))
- filters)))
- (if (> (length where-clause) 0)
- (string-append
- "WHERE "
- (string-join where-clause " AND "))
- "")))
-
- (define (format-order-clause filters)
- (or (any (match-lambda
- (('order 'build-id)
- "ORDER BY Builds.id ASC")
- (('order 'decreasing-build-id)
- "ORDER BY Builds.id DESC")
- (('order 'finish-time)
- "ORDER BY Builds.stoptime DESC")
- (('order 'start-time)
- "ORDER BY Builds.start DESC")
- (('order 'submission-time)
- "ORDER BY Builds.timestamp DESC")
- (_ #f))
- filters)
- "ORDER BY Builds.id DESC")) ;default order
-
- (define (format-limit-clause filters)
- (or (any (match-lambda
- (('nr number)
- (format #f "LIMIT '~A'" number))
- (_ #f))
- filters)
- ""))
+ ;; XXX Change caller and remove
+ (define (assqx-ref filters key)
+ (if (null? filters)
+ #f
+ (match (car filters)
+ ((xkey xvalue) (if (eq? key xkey)
+ xvalue
+ (assqx-ref (cdr filters) key))))))
+ (let* ((order (if (eq? (assqx-ref filters 'order) 'build-id)
+ "ASC"
+ "DESC"))
+ (order-column-name
+ (match (assqx-ref filters 'order)
+ (('order 'build-id) "Builds.id")
+ (('order 'decreasing-build-id) "Builds.id")
+ (('order 'finish-time) "Builds.stoptime")
+ (('order 'start-time) "Builds.starttime")
+ (('order 'submission-time) "Builds.timestamp")
+ (_ "Builds.id")))
+ (stmt-text (format #f "\
+SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.derivation,\
+Derivations.job_name, Derivations.system, Derivations.nix_name,\
+Specifications.repo_name, Specifications.branch \
+FROM Builds \
+INNER JOIN Derivations ON Builds.derivation = Derivations.derivation AND Builds.evaluation = Derivations.evaluation \
+INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
+INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_name \
+WHERE (:id IS NULL OR (:id = Builds.id)) \
+OR (:project IS NULL OR (:project = Specifications.repo_name)) \
+OR (:jobset IS NULL OR (:jobset = Specifications.branch)) \
+OR (:job IS NULL OR (:job = Derivations.job_name)) \
+OR (:system IS NULL OR (:system = Derivations.system)) \
+OR (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status = 'pending' AND Builds.status < 0)) \
+ORDER BY ~a ~a LIMIT :nr;" order-column-name order))
+ (stmt (sqlite-prepare db stmt-text #:cache? #t)))
+ (sqlite-bind-args stmt #:id (assqx-ref filters 'id)
+ #:project (assqx-ref filters 'project)
+ #:jobset (assqx-ref filters 'jobset)
+ #:job (assqx-ref filters 'job)
+ #:system (assqx-ref filters 'system)
+ #:status (and=> (assqx-ref filters 'status)
+ object->string)
+ #:nr (match (assqx-ref filters 'nr)
+ (#f -1)
+ (x x)))
+ (map (cut db-format-build db <>) (sqlite-fetch-all stmt))))
- (let loop ((rows
- (sqlite-exec db (string-append
- db-build-request
- " "
- (format-where-clause filters)
- " "
- (format-order-clause filters)
- " "
- (format-limit-clause filters)
- ";")))
- (outputs '()))
- (match rows
- (()
- (reverse outputs))
- ((row . rest)
- (loop rest
- (cons (db-format-build db row) outputs))))))
+(define (db-get-build db id)
+ "Retrieve a build in database DB which corresponds to ID."
+ (match (db-get-builds db '(('id id)))
+ ((build)
+ build)
+ (() #f)))
(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
(() "")
@@ -403,10 +397,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))))
Danny Milosavljevic wrote 7 years ago
[PATCH v2 cuirass] database: Prevent SQL injection.
(address . 30386@debbugs.gnu.org)(name . Danny Milosavljevic)(address . dannym@scratchpost.org)
20180208163432.9468-1-dannym@scratchpost.org
* src/cuirass/database.scm: Use (srfi srfi-26).
(sqlite-fetch-all): New variable.
(sqlite-bind-args): New variable, for now.
(sqlite-exec): Automatically do not finalize literal SQL statements.
(db-add-specification): Use #f for NULL.
(db-get-specifications): Use #f for NULL.
(db-build-request): Delete variable.
(db-get-builds): Prevent SQL injection.
(db-get-build): Use db-get-builds.
---
src/cuirass/database.scm | 207 +++++++++++++++++++++++------------------------
1 file changed, 100 insertions(+), 107 deletions(-)

Toggle diff (265 lines)
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index a40a2d8..2803fd5 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -26,6 +26,7 @@
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
#:use-module (sqlite3)
#:export (;; Procedures.
assq-refs
@@ -46,29 +47,56 @@
db-get-builds
read-sql-file
read-quoted-string
- sqlite-exec
+ sqlite-exec ; for tests only
;; Parameters.
%package-database
%package-schema-file
;; Macros.
with-database))
-(define (sqlite-exec db sql . args)
- "Evaluate the given SQL query with the given ARGS. Return the list of
-rows."
- (define (normalize arg)
- ;; Turn ARG into a string, unless it's a primitive SQL datatype.
- (if (or (null? arg) (pair? arg) (vector? arg))
- (object->string arg)
- arg))
-
- (let ((stmt (sqlite-prepare db sql #:cache? #t)))
- (for-each (lambda (arg index)
- (sqlite-bind stmt index (normalize arg)))
- args (iota (length args) 1))
- (let ((result (sqlite-fold-right cons '() stmt)))
- (sqlite-finalize stmt)
- result)))
+(define (sqlite-fetch-all stmt)
+ (reverse! (sqlite-fold cons '() stmt)))
+
+(define (sqlite-bind-args stmt . args)
+ "Bind STMT parameters, one after another, to ARGS.
+Also binds named parameters to the respective ones."
+ (let loop ((i 1)
+ (args args))
+ (if (null? args)
+ #f
+ (let ((arg (car args))
+ (rest (cdr args)))
+ (if (keyword? arg)
+ (begin
+ (sqlite-bind stmt (keyword->symbol arg) (car rest))
+ (loop i (cdr rest)))
+ (begin
+ (sqlite-bind stmt i arg)
+ (loop (1+ i) rest)))))))
+
+(define-syntax sqlite-exec
+ (lambda (s)
+ (syntax-case s ()
+ ((_ db sqltext arg ...) (string? (syntax->datum #'sqltext))
+ #`(let* ((stmt (sqlite-prepare db sqltext #:cache? #t)))
+ (sqlite-bind-args stmt arg ...)
+ (sqlite-fetch-all stmt)))
+ ((_ db sqltext) (string? (syntax->datum #'sqltext))
+ #`(let* ((stmt (sqlite-prepare db sqltext #:cache? #t)))
+ (sqlite-fetch-all stmt)))
+ ((_ db sqltext arg ...)
+ #`(let ((stmt (sqlite-prepare db sqltext #:cache? #f)))
+ (sqlite-bind-args stmt arg ...)
+ (let ((result (sqlite-fetch-all stmt)))
+ (sqlite-finalize stmt)
+ result)))
+ (id (identifier? #'id)
+ #'(lambda (db sqltext . args)
+ (let ((stmt (sqlite-prepare db sqltext #:cache? #f)))
+ (apply 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.
@@ -143,7 +171,7 @@ INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \
(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")
+ (assq-refs spec '(#:branch #:tag #:commit) #f)
(list (if (assq-ref spec #:no-compile?) "1" "0"))))
(last-insert-rowid db))
@@ -162,8 +190,8 @@ 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 . ,tag)
+ (#:commit . ,rev)
(#:no-compile? . ,(positive? no-compile?)))
specs))))))
@@ -289,15 +317,6 @@ WHERE derivation=? AND status != ?;"
(cons `(,name . ((#:path . ,path)))
outputs))))))
-(define db-build-request "\
-SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.derivation,\
-Derivations.job_name, Derivations.system, Derivations.nix_name,\
-Specifications.repo_name, Specifications.branch \
-FROM Builds \
-INNER JOIN Derivations ON Builds.derivation = Derivations.derivation and Builds.evaluation = Derivations.evaluation \
-INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
-INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_name")
-
(define (db-format-build db build)
(match build
(#(id timestamp starttime stoptime log status derivation job-name system
@@ -316,90 +335,64 @@ INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_nam
(#:outputs . ,(db-get-outputs db id))
(#:branch . ,branch)))))
-(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)))
- (match res
- ((build)
- (db-format-build db build))
- (() #f))))
-
(define (db-get-builds db filters)
"Retrieve all builds in database DB which are matched by given FILTERS.
FILTERS is an assoc list which possible keys are 'project | 'jobset | 'job |
'system | 'nr | 'order | 'status."
- (define (format-where-clause filters)
- (let ((where-clause
- (filter-map
- (lambda (param)
- (match param
- (('project project)
- (format #f "Specifications.repo_name='~A'" project))
- (('jobset jobset)
- (format #f "Specifications.branch='~A'" jobset))
- (('job job)
- (format #f "Derivations.job_name='~A'" job))
- (('system system)
- (format #f "Derivations.system='~A'" system))
- (('status 'done)
- "Builds.status >= 0")
- (('status 'pending)
- "Builds.status < 0")
- (_ #f)))
- filters)))
- (if (> (length where-clause) 0)
- (string-append
- "WHERE "
- (string-join where-clause " AND "))
- "")))
-
- (define (format-order-clause filters)
- (or (any (match-lambda
- (('order 'build-id)
- "ORDER BY Builds.id ASC")
- (('order 'decreasing-build-id)
- "ORDER BY Builds.id DESC")
- (('order 'finish-time)
- "ORDER BY Builds.stoptime DESC")
- (('order 'start-time)
- "ORDER BY Builds.start DESC")
- (('order 'submission-time)
- "ORDER BY Builds.timestamp DESC")
- (('order 'status+submission-time)
- ;; With this order, builds in 'running' state (-1) appear
- ;; before those in 'scheduled' state (-2).
- "ORDER BY Builds.status DESC, Builds.timestamp DESC")
- (_ #f))
- filters)
- "ORDER BY Builds.id DESC")) ;default order
-
- (define (format-limit-clause filters)
- (or (any (match-lambda
- (('nr number)
- (format #f "LIMIT '~A'" number))
- (_ #f))
- filters)
- ""))
+ ;; XXX Change caller and remove
+ (define (assqx-ref filters key)
+ (if (null? filters)
+ #f
+ (match (car filters)
+ ((xkey xvalue) (if (eq? key xkey)
+ xvalue
+ (assqx-ref (cdr filters) key))))))
+ (let* ((order (if (eq? (assqx-ref filters 'order) 'build-id)
+ "ASC"
+ "DESC"))
+ (order-column-name
+ (match (assqx-ref filters 'order)
+ (('order 'build-id) "Builds.id")
+ (('order 'decreasing-build-id) "Builds.id")
+ (('order 'finish-time) "Builds.stoptime")
+ (('order 'start-time) "Builds.starttime")
+ (('order 'submission-time) "Builds.timestamp")
+ (_ "Builds.id")))
+ (stmt-text (format #f "\
+SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.derivation,\
+Derivations.job_name, Derivations.system, Derivations.nix_name,\
+Specifications.repo_name, Specifications.branch \
+FROM Builds \
+INNER JOIN Derivations ON Builds.derivation = Derivations.derivation AND Builds.evaluation = Derivations.evaluation \
+INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
+INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_name \
+WHERE (:id IS NULL OR (:id = Builds.id)) \
+OR (:project IS NULL OR (:project = Specifications.repo_name)) \
+OR (:jobset IS NULL OR (:jobset = Specifications.branch)) \
+OR (:job IS NULL OR (:job = Derivations.job_name)) \
+OR (:system IS NULL OR (:system = Derivations.system)) \
+OR (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status = 'pending' AND Builds.status < 0)) \
+ORDER BY ~a ~a LIMIT :nr;" order-column-name order))
+ (stmt (sqlite-prepare db stmt-text #:cache? #t)))
+ (sqlite-bind-args stmt #:id (assqx-ref filters 'id)
+ #:project (assqx-ref filters 'project)
+ #:jobset (assqx-ref filters 'jobset)
+ #:job (assqx-ref filters 'job)
+ #:system (assqx-ref filters 'system)
+ #:status (and=> (assqx-ref filters 'status)
+ object->string)
+ #:nr (match (assqx-ref filters 'nr)
+ (#f -1)
+ (x x)))
+ (map (cut db-format-build db <>) (sqlite-fetch-all stmt))))
- (let loop ((rows
- (sqlite-exec db (string-append
- db-build-request
- " "
- (format-where-clause filters)
- " "
- (format-order-clause filters)
- " "
- (format-limit-clause filters)
- ";")))
- (outputs '()))
- (match rows
- (()
- (reverse outputs))
- ((row . rest)
- (loop rest
- (cons (db-format-build db row) outputs))))))
+(define (db-get-build db id)
+ "Retrieve a build in database DB which corresponds to ID."
+ (match (db-get-builds db '(('id id)))
+ ((build)
+ build)
+ (() #f)))
(define (db-get-stamp db spec)
"Return a stamp corresponding to specification SPEC in database DB."
Ludovic Courtès wrote 7 years ago
(name . Danny Milosavljevic)(address . dannym@scratchpost.org)(address . 30386@debbugs.gnu.org)
87r2pu4hk4.fsf@gnu.org
Hi Danny,

Apologies for not noticing your message earlier! I was head-down trying
to get this thing in shape and wasn’t checking for email. I’ll do
better now on, especially since you know way better than me how to deal
with these database issues. :-)

Danny Milosavljevic <dannym@scratchpost.org> skribis:

Toggle quote (15 lines)
> + (stmt-text (format #f "\
> +SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.derivation,\
> +Derivations.job_name, Derivations.system, Derivations.nix_name,\
> +Specifications.repo_name, Specifications.branch \
> +FROM Builds \
> +INNER JOIN Derivations ON Builds.derivation = Derivations.derivation AND Builds.evaluation = Derivations.evaluation \
> +INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
> +INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_name \
> +WHERE (:id IS NULL OR (:id = Builds.id)) \
> +OR (:project IS NULL OR (:project = Specifications.repo_name)) \
> +OR (:jobset IS NULL OR (:jobset = Specifications.branch)) \
> +OR (:job IS NULL OR (:job = Derivations.job_name)) \
> +OR (:system IS NULL OR (:system = Derivations.system)) \
> +OR (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status = 'pending' AND Builds.status < 0))

Do you think we can salvage this bit from your patch? The NULL
optimization looks good, provided the extra conditions don’t make sqlite
slower. It might allow us to use ‘sqlite-exec’ directly, and thus
benefit from the binding support in there, as in:

(sqlite-exec db "… WHERE " id " is NULL or …")

Thoughts?

Thanks!

Ludo’.
Danny Milosavljevic wrote 7 years ago
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 30386@debbugs.gnu.org)
20180209121612.09a0cf53@scratchpost.org
Hi Ludo,

no worries!

Toggle quote (3 lines)
> optimization looks good, provided the extra conditions don’t make sqlite
> slower.

Compared to parsing the SQL text again and again (which is dead slow), I think
an extra NULL check *on the same field* is not going to matter at all.

Even compared to using lots of main memory and thus not being able to use
the processor's cache (if we had lots of prepared statements), I think an
extra NULL check is still better :)

Of course once we have a lot of data in the tables, the actual lookup costs
will dwarf any setup costs. Then still, it's checking the same field that's
used anyway, so the extra cost should be neglible.

Toggle quote (2 lines)
>Do you think we can salvage this bit from your patch?

Sure.

Toggle quote (5 lines)
> It might allow us to use ‘sqlite-exec’ directly, and thus
> benefit from the binding support in there, as in:
>
> (sqlite-exec db "… WHERE " id " is NULL or …")

I added sqlite-bind-arguments with keyword arguments specifically so sqlite-exec
doesn't suck.

So it would be like (sqlite-exec db "SELECT … :a … :b … :a"
#:a 42
#:b 2)

Before, it was:

(sqlite-exec db "SELECT … ? … ? … ?"
42
2
42)

which repeated stuff - and was very fragile when changing things (one can easily
get the order wrong and it would not have errored out).
Ludovic Courtès wrote 7 years ago
(name . Danny Milosavljevic)(address . dannym@scratchpost.org)(address . 30386@debbugs.gnu.org)
87k1vmywq9.fsf@gnu.org
Danny Milosavljevic <dannym@scratchpost.org> skribis:

Toggle quote (14 lines)
>> optimization looks good, provided the extra conditions don’t make sqlite
>> slower.
>
> Compared to parsing the SQL text again and again (which is dead slow), I think
> an extra NULL check *on the same field* is not going to matter at all.
>
> Even compared to using lots of main memory and thus not being able to use
> the processor's cache (if we had lots of prepared statements), I think an
> extra NULL check is still better :)
>
> Of course once we have a lot of data in the tables, the actual lookup costs
> will dwarf any setup costs. Then still, it's checking the same field that's
> used anyway, so the extra cost should be neglible.

Sounds good, let’s do that then.

Toggle quote (19 lines)
>> It might allow us to use ‘sqlite-exec’ directly, and thus
>> benefit from the binding support in there, as in:
>>
>> (sqlite-exec db "… WHERE " id " is NULL or …")
>
> I added sqlite-bind-arguments with keyword arguments specifically so sqlite-exec
> doesn't suck.
>
> So it would be like (sqlite-exec db "SELECT … :a … :b … :a"
> #:a 42
> #:b 2)
>
> Before, it was:
>
> (sqlite-exec db "SELECT … ? … ? … ?"
> 42
> 2
> 42)

Right, but now it’s as I wrote above: you can include arguments in the
middle of the SQL strings, and ‘sqlite-exec’ takes care of turning
that into question marks and so on:


Anyway, we can support both the keyword style you show above, and the
other thing I mention, and use whichever is most convenient for the code
at hand.

I find the ‘sqlite-exec’ convenient for simple cases where the query is
a literal, but the keyword style might be more convenient for complex
queries like ‘db-get-builds’.

Thanks,
Ludo’.
Danny Milosavljevic wrote 7 years ago
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 30386@debbugs.gnu.org)
20180209174507.74345900@scratchpost.org
Toggle quote (6 lines)
> Right, but now it’s as I wrote above: you can include arguments in the
> middle of the SQL strings, and ‘sqlite-exec’ takes care of turning
> that into question marks and so on:
>
> https://git.savannah.gnu.org/cgit/guix/guix-cuirass.git/commit/?id=b0c39b31f61cfc494e0dfbe823b3fe4275efbc7a

Ah, didn't see that Before. Wow! Nice.

I should pull more often :)
Ludovic Courtès wrote 7 years ago
(name . Danny Milosavljevic)(address . dannym@scratchpost.org)(address . 30386-done@debbugs.gnu.org)
87a7vqhbvp.fsf@gnu.org
Danny Milosavljevic <dannym@scratchpost.org> skribis:

Toggle quote (27 lines)
> + (stmt-text (format #f "\
> +SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.derivation,\
> +Derivations.job_name, Derivations.system, Derivations.nix_name,\
> +Specifications.repo_name, Specifications.branch \
> +FROM Builds \
> +INNER JOIN Derivations ON Builds.derivation = Derivations.derivation AND Builds.evaluation = Derivations.evaluation \
> +INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
> +INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_name \
> +WHERE (:id IS NULL OR (:id = Builds.id)) \
> +OR (:project IS NULL OR (:project = Specifications.repo_name)) \
> +OR (:jobset IS NULL OR (:jobset = Specifications.branch)) \
> +OR (:job IS NULL OR (:job = Derivations.job_name)) \
> +OR (:system IS NULL OR (:system = Derivations.system)) \
> +OR (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status = 'pending' AND Builds.status < 0)) \
> +ORDER BY ~a ~a LIMIT :nr;" order-column-name order))
> + (stmt (sqlite-prepare db stmt-text #:cache? #t)))
> + (sqlite-bind-args stmt #:id (assqx-ref filters 'id)
> + #:project (assqx-ref filters 'project)
> + #:jobset (assqx-ref filters 'jobset)
> + #:job (assqx-ref filters 'job)
> + #:system (assqx-ref filters 'system)
> + #:status (and=> (assqx-ref filters 'status)
> + object->string)
> + #:nr (match (assqx-ref filters 'nr)
> + (#f -1)
> + (x x)))

This was pushed as 1bab5c4e56eb1849edc2cf0b23d433aeb2cac421, closing
this issue now.

Thank you!

Ludo’.
Closed
?
Your comment

This issue is archived.

To comment on this conversation send an email to 30386@debbugs.gnu.org

To respond to this issue using the mumi CLI, first switch to it
mumi current 30386
Then, you may apply the latest patchset in this issue (with sign off)
mumi am -- -s
Or, compose a reply to this issue
mumi compose
Or, send patches to this issue
mumi send-email *.patch
You may also tag this issue. See list of standard tags. For example, to set the confirmed and easy tags
mumi command -t +confirmed -t +easy
Or, remove the moreinfo tag and set the help tag
mumi command -t -moreinfo -t +help