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