From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:38824) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ejpAB-0006S7-Sn for guix-patches@gnu.org; Thu, 08 Feb 2018 11:35:09 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ejpA5-0002xF-Sh for guix-patches@gnu.org; Thu, 08 Feb 2018 11:35:07 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:54577) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1ejpA5-0002x9-P6 for guix-patches@gnu.org; Thu, 08 Feb 2018 11:35:01 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ejpA5-0006XG-JE for guix-patches@gnu.org; Thu, 08 Feb 2018 11:35:01 -0500 Subject: [bug#30386] [PATCH v2 cuirass] database: Prevent SQL injection. Resent-Message-ID: From: Danny Milosavljevic Date: Thu, 8 Feb 2018 17:34:32 +0100 Message-Id: <20180208163432.9468-1-dannym@scratchpost.org> In-Reply-To: <20180207231258.31169-1-dannym@scratchpost.org> References: <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: 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."