--- Begin Message ---
|
Subject: |
[PATCH cuirass] database: Prevent SQL injection. |
|
Date: |
Thu, 8 Feb 2018 00:12:58 +0100 |
* 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'address@hidden, 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'address@hidden, 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))))
--- End Message ---