Store and display the location of packages

Store the location a package can be found at, and display this on the package
page.

If available, link off to the git repository containing the package.

15 files changed, 217 insertions, 28 deletions

diff --git a/Makefile.am b/Makefile.am
index 43248f1..2cf92ca 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -46,6 +46,7 @@ SOURCES =							\
   guix-data-service/model/git-repository.scm			\
   guix-data-service/model/guix-revision-package-derivation.scm	\
   guix-data-service/model/guix-revision.scm			\
+  guix-data-service/model/location.scm				\
   guix-data-service/model/package-derivation.scm		\
   guix-data-service/model/package-metadata.scm			\
   guix-data-service/model/package.scm				\
diff --git a/guix-data-service/model/git-repository.scm b/guix-data-service/model/git-repository.scm
index 5f35cd3..16c57bf 100644
--- a/guix-data-service/model/git-repository.scm
+++ b/guix-data-service/model/git-repository.scm
@@ -4,6 +4,7 @@
   #:export (all-git-repositories
             git-repository-id->url
             git-repository-url->git-repository-id
+            git-repositories-containing-commit
 
             guix-revisions-and-jobs-for-git-repository))
 
@@ -56,3 +57,15 @@ ORDER BY 1 DESC NULLS FIRST, 2 DESC LIMIT 10;")
    conn
    query
    (list git-repository-id)))
+
+(define (git-repositories-containing-commit conn commit)
+  (define query
+    "
+SELECT id, label, url, cgit_url_base
+FROM git_repositories WHERE id IN (
+  SELECT git_repository_id
+  FROM git_branches
+  WHERE commit = $1
+)")
+
+  (exec-query conn query (list commit)))
diff --git a/guix-data-service/model/location.scm b/guix-data-service/model/location.scm
new file mode 100644
index 0000000..1a01b9a
--- /dev/null
+++ b/guix-data-service/model/location.scm
@@ -0,0 +1,54 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-data-service model location)
+  #:use-module (ice-9 match)
+  #:use-module (guix utils)
+  #:use-module (squee)
+  #:export (location->location-id))
+
+(define select-existing-location
+  (string-append
+   "SELECT id "
+   "FROM locations "
+   "WHERE file = $1 AND line = $2 AND column_number = $3"))
+
+(define insert-location
+  (string-append
+   "INSERT INTO locations "
+   "(file, line, column_number) VALUES "
+   "($1, $2, $3) "
+   "RETURNING id"))
+
+(define (location->location-id conn location)
+  (match location
+    (($ <location> file line column)
+     (match (exec-query conn
+                        select-existing-location
+                        (list file
+                              (number->string line)
+                              (number->string column)))
+       (((id))
+        (string->number id))
+       (()
+        (string->number
+         (caar
+          (exec-query conn
+                      insert-location
+                      (list file
+                            (number->string line)
+                            (number->string column))))))))))
diff --git a/guix-data-service/model/package-metadata.scm b/guix-data-service/model/package-metadata.scm
index 8578bb1..644050e 100644
--- a/guix-data-service/model/package-metadata.scm
+++ b/guix-data-service/model/package-metadata.scm
@@ -7,36 +7,64 @@
   #:use-module (rnrs bytevectors)
   #:use-module (guix base16)
   #:use-module (guix inferior)
