Add a few new pages

For showing more information about builds, revisions and derivations.

guix-data-service/model/package.scm

@@ -6,6 +6,7 @@
   #:use-module (guix inferior)
   #:use-module (guix-data-service model utils)
   #:export (select-existing-package-entries
+            select-packages-in-revision
             insert-into-package-entries
             inferior-packages->package-ids))
 
@@ -28,6 +29,20 @@
                  "packages.derivation_id = vals.derivation_id"
                  ";"))
 
+(define (select-packages-in-revision conn commit-hash)
+  (define query
+    (string-append
+     "SELECT packages.name, packages.version, packages.derivation_id "
+     "FROM packages "
+     "INNER JOIN guix_revision_packages"
+     " ON packages.id = guix_revision_packages.package_id "
+     "INNER JOIN guix_revisions"
+     " ON guix_revision_packages.revision_id = guix_revisions.id "
+     "WHERE guix_revisions.commit = $1 "
+     "ORDER BY packages.name, packages.version"))
+
+  (exec-query conn query (list commit-hash)))
+
 (define (insert-into-package-entries package-entries)
   (string-append "INSERT INTO packages "
                  "(name, version, package_metadata_id, derivation_id) VALUES "

guix-data-service/web/controller.scm

@@ -28,6 +28,8 @@
   #:use-module (squee)
   #:use-module (guix-data-service comparison)
   #:use-module (guix-data-service model guix-revision)
+  #:use-module (guix-data-service model package)
+  #:use-module (guix-data-service model build)
   #:use-module (guix-data-service jobs load-new-guix-revision)
   #:use-module (guix-data-service web render)
   #:use-module (guix-data-service web util)
@@ -204,6 +206,19 @@
      (apply render-html (index
                          (most-recent-n-guix-revisions conn 10)
                          (most-recent-n-load-new-guix-revision-jobs conn 1000))))
+    ((GET "builds")
+     (apply render-html
+            (view-builds (select-build-stats conn)
+                         (select-builds-with-context conn))))
+    ((GET "revision" commit-hash)
+     (apply render-html
+            (view-revision commit-hash
+                           (select-packages-in-revision conn
+                                                        commit-hash))))
+    ((GET "derivation" derivation-file-name ...)
+     (apply render-html
+            (view-derivation (string-append
+                              "/" (string-join derivation-file-name "/")))))
     ((GET "compare")
      (with-base-and-target-commits
       request conn

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

@@ -24,6 +24,9 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:export (index
+            view-revision
+            view-builds
+            view-derivation
             compare
             compare/derivations
             compare/packages
@@ -164,6 +167,104 @@
                        (td ,source))))
                   queued-guix-revisions)))))))))
 
+(define (view-revision commit-hash packages)
+  (layout
+   #:extra-headers
+   '((cache-control . ((max-age . 60))))
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (h1 "Revision " (samp ,commit-hash)))
+      (div
+       (@ (class "row"))
+       (h3 "Packages")
+       (table
+        (@ (class "table"))
+        (thead
+         (tr
+          (th (@ (class "col-md-3")) "Name")
+          (th (@ (class "col-md-9")) "Version")))
+        (tbody
+         ,@(map
+            (match-lambda
+              ((name version rest ...)
+               `(tr
+                 (td ,name)
+                 (td ,version))))
+            packages))))))))
+
+(define (view-builds stats builds)
+  (layout
+   #:extra-headers
+   '((cache-control . ((max-age . 60))))
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (h1 "Builds")
+       (table
+        (@ (class "table"))
+        (thead
+         (tr
+          (th (@ (class "col-md-2")) "Status")
+          (th (@ (class "col-md-2")) "Count")))
+        (tbody
+         ,@(map
+            (match-lambda
+              ((status count)
+               `(tr
+                 (td ,status)
+                 (td ,count))))
+            stats))))
+      (div
+       (@ (class "row"))
+       (table
+        (@ (class "table"))
+        (thead
+         (tr
+          (th (@ (class "col-xs-2")) "Status")
+          (th (@ (class "col-xs-9")) "Derivation")
+          (th (@ (class "col-xs-1")) "Started at")
+          (th (@ (class "col-xs-1")) "Finished at")
+          (th (@ (class "col-xs-1")) "")))
+        (tbody
+         ,@(map
+            (match-lambda
+              ((build-id build-server-url derivation-file-name
+                         status-fetched-at starttime stoptime status)
+               `(tr
+                 (td (@ (class ,(cond
+                                 ((string=? status "succeeded")
+                                  "bg-success")
+                                 ((string=? status "failed")
+                                  "bg-danger")
+                                 (else ""))))
+                     ,status)
+                 (td ,derivation-file-name)
+                 (td ,starttime)
+                 (td ,stoptime)
+                 (td (a (@ (href ,(simple-format
+                                   #f "~Abuild/~A" build-server-url build-id)))
+                        "View build on " ,build-server-url)))))
+            builds))))))))
+
+(define (view-derivation derivation-file-name)
+  (layout
+   #:extra-headers
+   '((cache-control . ((max-age . 60))))
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (h1 "Derivation " (samp ,derivation-file-name)))))))
+
 (define (compare base-commit
                  target-commit
                  new-packages