diff options
| -rw-r--r-- | src/cuirass/database.scm | 71 | ||||
| -rw-r--r-- | src/cuirass/http.scm | 32 | ||||
| -rw-r--r-- | src/cuirass/templates.scm | 137 |
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)))))))) |