http: Change the paramater format from two-elements lists to pairs.
* src/cuirass/database.scm (assqx-ref): Remove exported procedure.
(db-get-builds, db-get-build): Adapt to new format.
* src/cuirass/http.scm (request-parameters): Use (cons key param) instead
of (list key param).
(url-handler): Adapt to new format.
* tests/database.scm ("db-get-builds"): Idem.
This commit is contained in:
Clément Lassieur
parent
675cd04a85
commit
99241ef1af
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue