diff options
| -rw-r--r-- | guix-data-service/web/controller.scm | 48 | ||||
| -rw-r--r-- | guix-data-service/web/jobs/controller.scm | 69 | ||||
| -rw-r--r-- | guix-data-service/web/jobs/html.scm | 224 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 210 |
4 files changed, 309 insertions, 242 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 6f534e9..e89519c 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -51,6 +51,7 @@ #:use-module (guix-data-service web sxml) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) + #:use-module (guix-data-service web jobs controller) #:use-module (guix-data-service web view html) #:export (controller)) @@ -881,27 +882,6 @@ derivations)) #:extra-headers http-headers-for-unchanging-content))))) -(define (render-jobs mime-types conn) - (render-html - #:sxml (view-jobs - (select-jobs-and-events conn)))) - -(define (render-job-queue mime-types conn) - (render-html - #:sxml (view-job-queue - (select-unprocessed-jobs-and-events conn)))) - -(define (render-job mime-types conn job-id query-parameters) - (render-html - #:sxml (view-job - job-id - query-parameters - (log-for-job conn job-id - #:character-limit - (assq-ref query-parameters 'characters) - #:start-character - (assq-ref query-parameters 'start_character))))) - (define (parse-commit conn) (lambda (s) (if (guix-commit-exists? conn s) @@ -983,6 +963,13 @@ (define path (uri-path (request-uri request))) + (define (delegate-to f) + (f request + method-and-path-components + mime-types + body + conn)) + (match method-and-path-components (('GET) (render-html @@ -1317,21 +1304,8 @@ (render-compare/packages mime-types conn parsed-query-parameters))) - (('GET "jobs") - (render-jobs mime-types - conn)) - (('GET "jobs" "queue") - (render-job-queue mime-types - conn)) - (('GET "job" job-id) - (let ((parsed-query-parameters - (parse-query-parameters - request - `((start_character ,parse-number) - (characters ,parse-number #:default 1000000))))) - (render-job mime-types - conn - job-id - parsed-query-parameters))) + (('GET "jobs") (delegate-to jobs-controller)) + (('GET "jobs" "queue") (delegate-to jobs-controller)) + (('GET "job" job-id) (delegate-to jobs-controller)) (('GET path ...) (not-found (request-uri request))))) diff --git a/guix-data-service/web/jobs/controller.scm b/guix-data-service/web/jobs/controller.scm new file mode 100644 index 0000000..8367196 --- /dev/null +++ b/guix-data-service/web/jobs/controller.scm @@ -0,0 +1,69 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service web jobs controller) + #:use-module (ice-9 match) + #:use-module (guix-data-service web render) + #:use-module (guix-data-service web query-parameters) + #:use-module (guix-data-service jobs load-new-guix-revision) + #:use-module (guix-data-service web jobs html) + #:export (jobs-controller)) + +(define (jobs-controller request + method-and-path-components + mime-types + body + conn) + (match method-and-path-components + (('GET "jobs") + (render-jobs mime-types + conn)) + (('GET "jobs" "queue") + (render-job-queue mime-types + conn)) + (('GET "job" job-id) + (let ((parsed-query-parameters + (parse-query-parameters + request + `((start_character ,parse-number) + (characters ,parse-number #:default 1000000))))) + (render-job mime-types + conn + job-id + parsed-query-parameters))))) + +(define (render-jobs mime-types conn) + (render-html + #:sxml (view-jobs + (select-jobs-and-events conn)))) + +(define (render-job-queue mime-types conn) + (render-html + #:sxml (view-job-queue + (select-unprocessed-jobs-and-events conn)))) + +(define (render-job mime-types conn job-id query-parameters) + (render-html + #:sxml (view-job + job-id + query-parameters + (log-for-job conn job-id + #:character-limit + (assq-ref query-parameters 'characters) + #:start-character + (assq-ref query-parameters 'start_character))))) + diff --git a/guix-data-service/web/jobs/html.scm b/guix-data-service/web/jobs/html.scm new file mode 100644 index 0000000..5d77a70 --- /dev/null +++ b/guix-data-service/web/jobs/html.scm @@ -0,0 +1,224 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service web jobs html) + #:use-module (ice-9 match) + #:use-module (guix-data-service web view html) + #:export (view-jobs + view-job-queue + view-job)) + +(define (view-jobs jobs-and-events) + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h1 (@ (style "display: inline-block;")) + "Jobs") + (div + (@ (class "btn-group pull-right") + (style "margin-top: 1.3rem;") + (role "group")) + (a (@ (class "btn btn-lg btn-default") + (href "/jobs/queue") + (role "button")) + "Queue")))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (table + (@ (class "table")) + (thead + (tr + (th "Commit") + (th "Source") + (th "Events") + (th ""))) + (tdata + ,@(map (match-lambda + ((id commit source git-repository-id created-at succeeded-at + events log-exists?) + `(tr + (@ (class + ,(let ((event-names + (map (lambda (event) + (assoc-ref event "event")) + (vector->list events)))) + (cond + ((member "success" event-names) + "success") + ((member "failure" event-names) + "danger") + ((member "start" event-names) + "info") + (else + ""))))) + (td (a (@ (href + ,(string-append + "/revision/" commit))) + (samp ,commit))) + (td ,source) + (td + (dl + (@ (class "dl-horizontal")) + ,@(map + (lambda (event) + `((dt ,(assoc-ref event "event")) + (dd ,(assoc-ref event "occurred_at")))) + (cons + `(("event" . "created") + ("occurred_at" . ,created-at)) + (vector->list events))))) + (td + ,@(if log-exists? + `((a (@ (href ,(string-append "/job/" id))) + "View log")) + '()))))) + jobs-and-events))))))))) + +(define (view-job-queue jobs-and-events) + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (a (@ (href "/jobs")) + (h3 "Jobs")) + (h1 "Queued jobs (" + ,(length jobs-and-events) + ")"))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (table + (@ (class "table")) + (thead + (tr + (th "Commit") + (th "Source") + (th "Events") + (th ""))) + (tdata + ,@(map (match-lambda + ((id commit source git-repository-id created-at + events log-exists? latest-branch-commit?) + `(tr + (@ (class + ,(let ((event-names + (map (lambda (event) + (assoc-ref event "event")) + (vector->list events)))) + (cond + ((member "success" event-names) + "success") + ((member "failure" event-names) + "danger") + ((member "start" event-names) + "info") + (else + ""))))) + (td (a (@ (href + ,(string-append + "/revision/" commit))) + (samp ,commit) + ,@(if latest-branch-commit? + '((br) + (span (@ (class "text-danger")) + "(latest branch commit)")) + '()))) + (td ,source) + (td + (dl + (@ (class "dl-horizontal")) + ,@(map + (lambda (event) + `((dt ,(assoc-ref event "event")) + (dd ,(assoc-ref event "occurred_at")))) + (cons + `(("event" . "created") + ("occurred_at" . ,created-at)) + (vector->list events))))) + (td + ,@(if log-exists? + `((a (@ (href ,(string-append "/job/" id))) + "View log")) + '()))))) + jobs-and-events))))))))) + +(define (view-job job-id query-parameters log) + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h1 "Job " ,job-id))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (div + (@ (class "well")) + (form + (@ (method "get") + (action "") + (class "form-horizontal")) + ,(form-horizontal-control + "Characters" query-parameters + #:help-text "Return at most this many characters.") + ,(form-horizontal-control + "Start character" query-parameters + #:help-text "Start reading the log from this character.") + (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 log"))))))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (a (@ (class "btn btn-default btn-lg pull-right") + (style "margin-bottom: 20px;") + (href "#bottom")) + "Scroll to the bottom of the page"))) + (div + (@ (class "row")) + (div + (pre (raw ,log)) + (a (@ (id "bottom"))))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (a (@ (class "btn btn-default btn-lg pull-right") + (href "#top")) + "Scroll to the top of the page"))))))) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index ff815c4..2750944 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -28,7 +28,11 @@ #:use-module (texinfo) #:use-module (texinfo html) #:use-module (json) - #:export (index + #:export (layout + header + form-horizontal-control + + index readme general-not-found unknown-revision @@ -45,9 +49,6 @@ view-builds view-derivation view-store-item - view-jobs - view-job-queue - view-job compare compare/derivations compare-by-datetime/derivations @@ -1428,207 +1429,6 @@ derivations derivations-using-store-item-list))))) -(define (view-jobs jobs-and-events) - (layout - #:body - `(,(header) - (div - (@ (class "container")) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h1 (@ (style "display: inline-block;")) - "Jobs") - (div - (@ (class "btn-group pull-right") - (style "margin-top: 1.3rem;") - (role "group")) - (a (@ (class "btn btn-lg btn-default") - (href "/jobs/queue") - (role "button")) - "Queue")))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (table - (@ (class "table")) - (thead - (tr - (th "Commit") - (th "Source") - (th "Events") - (th ""))) - (tdata - ,@(map (match-lambda - ((id commit source git-repository-id created-at succeeded-at - events log-exists?) - `(tr - (@ (class - ,(let ((event-names - (map (lambda (event) - (assoc-ref event "event")) - (vector->list events)))) - (cond - ((member "success" event-names) - "success") - ((member "failure" event-names) - "danger") - ((member "start" event-names) - "info") - (else - ""))))) - (td (a (@ (href - ,(string-append - "/revision/" commit))) - (samp ,commit))) - (td ,source) - (td - (dl - (@ (class "dl-horizontal")) - ,@(map - (lambda (event) - `((dt ,(assoc-ref event "event")) - (dd ,(assoc-ref event "occurred_at")))) - (cons - `(("event" . "created") - ("occurred_at" . ,created-at)) - (vector->list events))))) - (td - ,@(if log-exists? - `((a (@ (href ,(string-append "/job/" id))) - "View log")) - '()))))) - jobs-and-events))))))))) - -(define (view-job-queue jobs-and-events) - (layout - #:body - `(,(header) - (div - (@ (class "container")) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (a (@ (href "/jobs")) - (h3 "Jobs")) - (h1 "Queued jobs (" - ,(length jobs-and-events) - ")"))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (table - (@ (class "table")) - (thead - (tr - (th "Commit") - (th "Source") - (th "Events") - (th ""))) - (tdata - ,@(map (match-lambda - ((id commit source git-repository-id created-at - events log-exists? latest-branch-commit?) - `(tr - (@ (class - ,(let ((event-names - (map (lambda (event) - (assoc-ref event "event")) - (vector->list events)))) - (cond - ((member "success" event-names) - "success") - ((member "failure" event-names) - "danger") - ((member "start" event-names) - "info") - (else - ""))))) - (td (a (@ (href - ,(string-append - "/revision/" commit))) - (samp ,commit) - ,@(if latest-branch-commit? - '((br) - (span (@ (class "text-danger")) - "(latest branch commit)")) - '()))) - (td ,source) - (td - (dl - (@ (class "dl-horizontal")) - ,@(map - (lambda (event) - `((dt ,(assoc-ref event "event")) - (dd ,(assoc-ref event "occurred_at")))) - (cons - `(("event" . "created") - ("occurred_at" . ,created-at)) - (vector->list events))))) - (td - ,@(if log-exists? - `((a (@ (href ,(string-append "/job/" id))) - "View log")) - '()))))) - jobs-and-events))))))))) - -(define (view-job job-id query-parameters log) - (layout - #:body - `(,(header) - (div - (@ (class "container")) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h1 "Job " ,job-id))) - (div - (@ (class "row")) - (div - (@ (class "col-md-12")) - (div - (@ (class "well")) - (form - (@ (method "get") - (action "") - (class "form-horizontal")) - ,(form-horizontal-control - "Characters" query-parameters - #:help-text "Return at most this many characters.") - ,(form-horizontal-control - "Start character" query-parameters - #:help-text "Start reading the log from this character.") - (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 log"))))))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (a (@ (class "btn btn-default btn-lg pull-right") - (style "margin-bottom: 20px;") - (href "#bottom")) - "Scroll to the bottom of the page"))) - (div - (@ (class "row")) - (div - (pre (raw ,log)) - (a (@ (id "bottom"))))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (a (@ (class "btn btn-default btn-lg pull-right") - (href "#top")) - "Scroll to the top of the page"))))))) - (define (view-derivation derivation derivation-inputs derivation-outputs builds) (layout |