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

Tweak linking to build servers

Browse source 
Move the logic from different places in the view code, and also start
supporting linking to guix.cbaines.net builds. I'm unsure quite how to
generalise this, but just starting doing it is probably the way forward.
This commit is contained in:
Christopher Baines 2020-10-11 21:19:00 +01:00
parent d05a7397fb
commit 4231f11cb8
4 changed files with 27 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -116,11 +116,9 @@
(td (a (@ (href ,derivation-file-name)) (td (a (@ (href ,derivation-file-name))
,(display-store-item-short derivation-file-name))) ,(display-store-item-short derivation-file-name)))
(td ,timestamp) (td ,timestamp)
(td (a (@ (href ,(simple-format (td (a (@ (href ,(build-server-link-url
#f "~Abuild/~A"
build-server-url build-server-url
(string-drop build-server-build-id
derivation-file-name derivation-file-name)))
(string-length "/gnu/store/")))))
"View build on " ,build-server-url))))) "View build on " ,build-server-url)))))
builds))))))))) builds)))))))))

18
guix-data-service/web/html-utils.scm
View file

@ -26,6 +26,7 @@
build-status-value->display-string build-status-value->display-string
build-status-span build-status-span
build-url build-url
build-server-link-url
build-status-alist->build-icon)) build-status-alist->build-icon))
(define (sexp-div sexp) (define (sexp-div sexp)
@ -79,6 +80,23 @@
build-server-id build-server-id
derivation-file-name))) derivation-file-name)))
(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/")))))
(define (build-status-span status) (define (build-status-span status)
`(span (@ (class ,(string-append `(span (@ (class ,(string-append
"label label-" "label label-"

8
guix-data-service/web/revision/html.scm
View file

@ -1978,12 +1978,10 @@ figure {
(td (a (@ (href ,derivation-file-name)) (td (a (@ (href ,derivation-file-name))
,(display-store-item-short derivation-file-name))) ,(display-store-item-short derivation-file-name)))
(td ,timestamp) (td ,timestamp)
(td (a (@ (href ,(simple-format (td (a (@ (href ,(build-server-link-url
#f "~Abuild/~A"
build-server-url build-server-url
(string-drop build-server-build-id
derivation-file-name derivation-file-name)))
(string-length "/gnu/store/")))))
"View build on " ,build-server-url))))) "View build on " ,build-server-url)))))
builds))))))))) builds)))))))))

8
guix-data-service/web/view/html.scm
View file

@ -671,12 +671,10 @@ time."
(second derivation)))) (second derivation))))
,(build-status-span status))) ,(build-status-span status)))
(a (@ (style "display: inline-block; margin-top: 0.4em;") (a (@ (style "display: inline-block; margin-top: 0.4em;")
(href ,(simple-format (href ,(build-server-link-url
#f "~Abuild/~A"
build-server-url build-server-url
(string-drop build-server-build-id
(second derivation) (second derivation))))
(string-length "/gnu/store/")))))
"View build on " ,build-server-url)))) "View build on " ,build-server-url))))
builds))) builds)))
(div (div