[no subject]

[Ludovic Courtès]

branch: master
commit 8c7c93922bbe0513ff4c4ff3a6e554e3a72635b6
Author: Ludovic Courtès <address@hidden>
Date:   Thu Feb 8 18:45:03 2018 +0100

    database: Use argument binding in 'db-get-builds' queries.
    
    That makes it safe from SQL injection.
    
    * src/cuirass/database.scm (db-get-builds): Rewrite to use question
    marks in SQL queries and binding through '%sqlite-exec'.
    * tests/database.scm ("database")["db-get-builds"]: Exercise 'WHERE'
    clauses.
---
 src/cuirass/database.scm | 111 ++++++++++++++++++++++++++++-------------------
 tests/database.scm       |   5 +++
 2 files changed, 71 insertions(+), 45 deletions(-)

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index a9f1c2d..d3e2666 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -377,32 +377,55 @@ INNER JOIN Specifications ON Evaluations.specification = 
Specifications.repo_nam
 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)
+  (define (clauses->query+arguments clauses)
+    ;; Given CLAUSES, return two values: a SQL query string, and a list of
+    ;; arguments to bind.  Each element of CLAUSES must be either a string, or
+    ;; a (SQL ARGUMENT) tuple, where SQL is a query fragment and ARGUMENT is
+    ;; the argument to be bound for that fragment.
+    (let loop ((clauses   clauses)
+               (query     '())
+               (arguments '()))
+      (match clauses
+        (()
+         (values (string-concatenate-reverse query)
+                 (reverse arguments)))
+        (((? string? clause) . rest)
+         (loop rest
+               (cons clause query)
+               arguments))
+        ((((? string? clause) argument) . rest)
+         (loop rest
+               (cons clause query)
+               (cons argument arguments))))))
+
+  (define (where-clauses filters)
+    (match (filter-map (match-lambda
+                         (('project project)
+                          (list "Specifications.repo_name=?" project))
+                         (('jobset jobset)
+                          (list "Specifications.branch=?" jobset))
+                         (('job job)
+                          (list "Derivations.job_name=?" job))
+                         (('system system)
+                          (list "Derivations.system=?" system))
+                         (('status 'done)
+                          "Builds.status >= 0")
+                         (('status 'pending)
+                          "Builds.status < 0")
+                         (_ #f))
+                       filters)
+      (()
+       '(""))
+      ((clause)
+       (list "WHERE " clause))
+      ((clause0 rest ...)
+       (cons* "WHERE " clause0
+              (fold-right (lambda (clause result)
+                            `(" AND " ,clause ,@result))
+                          '()
+                          rest)))))
+
+  (define (order-clause filters)
     (or (any (match-lambda
                (('order 'build-id)
                 "ORDER BY Builds.id ASC")
@@ -422,31 +445,29 @@ FILTERS is an assoc list which possible keys are 'project 
| 'jobset | 'job |
              filters)
         "ORDER BY Builds.id DESC"))               ;default order
 
-  (define (format-limit-clause filters)
+  (define (limit-clause filters)
     (or (any (match-lambda
                (('nr number)
-                (format #f "LIMIT '~A'" number))
+                (list "LIMIT ?" number))
                (_ #f))
              filters)
         ""))
 
-  (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))))))
+  (call-with-values
+      (lambda ()
+        (clauses->query+arguments (append (list db-build-request " ")
+                                          (where-clauses filters) '(" ")
+                                          (list (order-clause filters) " ")
+                                          (list (limit-clause filters) " "))))
+    (lambda (sql arguments)
+      (let loop ((rows    (apply %sqlite-exec db sql arguments))
+                 (outputs '()))
+        (match rows
+          (()
+           (reverse outputs))
+          ((row . rest)
+           (loop rest
+                 (cons (db-format-build db row) outputs))))))))
 
 (define (db-get-stamp db spec)
   "Return a stamp corresponding to specification SPEC in database DB."
diff --git a/tests/database.scm b/tests/database.scm
index 2382292..306068b 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -121,6 +121,8 @@ INSERT INTO Evaluations (specification, revision) VALUES 
(3, 3);")
   (test-equal "db-get-builds"
     #(((1 "/foo.drv") (2 "/bar.drv") (3 "/baz.drv")) ;ascending order
       ((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;descending order
+      ((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto
+      ((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto
       ((3 "/baz.drv")))                              ;nr = 1
     (with-temporary-database db
       ;; Populate the 'Builds', 'Derivations', 'Evaluations', and
@@ -145,6 +147,9 @@ INSERT INTO Evaluations (specification, revision) VALUES 
(3, 3);")
                                (assq-ref alist #:derivation)))))
         (vector (map summarize (db-get-builds db '((nr 3) (order build-id))))
                 (map summarize (db-get-builds db '()))
+                (map summarize (db-get-builds db '((project "guix"))))
+                (map summarize (db-get-builds db '((project "guix")
+                                                   (jobset "master"))))
                 (map summarize (db-get-builds db '((nr 1))))))))
 
   (test-equal "db-update-build-status!"