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.

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				\

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

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

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, "
+  (define fields
-                 "package_metadata.description, package_metadata.home_page "
+    '("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)
+                 (string-join (map
+                               (match-lambda
+                                 ((synopsis description home-page location-id)
                                   (apply
                                    simple-format
-                                      #f "(~A, ~A, ~A)"
+                                   #f
-                                      (map value->quoted-string-or-null
+                                   (string-append
-                                           field-values)))
+                                    "("
+                                    (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) "
+                 ") AS vals (" (string-join fields ", ") ") "
-                 "ON package_metadata.synopsis = vals.synopsis AND "
+                 "ON "
-                 "package_metadata.description = vals.description AND "
+                 (string-join
-                 "package_metadata.home_page = vals.home_page"))
+                  (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

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

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))
+              (dd (a (@ (href ,home-page)) ,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

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;

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;

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;

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;

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

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;

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;

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

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