Continue improving pages and linking things together

2 files changed, 112 insertions, 13 deletions

diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 0a2047e..9f436dc 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -210,17 +210,31 @@
                                   (first derivation)))
               (derivation-outputs (select-derivation-outputs-by-derivation-id
                                    conn
-                                   (first derivation))))
+                                   (first derivation)))
+              (builds (select-builds-with-context-by-derivation-id
+                       conn
+                       (first derivation))))
           (apply render-html
                  (view-derivation derivation
                                   derivation-inputs
-                                  derivation-outputs)))
+                                  derivation-outputs
+                                  builds)))
         #f ;; TODO
         )))
 
 (define (render-store-item conn filename)
-  (apply render-html
-         (view-store-item filename)))
+  (let ((derivation (select-derivation-by-output-filename conn filename)))
+    (match derivation
+      (()
+       #f)
+      ((derivation)
+       (apply render-html
+              (view-store-item filename
+                               derivation
+                               (match derivation
+                                 ((file-name output-id rest ...)
+                                  (select-derivations-using-output
+                                   conn output-id)))))))))
 
 (define (controller request body conn)
   (match-lambda
@@ -237,6 +251,11 @@
             (view-revision commit-hash
                            (select-packages-in-revision conn
                                                         commit-hash))))
+    ((GET "revision" commit-hash "package" name version)
+     (apply render-html
+            (view-revision-package-and-version commit-hash
+                                               name
+                                               version)))
     ((GET "gnu" "store" filename)
      (if (string-suffix? ".drv" filename)
          (render-derivation conn (string-append "/gnu/store/" filename))
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 62bb828..c7c353a 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -24,6 +24,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:export (index
+            view-revision-package-and-version
             view-revision
             view-builds
             view-derivation
@@ -144,7 +145,9 @@
                     ((id url commit store_path)
                      `(tr
                        (td ,url)
-                       (td (samp ,commit)))))
+                       (td (a (@ (href ,(string-append
+                                         "/revision/" commit)))
+                              (samp ,commit))))))
                   guix-revisions)))))
       (div
        (@ (class "row"))
@@ -168,6 +171,18 @@
                        (td ,source))))
                   queued-guix-revisions)))))))))
 
+(define (view-revision-package-and-version revision-commit-hash name version)
+  (layout
+   #:extra-headers
+   '((cache-control . ((max-age . 60))))
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (h1 "Package " ,name " @ " ,version))))))
+
 (define (view-revision commit-hash packages)
   (layout
    #:extra-headers
@@ -187,13 +202,16 @@
         (thead
          (tr
           (th (@ (class "col-md-3")) "Name")
-          (th (@ (class "col-md-9")) "Version")))
+          (th (@ (class "col-md-3")) "Version")))
         (tbody
          ,@(map
             (match-lambda
               ((name version rest ...)
                `(tr
-                 (td ,name)
+                 (td (a (@ (href ,(string-append
+                                   "/revision/" commit-hash
+                                   "/package/" name "/" version)))
+                        ,name))
                  (td ,version))))
             packages))))))))
 
@@ -258,7 +276,7 @@
 (define (display-store-item-short item)
   `((span (@ (style "font-size: small; font-family: monospace; display: block;"))
           ,(string-take item 44))
-    (span (@ (style "font-size: x-large; font-family: monospace;"))
+    (span (@ (style "font-size: x-large; font-family: monospace; display: block;"))
           ,(string-drop item 44))))
 
 (define (display-store-item item)
@@ -267,7 +285,22 @@
     (span (@ (style "font-size: x-large; font-family: monospace;"))
           ,(string-drop item 44))))
 
-(define (view-store-item filename)
+(define (display-store-item-title item)
+  `(h1 (span (@ (style "font-size: 1em; font-family: monospace; display: block;"))
+             ,(string-take item 44))
+       (span (@ (style "line-height: 1.7em; font-size: 1.5em; font-family: monospace;"))
+             ,(string-drop item 44))))
+
+(define (display-file-in-store-item filename)
+  (match (string-split filename #\/)
+    (("" "gnu" "store" item fileparts ...)
+     `(,(let ((full-item (string-append "/gnu/store/" item)))
+          `(a (@ (href ,full-item))
+              ,(display-store-item-short full-item)))
+       ,(string-append
+         "/" (string-join fileparts "/"))))))
+
+(define (view-store-item filename derivation derivations-using-store-item)
   (layout
    #:extra-headers
    '((cache-control . ((max-age . 60))))
@@ -277,9 +310,32 @@
       (@ (class "container"))
       (div
        (@ (class "row"))
-       (h1 (samp ,filename)))))))
+       ,(display-store-item-title filename))
+      (div
+       (@ (class "row"))
+       (h4 "Derivation: ")
+       ,(match derivation
+          ((file-name output-id)
+           `(a (@ (href ,file-name))
+               ,(display-store-item file-name)))))
+      (div
+       (@ (class "row"))
+       (h2 "Derivations using this store item "
+           ,(let ((count (length derivations-using-store-item)))
+              (if (eq? count 100)
+                  "(> 100)"
+                  (simple-format #f "(~A)" count))))
+       (ul
+        (@ (class "list-unstyled"))
+        ,(map
+          (match-lambda
+            ((file-name)
+             `(li (a (@ (href ,file-name))
+                     ,(display-store-item file-name)))))
+          derivations-using-store-item)))))))
 
-(define (view-derivation derivation derivation-inputs derivation-outputs)
+(define (view-derivation derivation derivation-inputs derivation-outputs
+                         builds)
   (layout
    #:extra-headers
    '((cache-control . ((max-age . 60))))
@@ -291,7 +347,7 @@
          ((id file-name builder args env-vars system)
           `(div
             (@ (class "row"))
-            (h1 "Derivation " (samp ,file-name)))))
+            ,(display-store-item-title file-name))))
       (div
        (@ (class "row"))
        (div
@@ -311,7 +367,31 @@
                  derivation-inputs))))
        (div
         (@ (class "col-md-4"))
-        "Details")
+        (h3 "Derivation details")
+        ,(match derivation
+           ((id file-name builder args env-vars system)
+            `(table
+              (@ (class "table"))
+              (tbody
+               (tr
+                (td "Builder")
+                (td (a (@ (href ,builder))
+                       ,(display-file-in-store-item builder))))
+               (tr
+                (td "System")
+                (td (samp ,system)))))))
+        (h3 "Build status")
+        ,@(map
+           (match-lambda
+             ((build-id build-server-url status-fetched-at
+                        starttime stoptime status)
+              `(div
+                (@ (class "text-center"))
+                (div ,status)
+                (a (@ (href ,(simple-format
+                              #f "~Abuild/~A" build-server-url build-id)))
+                   "View build on " ,build-server-url))))
+           builds))
        (div
         (@ (class "col-md-4"))
         (h3 "Outputs")