2019-12-02 13:25:42 +01:00
|
|
|
;;; 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 html-utils)
|
2019-12-13 18:13:27 +01:00
|
|
|
#:use-module (srfi srfi-1)
|
2019-12-02 13:25:42 +01:00
|
|
|
#:use-module (ice-9 match)
|
2019-12-13 18:13:27 +01:00
|
|
|
#:use-module (guix-data-service web query-parameters)
|
2019-12-03 10:05:08 +01:00
|
|
|
#:export (sexp-div
|
|
|
|
|
2019-12-13 18:13:27 +01:00
|
|
|
next-page-link
|
|
|
|
|
2019-12-03 10:05:08 +01:00
|
|
|
build-status-value->display-string
|
2019-12-05 16:31:38 +01:00
|
|
|
build-status-span
|
2020-07-01 20:51:21 +02:00
|
|
|
build-url
|
2020-10-11 22:19:00 +02:00
|
|
|
build-server-link-url
|
2020-10-31 16:53:50 +01:00
|
|
|
build-status-alist->build-icon
|
|
|
|
build-statuses->build-status-labels))
|
2019-12-02 13:25:42 +01:00
|
|
|
|
|
|
|
(define (sexp-div sexp)
|
|
|
|
(match sexp
|
|
|
|
(#(val rest ...)
|
|
|
|
`(div (@ (style "margin-left: 1em;"))
|
|
|
|
"( "
|
|
|
|
,val
|
|
|
|
" "
|
|
|
|
,@(map sexp-div rest)
|
|
|
|
" )"))
|
|
|
|
((("base16" . hash))
|
|
|
|
`(span (@ (style "font-family: monospace;"))
|
|
|
|
,hash))
|
|
|
|
((and string val)
|
|
|
|
val)))
|
2019-12-03 10:05:08 +01:00
|
|
|
|
2019-12-13 18:13:27 +01:00
|
|
|
(define (next-page-link path
|
|
|
|
query-parameters
|
|
|
|
field
|
|
|
|
value)
|
|
|
|
(string-append
|
|
|
|
path
|
|
|
|
"?"
|
|
|
|
(query-parameters->string
|
|
|
|
`((,field . ,value)
|
|
|
|
,@(alist-delete
|
|
|
|
field
|
|
|
|
query-parameters)))))
|
|
|
|
|
2019-12-03 10:05:08 +01:00
|
|
|
(define (build-status-value->display-string value)
|
|
|
|
(assoc-ref
|
|
|
|
'(("scheduled" . "Scheduled")
|
|
|
|
("started" . "Started")
|
|
|
|
("succeeded" . "Succeeded")
|
|
|
|
("failed" . "Failed")
|
|
|
|
("failed-dependency" . "Failed (dependency)")
|
|
|
|
("failed-other" . "Failed (other)")
|
|
|
|
("canceled" . "Canceled")
|
2021-01-03 10:43:24 +01:00
|
|
|
("" . "Unknown")
|
|
|
|
(#f . "Unknown"))
|
2019-12-03 10:05:08 +01:00
|
|
|
value))
|
|
|
|
|
2020-07-01 20:51:21 +02:00
|
|
|
(define (build-url build-server-id build-server-build-id derivation-file-name)
|
2020-10-21 19:38:29 +02:00
|
|
|
(if (and (string? build-server-build-id)
|
|
|
|
(not (string-null? build-server-build-id)))
|
2020-07-01 20:51:21 +02:00
|
|
|
(simple-format
|
|
|
|
#f "/build-server/~A/build?build_server_build_id=~A"
|
|
|
|
build-server-id
|
|
|
|
build-server-build-id)
|
|
|
|
(simple-format
|
|
|
|
#f "/build-server/~A/build?derivation_file_name=~A"
|
|
|
|
build-server-id
|
|
|
|
derivation-file-name)))
|
|
|
|
|
2020-10-11 22:19:00 +02:00
|
|
|
(define (build-server-link-url url-base
|
|
|
|
build-server-build-id
|
|
|
|
derivation-file-name)
|
|
|
|
(string-append
|
|
|
|
url-base
|
|
|
|
(if (string-suffix? "/" url-base)
|
|
|
|
""
|
|
|
|
"/")
|
|
|
|
"build/"
|
|
|
|
(if (and (string? build-server-build-id)
|
|
|
|
(eq? (string-length build-server-build-id)
|
|
|
|
36)) ; crude UUID check
|
|
|
|
build-server-build-id
|
|
|
|
(string-drop
|
|
|
|
derivation-file-name
|
|
|
|
(string-length "/gnu/store/")))))
|
|
|
|
|
2019-12-03 10:05:08 +01:00
|
|
|
(define (build-status-span status)
|
|
|
|
`(span (@ (class ,(string-append
|
|
|
|
"label label-"
|
|
|
|
(assoc-ref
|
|
|
|
'(("scheduled" . "info")
|
|
|
|
("started" . "primary")
|
|
|
|
("succeeded" . "success")
|
|
|
|
("failed" . "danger")
|
|
|
|
("failed-dependency" . "warning")
|
|
|
|
("failed-other" . "danger")
|
|
|
|
("canceled" . "default")
|
2021-01-03 10:43:24 +01:00
|
|
|
("" . "default")
|
|
|
|
(#f . "default"))
|
2019-12-03 10:05:08 +01:00
|
|
|
status)))
|
2019-12-16 21:15:11 +01:00
|
|
|
(style "display: inline-block; font-size: 1.2em; margin-top: 0.4em; margin-bottom: 0.4em;"))
|
2019-12-03 10:05:08 +01:00
|
|
|
,(build-status-value->display-string status)))
|
2019-12-05 16:31:38 +01:00
|
|
|
|
|
|
|
(define (build-status-alist->build-icon status)
|
2020-12-26 14:38:58 +01:00
|
|
|
(build-status-span (or (assoc-ref status "status")
|
|
|
|
(assq-ref status 'status))))
|
2020-10-31 16:53:50 +01:00
|
|
|
|
|
|
|
(define (build-status-label status count)
|
|
|
|
`(span (@ (class ,(string-append
|
|
|
|
"pull-right label label-"
|
|
|
|
(assoc-ref
|
|
|
|
'(("scheduled" . "info")
|
|
|
|
("started" . "primary")
|
|
|
|
("succeeded" . "success")
|
|
|
|
("failed" . "danger")
|
|
|
|
("failed-dependency" . "warning")
|
|
|
|
("failed-other" . "danger")
|
|
|
|
("canceled" . "default")
|
|
|
|
("" . "default"))
|
|
|
|
status))))
|
|
|
|
,count))
|
|
|
|
|
|
|
|
(define (build-statuses->build-status-labels builds)
|
|
|
|
(define statuses-and-counts
|
|
|
|
(fold (lambda (status counts)
|
|
|
|
`((,status . ,(+ 1
|
|
|
|
(or (assoc-ref counts status)
|
|
|
|
0)))
|
|
|
|
,@(alist-delete status counts)))
|
|
|
|
'()
|
|
|
|
(sort
|
|
|
|
(map (lambda (build)
|
|
|
|
(assoc-ref build "status"))
|
|
|
|
builds)
|
|
|
|
string<?)))
|
|
|
|
|
|
|
|
(map
|
|
|
|
(match-lambda
|
|
|
|
((status . count)
|
|
|
|
(build-status-label status count)))
|
|
|
|
statuses-and-counts))
|