2
0
Fork 0
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git synced 2023-12-14 06:03:04 +01:00

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.
This commit is contained in:
Ludovic Courtès 2019-08-17 18:48:34 +02:00
parent 92bdf3cda0
commit c6f4fa5f57
4 changed files with 76 additions and 101 deletions

2
README
View file

@ -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

View file

@ -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)

View file

@ -1,5 +1,5 @@
;;; utils.scm -- helper procedures
;;; Copyright © 2012, 2013, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
@ -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))))

View file

@ -1,6 +1,6 @@
;;; http.scm -- tests for (cuirass http) module
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
@ -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)))