Start to handle information about Git branches

Add some new pages /branches and /branch/... as well as a new git_branches
table. Also extend the email processing to enter the branch information in to
the database.

2 files changed, 123 insertions, 10 deletions

diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 6dda0da..26acfd4 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -27,6 +27,7 @@
   #:use-module (web uri)
   #:use-module (squee)
   #:use-module (guix-data-service comparison)
+  #:use-module (guix-data-service model git-branch)
   #:use-module (guix-data-service model git-repository)
   #:use-module (guix-data-service model guix-revision)
   #:use-module (guix-data-service model package)
@@ -287,14 +288,24 @@
 
   (match-lambda
     ((GET)
-     (apply render-html (index
-                         (map
-                          (lambda (git-repository-details)
-                            (cons git-repository-details
-                                  (guix-revisions-and-jobs-for-git-repository
-                                   conn
-                                   (car git-repository-details))))
-                          (all-git-repositories conn)))))
+     (apply render-html
+            (index
+             (map
+              (lambda (git-repository-details)
+                (cons
+                 git-repository-details
+                 (map
+                  (match-lambda
+                    ((id job-id commit source)
+                     (list id
+                           job-id
+                           commit
+                           source
+                           (git-branches-for-commit conn commit))))
+                  (guix-revisions-and-jobs-for-git-repository
+                   conn
+                   (car git-repository-details)))))
+              (all-git-repositories conn)))))
     ((GET "builds")
      (apply render-html
             (view-builds (select-build-stats conn)
@@ -331,6 +342,17 @@
               commit-hash
               name
               version))))
+    ((GET "branches")
+     (apply render-html
+            (view-branches
+             (all-branches-with-most-recent-commit conn))))
+    ((GET "branch" branch-name)
+     (apply render-html
+            (view-branch
+             branch-name
+             (most-recent-100-commits-for-branch
+              conn
+              branch-name))))
     ((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 8c74c18..3593402 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -30,6 +30,8 @@
             view-revision-package-and-version
             view-revision
             view-revision-packages
+            view-branches
+            view-branch
             view-builds
             view-derivation
             view-store-item
@@ -160,13 +162,21 @@
                       (tbody
                        ,@(map
                           (match-lambda
-                            ((id job-id commit source)
+                            ((id job-id commit source branches)
                              `(tr
                                (td ,(if (string-null? id)
                                         `(samp ,commit)
                                         `(a (@ (href ,(string-append
                                                        "/revision/" commit)))
-                                            (samp ,commit)))))))
+                                            (samp ,commit))))
+                               (td
+                                ,@(map
+                                   (match-lambda
+                                     ((name date)
+                                      `(a (@ (href ,(string-append
+                                                     "/branch/" name)))
+                                          ,name)))
+                                   branches)))))
                           revisions))))))))
          git-repositories-and-revisions)))))
 
@@ -348,6 +358,87 @@
                          "More information")))))
              packages)))))))))
 
+(define (view-branches branches-with-most-recent-commits)
+  (layout
+   #:extra-headers
+   '((cache-control . ((max-age . 60))))
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-12"))
+        (h1 "Branches")))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-12"))
+        (table
+         (@ (class "table table-responsive"))
+         (thead
+          (tr
+           (th (@ (class "col-md-3")) "Name")
+           (th (@ (class "col-md-3")) "Commit")
+           (th (@ (class "col-md-3")) "Date")))
+         (tbody
+          ,@(map
+             (match-lambda
+               ((name commit date revision-exists)
+                `(tr
+                  (td
+                   (a (@ (href ,(string-append "/branch/" name)))
+                      ,name))
+                  (td ,date)
+                  (td ,(if (string=? revision-exists "t")
+                           `(a (@ (href ,(string-append
+                                          "/revision/" commit)))
+                               (samp ,commit))
+                           `(samp ,(if (string=? commit "NULL")
+                                       "branch deleted"
+                                       commit)))))))
+             branches-with-most-recent-commits)))))))))
+
+(define (view-branch branch-name branch-commits)
+  (layout
+   #:extra-headers
+   '((cache-control . ((max-age . 60))))
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-12"))
+        (h1 (@ (style "white-space: nowrap;"))
+            (samp ,branch-name) " branch")))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-12"))
+        (table
+         (@ (class "table table-responsive"))
+         (thead
+          (tr
+           (th (@ (class "col-md-3")) "Date")
+           (th (@ (class "col-md-3")) "Commit")))
+         (tbody
+          ,@(map
+             (match-lambda
+               ((commit date revision-exists)
+                `(tr
+                  (td ,date)
+                  (td ,(if (string=? revision-exists "t")
+                           `(a (@ (href ,(string-append
+                                          "/revision/" commit)))
+                               (samp ,commit))
+                           `(samp ,(if (string=? commit "NULL")
+                                       "branch deleted"
+                                       commit)))))))
+             branch-commits)))))))))
+
 (define (view-builds stats builds)
   (layout
    #:extra-headers