Re: Cuirass news

[Danny Milosavljevic <dannym@scratchpost.org>]

[-- Attachment #1: Type: text/plain, Size: 415 bytes --]

Hi Ludo,

I saw that (cuirass database) has some problems with sql injection.
I defused it a little, see attached patch.

The idea is that sqlite-exec uses sqlite-bind to pass arguments
rather than formatting them on its own.

While we are at it, we can also reuse prepared statements (using the
sqltext as key to find the right one).

I also monitor sqlite accesses now - maybe that's overkill (see "with-mutex").

[-- Attachment #2: 0001-database-Make-sqlite-exec-reuse-the-prepared-stateme.patch --]
[-- Type: text/x-patch, Size: 11757 bytes --]

From b8fdd9c4e3a11f11c8d948ee07b2003fa4981f81 Mon Sep 17 00:00:00 2001
From: Danny Milosavljevic <dannym@scratchpost.org>
Date: Fri, 26 Jan 2018 15:16:04 +0100
Subject: [PATCH] database: Make 'sqlite-exec' reuse the prepared statement.
Tags: patch

* src/cuirass/database.scm (%sqlite-exec): Delete variable.
(<db>): New variable.
(%wrap-db): New variable.
(%sqlite-prepare): New variable.
(%sqlite-bind-args): New variable.
(%sqlite-fetch-all): New variable.
(sqlite-exec): Modify.
(db-init): Use %wrap-db.
(db-open): Use %wrap-db.
(db-close): Modify.
(db-add-specification): Adjust for prepared statement parameters.
(db-get-specifications): Adjust for prepared statement parameters.
(db-add-derivation): Adjust for prepared statement parameters.
(db-get-derivation): Adjust for prepared statement parameters.
(db-add-evaluation): Adjust for prepared statement parameters.
(db-add-build): Adjust for prepared statement parameters.
(db-update-build-status!): Adjust for prepared statement parameters.
(db-get-build): Adjust for prepared statement parameters.
(db-get-builds): Adjust for prepared statement parameters.
(db-get-stamp): Adjust for prepared statement parameters.
(db-add-stamp): Adjust for prepared statement parameters.
---
 src/cuirass/database.scm | 125 ++++++++++++++++++++++++++++++++---------------
 1 file changed, 86 insertions(+), 39 deletions(-)

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index f1d0118..2c923ec 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -24,8 +24,11 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 threads)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-69)
   #:use-module (sqlite3)
   #:export (;; Procedures.
             assq-refs
@@ -53,28 +56,68 @@
             ;; 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-record-type <db>
+  (db native-db lock stmts)
+  db?
+  (native-db db-native-db)
+  (lock db-lock)
+  (stmts db-stmts))
+
+(define (%wrap-db native-db)
+  (db native-db (make-mutex) (make-weak-key-hash-table)))
+
+(define (%sqlite-prepare db sqlsym sqltext)
+  (with-mutex (db-lock db)
+    (let ((stmt (sqlite-prepare (db-native-db db) sqltext)))
+      (hashq-set! (db-stmts db) sqlsym stmt)
+      stmt)))
+
+(define (%sqlite-bind-args stmt args)
+  (let ((argsi (zip (iota (length args)) args)))
+    (for-each (match-lambda ((i arg)
+                (sqlite-bind stmt (1+ i) arg)))
+              argsi)))
+
+(define (%sqlite-fetch-all stmt)
+  (let loop ((res '()))
+    (let ((row (sqlite-step stmt)))
+      (if (not row)
+          (begin
+            (sqlite-reset stmt)
+            (reverse! res))
+          (loop (cons row res))))))
 
 (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* ((sqlsym (quote #,(datum->syntax #'here (string->symbol (string-trim (syntax->datum #'sqltext))))))
+               (stmt (or (hashq-ref (db-stmts db) sqlsym)
+                         (%sqlite-prepare db sqlsym sqltext))))
+          (with-mutex (db-lock db)
+            (%sqlite-bind-args stmt (list arg ...))
+            (%sqlite-fetch-all stmt))))
+     ((_ db sqltext) (string? (syntax->datum #'sqltext))
+      #`(let* ((sqlsym (quote #,(datum->syntax #'here (string->symbol (string-trim (syntax->datum #'sqltext))))))
+               (stmt (or (hashq-ref (db-stmts db) sqlsym)
+                         (%sqlite-prepare db sqlsym sqltext))))
+          (with-mutex (db-lock db)
+            (%sqlite-fetch-all stmt))))
+     ((_ db sqltext arg ...)
+      #`(with-mutex (db-lock db)
+          (let ((stmt (sqlite-prepare (db-native-db db) sqltext)))
+            (%sqlite-bind-args stmt (list arg ...))
+            (let ((result (%sqlite-fetch-all stmt)))
+              (sqlite-finalize stmt)
+              result))))
+     (id (identifier? #'id)
+      #'(lambda (db sqltext . args)
+          (with-mutex (db-lock db)
+            (let ((stmt (sqlite-prepare (db-native-db db) sqltext)))
+              (%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.
@@ -106,8 +149,8 @@ database object."
   (when (file-exists? db-name)
     (format (current-error-port) "Removing leftover database ~a~%" db-name)
     (delete-file db-name))
-  (let ((db (sqlite-open db-name (logior SQLITE_OPEN_CREATE
-                                         SQLITE_OPEN_READWRITE))))
+  (let ((db (%wrap-db (sqlite-open db-name (logior SQLITE_OPEN_CREATE
+                                                   SQLITE_OPEN_READWRITE)))))
     (for-each (lambda (sql) (sqlite-exec db sql))
               (read-sql-file schema))
     db))
@@ -116,12 +159,12 @@ database object."
   "Open database to store or read jobs and builds informations.  Return a
 database object."
   (if (file-exists? db)
-      (sqlite-open db SQLITE_OPEN_READWRITE)
+      (%wrap-db (sqlite-open db SQLITE_OPEN_READWRITE))
       (db-init db)))
 
 (define (db-close db)
   "Close database object DB."
-  (sqlite-close db))
+  (sqlite-close (db-native-db db)))
 
 (define* (assq-refs alst keys #:optional default-value)
   (map (lambda (key) (or (assq-ref alst key) default-value))
@@ -136,9 +179,13 @@ 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 '(#:name #:url #:load-path #:file))
+          (map symbol->string (assq-refs spec '(#:proc)))
+          (map (lambda (e)
+                 (format #f "~A" e))
+               (assq-refs spec '(#:arguments)))
           (assq-refs spec '(#:branch #:tag #:commit) "NULL")
           (list (if (assq-ref spec #:no-compile?) "1" "0"))))
   (last-insert-rowid db))
@@ -167,7 +214,7 @@ 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)
@@ -176,11 +223,11 @@ INSERT OR IGNORE INTO Derivations (derivation, job_name, system, nix_name, evalu
 
 (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))
@@ -227,7 +274,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)
@@ -241,7 +288,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))
@@ -254,17 +301,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
@@ -305,7 +352,7 @@ INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_nam
 (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)))
+                                            " WHERE Builds.id=?;") id)))
     (match res
       ((build)
        (db-format-build db build))
@@ -385,7 +432,7 @@ FILTERS is an assoc list which possible keys are 'project | 'jobset | 'job |
 
 (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
       (() "")
@@ -395,10 +442,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))))