From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:42678) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ejYuj-0007O8-EO for guix-patches@gnu.org; Wed, 07 Feb 2018 18:14:07 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ejYug-0008N5-4e for guix-patches@gnu.org; Wed, 07 Feb 2018 18:14:05 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:53911) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1ejYug-0008Mz-0p for guix-patches@gnu.org; Wed, 07 Feb 2018 18:14:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ejYuf-0006j6-R3 for guix-patches@gnu.org; Wed, 07 Feb 2018 18:14:01 -0500 Subject: [bug#30386] [PATCH cuirass] database: Prevent SQL injection. Resent-Message-ID: Received: from eggs.gnu.org ([2001:4830:134:3::10]:42365) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ejYu1-0006ZS-1w for guix-patches@gnu.org; Wed, 07 Feb 2018 18:13:23 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ejYtu-0007De-Qr for guix-patches@gnu.org; Wed, 07 Feb 2018 18:13:21 -0500 Received: from dd26836.kasserver.com ([85.13.145.193]:54616) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1ejYtu-00078b-FN for guix-patches@gnu.org; Wed, 07 Feb 2018 18:13:14 -0500 From: Danny Milosavljevic Date: Thu, 8 Feb 2018 00:12:58 +0100 Message-Id: <20180207231258.31169-1-dannym@scratchpost.org> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 30386@debbugs.gnu.org * 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))))