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))
,(display-store-item-short derivation-file-name)))
(td ,timestamp)
(td (a (@ (href ,(simple-format
#f "~Abuild/~A"
(td (a (@ (href ,(build-server-link-url
build-server-url
(string-drop
derivation-file-name
(string-length "/gnu/store/")))))
build-server-build-id
derivation-file-name)))
"View build on " ,build-server-url)))))
builds)))))))))

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

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

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

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

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

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