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

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

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)

src/cuirass/utils.scm

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

tests/http.scm

@@ -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")
+     (#:checkouts . #(((#:commit . "fakesha2")
-                      (#:input . "savannah")
+                       (#:input . "savannah")
-                      (#:directory . "dir3")))))))
+                       (#:directory . "dir3")))))))
 
 (test-group-with-cleanup "http"
   (test-assert "object->json-string"
-    ;; Note: We cannot compare the strings directly because field ordering
+    (lset= equal?
-    ;; depends on the hash algorithm used in Guile's hash tables, and that
+           (call-with-input-string
-    ;; algorithm changed in Guile 2.2.
+               (string-append "{"
-    (hash-table=?
+                              "\"boolean\" : false,"
-     (call-with-input-string
+                              "\"string\" : \"guix\","
-         (string-append "{"
+                              "\"alist\" : {\"subset\" : \"hello\"},"
-                        "\"boolean\" : false,"
+                              "\"list\" : [1, \"2\", \"three\"],"
-                        "\"string\" : \"guix\","
+                              "\"symbol\" : \"hydra-jobs\","
-                        "\"alist\" : {\"subset\" : \"hello\"},"
+                              "\"number\" : 1"
-                        "\"list\" : [1, \"2\", \"three\"],"
+                              "}")
-                        "\"symbol\" : \"hydra-jobs\","
+             json->scm)
-                        "\"number\" : 1"
+           (call-with-input-string
-                        "}")
+               (object->json-string '((#:number . 1)
-       json->scm)
+                                      (string . "guix")
-     (call-with-input-string
+                                      ("symbol" . hydra-jobs)
-         (object->json-string '((#:number . 1)
+                                      (#:alist . ((subset . "hello")))
-                                (string . "guix")
+                                      (list . #(1 "2" #:three))
-                                ("symbol" . hydra-jobs)
+                                      ("boolean" . #f)))
-                                (#:alist (subset . "hello"))
+             json->scm)))
-                                (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
+    (match (json-string->scm
-           (call-with-input-string
+            (utf8->string
-               (utf8->string
+             (http-get-body
-                (http-get-body
+              (test-cuirass-uri
-                 (test-cuirass-uri
+               "/api/latestbuilds?nr=1&jobset=guix"))))
-                  "/api/latestbuilds?nr=1&jobset=guix")))
+      (#(build)
-             json->scm)))
+       (lset= equal? build
-      (and (= (length hash-list) 1)
+              (json-string->scm
-           (hash-table=?
+               (object->json-string build-query-result))))))
-            (car hash-list)
-            (call-with-input-string
-                (object->json-string build-query-result)
-              json->scm)))))
 
-  (test-assert "/api/latestbuilds?nr=1&jobset=gnu"
+  (test-equal "/api/latestbuilds?nr=1&jobset=gnu"
-    ;; The result should be an empty JSON array.
+    #()                              ;the result should be an empty JSON array
-    (let ((hash-list
+    (json-string->scm
-           (call-with-input-string
+     (utf8->string
-               (utf8->string
+      (http-get-body
-                (http-get-body
+       (test-cuirass-uri
-                 (test-cuirass-uri
+        "/api/latestbuilds?nr=1&jobset=gnu")))))
-                  "/api/latestbuilds?nr=1&jobset=gnu")))
-             json->scm)))
-      (= (length hash-list) 0)))
 
   (test-equal "/api/queue?nr=100"
     `("fake-2.0" ,(build-status scheduled))
-    (match (call-with-input-string
+    (match (json-string->scm
-               (utf8->string
+            (utf8->string
-                (http-get-body
+             (http-get-body
-                 (test-cuirass-uri "/api/queue?nr=100")))
+              (test-cuirass-uri "/api/queue?nr=100"))))
-             json->scm)
+      (#(dictionary)
-      ((dictionary)
+       (list (assoc-ref dictionary "nixname")
-       (list (hash-ref dictionary "nixname")
+             (assoc-ref dictionary "buildstatus")))))
-             (hash-ref dictionary "buildstatus")))))
 
-  (test-assert "/api/evaluations?nr=1"
+  (test-equal "/api/evaluations?nr=1"
-    (let ((hash-list
+    (json-string->scm
-           (call-with-input-string
+     (object->json-string evaluations-query-result))
-               (utf8->string
+    (json-string->scm
-                (http-get-body (test-cuirass-uri "/api/evaluations?nr=1")))
+     (utf8->string
-             json->scm)))
+      (http-get-body (test-cuirass-uri "/api/evaluations?nr=1")))))
-      (and (= (length hash-list) 1)
-           (hash-table=?
-            (car hash-list)
-            (car (call-with-input-string
-                     (object->json-string evaluations-query-result)
-                   json->scm))))))
 
   (test-assert "db-close"
     (db-close (%db)))