[no subject]

[Mathieu Othacehe]

branch: master
commit 166aa9a11a446267713c9f00d0557e71e67adf68
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Wed Apr 21 09:49:42 2021 +0200

    Add a dashboard registration API.
---
 doc/cuirass.texi         | 51 ++++++++++++++++++++++++++++++++++++++++++++++++
 src/cuirass/database.scm | 25 ++++++++++++++++++++++++
 src/cuirass/http.scm     | 37 ++++++++++++++++++++++++++++++++++-
 src/cuirass/remote.scm   | 26 +-----------------------
 src/cuirass/utils.scm    | 28 +++++++++++++++++++++++++-
 src/schema.sql           |  7 +++++++
 src/sql/upgrade-8.sql    | 10 ++++++++++
 tests/database.scm       |  5 +++++
 8 files changed, 162 insertions(+), 27 deletions(-)

diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index 89eed92..966076a 100644
--- a/doc/cuirass.texi
+++ b/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
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index b773c4e..afbca36 100644
--- a/src/cuirass/database.scm
+++ b/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
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 5bd78d6..31b7a22 100644
--- a/src/cuirass/http.scm
+++ b/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))
diff --git a/src/cuirass/remote.scm b/src/cuirass/remote.scm
index f79a145..9386612 100644
--- a/src/cuirass/remote.scm
+++ b/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))
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index dfc5dd9..f64d318 100644
--- a/src/cuirass/utils.scm
+++ b/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))))))
diff --git a/src/schema.sql b/src/schema.sql
index bd20327..84740a6 100644
--- a/src/schema.sql
+++ b/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);
diff --git a/src/sql/upgrade-8.sql b/src/sql/upgrade-8.sql
new file mode 100644
index 0000000..c28de76
--- /dev/null
+++ b/src/sql/upgrade-8.sql
@@ -0,0 +1,10 @@
+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;
diff --git a/tests/database.scm b/tests/database.scm
index 1229ac6..3f32130 100644
--- a/tests/database.scm
+++ b/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))