Refactor the jobs pages code
Move the code out of the main controller and html modules. There's now too much code in these modules, so begin to separate the functionality, starting with the small amount of code for the jobs pages.
This commit is contained in:
Christopher Baines
parent
955ada8bca
commit
06723370e5
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
@ -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")))))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue