diff options
| -rw-r--r-- | README | 2 | ||||
| -rw-r--r-- | src/cuirass/http.scm | 23 | ||||
| -rw-r--r-- | src/cuirass/utils.scm | 4 | ||||
| -rw-r--r-- | tests/http.scm | 148 |
4 files changed, 76 insertions, 101 deletions
@@ -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 <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)))) 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 <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))) |