[bug#30386] [PATCH cuirass] database: Prevent SQL injection.

[bug#30386] [PATCH cuirass] database: Prevent SQL injection.

[Danny Milosavljevic]

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

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

[bug#30386] [PATCH v2 cuirass] database: Prevent SQL injection.

[Danny Milosavljevic]

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

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."

[bug#30386] [PATCH v2 cuirass] database: Prevent SQL injection.

[Ludovic Courtès]

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:

> +         (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’.

[bug#30386] [PATCH v2 cuirass] database: Prevent SQL injection.

[Danny Milosavljevic]

Hi Ludo,

no worries!

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

>Do you think we can salvage this bit from your patch?  

Sure.

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

[bug#30386] [PATCH v2 cuirass] database: Prevent SQL injection.

[Ludovic Courtès]

Danny Milosavljevic <dannym@scratchpost.org> skribis:

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

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

  https://git.savannah.gnu.org/cgit/guix/guix-cuirass.git/commit/?id=b0c39b31f61cfc494e0dfbe823b3fe4275efbc7a

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’.

[bug#30386] [PATCH v2 cuirass] database: Prevent SQL injection.

[Danny Milosavljevic]

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

bug#30386: [PATCH v2 cuirass] database: Prevent SQL injection.

[Ludovic Courtès]

Danny Milosavljevic <dannym@scratchpost.org> skribis:

> +         (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’.