aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service/web/revision
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2019-12-14 21:02:27 +0000
committerChristopher Baines <mail@cbaines.net>2019-12-14 21:02:27 +0000
commit6a0332bed20b7d5b990d9c127198b4da9b8c011d (patch)
tree6bfb3acd226a36c11b562b010bfcea041161add1 /guix-data-service/web/revision
parenta84fc954d19f70e49f575cb43a6d46569f317f81 (diff)
downloaddata-service-6a0332bed20b7d5b990d9c127198b4da9b8c011d.tar
data-service-6a0332bed20b7d5b990d9c127198b4da9b8c011d.tar.gz
Add a builds page for a specific revision
Like the /builds page, but filtered for a specific revision.
Diffstat (limited to 'guix-data-service/web/revision')
-rw-r--r--guix-data-service/web/revision/controller.scm78
-rw-r--r--guix-data-service/web/revision/html.scm99
2 files changed, 177 insertions, 0 deletions
diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm
index 9b7466a..63316a3 100644
--- a/guix-data-service/web/revision/controller.scm
+++ b/guix-data-service/web/revision/controller.scm
@@ -16,6 +16,7 @@
;;; <http://www.gnu.org/licenses/>.
(define-module (guix-data-service web revision controller)
+ #:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (web uri)
#:use-module (web request)
@@ -28,6 +29,9 @@
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util)
#:use-module (guix-data-service jobs load-new-guix-revision)
+ #:use-module (guix-data-service model build)
+ #:use-module (guix-data-service model build-server)
+ #:use-module (guix-data-service model build-status)
#:use-module (guix-data-service model channel-news)
#:use-module (guix-data-service model package)
#:use-module (guix-data-service model git-branch)
@@ -59,6 +63,28 @@
(define (parse-system s)
s)
+(define (parse-build-status status)
+ (if (member status build-status-strings)
+ status
+ (make-invalid-query-parameter
+ status
+ (string-append "unknown build status: "
+ status))))
+
+(define (parse-build-server conn)
+ (lambda (v)
+ (let ((build-servers (select-build-servers conn)))
+ (or (any (match-lambda
+ ((id url lookup-all-derivations?)
+ (if (eq? (string->number v)
+ id)
+ id
+ #f)))
+ build-servers)
+ (make-invalid-query-parameter
+ v
+ "unknown build server")))))
+
(define (revision-controller request
method-and-path-components
mime-types
@@ -189,6 +215,22 @@
(render-unknown-revision mime-types
conn
commit-hash)))
+ (('GET "revision" commit-hash "builds")
+ (if (guix-commit-exists? conn commit-hash)
+ (let ((parsed-query-parameters
+ (parse-query-parameters
+ request
+ `((build_status ,parse-build-status #:multi-value)
+ (build_server ,(parse-build-server conn) #:multi-value)))))
+
+ (render-revision-builds mime-types
+ conn
+ commit-hash
+ parsed-query-parameters
+ #:path-base path))
+ (render-unknown-revision mime-types
+ conn
+ commit-hash)))
(('GET "revision" commit-hash "lint-warnings")
(if (guix-commit-exists? conn commit-hash)
(let ((parsed-query-parameters
@@ -647,6 +689,42 @@
#:header-text header-text
#:header-link header-link)))))))
+(define* (render-revision-builds mime-types
+ conn
+ commit-hash
+ query-parameters
+ #:key
+ (path-base "/revision/")
+ (header-text
+ `("Revision " (samp ,commit-hash)))
+ (header-link
+ (string-append "/revision/" commit-hash)))
+ (if (any-invalid-query-parameters? query-parameters)
+ (render-html
+ #:sxml (view-revision-builds query-parameters
+ build-status-strings
+ '()
+ '()
+ '()))
+ (render-html
+ #:sxml (view-revision-builds query-parameters
+ build-status-strings
+ (map (match-lambda
+ ((id url lookup-all-derivations)
+ (cons url id)))
+ (select-build-servers conn))
+ (select-build-stats
+ conn
+ (assq-ref query-parameters
+ 'build_server)
+ #:revision-commit commit-hash)
+ (select-builds-with-context
+ conn
+ (assq-ref query-parameters
+ 'build_status)
+ (assq-ref query-parameters
+ 'build_server))))))
+
(define* (render-revision-lint-warnings mime-types
conn
commit-hash
diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm
index d0b1875..546538e 100644
--- a/guix-data-service/web/revision/html.scm
+++ b/guix-data-service/web/revision/html.scm
@@ -32,6 +32,7 @@
view-revision-packages
view-revision-derivations
view-revision-derivation-outputs
+ view-revision-builds
view-revision-lint-warnings
unknown-revision))
@@ -867,6 +868,104 @@
"Next page")))
'())))))))
+(define (view-revision-builds query-parameters
+ build-status-strings
+ build-server-options
+ stats
+ builds)
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container"))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h1 "Builds")
+ (table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th (@ (class "col-md-2")) "Status")
+ ,@(map (match-lambda
+ ((url . id)
+ `(th (@ (class "col-md-2"))
+ ,url)))
+ build-server-options)))
+ (tbody
+ ,@(map
+ (match-lambda
+ ((status counts-by-build-server-id)
+ `(tr
+ (td ,(build-status-span status))
+ ,@(map (lambda (id)
+ `(td ,(or (assq-ref counts-by-build-server-id
+ id)
+ 0)))
+ (map cdr build-server-options)))))
+ stats)))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (div
+ (@ (class "well"))
+ (form
+ (@ (method "get")
+ (action "")
+ (class "form-horizontal"))
+ ,(form-horizontal-control
+ "Build status" query-parameters
+ #:options
+ (map (lambda (build-status)
+ (cons (build-status-value->display-string build-status)
+ build-status))
+ build-status-strings)
+ #:help-text "Return builds with these statuses.")
+ ,(form-horizontal-control
+ "Build server"
+ query-parameters
+ #:options build-server-options
+ #:help-text "Return builds from these build servers.")
+ (div (@ (class "form-group form-group-lg"))
+ (div (@ (class "col-sm-offset-2 col-sm-10"))
+ (button (@ (type "submit")
+ (class "btn btn-lg btn-primary"))
+ "Update results")))))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th (@ (class "col-xs-2")) "Status")
+ (th (@ (class "col-xs-9")) "Derivation")
+ (th (@ (class "col-xs-1")) "Started at")
+ (th (@ (class "col-xs-1")) "Finished at")
+ (th (@ (class "col-xs-1")) "")))
+ (tbody
+ ,@(map
+ (match-lambda
+ ((build-id build-server-url derivation-file-name
+ timestamp status)
+ `(tr
+ (td (@ (class "text-center"))
+ ,(build-status-span status))
+ (td (a (@ (href ,derivation-file-name))
+ ,(display-store-item-short derivation-file-name)))
+ (td ,timestamp)
+ (td (a (@ (href ,(simple-format
+ #f "~Abuild/~A"
+ build-server-url
+ (string-drop
+ derivation-file-name
+ (string-length "/gnu/store/")))))
+ "View build on " ,build-server-url)))))
+ builds)))))))))
+
(define* (view-revision-lint-warnings revision-commit-hash
query-parameters
lint-warnings