Subject: [PATCH cuirass] database: Prevent SQL injection.

From: Danny Milosavljevic <[email-masked]>
Date: Thu, 8 Feb 2018 00:12:58 +0100

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