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

Extract the builds page in to it's own set of modules

Browse source 
To allow for expanding it, without cluttering the root controller.
This commit is contained in:
Christopher Baines 2019-11-24 20:42:37 +00:00
parent 33ecb7448e
commit 2a3ee20a99
5 changed files with 124 additions and 61 deletions
Download patch file Download diff file Expand all files Collapse all files

40
guix-data-service/web/build/controller.scm Normal file
View file

@ -0,0 +1,40 @@
;;; 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 build 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 model build)
#:use-module (guix-data-service web build html)
#:export (build-controller))
(define (build-controller request
method-and-path-components
mime-types
body
conn)
(match method-and-path-components
(('GET "builds")
(render-builds mime-types
conn))
(_ #f)))
(define (render-builds mime-types conn)
(render-html
#:sxml (view-builds (select-build-stats conn)
(select-builds-with-context conn))))

80
guix-data-service/web/build/html.scm Normal file
View file

@ -0,0 +1,80 @@
;;; 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 build html)
#:use-module (ice-9 match)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web view html)
#:export (view-builds))
(define (view-builds 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")
(th (@ (class "col-md-2")) "Count")))
(tbody
,@(map
(match-lambda
((status count)
`(tr
(td ,(build-status-span status))
(td ,count))))
stats)))))
(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)))))))))