Add a dashboard registration API.

doc/cuirass.texi

@@ -975,6 +975,40 @@ The jobs list for this evaluation, as a JSON array.
 
 @end table
 
+@subsection Dashboard registration
+
+The user can register a dashboard using the "/api/dashboard/register"
+API.  This request accepts two mandatory parameters.
+
+@table @code
+@item specification
+The specification name. This parameter is @emph{mandatory}.
+
+@item names
+The dashboard jobs names, where names is a comma separated list of job
+names.  This parameter is @emph{mandatory}.
+
+@end table
+
+For example, to register a dashboard for the @code{emacs.x86_64-linux}
+and @code{emacs-minimal.x86_64-linux} jobs of the @code{master}
+specification:
+
+@example
+$ curl "http://localhost:8080/api/dashboard/register?spec=master&names=emacs.x86_64-linux,emacs-minimal.x86_64-linux"
+@end example
+
+The nominal output is a JSON object which contains a unique field:
+
+@table @code
+@item id
+The registered dashboard id.
+
+@end table
+
+The dashboard is then accessible at the following address:
+@code{http://localhost:8080/dashboard/<id>}.
+
 @subsection Latest builds
 
 The list of latest builds can be obtained with the API
@@ -1364,6 +1398,23 @@ the worker.
 
 @end table
 
+@section Dashboards
+@cindex dashboards, database
+
+This table contains the user registered Dashboards.
+
+@table @code
+@item id
+This is an automatically incrementing numeric identifier.
+
+@item specification
+This field holds the @code{name} of a specification from the
+@code{Specifications} table.
+
+@item jobs
+This text field holds a list of comma separated job names.
+
+@end table
 @c *********************************************************************
 
 @node Contributing

src/cuirass/database.scm

@@ -104,6 +104,8 @@
             db-get-build-product-path
             db-push-notification
             db-pop-notification
+            db-register-dashboard
+            db-get-dashboard
             db-add-or-update-worker
             db-get-worker
             db-get-workers
@@ -1608,6 +1610,29 @@ DELETE FROM Notifications WHERE id =" id ";")
              (db-get-build (string->number build))))
       (else #f))))
 
+(define (db-register-dashboard specification jobs)
+  "Insert a new dashboard for SPECIFICATION and JOBS into Dashboards table."
+  (let ((id (random-string 16)))
+    (with-db-worker-thread db
+      (match (expect-one-row
+              (exec-query/bind db "\
+INSERT INTO Dashboards (id, specification, jobs)
+VALUES (" id ", " specification "," jobs ")
+RETURNING id;"))
+        ((id) id)
+        (else #f)))))
+
+(define (db-get-dashboard id)
+  "Return the dashboard specification and jobs with the given ID."
+  (with-db-worker-thread db
+    (match (expect-one-row
+            (exec-query/bind db "
+SELECT specification, jobs from Dashboards WHERE id = " id ";"))
+      ((specification jobs)
+       `((#:specification . ,specification)
+         (#:jobs . ,jobs)))
+      (else #f))))
+
 (define (db-add-or-update-worker worker)
   "Insert WORKER into Worker table."
   (with-db-worker-thread db

src/cuirass/http.scm

@@ -738,6 +738,22 @@ into a specification record and return it."
                                     #:limit limit))))
            (lambda _
              (respond-json-with-error 500 "Invalid body")))))))
+    (('GET "api" "dashboard" "register")
+     (let* ((params (request-parameters request))
+            (spec (assq-ref params 'spec))
+            (names (assq-ref params 'names)))
+       (cond
+        ((not (and names spec))
+         (respond-json-with-error 500 "Parameter not defined"))
+        (else
+         (let ((id (db-register-dashboard spec names)))
+           (if id
+               (respond-json
+                (object->json-string
+                 `((#:id . ,id))))
+               (respond-json-with-error
+                500
+                "Failed to register the dashboard")))))))
     (('GET "api" "evaluation")
      (let* ((params (request-parameters request))
             (id (assq-ref params 'id)))
@@ -805,7 +821,26 @@ into a specification record and return it."
                                `((#:id . ,(assq-ref e #:evaluation))))
                              evals))))
                     '())))
-
+    (('GET "dashboard" id)
+     (let ((dashboard (db-get-dashboard id)))
+       (if dashboard
+           (let* ((spec (assq-ref dashboard #:specification))
+                  (jobs (assq-ref dashboard #:jobs))
+                  (evaluations (db-get-latest-evaluations))
+                  (evaluation
+                   (any (lambda (eval)
+                          (and (string=? (assq-ref eval #:specification)
+                                         spec)
+                               (assq-ref eval #:evaluation)))
+                        evaluations))
+                  (uri
+                   (string->uri-reference
+                    (format #f "/eval/~a/dashboard?names=~a"
+                            evaluation jobs))))
+             (respond (build-response #:code 302
+                                      #:headers `((location . ,uri)))
+                      #:body ""))
+           (respond-html-eval-not-found id))))
     (('GET "jobset" name)
      (respond-html
       (let* ((evaluation-id-max (db-get-evaluations-id-max name))

src/cuirass/remote.scm

@@ -18,6 +18,7 @@
 
 (define-module (cuirass remote)
   #:use-module (cuirass logging)
+  #:use-module (cuirass utils)
   #:use-module (guix avahi)
   #:use-module (guix config)
   #:use-module (guix derivations)
@@ -136,31 +137,6 @@
       (systems systems)
       (last-seen last-seen)))))
 
-(define %seed
-  (seed->random-state
-   (logxor (getpid) (car (gettimeofday)))))
-
-(define (integer->alphanumeric-char n)
-  "Map N, an integer in the [0..62] range, to an alphanumeric character."
-  (cond ((< n 10)
-         (integer->char (+ (char->integer #\0) n)))
-        ((< n 36)
-         (integer->char (+ (char->integer #\A) (- n 10))))
-        ((< n 62)
-         (integer->char (+ (char->integer #\a) (- n 36))))
-        (else
-         (error "integer out of bounds" n))))
-
-(define (random-string len)
-  "Compute a random string of size LEN where each character is alphanumeric."
-  (let loop ((chars '())
-             (len len))
-    (if (zero? len)
-        (list->string chars)
-        (let ((n (random 62 %seed)))
-          (loop (cons (integer->alphanumeric-char n) chars)
-                (- len 1))))))
-
 (define (generate-worker-name)
   "Return the service name of the server."
   (random-string 8))

src/cuirass/utils.scm

@@ -55,7 +55,8 @@
             essential-task
             bytevector-range
 
-            date->rfc822-str))
+            date->rfc822-str
+            random-string))
 
 (define (alist? obj)
   "Return #t if OBJ is an alist."
@@ -323,3 +324,28 @@ die silently while the rest of the program keeps going."
 
 (define (date->rfc822-str date)
   (date->string date "~a, ~d ~b ~Y ~T ~z"))
+
+(define %seed
+  (seed->random-state
+   (logxor (getpid) (car (gettimeofday)))))
+
+(define (integer->alphanumeric-char n)
+  "Map N, an integer in the [0..62] range, to an alphanumeric character."
+  (cond ((< n 10)
+         (integer->char (+ (char->integer #\0) n)))
+        ((< n 36)
+         (integer->char (+ (char->integer #\A) (- n 10))))
+        ((< n 62)
+         (integer->char (+ (char->integer #\a) (- n 36))))
+        (else
+         (error "integer out of bounds" n))))
+
+(define (random-string len)
+  "Compute a random string of size LEN where each character is alphanumeric."
+  (let loop ((chars '())
+             (len len))
+    (if (zero? len)
+        (list->string chars)
+        (let ((n (random 62 %seed)))
+          (loop (cons (integer->alphanumeric-char n) chars)
+                (- len 1))))))

src/schema.sql

@@ -111,6 +111,13 @@ CREATE TABLE Workers (
   last_seen   INTEGER NOT NULL
 );
 
+CREATE TABLE Dashboards (
+  id              TEXT NOT NULL PRIMARY KEY,
+  specification   TEXT NOT NULL,
+  jobs            TEXT NOT NULL,
+  FOREIGN KEY (specification) REFERENCES Specifications(name) ON DELETE CASCADE
+);
+
 -- XXX: All queries targeting Builds and Outputs tables *must* be covered by
 -- an index.  It is also preferable for the other tables.
 CREATE INDEX Builds_status_index ON Builds (status);

src/sql/upgrade-8.sql

+BEGIN TRANSACTION;
+
+CREATE TABLE Dashboards (
+  id              TEXT NOT NULL PRIMARY KEY,
+  specification   TEXT NOT NULL,
+  jobs            TEXT NOT NULL,
+  FOREIGN KEY (specification) REFERENCES Specifications(name) ON DELETE CASCADE
+);
+
+COMMIT;

tests/database.scm

@@ -674,6 +674,11 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
            (eq? (assq-ref (db-get-build drv-2) #:id)
                 (assq-ref build #:id)))))))
 
+  (test-equal "db-register-dashboard"
+    "guix"
+    (let ((id (db-register-dashboard "guix" "emacs")))
+      (assq-ref (db-get-dashboard id) #:specification)))
+
   (test-assert "db-close"
     (begin
       (false-if-exception (delete-file tmp-mail))