[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Ludovic Courtès |
|
Date: |
Sat, 17 Aug 2019 13:09:25 -0400 (EDT) |
branch: master
commit c6f4fa5f577e4752d845fa3ce17c68fcd2079904
Author: Ludovic Courtès <address@hidden>
Date: Sat Aug 17 18:48:34 2019 +0200
Switch to Guile-JSON 3.x.
Guile-JSON 3.x is incompatible with Guile-JSON 1.x, which we relied on
until now: it maps JSON dictionaries to alists (instead of hash tables),
and JSON arrays to vectors (instead of lists). This commit is about
adjusting all the existing code to this new mapping.
* src/cuirass/http.scm (evaluation->json-object): New procedure.
(handle-builds-request): Pass the result through 'list->vector'.
(handle-builds-search-request): Likewise.
(url-handler): Likewise for /jobsets, /specifications, /api/evaluations,
and /build. For /api/evaluations, use 'evaluation->json-object'.
* src/cuirass/utils.scm (object->json-scm): Add 'vector?' case.
* tests/http.scm (hash-table-keys, hash-table=?): Remove.
(evaluations-query-result): Use vectors for JSON arrays.
("object->json-string"): Expects alists instead of hash tables.
("/build/1"): Use 'lset=' instead of 'hash-table=?'.
("/api/latestbuilds?nr=1&jobset=guix"): Likewise, and expect alists
instead of hash tables.
("/api/latestbuilds?nr=1&jobset=gnu"): Likewise.
("/api/evaluations?nr=1"): Likewise.
* README: Mention Guile-JSON 3.x.
---
README | 2 +-
src/cuirass/http.scm | 23 ++++++--
src/cuirass/utils.scm | 4 +-
tests/http.scm | 148 ++++++++++++++++++--------------------------------
4 files changed, 76 insertions(+), 101 deletions(-)
diff --git a/README b/README
index 98824cf..58200f6 100644
--- a/README
+++ b/README
@@ -9,7 +9,7 @@ Cuirass currently depends on the following packages:
- GNU Guile 2.0.9 or later
- GNU Guix (and all its development dependencies)
- GNU Make
- - Guile-JSON
+ - Guile-JSON 3.x
- Guile-SQLite3
- Guile-Git
- Fibers
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index b69b6ce..a26b1c6 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -105,6 +105,14 @@
(#:releasename . #nil)
(#:buildinputs_builds . #nil)))
+(define (evaluation->json-object evaluation)
+ "Turn EVALUATION into a representation suitable for 'json->scm'."
+ ;; XXX: Since #:checkouts is a list of alists, we must turn it into a vector
+ ;; so that 'json->scm' converts it to a JSON array.
+ `(,@(alist-delete #:checkouts evaluation eq?)
+ (#:checkouts . ,(list->vector
+ (assq-ref evaluation #:checkouts)))))
+
(define (handle-build-request build-id)
"Retrieve build identified by BUILD-ID over the database and convert it to
hydra format. Return #f is not build was found."
@@ -116,14 +124,14 @@ hydra format. Return #f is not build was found."
Hydra format."
(let ((builds (with-time-logging "builds request"
(db-get-builds filters))))
- (map build->hydra-build builds)))
+ (list->vector (map build->hydra-build builds))))
(define (handle-builds-search-request filters)
"Retrieve all builds matched by FILTERS in the database and convert them to
Hydra format."
(let ((builds (with-time-logging "builds search request"
(db-get-builds-by-search filters))))
- (map build->hydra-build builds)))
+ (list->vector (map build->hydra-build builds))))
(define (request-parameters request)
"Parse the REQUEST query parameters and return them under the form
@@ -233,7 +241,8 @@ Hydra format."
(request-path-components request)
'method-not-allowed)
(((or "jobsets" "specifications") . rest)
- (respond-json (object->json-string (db-get-specifications))))
+ (respond-json (object->json-string
+ (list->vector (db-get-specifications)))))
(("build" build-id)
(let ((hydra-build (handle-build-request (string->number build-id))))
(if hydra-build
@@ -274,7 +283,10 @@ Hydra format."
;; 'nr parameter is mandatory to limit query size.
(nr (assq-ref params 'nr)))
(if nr
- (respond-json (object->json-string (db-get-evaluations nr)))
+ (respond-json (object->json-string
+ (list->vector
+ (map evaluation->json-object
+ (db-get-evaluations nr)))))
(respond-json-with-error 500 "Parameter not defined!"))))
(("api" "latestbuilds")
(let* ((params (request-parameters request))
@@ -304,7 +316,8 @@ Hydra format."
('()
(respond-html (html-page
"Cuirass"
- (specifications-table (db-get-specifications))
+ (specifications-table
+ (list->vector (db-get-specifications)))
'())))
(("jobset" name)
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 48e797c..fe74b69 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -1,5 +1,5 @@
;;; utils.scm -- helper procedures
-;;; Copyright © 2012, 2013, 2016, 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2016, 2018, 2019 Ludovic Courtès <address@hidden>
;;; Copyright © 2015 David Thompson <address@hidden>
;;; Copyright © 2016 Mathieu Lirzin <address@hidden>
;;; Copyright © 2018 Clément Lassieur <address@hidden>
@@ -57,6 +57,8 @@
((null? obj) obj)
((symbol? obj) (symbol->string obj))
((keyword? obj) (object->json-scm (keyword->symbol obj)))
+ ((vector? obj) (list->vector
+ (map object->json-scm (vector->list obj))))
((alist? obj) (map object->json-scm obj))
((pair? obj) (cons (object->json-scm (car obj))
(object->json-scm (cdr obj))))
diff --git a/tests/http.scm b/tests/http.scm
index ae56356..600f574 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -1,6 +1,6 @@
;;; http.scm -- tests for (cuirass http) module
;;; Copyright © 2016 Mathieu Lirzin <address@hidden>
-;;; Copyright © 2017, 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <address@hidden>
;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
;;; Copyright © 2018 Clément Lassieur <address@hidden>
;;;
@@ -32,29 +32,6 @@
(srfi srfi-64)
(ice-9 match))
-(define (hash-table-keys table)
- (hash-fold (lambda (key value rest)
- (cons key rest))
- '()
- table))
-
-(define (hash-table=? t1 t2)
- (and (lset= equal?
- (hash-table-keys t1)
- (hash-table-keys t2))
- (hash-fold (lambda (key value result)
- (and result
- (let ((equal?
- (match value
- ((? hash-table?) hash-table=?)
- (((? hash-table?) ...)
- (cut every hash-table=? <> <>))
- (_ equal?))))
- (equal? value
- (hash-ref t2 key)))))
- #t
- t1)))
-
(define (http-get-body uri)
(call-with-values (lambda () (http-get uri))
(lambda (response body) body)))
@@ -98,37 +75,34 @@
(#:buildinputs_builds . #nil)))
(define evaluations-query-result
- '(((#:id . 2)
+ #(((#:id . 2)
(#:specification . "guix")
(#:in-progress . 1)
- (#:checkouts . (((#:commit . "fakesha2")
- (#:input . "savannah")
- (#:directory . "dir3")))))))
+ (#:checkouts . #(((#:commit . "fakesha2")
+ (#:input . "savannah")
+ (#:directory . "dir3")))))))
(test-group-with-cleanup "http"
(test-assert "object->json-string"
- ;; Note: We cannot compare the strings directly because field ordering
- ;; depends on the hash algorithm used in Guile's hash tables, and that
- ;; algorithm changed in Guile 2.2.
- (hash-table=?
- (call-with-input-string
- (string-append "{"
- "\"boolean\" : false,"
- "\"string\" : \"guix\","
- "\"alist\" : {\"subset\" : \"hello\"},"
- "\"list\" : [1, \"2\", \"three\"],"
- "\"symbol\" : \"hydra-jobs\","
- "\"number\" : 1"
- "}")
- json->scm)
- (call-with-input-string
- (object->json-string '((#:number . 1)
- (string . "guix")
- ("symbol" . hydra-jobs)
- (#:alist (subset . "hello"))
- (list 1 "2" #:three)
- ("boolean" . #f)))
- json->scm)))
+ (lset= equal?
+ (call-with-input-string
+ (string-append "{"
+ "\"boolean\" : false,"
+ "\"string\" : \"guix\","
+ "\"alist\" : {\"subset\" : \"hello\"},"
+ "\"list\" : [1, \"2\", \"three\"],"
+ "\"symbol\" : \"hydra-jobs\","
+ "\"number\" : 1"
+ "}")
+ json->scm)
+ (call-with-input-string
+ (object->json-string '((#:number . 1)
+ (string . "guix")
+ ("symbol" . hydra-jobs)
+ (#:alist . ((subset . "hello")))
+ (list . #(1 "2" #:three))
+ ("boolean" . #f)))
+ json->scm)))
(test-assert "db-init"
(begin
@@ -215,7 +189,7 @@
(db-add-evaluation "guix" checkouts2)))
(test-assert "/build/1"
- (hash-table=?
+ (lset= equal?
(call-with-input-string
(utf8->string
(http-get-body (test-cuirass-uri "/build/1")))
@@ -247,54 +221,40 @@
(response-code (http-get (test-cuirass-uri "/api/latestbuilds"))))
(test-assert "/api/latestbuilds?nr=1&jobset=guix"
- (let ((hash-list
- (call-with-input-string
- (utf8->string
- (http-get-body
- (test-cuirass-uri
- "/api/latestbuilds?nr=1&jobset=guix")))
- json->scm)))
- (and (= (length hash-list) 1)
- (hash-table=?
- (car hash-list)
- (call-with-input-string
- (object->json-string build-query-result)
- json->scm)))))
+ (match (json-string->scm
+ (utf8->string
+ (http-get-body
+ (test-cuirass-uri
+ "/api/latestbuilds?nr=1&jobset=guix"))))
+ (#(build)
+ (lset= equal? build
+ (json-string->scm
+ (object->json-string build-query-result))))))
- (test-assert "/api/latestbuilds?nr=1&jobset=gnu"
- ;; The result should be an empty JSON array.
- (let ((hash-list
- (call-with-input-string
- (utf8->string
- (http-get-body
- (test-cuirass-uri
- "/api/latestbuilds?nr=1&jobset=gnu")))
- json->scm)))
- (= (length hash-list) 0)))
+ (test-equal "/api/latestbuilds?nr=1&jobset=gnu"
+ #() ;the result should be an empty JSON array
+ (json-string->scm
+ (utf8->string
+ (http-get-body
+ (test-cuirass-uri
+ "/api/latestbuilds?nr=1&jobset=gnu")))))
(test-equal "/api/queue?nr=100"
`("fake-2.0" ,(build-status scheduled))
- (match (call-with-input-string
- (utf8->string
- (http-get-body
- (test-cuirass-uri "/api/queue?nr=100")))
- json->scm)
- ((dictionary)
- (list (hash-ref dictionary "nixname")
- (hash-ref dictionary "buildstatus")))))
+ (match (json-string->scm
+ (utf8->string
+ (http-get-body
+ (test-cuirass-uri "/api/queue?nr=100"))))
+ (#(dictionary)
+ (list (assoc-ref dictionary "nixname")
+ (assoc-ref dictionary "buildstatus")))))
- (test-assert "/api/evaluations?nr=1"
- (let ((hash-list
- (call-with-input-string
- (utf8->string
- (http-get-body (test-cuirass-uri "/api/evaluations?nr=1")))
- json->scm)))
- (and (= (length hash-list) 1)
- (hash-table=?
- (car hash-list)
- (car (call-with-input-string
- (object->json-string evaluations-query-result)
- json->scm))))))
+ (test-equal "/api/evaluations?nr=1"
+ (json-string->scm
+ (object->json-string evaluations-query-result))
+ (json-string->scm
+ (utf8->string
+ (http-get-body (test-cuirass-uri "/api/evaluations?nr=1")))))
(test-assert "db-close"
(db-close (%db)))