branch master updated: Tweak linking to build servers

[Christopher Baines]

This is an automated email from the git hooks/post-receive script.

cbaines pushed a commit to branch master
in repository data-service.

The following commit(s) were added to refs/heads/master by this push:
     new 4231f11  Tweak linking to build servers
4231f11 is described below

commit 4231f11cb8d5f556e38715878624cb0b88349b13
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sun Oct 11 21:19:00 2020 +0100

    Tweak linking to build servers
    
    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.
---
 guix-data-service/web/build/html.scm    |  8 +++-----
 guix-data-service/web/html-utils.scm    | 18 ++++++++++++++++++
 guix-data-service/web/revision/html.scm |  8 +++-----
 guix-data-service/web/view/html.scm     |  8 +++-----
 4 files changed, 27 insertions(+), 15 deletions(-)

diff --git a/guix-data-service/web/build/html.scm 
b/guix-data-service/web/build/html.scm
index f9939af..461f44a 100644
--- a/guix-data-service/web/build/html.scm
+++ b/guix-data-service/web/build/html.scm
@@ -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)))))))))
diff --git a/guix-data-service/web/html-utils.scm 
b/guix-data-service/web/html-utils.scm
index bdafae3..5fa1ad4 100644
--- a/guix-data-service/web/html-utils.scm
+++ b/guix-data-service/web/html-utils.scm
@@ -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-"
diff --git a/guix-data-service/web/revision/html.scm 
b/guix-data-service/web/revision/html.scm
index 571f6f6..b72dd9f 100644
--- a/guix-data-service/web/revision/html.scm
+++ b/guix-data-service/web/revision/html.scm
@@ -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)))))))))
 
diff --git a/guix-data-service/web/view/html.scm 
b/guix-data-service/web/view/html.scm
index 70893c4..78a6da1 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -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