diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 9b442c1..56f421d 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -58,7 +58,6 @@ read-sql-file read-quoted-string sqlite-exec - assqx-ref ;; Parameters. %package-database %package-schema-file @@ -461,16 +460,6 @@ log file for DRV." (#:repo-name . ,repo-name) (#:outputs . ,(db-get-outputs db id)))))) -;; XXX Change caller and remove -(define (assqx-ref filters key) - (match filters - (() - #f) - (((xkey xvalue) rest ...) - (if (eq? key xkey) - xvalue - (assqx-ref rest key))))) - (define (db-get-builds db filters) "Retrieve all builds in database DB which are matched by given FILTERS. FILTERS is an assoc list whose possible keys are 'id | 'jobset | 'job | @@ -547,13 +536,13 @@ Assumes that if group id stays the same the group headers stay the same." (collect-outputs x-builds-id x-repeated-row '() rows))))) (let* ((order (match (assq 'order filters) - (('order 'build-id) "id ASC") - (('order 'decreasing-build-id) "id DESC") - (('order 'finish-time) "stoptime DESC") - (('order 'finish-time+build-id) "stoptime DESC, id DESC") - (('order 'start-time) "starttime DESC") - (('order 'submission-time) "timestamp DESC") - (('order 'status+submission-time) + (('order . 'build-id) "id ASC") + (('order . 'decreasing-build-id) "id DESC") + (('order . 'finish-time) "stoptime DESC") + (('order . 'finish-time+build-id) "stoptime DESC, id DESC") + (('order . 'start-time) "starttime DESC") + (('order . 'submission-time) "timestamp DESC") + (('order . 'status+submission-time) ;; With this order, builds in 'running' state (-1) appear ;; before those in 'scheduled' state (-2). "status DESC, timestamp DESC") @@ -585,17 +574,17 @@ ORDER BY ~a, id ASC;" order)) (stmt (sqlite-prepare db stmt-text #:cache? #t))) (sqlite-bind-arguments stmt - #:id (assqx-ref filters 'id) - #:jobset (assqx-ref filters 'jobset) - #:job (assqx-ref filters 'job) - #:evaluation (assqx-ref filters 'evaluation) - #:system (assqx-ref filters 'system) - #:status (and=> (assqx-ref filters 'status) object->string) - #:borderlowid (assqx-ref filters 'border-low-id) - #:borderhighid (assqx-ref filters 'border-high-id) - #:borderlowtime (assqx-ref filters 'border-low-time) - #:borderhightime (assqx-ref filters 'border-high-time) - #:nr (match (assqx-ref filters 'nr) + #:id (assq-ref filters 'id) + #:jobset (assq-ref filters 'jobset) + #:job (assq-ref filters 'job) + #:evaluation (assq-ref filters 'evaluation) + #:system (assq-ref filters 'system) + #:status (and=> (assq-ref filters 'status) object->string) + #:borderlowid (assq-ref filters 'border-low-id) + #:borderhighid (assq-ref filters 'border-high-id) + #:borderlowtime (assq-ref filters 'border-low-time) + #:borderhightime (assq-ref filters 'border-high-time) + #:nr (match (assq-ref filters 'nr) (#f -1) (x x))) (sqlite-reset stmt) @@ -603,7 +592,7 @@ ORDER BY ~a, id ASC;" order)) (define (db-get-build db id) "Retrieve a build in database DB which corresponds to ID." - (match (db-get-builds db `((id ,id))) + (match (db-get-builds db `((id . ,id))) ((build) build) (() #f))) diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm index 5a5eb52..2d66ff9 100644 --- a/src/cuirass/http.scm +++ b/src/cuirass/http.scm @@ -118,7 +118,7 @@ (define (request-parameters request) "Parse the REQUEST query parameters and return them under the form - '((parameter value) ...)." + '((parameter . value) ...)." (let* ((uri (request-uri request)) (query (uri-query uri))) (if query @@ -126,7 +126,7 @@ (match (string-split param #\=) ((key param) (let ((key-symbol (string->symbol key))) - (list key-symbol + (cons key-symbol (match key-symbol ('id (string->number param)) ('nr (string->number param)) @@ -248,9 +248,7 @@ (("api" "evaluations") (let* ((params (request-parameters request)) ;; 'nr parameter is mandatory to limit query size. - (nr (match (assq-ref params 'nr) - ((val) val) - (_ #f)))) + (nr (assq-ref params 'nr))) (if nr (respond-json (object->json-string (with-critical-section db-channel (db) @@ -265,9 +263,9 @@ (respond-json (object->json-string (with-critical-section db-channel (db) - (handle-builds-request db `((status done) + (handle-builds-request db `((status . done) ,@params - (order finish-time)))))) + (order . finish-time)))))) (respond-json-with-error 500 "Parameter not defined!")))) (("api" "queue") (let* ((params (request-parameters request)) @@ -279,9 +277,9 @@ ;; Use the 'status+submission-time' order so that builds in ;; 'running' state appear before builds in 'scheduled' state. (with-critical-section db-channel (db) - (handle-builds-request db `((status pending) + (handle-builds-request db `((status . pending) ,@params - (order status+submission-time)))))) + (order . status+submission-time)))))) (respond-json-with-error 500 "Parameter not defined!")))) ('() (respond-html (html-page @@ -296,8 +294,8 @@ (let* ((evaluation-id-max (db-get-evaluations-id-max db name)) (evaluation-id-min (db-get-evaluations-id-min db name)) (params (request-parameters request)) - (border-high (assqx-ref params 'border-high)) - (border-low (assqx-ref params 'border-low)) + (border-high (assq-ref params 'border-high)) + (border-low (assq-ref params 'border-low)) (evaluations (db-get-evaluations-build-summary db name %page-size @@ -314,20 +312,20 @@ (let* ((builds-id-max (db-get-builds-max db id)) (builds-id-min (db-get-builds-min db id)) (params (request-parameters request)) - (border-high-time (assqx-ref params 'border-high-time)) - (border-low-time (assqx-ref params 'border-low-time)) - (border-high-id (assqx-ref params 'border-high-id)) - (border-low-id (assqx-ref params 'border-low-id))) + (border-high-time (assq-ref params 'border-high-time)) + (border-low-time (assq-ref params 'border-low-time)) + (border-high-id (assq-ref params 'border-high-id)) + (border-low-id (assq-ref params 'border-low-id))) (html-page "Evaluation" (build-eval-table - (handle-builds-request db `((evaluation ,id) - (nr ,%page-size) - (order finish-time+build-id) - (border-high-time ,border-high-time) - (border-low-time ,border-low-time) - (border-high-id ,border-high-id) - (border-low-id ,border-low-id))) + (handle-builds-request db `((evaluation . ,id) + (nr . ,%page-size) + (order . finish-time+build-id) + (border-high-time . ,border-high-time) + (border-low-time . ,border-low-time) + (border-high-id . ,border-high-id) + (border-low-id . ,border-low-id))) builds-id-min builds-id-max)))))) diff --git a/tests/database.scm b/tests/database.scm index 6ca9d1c..17d48f5 100644 --- a/tests/database.scm +++ b/tests/database.scm @@ -194,12 +194,14 @@ INSERT INTO Evaluations (specification, commits) VALUES (3, 3);") (let ((summarize (lambda (alist) (list (assq-ref alist #:id) (assq-ref alist #:derivation))))) - (vector (map summarize (db-get-builds db '((nr 3) (order build-id)))) + (vector (map summarize (db-get-builds db '((nr . 3) + (order . build-id)))) (map summarize (db-get-builds db '())) - (map summarize (db-get-builds db '((jobset "guix")))) - (map summarize (db-get-builds db '((nr 1)))) + (map summarize (db-get-builds db '((jobset . "guix")))) + (map summarize (db-get-builds db '((nr . 1)))) (map summarize - (db-get-builds db '((order status+submission-time)))))))) + (db-get-builds + db '((order . status+submission-time)))))))) (test-equal "db-get-pending-derivations" '("/bar.drv" "/foo.drv")