Add a page for channel instance derivations

guix-data-service/web/revision/controller.scm

@@ -34,6 +34,7 @@
   #:use-module (guix-data-service model build-server)
   #:use-module (guix-data-service model build-status)
   #:use-module (guix-data-service model channel-news)
+  #:use-module (guix-data-service model channel-instance)
   #:use-module (guix-data-service model package)
   #:use-module (guix-data-service model git-branch)
   #:use-module (guix-data-service model git-repository)
@@ -225,6 +226,15 @@
          (render-unknown-revision mime-types
                                   conn
                                   commit-hash)))
+    (('GET "revision" commit-hash "channel-instances")
+     (if (guix-commit-exists? conn commit-hash)
+         (render-revision-channel-instances mime-types
+                                            conn
+                                            commit-hash
+                                            #:path-base path)
+         (render-unknown-revision mime-types
+                                  conn
+                                  commit-hash)))
     (('GET "revision" commit-hash "package-reproducibility")
      (if (guix-commit-exists? conn commit-hash)
          (render-revision-package-reproduciblity mime-types
@@ -378,6 +388,33 @@
                 #:header-text header-text
                 #:header-link header-link))))))
 
+(define* (render-revision-channel-instances mime-types
+                                            conn
+                                            commit-hash
+                                            #:key
+                                            (path-base "/revision/")
+                                            (header-text
+                                             `("Revision " (samp ,commit-hash)))
+                                            (header-link
+                                             (string-append "/revision/"
+                                                            commit-hash)))
+  (let ((channel-instances
+         (select-channel-instances-for-guix-revision conn commit-hash)))
+    (case (most-appropriate-mime-type
+           '(application/json text/html)
+           mime-types)
+      ((application/json)
+       (render-json
+        '()))                           ; TODO
+      (else
+       (render-html
+        #:sxml (view-revision-channel-instances
+                commit-hash
+                channel-instances
+                #:path-base path-base
+                #:header-text header-text
+                #:header-link header-link))))))
+
 (define* (render-revision-package-reproduciblity mime-types
                                                  conn
                                                  commit-hash

guix-data-service/web/revision/html.scm

@@ -36,6 +36,7 @@
             view-revision-derivations
             view-revision-derivation-outputs
             view-revision-system-tests
+            view-revision-channel-instances
             view-revision-builds
             view-revision-lint-warnings
             unknown-revision))
@@ -723,6 +724,56 @@
                          builds)))))
              system-tests)))))))))
 
+(define* (view-revision-channel-instances commit-hash
+                                          channel-instances
+                                          #:key (path-base "/revision/")
+                                          header-text header-link)
+  (layout
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-sm-12"))
+        (h3 (a (@ (style "white-space: nowrap;")
+                  (href ,header-link))
+               ,@header-text))))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-12"))
+        (h1 "Channel instances")
+        (table
+         (@ (class "table"))
+         (thead
+          (tr
+           (th "System")
+           (th "Derivation")
+           (th "Build status")))
+         (tbody
+          ,@(map
+             (match-lambda
+               ((system derivation-file-name builds)
+                `(tr
+                  (td (@ (style "font-family: monospace;"))
+                      ,system)
+                  (td (a (@ (href ,derivation-file-name))
+                         ,(display-store-item-short derivation-file-name)))
+                  (td ,@(map
+                         (lambda (build)
+                           (let ((build-server-id
+                                  (assoc-ref build "build_server_id")))
+                             `(a (@ (href
+                                     ,(simple-format
+                                       #f "/build-server/~A/build?derivation_file_name=~A"
+                                       build-server-id
+                                       derivation-file-name)))
+                                 ,(build-status-alist->build-icon build))))
+                         builds)))))
+             channel-instances)))))))))
+
 (define* (view-revision-package-reproducibility revision-commit-hash
                                                 output-consistency)
   (layout