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.

4 files changed, 205 insertions, 18 deletions

diff --git a/guix-data-service/branch-updated-emails.scm b/guix-data-service/branch-updated-emails.scm
index 16dced4..3c36f36 100644
--- a/guix-data-service/branch-updated-emails.scm
+++ b/guix-data-service/branch-updated-emails.scm
@@ -16,8 +16,10 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (guix-data-service branch-updated-emails)
+  #:use-module (srfi srfi-19)
   #:use-module (email email)
   #:use-module (guix-data-service model git-repository)
+  #:use-module (guix-data-service model git-branch)
   #:use-module (guix-data-service jobs load-new-guix-revision)
   #:export (enqueue-job-for-email))
 
@@ -26,6 +28,7 @@
 
 (define (enqueue-job-for-email conn email)
   (let* ((headers       (email-headers email))
+         (date          (assq-ref headers 'date))
          (x-git-repo    (assq-ref headers 'x-git-repo))
          (x-git-reftype (assq-ref headers 'x-git-reftype))
          (x-git-refname (assq-ref headers 'x-git-refname))
@@ -35,11 +38,25 @@
                (and (string? x-git-repo)
                     (string=? x-git-repo "guix"))
                (string? x-git-newrev))
-      (enqueue-load-new-guix-revision-job
-       conn
-       (git-repository-url->git-repository-id
-        conn
-        (assoc-ref %repository-url-for-repo
-                   x-git-repo))
-       x-git-newrev
-       (string-append x-git-repo " " x-git-refname " updated")))))
+
+      (let ((branch-name
+             (string-drop x-git-refname 11))
+            (git-repository-id
+             (git-repository-url->git-repository-id
+              conn
+              (assoc-ref %repository-url-for-repo x-git-repo))))
+
+        (insert-git-branch-entry conn
+                                 branch-name
+                                 (if (string=? "0000000000000000000000000000000000000000"
+                                               x-git-newrev)
+                                     "NULL"
+                                     x-git-newrev)
+                                 git-repository-id
+                                 (date->string date "~4"))
+
+        (enqueue-load-new-guix-revision-job
+         conn
+         git-repository-id
+         x-git-newrev
+         (string-append x-git-repo " " x-git-refname " updated"))))))
diff --git a/guix-data-service/model/git-branch.scm b/guix-data-service/model/git-branch.scm
new file mode 100644
index 0000000..896e551
--- /dev/null
+++ b/guix-data-service/model/git-branch.scm
@@ -0,0 +1,57 @@
+(define-module (guix-data-service model git-branch)
+  #:use-module (squee)
+  #:export (insert-git-branch-entry
+            git-branches-for-commit
+            most-recent-100-commits-for-branch
+            all-branches-with-most-recent-commit))
+
+(define (insert-git-branch-entry conn
+                                 name commit
+                                 git-repository-id datetime)
+  (exec-query
+   conn
+   (string-append
+    "INSERT INTO git_branches (name, commit, git_repository_id, datetime) "
+    "VALUES ($1, $2, $3, $4) "
+    "ON CONFLICT DO NOTHING")
+   (list name
+         commit
+         git-repository-id
+         datetime)))
+
+(define (git-branches-for-commit conn commit)
+  (define query
+    "
+SELECT name, datetime FROM git_branches WHERE commit = $1
+ORDER BY datetime DESC")
+
+  (exec-query conn query (list commit)))
+
+(define (most-recent-100-commits-for-branch conn branch-name)
+  (define query
+    (string-append
+     "SELECT git_branches.commit, datetime, "
+     "(guix_revisions.id IS NOT NULL) as guix_revision_exists "
+     "FROM git_branches "
+     "LEFT OUTER JOIN guix_revisions ON git_branches.commit = guix_revisions.commit "
+     "WHERE name = $1 ORDER BY datetime DESC LIMIT 100;"))
+
+  (exec-query
+   conn
+   query
+   (list branch-name)))
+
+(define (all-branches-with-most-recent-commit conn)
+  (define query
+    (string-append
+     "SELECT DISTINCT ON (name) name, git_branches.commit, "
+     "datetime, (guix_revisions.id IS NOT NULL) guix_revision_exists "
+     "FROM git_branches "
+     "LEFT OUTER JOIN guix_revisions ON git_branches.commit = guix_revisions.commit "
+     "WHERE git_branches.commit IS NOT NULL "
+     "ORDER BY name, datetime DESC;"))
+
+  (exec-query
+   conn
+   query))
+
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