cuirass: Add search for builds.

* src/cuirass/database.scm (db-get-builds-by-search, db-get-builds-query-min,
db-get-builds-query-max): New procedures.
* src/cuirass/http.scm (handle-builds-search-request): New procedure.
(url-handler): Handle "search" route.
* src/cuirass/templates.scm (search-form): New variable.
(html-page): Use it.
(build-search-results-table): New procedure.

3 files changed, 231 insertions, 9 deletions

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 33705b5..89e3e83 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -47,8 +48,11 @@
             db-update-build-status!
             db-get-build
             db-get-builds
+            db-get-builds-by-search
             db-get-builds-min
             db-get-builds-max
+            db-get-builds-query-min
+            db-get-builds-query-max
             db-get-evaluations
             db-get-evaluations-build-summary
             db-get-evaluations-id-min
@@ -552,6 +556,59 @@ WHERE derivation =" derivation ";"))
     (('order . 'status+submission-time) "status DESC, timestamp DESC")
     (_ "rowid DESC")))
 
+(define (db-get-builds-by-search filters)
+  "Retrieve all builds in the database which are matched by given FILTERS.
+FILTERS is an assoc list whose possible keys are the symbols query,
+border-low-id, border-high-id, and nr."
+  (with-db-critical-section db
+    (let* ((stmt-text (format #f "SELECT * FROM (
+SELECT Builds.rowid, Builds.timestamp, Builds.starttime,
+Builds.stoptime, Builds.log, Builds.status, Builds.job_name, Builds.system,
+Builds.nix_name, Specifications.name
+FROM Builds
+INNER JOIN Evaluations ON Builds.evaluation = Evaluations.id
+INNER JOIN Specifications ON Evaluations.specification = Specifications.name
+WHERE (Builds.nix_name LIKE :query)
+AND (:borderlowid IS NULL
+ OR (:borderlowid < Builds.rowid))
+AND (:borderhighid IS NULL
+ OR (:borderhighid > Builds.rowid))
+ORDER BY
+CASE WHEN :borderlowid IS NULL THEN Builds.rowid
+                               ELSE -Builds.rowid
+END DESC
+LIMIT :nr)
+ORDER BY rowid DESC;"))
+           (stmt (sqlite-prepare db stmt-text #:cache? #t)))
+      (sqlite-bind-arguments
+       stmt
+       #:query (and=> (assq-ref filters 'query)
+                      (lambda (query) (string-append query "-%")))
+       #:borderlowid (assq-ref filters 'border-low-id)
+       #:borderhighid (assq-ref filters 'border-high-id)
+       #:nr (match (assq-ref filters 'nr)
+              (#f -1)
+              (x x)))
+      (sqlite-reset stmt)
+      (let loop ((rows (sqlite-fold-right cons '() stmt))
+                 (builds '()))
+        (match rows
+          (() (reverse builds))
+          ((#(id timestamp starttime stoptime log status job-name
+                 system nix-name specification) . rest)
+           (loop rest
+                 (cons `((#:id . ,id)
+                         (#:timestamp . ,timestamp)
+                         (#:starttime . ,starttime)
+                         (#:stoptime . ,stoptime)
+                         (#:log . ,log)
+                         (#:status . ,status)
+                         (#:job-name . ,job-name)
+                         (#:system . ,system)
+                         (#:nix-name . ,nix-name)
+                         (#:specification . ,specification))
+                       builds))))))))
+
 (define (db-get-builds filters)
   "Retrieve all builds in the database which are matched by given FILTERS.
 FILTERS is an assoc list whose possible keys are 'derivation | 'id | 'jobset |
@@ -723,6 +780,20 @@ SELECT MAX(id) FROM Evaluations
 WHERE specification=" spec)))
       (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
 
+(define (db-get-builds-query-min query)
+  "Return the smallest build row identifier matching QUERY."
+  (with-db-critical-section db
+    (let ((rows (sqlite-exec db "
+SELECT MIN(rowid) FROM Builds WHERE nix_name LIKE " (string-append query "-%"))))
+      (and=> (expect-one-row rows) vector->list))))
+
+(define (db-get-builds-query-max query)
+  "Return the largest build row identifier matching QUERY."
+  (with-db-critical-section db
+    (let ((rows (sqlite-exec db "
+SELECT MAX(rowid) FROM Builds WHERE nix_name LIKE " (string-append query "-%"))))
+      (and=> (expect-one-row rows) vector->list))))
+
 (define (db-get-builds-min eval status)
   "Return the min build (stoptime, rowid) pair for the given evaluation EVAL
 and STATUS."
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 92f1ca6..48a2b39 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -116,6 +117,13 @@ Hydra format."
                                    (db-get-builds filters))))
     (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)))
+
 (define (request-parameters request)
   "Parse the REQUEST query parameters and return them under the form
   '((parameter . value) ...)."
@@ -341,6 +349,30 @@ Hydra format."
                 (#:link . ,(string-append "/eval/" id))))))
            (respond-html-eval-not-found id))))
 
+    (("search")
+     (let* ((params (request-parameters request))
+            (query (assq-ref params 'query))
+            (builds-id-min (db-get-builds-query-min query))
+            (builds-id-max (db-get-builds-query-max query))
+            (border-low-id (assq-ref params 'border-low-id))
+            (border-high-id (assq-ref params 'border-high-id)))
+       (if query
+           (respond-html
+            (html-page
+             "Search results"
+             (build-search-results-table
+              query
+              (handle-builds-search-request
+               `((query . ,query)
+                 (nr . ,%page-size)
+                 (order . finish-time+build-id)
+                 (border-low-id . ,border-low-id)
+                 (border-high-id . ,border-high-id)))
+              builds-id-min
+              builds-id-max)
+             '()))
+           (respond-json-with-error 500 "Query parameter not provided!"))))
+
     (("static" path ...)
      (respond-static-file path))
     ('method-not-allowed
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 8ef3275..011d2ec 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -1,6 +1,7 @@
 ;;; templates.scm -- HTTP API
 ;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -27,7 +28,8 @@
   #:export (html-page
             specifications-table
             evaluation-info-table
-            build-eval-table))
+            build-eval-table
+            build-search-results-table))
 
 (define (navigation-items navigation)
   (match navigation
@@ -39,6 +41,23 @@
                    ,(assq-ref item #:name)))
            (navigation-items rest)))))
 
+(define search-form
+  `(form (@ (id "search")
+            (class "form-inline")
+            (action "/search"))
+         (div
+          (@ (class "input-group"))
+          (input (@ (type "text")
+                    (class "form-control")
+                    (id   "query")
+                    (name "query")
+                    (placeholder "search for builds")))
+          (span (@ (class "input-group-append"))
+                (button
+                 (@ (type "submit")
+                    (class "btn btn-primary"))
+                 "Search")))))
+
 (define (html-page title body navigation)
   "Return HTML page with given TITLE and BODY."
   `(html (@ (xmlns "http://www.w3.org/1999/xhtml")
@@ -64,14 +83,15 @@
                           (alt "logo")
                           (height "25")
                           (style "margin-top: -12px"))))
-               (div (@ (class "navbar-nav-scroll"))
-                    (ul (@ (class "navbar-nav"))
-                        (li (@ (class "nav-item"))
-                            (a (@ (class "nav-link" ,(if (null? navigation)
-                                                         " active" ""))
-                                  (href "/"))
-                               Home))
-                        ,@(navigation-items navigation))))
+               (div (@ (class "navbar-collapse"))
+                         (ul (@ (class "navbar-nav"))
+                             (li (@ (class "nav-item"))
+                                 (a (@ (class "nav-link" ,(if (null? navigation)
+                                                              " active" ""))
+                                       (href "/"))
+                                    Home))
+                             ,@(navigation-items navigation)))
+               ,search-form)
           (main (@ (role "main") (class "container pt-4 px-1"))
                 ,body
                 (hr)))))
