cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add a job events page

Browse source
This commit is contained in:
Christopher Baines 2020-01-20 19:46:00 +00:00
parent f3ebe83532
commit bf25a8db02
3 changed files with 95 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

3
guix-data-service/web/controller.scm
View file

@ -319,8 +319,7 @@
(delegate-to-with-secret-key-base build-server-controller))
(('GET "compare" _ ...) (delegate-to compare-controller))
(('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
(('GET "jobs") (delegate-to jobs-controller))
(('GET "jobs" "queue") (delegate-to jobs-controller))
(('GET "jobs" _ ...) (delegate-to jobs-controller))
(('GET "job" job-id) (delegate-to jobs-controller))
(('GET _ ...) (delegate-to nar-controller))
((method path ...)

25
guix-data-service/web/jobs/controller.scm
View file

@ -43,6 +43,19 @@
(render-jobs mime-types
conn
parsed-query-parameters)))
(('GET "jobs" "events")
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
request
`((limit_results ,parse-result-limit
#:no-default-when (all_results)
#:default 50)
(all_results ,parse-checkbox-value)))
'((limit_results all_results)))))
(render-job-events mime-types
conn
parsed-query-parameters)))
(('GET "jobs" "queue")
(render-job-queue mime-types
conn))
@ -75,6 +88,18 @@
(>= (length jobs)
limit-results))))))
(define (render-job-events mime-types conn query-parameters)
(let* ((limit-results
(assq-ref query-parameters 'limit_results))
(recent-events (select-recent-job-events
conn
;; TODO Ideally there wouldn't be a limit
#:limit (or limit-results 1000000))))
(render-html
#:sxml (view-job-events
query-parameters
recent-events))))
(define (render-job-queue mime-types conn)
(render-html
#:sxml (view-job-queue

69
guix-data-service/web/jobs/html.scm
View file

@ -21,6 +21,7 @@
#:use-module (guix-data-service web html-utils)
#:use-module (guix-data-service web view html)
#:export (view-jobs
view-job-events
view-job-queue
view-job))
@ -171,6 +172,74 @@
"Next page")))
'())))))))
(define (view-job-events query-parameters
recent-events)
(layout
#:body
`(,(header)
(div
(@ (class "container"))
(div
(@ (class "row"))
(div
(@ (class "col-sm-12"))
(a (@ (href "/jobs"))
(h3 "Jobs"))
(h1 "Recent events")))
(div
(@ (class "row"))
(div
(@ (class "col-sm-12"))
(div
(@ (class "well"))
(form
(@ (method "get")
(action "")
(style "padding-bottom: 0")
(class "form-horizontal"))
,(form-horizontal-control
"Limit results" query-parameters
#:help-text "The maximum number of jobs to return.")
,(form-horizontal-control
"All results" query-parameters
#:type "checkbox"
#:help-text "Return all results.")
(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 "Commit")
(th "Event")
(th "Occurred at")))
(tbody
,@(map
(match-lambda
((id commit source git-repository-id event occurred-at)
`(tr
(td (a (@ (href
,(string-append
"/revision/" commit)))
(samp ,commit)))
(td ,@(let ((classes '(("start" . "info")
("success" . "success")
("failure" . "danger"))))
(or (and=> (assoc-ref classes event)
(lambda (class)
`((@ (class ,class)))))
'()))
,event)
(td ,occurred-at))))
recent-events)))))))))
(define (view-job-queue jobs-and-events)
(layout
#:body