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.

Makefile.am

@@ -42,6 +42,7 @@ SOURCES =							\
   guix-data-service/model/build-status.scm			\
   guix-data-service/model/build.scm				\
   guix-data-service/model/derivation.scm			\
+  guix-data-service/model/git-branch.scm			\
   guix-data-service/model/git-repository.scm			\
   guix-data-service/model/guix-revision-package-derivation.scm	\
   guix-data-service/model/guix-revision.scm			\
@@ -60,7 +61,9 @@ TEST_EXTENSIONS = .scm
 
 TESTS =				\
   tests/model-derivation.scm		\
-  tests/model-git-repository.scm
+  tests/model-git-branch.scm		\
+  tests/model-git-repository.scm	\
+  tests/branch-updated-emails.scm
 
 AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)"
 

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
+      (let ((branch-name
-       (git-repository-url->git-repository-id
+             (string-drop x-git-refname 11))
-        conn
+            (git-repository-id
-        (assoc-ref %repository-url-for-repo
+             (git-repository-url->git-repository-id
-                   x-git-repo))
+              conn
-       x-git-newrev
+              (assoc-ref %repository-url-for-repo x-git-repo))))
-       (string-append x-git-repo " " x-git-refname " updated")))))
+
+        (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"))))))

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))
+

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
+     (apply render-html
-                         (map
+            (index
-                          (lambda (git-repository-details)
+             (map
-                            (cons git-repository-details
+              (lambda (git-repository-details)
-                                  (guix-revisions-and-jobs-for-git-repository
+                (cons
-                                   conn
+                 git-repository-details
-                                   (car git-repository-details))))
+                 (map
-                          (all-git-repositories conn)))))
+                  (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))

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

sqitch/deploy/git_branches.sql

@@ -0,0 +1,13 @@
+-- Deploy guix-data-service:git_branches to pg
+
+BEGIN;
+
+CREATE TABLE git_branches (
+    name character varying NOT NULL,
+    commit character varying,
+    git_repository_id integer NOT NULL,
+    datetime timestamp without time zone NOT NULL,
+    CONSTRAINT name_commit PRIMARY KEY(name, commit)
+);
+
+COMMIT;

sqitch/revert/git_branches.sql

@@ -0,0 +1,7 @@
+-- Revert guix-data-service:git_branches from pg
+
+BEGIN;
+
+DROP TABLE git_branches;
+
+COMMIT;

sqitch/sqitch.plan

@@ -6,3 +6,4 @@ appschema 2019-04-13T11:43:59Z Christopher Baines <mail@cbaines.net> # Add schem
 buildstatus_enum [appschema] 2019-04-13T11:56:37Z Christopher Baines <mail@cbaines.net> # Creates the buildstatus enum
 initial_import 2019-04-13T13:06:28Z Christopher Baines <mail@cbaines.net> # Import the manually managed database schema
 git_repositories 2019-05-04T19:03:38Z Christopher Baines <mail@cbaines.net> # Add a git_repositories table
+git_branches 2019-05-05T14:53:12Z Christopher Baines <mail@cbaines.net> # Add a git_branches table

sqitch/verify/git_branches.sql

@@ -0,0 +1,8 @@
+-- Verify guix-data-service:git_branches on pg
+
+BEGIN;
+
+SELECT name, commit, git_repository_id, datetime
+  FROM git_branches WHERE FALSE;
+
+ROLLBACK;

tests/branch-updated-emails.scm

@@ -0,0 +1,119 @@
+(define-module (test-branch-updated-emails)
+  #:use-module (srfi srfi-64)
+  #:use-module (email email)
+  #:use-module (guix-data-service database)
+  #:use-module (guix-data-service model git-repository)
+  #:use-module (guix-data-service branch-updated-emails))
+
+(define master-branch-updated-email
+  "Return-Path: <guix-commits-bounces+patchwork=mira.cbaines.net@gnu.org>
+X-Original-To: patchwork@mira.cbaines.net
+Delivered-To: patchwork@mira.cbaines.net
+Received: by mira.cbaines.net (Postfix, from userid 113)
+	id 893C316F50; Fri, 26 Apr 2019 13:19:54 +0100 (BST)
+X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net
+X-Spam-Level: 
+X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,URIBL_BLOCKED
+	autolearn=ham autolearn_force=no version=3.4.0
+Received: from lists.gnu.org (lists.gnu.org [209.51.188.17])
+	by mira.cbaines.net (Postfix) with ESMTP id 0169916F46
+	for <patchwork@mira.cbaines.net>; Fri, 26 Apr 2019 13:19:51 +0100 (BST)
+Received: from localhost ([127.0.0.1]:46383 helo=lists.gnu.org)
+	by lists.gnu.org with esmtp (Exim 4.71)
+	(envelope-from <guix-commits-bounces+patchwork=mira.cbaines.net@gnu.org>)
+	id 1hJzpX-0004ZG-5K
+	for patchwork@mira.cbaines.net; Fri, 26 Apr 2019 08:19:51 -0400
+Received: from eggs.gnu.org ([209.51.188.92]:41385)
+	by lists.gnu.org with esmtp (Exim 4.71)
+	(envelope-from <ludo@gnu.org>) id 1hJzpT-0004WT-2H
+	for guix-commits@gnu.org; Fri, 26 Apr 2019 08:19:47 -0400
+Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
+	(envelope-from <ludo@gnu.org>) id 1hJzpS-00037m-84
+	for guix-commits@gnu.org; Fri, 26 Apr 2019 08:19:47 -0400
+Received: from vcs0.savannah.gnu.org ([209.51.188.201]:48450)
+	by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@gnu.org>)
+	id 1hJzpS-00037O-4X
+	for guix-commits@gnu.org; Fri, 26 Apr 2019 08:19:46 -0400
+Received: by vcs0.savannah.gnu.org (Postfix, from userid 68006)
+	id BD977209B1; Fri, 26 Apr 2019 08:19:45 -0400 (EDT)
+To: guix-commits@gnu.org
+Subject: branch master updated (9ca5ff8 -> 272db5b)
+MIME-Version: 1.0
+Content-Type: text/plain; charset=utf-8
+Message-ID: <20190426121944.32203.70977@vcs0.savannah.gnu.org>
+From: guix-commits@gnu.org
+Mail-Followup-To: guix-devel@gnu.org
+X-Git-Repo: guix
+X-Git-Refname: refs/heads/master
+X-Git-Reftype: branch
+X-Git-Oldrev: 9ca5ff882e2ac4eaab02eb0fde545bd784af478b
+X-Git-Newrev: 272db5bcf53d9d05d5c4b2df021d9e74f78866cd
+Auto-Submitted: auto-generated
+Date: Fri, 26 Apr 2019 08:19:45 -0400 (EDT)
+Content-Transfer-Encoding: quoted-printable
+X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
+X-Received-From: 209.51.188.201
+X-BeenThere: guix-commits@gnu.org
+X-Mailman-Version: 2.1.21
+Precedence: list
+List-Id: <guix-commits.gnu.org>
+List-Unsubscribe: <https://lists.gnu.org/mailman/options/guix-commits>,
+	<mailto:guix-commits-request@gnu.org?subject=unsubscribe>
+List-Archive: <http://lists.gnu.org/archive/html/guix-commits/>
+List-Post: <mailto:guix-commits@gnu.org>
+List-Help: <mailto:guix-commits-request@gnu.org?subject=help>
+List-Subscribe: <https://lists.gnu.org/mailman/listinfo/guix-commits>,
+	<mailto:guix-commits-request@gnu.org?subject=subscribe>
+Errors-To: guix-commits-bounces+patchwork=mira.cbaines.net@gnu.org
+Sender: \"Guix-commits\"
+	<guix-commits-bounces+patchwork=mira.cbaines.net@gnu.org>
+
+civodul pushed a change to branch master
+in repository guix.
+
+      from  9ca5ff8   bootstrap: Break automake dependency on generated f=
+iles.
+       new  504a0fc   accounts: Always honor the configured user account =
+shell.
+       new  538b99f   system: Provide a new VM image configuration.
+       new  6c849cd   installer: Run wrapped program with 'execl', not 's=
+ystem'.
+       new  9529f78   installer: Take 'guix system init' exit code into a=
+ccount.
+       new  98f0354   installer: Actually reboot when the user presses \"R=
+eboot.\"
+       new  b57dd20   doc: Add 'BASE-URL' variable.
+       new  272db5b   doc: Use ftp.gnu.org for downloads.
+
+The 7 revisions listed above as \"new\" are entirely new to this
+repository and will be described in separate emails.  The revisions
+listed as \"adds\" were already present in the repository and have only
+been added to this reference.
+
+
+Summary of changes:
+ doc/guix.texi                     | 39 ++++++++++-----
+ gnu/build/accounts.scm            |  9 ++--
+ gnu/installer.scm                 | 22 +++++++--
+ gnu/installer/final.scm           |  5 +-
+ gnu/installer/newt/final.scm      |  5 +-
+ gnu/installer/utils.scm           | 26 ++++++++--
+ gnu/system/examples/vm-image.tmpl | 99 +++++++++++++++++++++++++--------=
+------
+ 7 files changed, 140 insertions(+), 65 deletions(-)
+
+")
+
+(test-begin "test-branch-updated-emails")
+
+(with-postgresql-connection
+ (lambda (conn)
+   (test-assert "enqueue-job-for-email works"
+     (with-postgresql-transaction
+      conn
+      (lambda (conn)
+        (enqueue-job-for-email conn
+                               (parse-email master-branch-updated-email)))
+      #:always-rollback? #t))))
+
+(test-end)

tests/model-git-branch.scm

@@ -0,0 +1,25 @@
+(define-module (test-model-git-branch)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix-data-service database)
+  #:use-module (guix-data-service model git-repository)
+  #:use-module (guix-data-service model git-branch))
+
+(test-begin "test-model-git-branch")
+
+(with-postgresql-connection
+ (lambda (conn)
+   (test-assert "insert-git-branch-entry works"
+     (with-postgresql-transaction
+      conn
+      (lambda (conn)
+        (let* ((url "test-url")
+               (id (git-repository-url->git-repository-id conn url)))
+          (insert-git-branch-entry conn
+                                   "master"
+                                   "test-commit"
+                                   id
+                                   (strftime "%c" (gmtime (current-time)))))
+        #t)
+      #:always-rollback? #t))))
+
+(test-end)