diff options
Diffstat (limited to 'guix-data-service')
| -rw-r--r-- | guix-data-service/web/revision/controller.scm | 78 | ||||
| -rw-r--r-- | guix-data-service/web/revision/html.scm | 99 |
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 |