branch: master
commit 77bf78ecf7a3e2b500af9095d023ad0086599d02
Author: Ludovic Courtès <[email protected]>
AuthorDate: Wed Aug 23 15:50:24 2023 +0200
http: Use Guile-JSON's 'scm->json-string' directly.
The intermediate representation with keywords instead of symbols in
alists turns out to be useless.
* src/cuirass/http.scm (build->hydra-build)
(evaluation->json-object, specification->json-object)
(jobs-history->json-object): Use symbols instead of keywords in the car
of alists. Use 'scm->json-string' instead of 'object->json-string'.
* src/cuirass/http.scm (url-handler): Likewise.
* tests/http.scm (build-query-result, evaluations-query-result): Use
symbols instead of keywords.
("/build/1", "/api/latestbuilds?nr=1&jobset=guix")
("/api/evaluations?nr=1"): Use 'scm->json-string' instead of
'object->json-string'.
---
src/cuirass/http.scm | 170 +++++++++++++++++++++++++--------------------------
tests/http.scm | 60 +++++++++---------
2 files changed, 115 insertions(+), 115 deletions(-)
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index e73cc54..4a20b7f 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -104,101 +104,101 @@
(define finished?
(>= (build-current-status build) 0))
- `((#:id . ,(build-id build))
- (#:evaluation . ,(build-evaluation-id build))
- (#:jobset . ,(build-specification-name build))
- (#:job . ,(build-job-name build))
+ `((id . ,(build-id build))
+ (evaluation . ,(build-evaluation-id build))
+ (jobset . ,(build-specification-name build))
+ (job . ,(build-job-name build))
;; Hydra's API uses "timestamp" as the time of the last useful event for
;; that build: evaluation or completion.
- (#:timestamp . ,(if finished?
- (build-completion-time build)
- (build-creation-time build)))
-
- (#:starttime . ,(build-start-time build))
- (#:stoptime . ,(build-completion-time build))
- (#:derivation . ,(build-derivation build))
- (#:buildoutputs . ,(map (lambda (output)
- (list (output-name output)
- (cons "path"
- (output-item output))))
- (build-outputs build)))
- (#:system . ,(build-system build))
- (#:nixname . ,(build-nix-name build))
- (#:buildstatus . ,(build-current-status build))
- (#:weather . ,(build-current-weather build))
- (#:busy . ,(bool->int (eqv? (build-status started)
- (build-current-status build))))
- (#:priority . ,(build-priority build))
- (#:finished . ,(bool->int finished?))
- (#:buildproducts . ,(list->vector (build-products build)))))
+ (timestamp . ,(if finished?
+ (build-completion-time build)
+ (build-creation-time build)))
+
+ (starttime . ,(build-start-time build))
+ (stoptime . ,(build-completion-time build))
+ (derivation . ,(build-derivation build))
+ (buildoutputs . ,(map (lambda (output)
+ (list (output-name output)
+ (cons "path"
+ (output-item output))))
+ (build-outputs build)))
+ (system . ,(build-system build))
+ (nixname . ,(build-nix-name build))
+ (buildstatus . ,(build-current-status build))
+ (weather . ,(build-current-weather build))
+ (busy . ,(bool->int (eqv? (build-status started)
+ (build-current-status build))))
+ (priority . ,(build-priority build))
+ (finished . ,(bool->int finished?))
+ (buildproducts . ,(list->vector (build-products build)))))
(define (evaluation->json-object evaluation)
"Turn EVALUATION into a representation suitable for 'json->scm'."
- `((#:id . ,(evaluation-id evaluation))
- (#:specification . ,(evaluation-specification-name evaluation))
- (#:status . ,(evaluation-current-status evaluation))
- (#:timestamp . ,(evaluation-completion-time evaluation))
- (#:checkouttime . ,(evaluation-checkout-time evaluation))
- (#:evaltime . ,(evaluation-start-time evaluation))
- (#:checkouts
+ `((id . ,(evaluation-id evaluation))
+ (specification . ,(evaluation-specification-name evaluation))
+ (status . ,(evaluation-current-status evaluation))
+ (timestamp . ,(evaluation-completion-time evaluation))
+ (checkouttime . ,(evaluation-checkout-time evaluation))
+ (evaltime . ,(evaluation-start-time evaluation))
+ (checkouts
. ,(list->vector
(map (lambda (checkout)
- `((#:commit . ,(checkout-commit checkout))
- (#:channel . ,(checkout-channel checkout))
- (#:directory . ,(checkout-directory checkout))))
+ `((commit . ,(checkout-commit checkout))
+ (channel . ,(checkout-channel checkout))
+ (directory . ,(checkout-directory checkout))))
(evaluation-checkouts evaluation))))))
(define (specification->json-object spec)
"Turn SPEC into a representation suitable for 'json->scm'."
(define (channel->json-object channel)
- `((#:name . ,(channel-name channel))
- (#:url . ,(channel-url channel))
- (#:branch . ,(channel-branch channel))
- (#:commit . ,(channel-commit channel))))
+ `((name . ,(channel-name channel))
+ (url . ,(channel-url channel))
+ (branch . ,(channel-branch channel))
+ (commit . ,(channel-commit channel))))
(define (build-output->json-object build-output)
- `((#:job . ,(build-output-job build-output))
- (#:type . ,(build-output-type build-output))
- (#:output . ,(build-output-output build-output))
- (#:path . ,(build-output-path build-output))))
+ `((job . ,(build-output-job build-output))
+ (type . ,(build-output-type build-output))
+ (output . ,(build-output-output build-output))
+ (path . ,(build-output-path build-output))))
(define (notification->json-object notif)
(cond
((email? notif)
- `((#:type . email)
- (#:from . ,(email-from notif))
- (#:to . ,(email-to notif))
- (#:server . ,(email-server notif))))
+ `((type . email)
+ (from . ,(email-from notif))
+ (to . ,(email-to notif))
+ (server . ,(email-server notif))))
((mastodon? notif)
- `((#:type . mastodon)))))
-
- `((#:name . ,(specification-name spec))
- (#:build . ,(specification-build spec))
- (#:channels . ,(list->vector
- (map channel->json-object
- (specification-channels spec))))
- (#:build-outputs . ,(list->vector
- (map build-output->json-object
- (specification-build-outputs spec))))
- (#:notifications . ,(list->vector
- (map notification->json-object
- (specification-notifications spec))))
- (#:period . ,(specification-period spec))
- (#:priority . ,(specification-priority spec))
- (#:systems . ,(list->vector
- (specification-systems spec)))))
+ `((type . mastodon)))))
+
+ `((name . ,(specification-name spec))
+ (build . ,(specification-build spec))
+ (channels . ,(list->vector
+ (map channel->json-object
+ (specification-channels spec))))
+ (build-outputs . ,(list->vector
+ (map build-output->json-object
+ (specification-build-outputs spec))))
+ (notifications . ,(list->vector
+ (map notification->json-object
+ (specification-notifications spec))))
+ (period . ,(specification-period spec))
+ (priority . ,(specification-priority spec))
+ (systems . ,(list->vector
+ (specification-systems spec)))))
(define (jobs-history->json-object history)
"Turn HISTORY into a representation suitable for 'json->scm'."
- (object->json-string
+ (scm->json-string
(list->vector
(map (lambda (eval)
- `((#:evaluation . ,(assq-ref eval #:evaluation))
- (#:checkouts . ,(list->vector
- (assq-ref eval #:checkouts)))
- (#:jobs . ,(list->vector
- (assq-ref eval #:jobs)))))
+ `((evaluation . ,(assq-ref eval #:evaluation))
+ (checkouts . ,(list->vector
+ (assq-ref eval #:checkouts)))
+ (jobs . ,(list->vector
+ (assq-ref eval #:jobs)))))
history))))
(define (handle-build-request build-id)
@@ -530,7 +530,7 @@ passed, only display JOBS targeting this SYSTEM."
(build-response #:headers '((content-type . (application/json)))
#:code error-code)
#:body
- (object->json-string
+ (scm->json-string
`((error . ,message)))))
(define (redirect ref)
@@ -734,7 +734,7 @@ passed, only display JOBS targeting this SYSTEM."
#:body "")))
(('GET (or "jobsets" "specifications") . rest)
- (respond-json (object->json-string
+ (respond-json (scm->json-string
(list->vector
(map specification->json-object
(db-get-specifications))))))
@@ -761,7 +761,7 @@ passed, only display JOBS targeting this SYSTEM."
(hydra-build (and build
(handle-build-request build))))
(if hydra-build
- (respond-json (object->json-string hydra-build))
+ (respond-json (scm->json-string hydra-build))
(respond-build-not-found id))))
(('GET "build" (= string->number id) "details")
(let* ((build (and id (db-get-build id)))
@@ -801,18 +801,18 @@ passed, only display JOBS targeting this SYSTEM."
(if output
(let ((build (db-get-build (output-derivation output))))
(respond-json
- (object->json-string
- `((#:name . ,(output-name output))
- (#:derivation . ,(output-derivation output))
- (#:build . ,(or (and=> build build->hydra-build)
- #nil))))))
+ (scm->json-string
+ `((name . ,(output-name output))
+ (derivation . ,(output-derivation output))
+ (build . ,(or (and=> build build->hydra-build)
+ #nil))))))
(respond-output-not-found id))))
(('GET "api" "jobs")
(let* ((params (request-parameters request))
(eval-id (assq-ref params 'evaluation)))
(if eval-id
(respond-json
- (object->json-string
+ (scm->json-string
(list->vector
(map job->alist
(db-get-jobs eval-id
@@ -853,8 +853,8 @@ passed, only display JOBS targeting this SYSTEM."
(let ((id (db-register-dashboard spec names)))
(if id
(respond-json
- (object->json-string
- `((#:id . ,id))))
+ (scm->json-string
+ `((id . ,id))))
(respond-json-with-error
500
"Failed to register the dashboard")))))))
@@ -862,7 +862,7 @@ passed, only display JOBS targeting this SYSTEM."
(let* ((params (request-parameters request))
(id (assq-ref params 'id)))
(if id
- (respond-json (object->json-string
+ (respond-json (scm->json-string
(evaluation->json-object
(db-get-evaluation id))))
(respond-json-with-error 500 "Parameter not defined!"))))
@@ -872,7 +872,7 @@ passed, only display JOBS targeting this SYSTEM."
;; 'nr parameter is mandatory to limit query size.
(nr (assq-ref params 'nr)))
(if nr
- (respond-json (object->json-string
+ (respond-json (scm->json-string
(list->vector
(map evaluation->json-object
(db-get-evaluations nr spec)))))
@@ -893,7 +893,7 @@ passed, only display JOBS targeting this SYSTEM."
;; time to complete. Ordering by timestamp wouldn't work as
;; evaluations are not always performed sequentially.
(respond-json
- (object->json-string
+ (scm->json-string
(handle-builds-request `((status . done)
,@params
(order . evaluation)))))))))
@@ -908,7 +908,7 @@ passed, only display JOBS targeting this SYSTEM."
(respond-json-with-error 500 "Maximum limit exceeded"))
(else
(respond-json
- (object->json-string
+ (scm->json-string
;; Use the 'status+submission-time' order so that builds in
;; 'running' state appear before builds in 'scheduled' state.
(handle-builds-request `((status . pending)
diff --git a/tests/http.scm b/tests/http.scm
index 3561f01..3bf52d2 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -1,6 +1,6 @@
;;; http.scm -- tests for (cuirass http) module
;;; Copyright © 2016 Mathieu Lirzin <[email protected]>
-;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <[email protected]>
+;;; Copyright © 2017, 2018, 2019, 2020, 2023 Ludovic Courtès <[email protected]>
;;; Copyright © 2017, 2020, 2021 Mathieu Othacehe <[email protected]>
;;; Copyright © 2018 Clément Lassieur <[email protected]>
;;;
@@ -53,34 +53,34 @@
(string-append "http://localhost:6688"; route))
(define build-query-result
- '((#:id . 1)
- (#:evaluation . 1)
- (#:jobset . "guix")
- (#:job . "fake-job")
- (#:timestamp . 1501347493)
- (#:starttime . 1501347493)
- (#:stoptime . 1501347493)
- (#:derivation . "/gnu/store/fake.drv")
- (#:buildoutputs . ((out ("path" . "/gnu/store/fake-1.0"))))
- (#:system . "x86_64-linux")
- (#:nixname . "fake-1.0")
- (#:buildstatus . 0)
- (#:weather . -1)
- (#:busy . 0)
- (#:priority . 9)
- (#:finished . 1)
- (#:buildproducts . #())))
+ '((id . 1)
+ (evaluation . 1)
+ (jobset . "guix")
+ (job . "fake-job")
+ (timestamp . 1501347493)
+ (starttime . 1501347493)
+ (stoptime . 1501347493)
+ (derivation . "/gnu/store/fake.drv")
+ (buildoutputs . ((out ("path" . "/gnu/store/fake-1.0"))))
+ (system . "x86_64-linux")
+ (nixname . "fake-1.0")
+ (buildstatus . 0)
+ (weather . -1)
+ (busy . 0)
+ (priority . 9)
+ (finished . 1)
+ (buildproducts . #())))
(define evaluations-query-result
- #(((#:id . 2)
- (#:specification . "guix")
- (#:status . -1)
- (#:timestamp . 1501347493)
- (#:checkouttime . 0)
- (#:evaltime . 0)
- (#:checkouts . #(((#:commit . "fakesha2")
- (#:channel . "guix")
- (#:directory . "dir3")))))))
+ #(((id . 2)
+ (specification . "guix")
+ (status . -1)
+ (timestamp . 1501347493)
+ (checkouttime . 0)
+ (evaltime . 0)
+ (checkouts . #(((commit . "fakesha2")
+ (channel . "guix")
+ (directory . "dir3")))))))
(test-group-with-cleanup "http"
(test-assert "object->json-string"
@@ -207,7 +207,7 @@
(http-get-body (test-cuirass-uri "/build/1")))
json->scm)
(call-with-input-string
- (object->json-string build-query-result)
+ (scm->json-string build-query-result)
json->scm)))
(test-equal "/build/42"
@@ -247,7 +247,7 @@
(#(build)
(lset= equal? build
(json-string->scm
- (object->json-string build-query-result))))))
+ (scm->json-string build-query-result))))))
(test-equal "/api/latestbuilds?nr=1&jobset=gnu"
#() ;the result should be an empty JSON array
@@ -276,7 +276,7 @@
(test-equal "/api/evaluations?nr=1"
(json-string->scm
- (object->json-string evaluations-query-result))
+ (scm->json-string evaluations-query-result))
(json-string->scm
(utf8->string
(http-get-body (test-cuirass-uri "/api/evaluations?nr=1")))))
