[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Clément Lassieur |
|
Date: |
Sun, 29 Jul 2018 18:39:19 -0400 (EDT) |
branch: master
commit 99241ef1af24cadf39e3cad39f9ff27c96b22068
Author: Clément Lassieur <address@hidden>
Date: Fri Jul 20 10:50:48 2018 +0200
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.
---
src/cuirass/database.scm | 49 +++++++++++++++++++-----------------------------
src/cuirass/http.scm | 42 ++++++++++++++++++++---------------------
tests/database.scm | 10 ++++++----
3 files changed, 45 insertions(+), 56 deletions(-)
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")