@@ -341,3 +361,102 @@ and BUILD-MAX are global minimal and maximal (stoptime, rowid) pairs."
              (build-stoptime build-min)
              (1- (build-id build-min))
              status))))))
+
+(define (build-search-results-table query builds build-min build-max)
+  "Return HTML for the BUILDS table evaluation matching QUERY.  BUILD-MIN
+and BUILD-MAX are global minimal and maximal row identifiers."
+  (define (table-header)
+    `(thead
+      (tr
+       (th (@ (scope "col")) '())
+       (th (@ (scope "col")) "ID")
+       (th (@ (scope "col")) "Specification")
+       (th (@ (scope "col")) "Completion time")
+       (th (@ (scope "col")) "Job")
+       (th (@ (scope "col")) "Name")
+       (th (@ (scope "col")) "System")
+       (th (@ (scope "col")) "Log"))))
+
+  (define (table-row build)
+    (define status
+      (assq-ref build #:buildstatus))
+
+    (define completed?
+      (or (= (build-status succeeded) status)
+          (= (build-status failed) status)))
+
+    `(tr
+      (td ,(cond
+            ((= (build-status succeeded) status)
+             `(span (@ (class "oi oi-check text-success")
+                       (title "Succeeded")
+                       (aria-hidden "true"))
+                    ""))
+            ((= (build-status scheduled) status)
+             `(span (@ (class "oi oi-clock text-warning")
+                       (title "Scheduled")
+                       (aria-hidden "true"))
+                    ""))
+            ((= (build-status canceled) status)
+             `(span (@ (class "oi oi-question-mark text-warning")
+                       (title "Canceled")
+                       (aria-hidden "true"))
+                    ""))
+            ((= (build-status failed-dependency) status)
+             `(span (@ (class "oi oi-warning text-danger")
+                       (title "Dependency failed")
+                       (aria-hidden "true"))
+                    ""))
+            (else
+             `(span (@ (class "oi oi-x text-danger")
+                       (title "Failed")
+                       (aria-hidden "true"))
+                    ""))))
+      (th (@ (scope "row")),(assq-ref build #:id))
+      (td ,(assq-ref build #:jobset))
+      (td ,(if completed?
+               (time->string (assq-ref build #:stoptime))
+               "—"))
+      (td ,(assq-ref build #:job))
+      (td ,(assq-ref build #:nixname))
+      (td ,(assq-ref build #:system))
+      (td ,(if completed?
+               `(a (@ (href "/build/" ,(assq-ref build #:id) "/log/raw"))
+                   "raw")
+               "—"))))
+
+  `((p (@ (class "lead"))
+       ,(format #f "Builds matching ~a" query))
+    (table
+     (@ (class "table table-sm table-hover table-striped"))
+     ,@(if (null? builds)
+           `((th (@ (scope "col")) "No elements here."))
+           `(,(table-header)
+             (tbody ,@(map table-row builds)))))
+
+    ,(if (null? builds)
+         (pagination "" "" "" "")
+         (let* ((build-ids (map (lambda (row) (assq-ref row #:id)) builds))
+                (page-build-min (last build-ids))
+                (page-build-max (first build-ids)))
+           (pagination
+            (format
+             #f "?query=~a&border-high-id=~d"
+             query
+             (1+ (first build-max)))
+            (if (equal? page-build-max (first build-max))
+                ""
+                (format
+                 #f "?query=~a&border-low-id=~d"
+                 query
+                 page-build-max))
+            (if (equal? page-build-min (first build-min))
+                ""
+                (format
+                 #f "?query=~a&border-high-id=~d"
+                 query
+                 page-build-min))
+            (format
+             #f "?query=~a&border-low-id=~d"
+             query
+             (1- (first build-min))))))))