[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#30386] [PATCH v2 cuirass] database: Prevent SQL injection.
From: |
Danny Milosavljevic |
Subject: |
[bug#30386] [PATCH v2 cuirass] database: Prevent SQL injection. |
Date: |
Thu, 8 Feb 2018 17:34:32 +0100 |
* 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."