cuirass: add Hydra compatible HTTP API.

* doc/cuirass.texi (Sections)[Web API]: New section describing the HTTP API.
* src/cuirass/http.scm (spec->json-string): Move it to utils.scm and rename it
  object->json-string.
(object->json-scm): Move it utils.scm.
(handle-*-request): New helpers procedures.
(request-parameters): New procedure to parse a request query.
(url-handler): Add new API's.
* src/cuirass/utils.scm (object->json-scm, object->json-string): Exported
procedures moved from http.scm.
* tests/http.scm: Add various tests on new HTTP API.

doc/cuirass.texi

@@ -57,6 +57,7 @@ Tutorial sections:
 Reference sections:
 * Invocation::                  How to run Cuirass.
 * Database::                    About the database schema.
+* Web API::                     Description of the Web API.
 
 * Contributing::                Your help needed!
 * GNU Free Documentation License::  The license of this manual.
@@ -381,8 +382,198 @@ This text field holds the name of the output.
 This text field holds the path of the output.
 
 @end table
+
+@c *********************************************************************
+@node Web API
+@chapter Web API
+@cindex web api
+
+Cuirass web API is derived from Hydra one, see @url{https://github.com/NixOS/hydra/blob/master/doc/manual/api.xml, Hydra API description}.
+
+For now only a subset of this API is implemented.
+
+@section API description
+@cindex description, json
+
+@subsection Build information
+
+It is possible to query Cuirass web server for build informations. The
+dedicated API is "/build/@var{build-id}" where @var{build-id} is the
+unique id associated to the build in database.
+
+For instance, querying a local Cuirass web server can be done with
+@code{curl} and @code{jq} to format the JSON response :
+
+@example
+$ curl -s "http://localhost:8080/build/2" | jq
+
+@{
+  "id": 2,
+  "project": "guix",
+  "jobset": "master",
+  "job": "acpica-20150410-job",
+  "timestamp": 1501347493,
+  "starttime": 1501347493,
+  "stoptime": 1501347493,
+  "buildoutputs": @{
+    "out": @{
+      "path": "/gnu/store/6g3njhfzqpdm335s7qhvmwvs5l7gcbq1-acpica-20150410"
+    @}
+  @},
+  "system": "x86_64-linux",
+  "nixname": "acpica-20150410",
+  "buildstatus": 0,
+  "busy": 0,
+  "priority": 0,
+  "finished": 1,
+  "buildproducts": null,
+  "releasename": null,
+  "buildinputs_builds": null
+@}
+@end example
+
+If requested @var{build-id} is not known, the HTTP code 404 is
+answered with a JSON error message. For example :
+
+@example
+$ curl -s "http://localhost:8080/build/fff"
+
+@{"error" : "Build with ID fff doesn't exist."@}
+@end example
+
+The nominal output is a JSON object whose fields are described
+hereafter.
+
+@table @code
+@item id
+The unique build id.
+
+@item project
+The associated specification name, as a string.
+
+@item jobset
+The associated specification branch, as a string.
+
+@item job
+The associated job-name, as a string.
+
+@item timestamp
+Timestamp taken at build creation time.
+
+@item starttime
+Timestamp taken at build start time.
+
+@item stoptime
+Timestamp taken at build stop time.
+
+@item buildoutputs
+Build outputs as a JSON object. The keys names are referring to the
+eventual output names. The associated value is another JSON object which
+only key is @code{path}. @code{path} value is the output directory in
+store as a string.
+
+@item system
+System name of the build, as a string.
+
+@item nixname
+Derivation name, as a string.
+
+@item buildstatus
+Build status, as an integer. Possible values are :
+
+@example
+0 -> succeeded
+1 -> failed
+2 -> failed dependency
+3 -> failed other
+4 -> cancelled
+@end example
+
+@item busy
+Whether the build is pending, as an integer (not implemented yet).
+
+@item priority
+Build priority, as an integer (not implemented yet).
+
+@item finished
+Build finished, as an integer (not implemented yet : always 1).
+
+@item buildproducts
+Build products in store as a JSON object (not implemented yet).
+
+@item releasename
+Unknown, not implemented yet.
+
+@item buildinputs_builds
+Inputs used for the build, as a JSON object (not implemented yet).
+
+@end table
+
+@subsection Build raw log output
+
+It is possible to ask Cuirass for the raw build output log with the API
+"/build/@var{build-id}/log/raw" where @var{build-id} is the
+unique id associated to the build in database.
+
+The output is a raw text, for example :
+
+@example
+$ curl http://localhost:8080/build/2/log/raw
+
+starting phase `set-SOURCE-DATE-EPOCH'
+phase `set-SOURCE-DATE-EPOCH' succeeded after 0.0 seconds
+starting phase `set-paths'
+...
+@end example
+
+If requested @var{build-id} is not known, the HTTP code 404 is
+answered with a JSON error message. For example :
+
+@example
+$ curl -s "http://localhost:8080/build/fff/log/raw"
+
+@{"error" : "Build with ID fff doesn't exist."@}
+@end example
+
+@subsection Latest builds
+
+The list of latest builds can be obtained with the API
+"/api/latestbuilds".  The output is a JSON array of
+builds. Builds are represented as in "/build/@var{build-id} API.
+
+This request accepts a mandatory parameter and multiple optional ones.
+
+@table @code
+@item nr
+Limit query result to nr elements. This parameter is @emph{mandatory}.
+
+@item project
+Filter query result to builds with the given @code{project}.
+
+@item jobset
+Filter query result to builds with the given @code{jobset}.
+
+@item job
+Filter query result to builds with the given @code{job} name.
+
+@item system
+Filter query result to builds with the given @code{system}.
+
 @end table
 
+For example, to ask for the ten last builds :
+
+@example
+$ curl "http://localhost:8080/api/latestbuilds?nr=10"
+@end example
+
+or the five last builds which project is ``guix'' and jobset ``master' :
+
+@example
+$ curl "http://localhost:8080/api/latestbuilds?nr=5&project=guix&jobset=master"
+@end example
+
+If no builds matching given parameters are found and empty JSON array is returned.
 
 @c *********************************************************************
 @node Contributing

src/cuirass/database.scm

@@ -232,7 +232,7 @@ INSERT INTO Outputs (build, name, path) VALUES ('~A', '~A', '~A');"
                    outputs))))))
 
 (define db-build-request "\
-SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status,\
+SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.derivation,\
 Derivations.job_name, Derivations.system, Derivations.nix_name,\
 Specifications.repo_name, Specifications.branch \
 FROM Builds \
@@ -242,20 +242,21 @@ INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_nam
 
 (define (db-format-build db build)
   (match build
-    (#(id timestamp starttime stoptime log status job-name system
+    (#(id timestamp starttime stoptime log status derivation job-name system
           nix-name repo-name branch)
-       `((#:id        . ,id)
-         (#:timestamp . ,timestamp)
-         (#:starttime . ,starttime)
-         (#:stoptime  . ,stoptime)
-         (#:log       . ,log)
-         (#:status    . ,status)
-         (#:job-name  . ,job-name)
-         (#:system    . ,system)
-         (#:nix-name  . ,nix-name)
-         (#:repo-name . ,repo-name)
-         (#:outputs   . ,(db-get-outputs db id))
-         (#:branch    . ,branch)))))
+     `((#:id         . ,id)
+       (#:timestamp  . ,timestamp)
+       (#:starttime  . ,starttime)
+       (#:stoptime   . ,stoptime)
+       (#:log        . ,log)
+       (#:status     . ,status)
+       (#:derivation . ,derivation)
+       (#:job-name   . ,job-name)
+       (#:system     . ,system)
+       (#:nix-name   . ,nix-name)
+       (#:repo-name  . ,repo-name)
+       (#:outputs    . ,(db-get-outputs db id))
+       (#:branch     . ,branch)))))
 
 (define (db-get-build db id)
   "Retrieve a build in database DB which corresponds to ID."

src/cuirass/http.scm

 ;;;; http.scm -- HTTP API
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -19,52 +20,147 @@
 (define-module (cuirass http)
   #:use-module (cuirass database)
   #:use-module (cuirass utils)
-  #:use-module (ice-9 hash-table)
+  #:use-module (guix config)
+  #:use-module (guix build utils)
+  #:use-module (guix utils)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
   #:use-module (json)
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (web server)
   #:use-module (web uri)
-  #:export (spec->json-string
-            run-cuirass-server))
+  #:export (run-cuirass-server))
 
-;;;
-;;; JSON format.
-;;;
+(define (build->hydra-build build)
+  "Convert BUILD to an assoc list matching hydra API format."
+  `((#:id . ,(assq-ref build #:id))
+    (#:project . ,(assq-ref build #:repo-name))
+    (#:jobset . ,(assq-ref build #:branch))
+    (#:job . ,(assq-ref build #:job-name))
+    (#:timestamp . ,(assq-ref build #:timestamp))
+    (#:starttime . ,(assq-ref build #:starttime))
+    (#:stoptime . ,(assq-ref build #:stoptime))
+    (#:buildoutputs . ,(assq-ref build #:outputs))
+    (#:system . ,(assq-ref build #:system))
+    (#:nixname . ,(assq-ref build #:nix-name))
+    (#:buildstatus . ,(assq-ref build #:status))
+
+    ;; TODO: Fill the fields above with correct values.
+    (#:busy . 0)
+    (#:priority . 0)
+    (#:finished . 1)
+    (#:buildproducts . #nil)
+    (#:releasename . #nil)
+    (#:buildinputs_builds . #nil)))
+
+(define (handle-build-request db build-id)
+  "Retrieve build identified by BUILD-ID in DB and convert it to hydra
+  format. Return #f is not build was found."
+  (let ((build (db-get-build db build-id)))
+    (and=> build build->hydra-build)))
 
-(define (object->json-scm obj)
-  "Prepare OBJ for JSON usage."
-  (cond ((string? obj)  obj)
-        ((number? obj)  obj)
-        ((boolean? obj) obj)
-        ((null? obj)    obj)
-        ((symbol? obj)  (symbol->string obj))
-        ((keyword? obj) (object->json-scm (keyword->symbol obj)))
-        ((alist? obj)   (alist->hash-table (map object->json-scm obj)))
-        ((pair? obj)    (cons (object->json-scm (car obj))
-                              (object->json-scm (cdr obj))))
-        (else           (object->string obj))))
-
-(define* (spec->json-string spec #:key pretty)
-  "Return SPEC as a JSON object."
-  (scm->json-string (object->json-scm spec) #:pretty pretty))
+(define (handle-builds-request db filters)
+  "Retrieve all builds matched by FILTERS in DB and convert them to hydra
+  format."
+  (let ((builds (db-get-builds db filters)))
+    (map build->hydra-build builds)))
+
+(define (handle-log-request db build)
+  "Retrieve the log file of BUILD. Return a lambda which PORT argument is an
+  input port from which the content of the log file can be read or #f if the
+  log file is not readable."
+  (let* ((log (assq-ref build #:log))
+         (access (and (string? log)
+                      (access? log R_OK))))
+    (and access
+         (lambda (out-port)
+           (let ((in-pipe-port
+                  (open-input-pipe
+                   (format #f "~a -dc ~a" %bzip2 log))))
+             (dump-port in-pipe-port out-port)
+             (close-pipe in-pipe-port))))))
+
+(define (request-parameters request)
+  "Parse the REQUEST query parameters and return them under the form
+  '((parameter value) ...)."
+  (let* ((uri (request-uri request))
+         (query (uri-query uri)))
+    (and query
+         (map (lambda (param)
+                (match (string-split param #\=)
+                  ((key param)
+                   (list (string->symbol key) param))))
+              (string-split query #\&)))))
 
 
 ;;;
 ;;; Web server.
 ;;;
+;;; The api is derived from the hydra one. It is partially described here :
+;;;
+;;; https://github.com/NixOS/hydra/blob/master/doc/manual/api.xml
+;;;
 
 (define (request-path-components request)
   (split-and-decode-uri-path (uri-path (request-uri request))))
 
 (define (url-handler request body db)
+
   (define* (respond response #:key body (db db))
     (values response body db))
+
+  (define-syntax-rule (respond-json body ...)
+    (respond '((content-type . (application/json)))
+             #:body body ...))
+
+  (define-syntax-rule (respond-text body ...)
+    (respond '((content-type . (text/plain)))
+             #:body body ...))
+
+  (define-syntax-rule (respond-json-with-error error-code message)
+    (respond
+     (build-response #:headers '((content-type . (application/json)))
+                     #:code error-code)
+     #:body
+     (object->json-string
+      `((error . ,message)))))
+
+  (define (respond-build-not-found build-id)
+    (respond-json-with-error
+     404
+     (format #f "Build with ID ~a doesn't exist." build-id)))
+
+  (define (respond-build-log-not-found build)
+    (let ((drv (assq-ref build #:derivation)))
+      (respond-json-with-error
+       404
+       (format #f "The build log of derivation ~a is not available." drv))))
+
   (match (request-path-components request)
     (((or "jobsets" "specifications") . rest)
-     (respond '((content-type . (application/json)))
-              #:body (spec->json-string (car (db-get-specifications db)))))
+     (respond-json (object->json-string (car (db-get-specifications db)))))
+    (("build" build-id)
+     (let ((hydra-build (handle-build-request db build-id)))
+       (if hydra-build
+           (respond-json (object->json-string hydra-build))
+           (respond-build-not-found build-id))))
+    (("build" build-id "log" "raw")
+     (let ((build (db-get-build db build-id)))
+       (if build
+           (let ((log-response (handle-log-request db build)))
+             (if log-response
+                 (respond-text log-response)
+                 (respond-build-log-not-found build)))
+           (respond-build-not-found build-id))))
+    (("api" "latestbuilds")
+     (let* ((params (request-parameters request))
+            ;; 'nr parameter is mandatory to limit query size.
+            (valid-params? (assq-ref params 'nr)))
+       (if valid-params?
+           (respond-json (object->json-string
+                          (handle-builds-request db params)))
+           (respond-json-with-error 500 "Parameter not defined!"))))
     (_
      (respond (build-response #:code 404)
               #:body (string-append "Resource not found: "
@@ -73,6 +169,6 @@
 (define* (run-cuirass-server db #:key (port 8080))
   (format (current-error-port) "listening on port ~A~%" port)
   (run-server url-handler
-              'http                     ;server implementation
-              `(#:port ,port)           ;implementation parameters
-              db))                      ;state
+              'http
+              `(#:port ,port)
+              db))

src/cuirass/utils.scm

@@ -21,9 +21,29 @@
 (define-module (cuirass utils)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:export (alist?))
+  #:use-module (json)
+  #:export (alist?
+            object->json-scm
+            object->json-string))
 
 (define (alist? obj)
   "Return #t if OBJ is an alist."
   (and (list? obj)
        (every pair? obj)))
+
+(define (object->json-scm obj)
+  "Prepare OBJ for JSON usage."
+  (cond ((string? obj)  obj)
+        ((number? obj)  obj)
+        ((boolean? obj) obj)
+        ((null? obj)    obj)
+        ((symbol? obj)  (symbol->string obj))
+        ((keyword? obj) (object->json-scm (keyword->symbol obj)))
+        ((alist? obj)   (map object->json-scm obj))
+        ((pair? obj)    (cons (object->json-scm (car obj))
+                              (object->json-scm (cdr obj))))
+        (else           (object->string obj))))
+
+(define* (object->json-string object #:key pretty)
+  "Return OBJECT as a JSON object."
+  (scm->json-string (object->json-scm object) #:pretty pretty))

tests/http.scm

 ;;; http.scm -- tests for (cuirass http) module
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -18,7 +19,14 @@
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (use-modules (cuirass http)
+             (cuirass database)
+             (cuirass utils)
+             (guix utils)
+             (guix build utils)
              (json)
+             (web client)
+             (web response)
+             (rnrs bytevectors)
              (srfi srfi-1)
              (srfi srfi-64))
 
@@ -42,30 +50,187 @@
                   #t
                   t1)))
 
-(test-begin "http")
-
-(test-assert "spec->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
-       (spec->json-string '((#:number . 1)
-                            (string . "guix")
-                            ("symbol" . hydra-jobs)
-                            (#:alist (subset . "hello"))
-                            (list 1 "2" #:three)
-                            ("boolean" . #f)))
-     json->scm)))
-
-(test-end)
+(define (http-get-body uri)
+  (call-with-values (lambda () (http-get uri))
+    (lambda (response body) body)))
+
+(define (wait-until-ready port)
+  ;; Wait until the server is accepting connections.
+  (let ((conn (socket PF_INET SOCK_STREAM 0)))
+    (let loop ()
+      (unless (false-if-exception
+               (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port))
+        (loop)))))
+
+(define (test-cuirass-uri route)
+  (string-append "http://localhost:6688" route))
+
+(define database-name
+  ;; Use an empty and temporary database for the tests.
+  (string-append (getcwd) "/" (number->string (getpid)) "-tmp.db"))
+
+(define %db
+  ;; Global Slot for a database object.
+  (make-parameter #t))
+
+(define build-query-result
+  '((#:id . 1)
+    (#:project . "guix")
+    (#:jobset . "master")
+    (#:job . "fake-job")
+    (#:timestamp . 1501347493)
+    (#:starttime . 1501347493)
+    (#:stoptime . 1501347493)
+    (#:buildoutputs . ((out ("path" . "/gnu/store/fake-1.0"))))
+    (#:system . "x86_64-linux")
+    (#:nixname . "fake-1.0")
+    (#:buildstatus . 0)
+    (#:busy . 0)
+    (#:priority . 0)
+    (#:finished . 1)
+    (#:buildproducts . #nil)
+    (#:releasename . #nil)
+    (#:buildinputs_builds . #nil)))
+
+(define log-file-name
+  ;; Use a fake temporary log file.
+  (string-append (getcwd) "/" (number->string (getpid)) "-log.txt"))
+
+(call-with-output-file log-file-name
+  ;; Write "build log" string compressed with bzip2 inside LOG-FILE-NAME.
+  (lambda (out)
+    (dump-port
+     (call-with-input-string "build log"
+       (lambda (port)
+         (compressed-port 'bzip2 port)))
+     out)))
+
+(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)))
+
+  (test-assert "db-init"
+    (%db (db-init database-name)))
+
+  (test-assert "cuirass-run"
+    (call-with-new-thread
+     (lambda ()
+       (run-cuirass-server (%db) #:port 6688))))
+
+  (test-assert "wait-server"
+    (wait-until-ready 6688))
+
+  (test-assert "fill-db"
+    (let ((build
+           `((#:derivation . "/gnu/store/fake.drv")
+             (#:eval-id . 1)
+             (#:log . ,log-file-name)
+             (#:status . 0)
+             (#:outputs . (("out" . "/gnu/store/fake-1.0")))
+             (#:timestamp . 1501347493)
+             (#:starttime . 1501347493)
+             (#:stoptime . 1501347493)))
+          (derivation
+           '((#:derivation . "/gnu/store/fake.drv")
+             (#:job-name . "fake-job")
+             (#:system . "x86_64-linux")
+             (#:nix-name . "fake-1.0")
+             (#:eval-id . 1)))
+          (specification
+           '((#:name . "guix")
+             (#:url . "git://git.savannah.gnu.org/guix.git")
+             (#:load-path . ".")
+             (#:file . "/tmp/gnu-system.scm")
+             (#:proc . hydra-jobs)
+             (#:arguments (subset . "hello"))
+             (#:branch . "master")
+             (#:tag . #f)
+             (#:commit . #f)
+             (#:no-compile? . #f)))
+          (evaluation
+           '((#:specification . "guix")
+             (#:revision . 1))))
+      (db-add-build (%db) build)
+      (db-add-derivation (%db) derivation)
+      (db-add-specification (%db) specification)
+      (db-add-evaluation (%db) evaluation)))
+
+  (test-assert "/build/1"
+    (hash-table=?
+     (call-with-input-string
+         (utf8->string
+          (http-get-body (test-cuirass-uri "/build/1")))
+       json->scm)
+     (call-with-input-string
+         (object->json-string build-query-result)
+       json->scm)))
+
+  (test-equal "/build/1/log/raw"
+    "build log"
+    (http-get-body
+     (test-cuirass-uri "/build/1/log/raw")))
+
+  (test-equal "/build/2"
+    404
+    (response-code (http-get (test-cuirass-uri "/build/2"))))
+
+  (test-equal "/build/2/log/raw"
+    404
+    (response-code (http-get (test-cuirass-uri "/build/2/log/raw"))))
+
+  (test-equal "/api/latestbuilds"
+    500
+    (response-code (http-get (test-cuirass-uri "/api/latestbuilds"))))
+
+  (test-assert "/api/latestbuilds?nr=1&project=guix&jobset=master"
+    (let ((hash-list
+           (call-with-input-string
+               (utf8->string
+                (http-get-body
+                 (test-cuirass-uri
+                  "/api/latestbuilds?nr=1&project=guix&jobset=master")))
+             json->scm)))
+      (and (= (length hash-list) 1)
+           (hash-table=?
+            (car hash-list)
+            (call-with-input-string
+                (object->json-string build-query-result)
+              json->scm)))))
+
+  (test-assert "/api/latestbuilds?nr=1&project=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&project=gnu")))
+             json->scm)))
+      (= (length hash-list) 0)))
+
+  (test-assert "db-close"
+    (db-close (%db)))
+
+  (delete-file database-name)
+  (delete-file log-file-name))