+  #:use-module (guix-data-service model location)
   #:use-module (guix-data-service model utils)
   #:export (select-package-metadata-by-revision-name-and-version
             inferior-packages->package-metadata-ids))
 
 (define (select-package-metadata package-metadata-values)
-  (string-append "SELECT id, package_metadata.synopsis, "
-                 "package_metadata.description, package_metadata.home_page "
+  (define fields
+    '("synopsis" "description" "home_page" "location_id"))
+
+  (string-append "SELECT id, " (string-join (map
+                                             (lambda (name)
+                                               (string-append
+                                                "package_metadata." name))
+                                             fields)
+                                            ", ") " "
                  "FROM package_metadata "
                  "JOIN (VALUES "
-                 (string-join (map (lambda (field-values)
-                                     (apply
-                                      simple-format
-                                      #f "(~A, ~A, ~A)"
-                                      (map value->quoted-string-or-null
-                                           field-values)))
-                                   package-metadata-values)
+                 (string-join (map
+                               (match-lambda
+                                 ((synopsis description home-page location-id)
+                                  (apply
+                                   simple-format
+                                   #f
+                                   (string-append
+                                    "("
+                                    (string-join
+                                     (list-tabulate
+                                      (length fields)
+                                      (lambda (n) "~A"))
+                                     ",")
+                                    ")")
+                                   (list
+                                    (value->quoted-string-or-null synopsis)
+                                    (value->quoted-string-or-null description)
+                                    (value->quoted-string-or-null home-page)
+                                    location-id))))
+                               package-metadata-values)
                               ",")
-                 ") AS vals (synopsis, description, home_page) "
-                 "ON package_metadata.synopsis = vals.synopsis AND "
-                 "package_metadata.description = vals.description AND "
-                 "package_metadata.home_page = vals.home_page"))
+                 ") AS vals (" (string-join fields ", ") ") "
+                 "ON "
+                 (string-join
+                  (map (lambda (field)
+                         (string-append
+                          "package_metadata." field " = vals." field))
+                       fields)
+                  " AND ")))
 
 (define (select-package-metadata-by-revision-name-and-version
          conn revision-commit-hash name version)
   (define query "
 SELECT package_metadata.synopsis, package_metadata.description,
-  package_metadata.home_page
+  package_metadata.home_page,
+  locations.file, locations.line, locations.column_number
 FROM package_metadata
 INNER JOIN packages
   ON package_metadata.id = packages.package_metadata_id
+LEFT OUTER JOIN locations
+  ON package_metadata.location_id = locations.id
 WHERE packages.id IN (
   SELECT package_derivations.package_id
   FROM package_derivations
@@ -54,16 +82,18 @@ WHERE packages.id IN (
 
 (define (insert-package-metadata metadata-rows)
   (string-append "INSERT INTO package_metadata "
-                 "(synopsis, description, home_page) "
+                 "(synopsis, description, home_page, location_id) "
                  "VALUES "
                  (string-join
                   (map (match-lambda
-                         ((synopsis description home_page)
+                         ((synopsis description home_page location_id)
                           (string-append
                            "("
                            (value->quoted-string-or-null synopsis) ","
                            (value->quoted-string-or-null description) ","
-                           (value->quoted-string-or-null home_page) ")")))
+                           (value->quoted-string-or-null home_page) ","
+                           (number->string location_id)
+                           ")")))
                        metadata-rows)
                   ",")
                  " RETURNING id"
@@ -75,14 +105,17 @@ WHERE packages.id IN (
     (map (lambda (package)
            (list (inferior-package-synopsis package)
                  (inferior-package-description package)
-                 (inferior-package-home-page package)))
+                 (inferior-package-home-page package)
+                 (location->location-id
+                  conn
+                  (inferior-package-location package))))
          packages))
 
   (let* ((existing-package-metadata-entries
           (exec-query->vhash conn
                              (select-package-metadata package-metadata)
                              (lambda (results)
-                               (cdr (take results 4)))
+                               (cdr (take results 5)))
                              first)) ;; id))
          (missing-package-metadata-entries
           (delete-duplicates
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 584392a..6b4167d 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -176,7 +176,10 @@
           conn
           commit-hash
           name
-          version)))
+          version))
+        (git-repositories
+         (git-repositories-containing-commit conn
+                                             commit-hash)))
     (case (most-appropriate-mime-type
            '(application/json text/html)
            mime-types)
@@ -202,7 +205,8 @@
                                                  name
                                                  version
                                                  metadata
-                                                 derivations))))))
+                                                 derivations
+                                                 git-repositories))))))
 
 (define (render-compare-unknown-commit mime-types
                                        conn
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 079b23d..ecc2e83 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -302,7 +302,7 @@
 
 (define (view-revision-package-and-version revision-commit-hash name version
                                            package-metadata
-                                           derivations)
+                                           derivations git-repositories)
   (layout
    #:extra-headers
    '((cache-control . ((max-age . 60))))
@@ -327,7 +327,7 @@
        (div
         (@ (class "col-sm-12"))
         ,(match package-metadata
-           (((synopsis description home-page))
+           (((synopsis description home-page file line column-number))
             `(dl
               (@ (class "dl-horizontal"))
               (dt "Synopsis")
@@ -335,8 +335,27 @@
               (dt "Description")
               (dd ,(stexi->shtml (texi-fragment->stexi description)))
               (dt "Home page")
-              (dd (a (@ (href ,home-page))
-                     ,home-page)))))))
+              (dd (a (@ (href ,home-page)) ,home-page))
+              ,@(if (and file (not (string-null? file))
+                         (not (null? git-repositories)))
+                    `((dt "Location")
+                      (dd ,@(map
+                             (match-lambda
+                               ((id label url cgit-url-base)
+                                (if
+                                 (and cgit-url-base
+                                      (not (string-null? cgit-url-base)))
+                                 `(a (@ (href
+                                         ,(string-append
+                                           cgit-url-base "tree/"
+                                           file "?id=" revision-commit-hash
+                                           "#n" line)))
+                                     ,file
+                                     " (line: " ,line
+                                     ", column: " ,column-number ")")
+                                 '())))
+                             git-repositories)))
+                    '()))))))
       (div
        (@ (class "row"))
        (div
diff --git a/sqitch/deploy/add_git_repositories_cgit_url_base.sql b/sqitch/deploy/add_git_repositories_cgit_url_base.sql
new file mode 100644
index 0000000..7a2d532
--- /dev/null
+++ b/sqitch/deploy/add_git_repositories_cgit_url_base.sql
@@ -0,0 +1,7 @@
+-- Deploy guix-data-service:add_git_repositories_cgit_url_base to pg
+
+BEGIN;
+
+ALTER TABLE git_repositories ADD COLUMN cgit_url_base character varying;
+
+COMMIT;
diff --git a/sqitch/deploy/add_location_information.sql b/sqitch/deploy/add_location_information.sql
new file mode 100644
index 0000000..7855feb
--- /dev/null
+++ b/sqitch/deploy/add_location_information.sql
@@ -0,0 +1,20 @@
+-- Deploy guix-data-service:add_location_information to pg
+
+BEGIN;
+
+CREATE TABLE locations (
+    id integer GENERATED BY DEFAULT AS IDENTITY,
+    file character varying NOT NULL,
+    line integer NOT NULL,
+    column_number integer NOT NULL,
+    CONSTRAINT file_line_column PRIMARY KEY(file, line, column_number),
+    UNIQUE (id)
+);
+
+ALTER TABLE package_metadata ADD COLUMN location_id integer REFERENCES locations(id);
+
+ALTER TABLE package_metadata DROP CONSTRAINT synopsis_description_home_page;
+
+ALTER TABLE package_metadata ADD CONSTRAINT synopsis_description_home_page_location_id UNIQUE (synopsis, description, home_page, location_id);
+
+COMMIT;
diff --git a/sqitch/revert/add_git_repositories_cgit_url_base.sql b/sqitch/revert/add_git_repositories_cgit_url_base.sql
new file mode 100644
index 0000000..67c5a87
--- /dev/null
+++ b/sqitch/revert/add_git_repositories_cgit_url_base.sql
@@ -0,0 +1,7 @@
+-- Revert guix-data-service:add_git_repositories_cgit_url_base from pg
+
+BEGIN;
+
+ALTER TABLE git_repositories DROP COLUMN cgit_url_base;
+
+COMMIT;
diff --git a/sqitch/revert/add_location_information.sql b/sqitch/revert/add_location_information.sql
new file mode 100644
index 0000000..31220ed
--- /dev/null
+++ b/sqitch/revert/add_location_information.sql
@@ -0,0 +1,7 @@
+-- Revert guix-data-service:add_location_information from pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan
index 026aa7f..1898562 100644
--- a/sqitch/sqitch.plan
+++ b/sqitch/sqitch.plan
@@ -8,3 +8,5 @@ initial_import 2019-04-13T13:06:28Z Christopher Baines <mail@cbaines.net> # Impo
 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
 remove_package_metadata_sha1_hash 2019-05-12T10:37:40Z Christopher Baines <mail@cbaines.net> # Remove the sha1_hash field from package_metadata
+add_location_information 2019-05-12T20:27:48Z Christopher Baines <mail@cbaines.net> # Add locations table and location to package_metadata
+add_git_repositories_cgit_url_base 2019-05-13T18:45:14Z Christopher Baines <mail@cbaines.net> # Add cgit_url_base to git_repositories
diff --git a/sqitch/verify/add_git_repositories_cgit_url_base.sql b/sqitch/verify/add_git_repositories_cgit_url_base.sql
new file mode 100644
index 0000000..9fa2dee
--- /dev/null
+++ b/sqitch/verify/add_git_repositories_cgit_url_base.sql
@@ -0,0 +1,7 @@
+-- Verify guix-data-service:add_git_repositories_cgit_url_base on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;
diff --git a/sqitch/verify/add_location_information.sql b/sqitch/verify/add_location_information.sql
new file mode 100644
index 0000000..821c643
--- /dev/null
+++ b/sqitch/verify/add_location_information.sql
@@ -0,0 +1,7 @@
+-- Verify guix-data-service:add_location_information on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;
diff --git a/tests/mock-inferior.scm b/tests/mock-inferior.scm
index 6424cd9..b59874e 100644
--- a/tests/mock-inferior.scm
+++ b/tests/mock-inferior.scm
@@ -9,6 +9,7 @@
             mock-inferior-package-synopsis
             mock-inferior-package-description
             mock-inferior-package-home-page
+            mock-inferior-package-location
 
             with-mock-inferior-packages))
 
@@ -19,7 +20,8 @@
   (version     mock-inferior-package-version)
   (synopsis    mock-inferior-package-synopsis)
   (description mock-inferior-package-description)
-  (home-page   mock-inferior-package-home-page))
+  (home-page   mock-inferior-package-home-page)
+  (location    mock-inferior-package-location))
 
 (define (with-mock-inferior-packages f)
   (mock
@@ -42,4 +44,8 @@
        ((guix inferior)
         inferior-package-home-page
         mock-inferior-package-home-page)
-       (f)))))))
+       (mock
+        ((guix inferior)
+         inferior-package-location
+         mock-inferior-package-location)
+        (f))))))))
diff --git a/tests/model-package-metadata.scm b/tests/model-package-metadata.scm
index 4c2bc8e..83d77bf 100644
--- a/tests/model-package-metadata.scm
+++ b/tests/model-package-metadata.scm
@@ -1,6 +1,7 @@
 (define-module (test-model-package-metadata)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-64)
+  #:use-module (guix utils)
   #:use-module (tests mock-inferior)
   #:use-module (guix-data-service database))
 
@@ -12,7 +13,8 @@
    (version "2")
    (synopsis "Foo")
    (description "Foo description")
-   (home-page "https://example.com")))
+   (home-page "https://example.com")
+   (location (location "file.scm" 5 0))))
 
 (with-mock-inferior-packages
  (lambda ()