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.
2024-12-29 11:40:16 +01:00 · 2019-08-17 18:48:34 +02:00 · 2019-08-17 18:48:34 +02:00 · c6f4fa5f57
commit c6f4fa5f57
parent 92bdf3cda0
4 changed files with 76 additions and 101 deletions
--- a/2
+++ b/2
@ -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
--- 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)
--- 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 <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))))
--- a/tests/http.scm
+++ b/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")
-                      (#: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)))