Store license information for packages

And display this on the package page.

This uses a couple of new tables, and an additional field in the
package_metadata table.

Currently, the order of the licenses in the package definition isn't stored,
as I'm not sure the order in the list is significant.

12 files changed, 393 insertions, 16 deletions

diff --git a/Makefile.am b/Makefile.am
index 2cf92ca..a3ea5f0 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -46,6 +46,8 @@ 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/license.scm				\
+  guix-data-service/model/license-set.scm			\
   guix-data-service/model/location.scm				\
   guix-data-service/model/package-derivation.scm		\
   guix-data-service/model/package-metadata.scm			\
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index 5549d27..58dc121 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -17,6 +17,7 @@
   #:use-module (guix-data-service model guix-revision)
   #:use-module (guix-data-service model package-derivation)
   #:use-module (guix-data-service model guix-revision-package-derivation)
+  #:use-module (guix-data-service model license-set)
   #:use-module (guix-data-service model package-metadata)
   #:use-module (guix-data-service model derivation)
   #:export (process-next-load-new-guix-revision-job
@@ -184,10 +185,16 @@
                              (lambda ()
                                (deduplicate-inferior-packages
                                 (inferior-packages inf)))))
+         (package-license-set-ids
+          (log-time "fetching inferior package license metadata"
+                    (lambda ()
+                      (inferior-packages->license-set-ids conn inf
+                                                          packages))))
          (packages-metadata-ids
           (log-time "fetching inferior package metadata"
                     (lambda ()
-                      (inferior-packages->package-metadata-ids conn packages))))
+                      (inferior-packages->package-metadata-ids
+                       conn packages package-license-set-ids))))
          (package-ids
           (log-time "getting package-ids"
                     (lambda ()
diff --git a/guix-data-service/model/license-set.scm b/guix-data-service/model/license-set.scm
new file mode 100644
index 0000000..44c0a70
--- /dev/null
+++ b/guix-data-service/model/license-set.scm
@@ -0,0 +1,70 @@
+(define-module (guix-data-service model license-set)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 vlist)
+  #:use-module (squee)
+  #:use-module (guix-data-service model utils)
+  #:use-module (guix-data-service model license)
+  #:export (inferior-packages->license-set-ids))
+
+(define select-license-sets
+  "
+SELECT id, license_ids
+FROM license_sets")
+
+(define (insert-license-sets license-id-lists)
+  (string-append
+   "INSERT INTO license_sets (license_ids) VALUES "
+   (string-join
+    (map (lambda (license-ids)
+           (string-append
+            "('{"
+            (string-join
+             (map number->string
+                  (sort (map string->number license-ids) <))
+             ", ")
+            "}')"))
+         license-id-lists)
+    ", ")
+   " RETURNING id"))
+
+(define (inferior-packages->license-set-ids conn inf packages)
+  (define license-id-lists
+    (inferior-packages->license-id-lists conn inf packages))
+
+  (let* ((unique-license-id-lists (delete-duplicates
+                                   license-id-lists))
+         (existing-license-sets
+          (exec-query->vhash conn
+                             select-license-sets
+                             (lambda (results)
+                               (string-split (string-drop-right
+                                              (string-drop (second results) 1)
+                                              1)
+                                             #\,))
+                             first)) ;; id
+         (missing-license-sets
+          (delete-duplicates
+           (filter (lambda (license-set-license-ids)
+                     (not (vhash-assoc license-set-license-ids
+                                       existing-license-sets)))
+                   unique-license-id-lists)))
+         (new-license-set-entries
+          (if (null? missing-license-sets)
+              '()
+              (map first
+                   (exec-query conn
+                               (insert-license-sets missing-license-sets)))))
+         (new-entries-id-lookup-vhash
+          (two-lists->vhash missing-license-sets
+                            new-license-set-entries)))
+
+    (map (lambda (license-id-list)
+           (cdr
+            (or (vhash-assoc license-id-list
+                             existing-license-sets)
+                (vhash-assoc license-id-list
+                             new-entries-id-lookup-vhash)
+                (begin
+                  (error "missing license set entry"
+                         license-id-list)))))
+         license-id-lists)))
diff --git a/guix-data-service/model/license.scm b/guix-data-service/model/license.scm
new file mode 100644
index 0000000..0b28343
--- /dev/null
+++ b/guix-data-service/model/license.scm
@@ -0,0 +1,132 @@
+(define-module (guix-data-service model license)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 vlist)
+  #:use-module (squee)
+  #:use-module (guix inferior)
+  #:use-module (guix-data-service model utils)
+  #:export (inferior-packages->license-id-lists))
+
+(define inferior-package-id
+  (@@ (guix inferior) inferior-package-id))
+
+(define (inferior-packages->license-data inf packages)
+  (define (proc packages)
+    `(map (lambda (inferior-package-id)
+            (let ((package (hashv-ref %package-table inferior-package-id)))
+              (match (package-license package)
+                ((? license? license)
+                 (list
+                  (list (license-name license)
+                        (license-uri license)
+                        (license-comment license))))
+                ((values ...)
+                 (map (match-lambda
+                        ((? license? license)
+                         (list (license-name license)
+                               (license-uri license)
+                               (license-comment license)))
+                        (x
+                         (simple-format
+                          (current-error-port)
+                          "error: unknown license value ~A for package ~A"
+                          x package)
+                         '()))
+                      values))
+                (x
+                 (simple-format
+                  (current-error-port)
+                  "error: unknown license value ~A for package ~A"
+                  x package)
+                 '()))))
+          (list ,@(map inferior-package-id packages))))
+
+  (inferior-eval '(use-modules (guix licenses)) inf)
+  (inferior-eval (proc packages) inf))
+
+(define (select-licenses license-values)
+  (string-append
+   "SELECT id, licenses.name, licenses.uri, licenses.comment "
+   "FROM licenses "
+   "JOIN (VALUES "
+   (string-join
+    (map (lambda (values)
+           (string-append
+            "("
+            (string-join
+             (map value->quoted-string-or-null
+                  values)
+             ", ")
+            ")"))
+         license-values)
+    ", ")
+   ") AS vals (name, uri, comment) "
+   "ON "
+   "licenses.name = vals.name AND "
+   "licenses.uri = vals.uri AND "
+   "licenses.comment = vals.comment"))
+
+(define (insert-licenses values)
+  (string-append
+   "INSERT INTO licenses "
+   "(name, uri, comment) "
+   "VALUES "
+   (string-join
+    (map (lambda (license-values)
+           (string-append
+            "("
+            (string-join
+             (map value->quoted-string-or-null
+                  license-values)
+             ", ")
+            ")"))
+         values)
+    ", ")
+   " RETURNING id"))
+
+(define (inferior-packages->license-id-lists conn inf packages)
+  (define license-data
+    (inferior-packages->license-data inf packages))
+
+  (define (sort-license-ids ids)
+    (map number->string
+         (sort (map string->number ids) <)))
+
+  (let* ((unique-license-tuples
+          (filter (lambda (license-tuple)
+                    (not (null? license-tuple)))
+                  (delete-duplicates
+                   (concatenate license-data))))
+         (existing-license-entries
+          (exec-query->vhash conn
+                             (select-licenses unique-license-tuples)
+                             cdr
+                             first)) ;; id
+         (missing-license-entries
+          (delete-duplicates
+           (filter (lambda (values)
+                     (not (vhash-assoc values
+                                       existing-license-entries)))
+                   unique-license-tuples)))
+         (new-license-entries
+          (if (null? missing-license-entries)
+              '()
+              (map first
+                   (exec-query conn
+                               (insert-licenses missing-license-entries)))))
+         (new-entries-id-lookup-vhash
+          (two-lists->vhash missing-license-entries
+                            new-license-entries)))
+
+    (map (lambda (license-value-lists)
+           (sort-license-ids
+            (map (lambda (license-values)
+                   (cdr
+                    (or (vhash-assoc license-values
+                                     existing-license-entries)
+                        (vhash-assoc license-values
+                                     new-entries-id-lookup-vhash)
+                        (begin
+                          (error "missing license entry"
+                                 license-values)))))
+                 license-value-lists)))
+         license-data)))
diff --git a/guix-data-service/model/package-metadata.scm b/guix-data-service/model/package-metadata.scm
index e83fef9..37a8da8 100644
--- a/guix-data-service/model/package-metadata.scm
+++ b/guix-data-service/model/package-metadata.scm
@@ -3,6 +3,7 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (squee)
+  #:use-module (json)
   #:use-module (gcrypt hash)
   #:use-module (rnrs bytevectors)
   #:use-module (guix base16)
@@ -14,7 +15,7 @@
 
 (define (select-package-metadata package-metadata-values)
   (define fields
-    '("synopsis" "description" "home_page" "location_id"))
+    '("synopsis" "description" "home_page" "location_id" "license_set_id"))
 
   (string-append "SELECT id, " (string-join (map
                                              (lambda (name)
@@ -26,7 +27,8 @@
                  "JOIN (VALUES "
                  (string-join (map
                                (match-lambda
-                                 ((synopsis description home-page location-id)
+                                 ((synopsis description home-page location-id
+                                            license-set-id)
                                   (apply
                                    simple-format
                                    #f
@@ -42,7 +44,8 @@
                                     (value->quoted-string-or-null synopsis)
                                     (value->quoted-string-or-null description)
                                     (value->quoted-string-or-null home-page)
-                                    location-id))))
+                                    location-id
+                                    license-set-id))))
                                package-metadata-values)
                               ",")
                  ") AS vals (" (string-join fields ", ") ") "
@@ -59,7 +62,16 @@
   (define query "
 SELECT package_metadata.synopsis, package_metadata.description,
   package_metadata.home_page,
-  locations.file, locations.line, locations.column_number
+  locations.file, locations.line, locations.column_number,
+  (SELECT JSON_AGG((license_data.*))
+   FROM (
+     SELECT licenses.name, licenses.uri, licenses.comment
+     FROM licenses
+     INNER JOIN license_sets ON licenses.id = ANY(license_sets.license_ids)
+     WHERE license_sets.id = package_metadata.license_set_id
+     ORDER BY licenses.name
+   ) AS license_data
+  ) AS licenses
 FROM package_metadata
 INNER JOIN packages
   ON package_metadata.id = packages.package_metadata_id
@@ -78,21 +90,31 @@ WHERE packages.id IN (
   AND packages.name = $2
   AND packages.version = $3")
 
-  (exec-query conn query (list revision-commit-hash name version)))
+  (map
+   (match-lambda
+     ((synopsis description home-page file line column-number
+                license-json)
+      (list synopsis description home-page file line column-number
+            (if (string-null? license-json)
+                #()
+                (json-string->scm license-json)))))
+   (exec-query conn query (list revision-commit-hash name version))))
 
 (define (insert-package-metadata metadata-rows)
   (string-append "INSERT INTO package_metadata "
-                 "(synopsis, description, home_page, location_id) "
+                 "(synopsis, description, home_page, location_id, license_set_id) "
                  "VALUES "
                  (string-join
                   (map (match-lambda
-                         ((synopsis description home_page location_id)
+                         ((synopsis description home_page
+                                    location-id license-set-id)
                           (string-append
                            "("
                            (value->quoted-string-or-null synopsis) ","
                            (value->quoted-string-or-null description) ","
                            (value->quoted-string-or-null home_page) ","
-                           location_id
+                           location-id ","
+                           license-set-id
                            ")")))
                        metadata-rows)
                   ",")
@@ -100,22 +122,25 @@ WHERE packages.id IN (
                  ";"))
 
 
-(define (inferior-packages->package-metadata-ids conn packages)
+(define (inferior-packages->package-metadata-ids conn
+                                                 packages
+                                                 license-set-ids)
   (define package-metadata
-    (map (lambda (package)
+    (map (lambda (package license-set-id)
            (list (inferior-package-synopsis package)
                  (inferior-package-description package)
                  (inferior-package-home-page package)
                  (location->location-id
                   conn
-                  (inferior-package-location package))))
-         packages))
+                  (inferior-package-location package))
+                 license-set-id))
+         packages
+         license-set-ids))
 
   (let* ((existing-package-metadata-entries
           (exec-query->vhash conn
                              (select-package-metadata package-metadata)
-                             (lambda (results)
-                               (cdr (take results 5)))
+                             cdr
                              first)) ;; id))
          (missing-package-metadata-entries
           (delete-duplicates
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index ecc2e83..95f628a 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -327,7 +327,8 @@
        (div
         (@ (class "col-sm-12"))
         ,(match package-metadata
-           (((synopsis description home-page file line column-number))
+           (((synopsis description home-page file line column-number
+                       licenses))
             `(dl
               (@ (class "dl-horizontal"))
               (dt "Synopsis")
@@ -355,6 +356,16 @@
                                      ", column: " ,column-number ")")
                                  '())))
                              git-repositories)))
+                    '())
+              ,@(if (> (vector-length licenses) 0)
+                    `((dt ,(if (eq? (vector-length licenses) 1)
+                               "License"
+                               "Licenses"))
+                      (dd (ul
+                           ,@(map (lambda (license)
+                                    `(li (a (@ (href ,(assoc-ref license "uri")))
+                                            ,(assoc-ref license "name"))))
+                                  (vector->list licenses)))))
                     '()))))))
       (div
        (@ (class "row"))
diff --git a/sqitch/deploy/license_support.sql b/sqitch/deploy/license_support.sql
new file mode 100644
index 0000000..64e2708
--- /dev/null
+++ b/sqitch/deploy/license_support.sql
@@ -0,0 +1,27 @@
+-- Deploy guix-data-service:license_support to pg
+
+BEGIN;
+
+CREATE TABLE licenses (
+    id integer NOT NULL GENERATED ALWAYS AS IDENTITY,
+    name character varying NOT NULL,
+    uri character varying,
+    comment character varying,
+    PRIMARY KEY(id),
+    UNIQUE (name, uri, comment)
+);
+
+CREATE TABLE license_sets (
+    id integer GENERATED ALWAYS AS IDENTITY,
+    license_ids integer[] NOT NULL,
+    PRIMARY KEY(license_ids),
+    UNIQUE (id)
+);
+
+ALTER TABLE package_metadata ADD COLUMN license_set_id integer REFERENCES license_sets(id);
+
+ALTER TABLE package_metadata DROP CONSTRAINT synopsis_description_home_page_location_id;
+
+ALTER TABLE package_metadata ADD CONSTRAINT package_metadata_unique_fields UNIQUE (synopsis, description, home_page, location_id, license_set_id);
+
+COMMIT;
diff --git a/sqitch/revert/license_support.sql b/sqitch/revert/license_support.sql
new file mode 100644
index 0000000..703bf2f
--- /dev/null
+++ b/sqitch/revert/license_support.sql
@@ -0,0 +1,9 @@
+-- Revert guix-data-service:license_support from pg
+
+BEGIN;
+
+DROP TABLE licenses;
+
+DROP TABLE license_sets;
+
+COMMIT;
diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan
index 1898562..c8a7529 100644
--- a/sqitch/sqitch.plan
+++ b/sqitch/sqitch.plan
@@ -10,3 +10,4 @@ git_branches 2019-05-05T14:53:12Z Christopher Baines <mail@cbaines.net> # Add a
 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
+license_support 2019-05-13T20:37:40Z Christopher Baines <mail@cbaines.net> # Add support for storing license information
diff --git a/sqitch/verify/license_support.sql b/sqitch/verify/license_support.sql
new file mode 100644
index 0000000..51377ed
--- /dev/null
+++ b/sqitch/verify/license_support.sql
@@ -0,0 +1,7 @@
+-- Verify guix-data-service:license_support on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;
diff --git a/tests/model-license-set.scm b/tests/model-license-set.scm
new file mode 100644
index 0000000..fecf242
--- /dev/null
+++ b/tests/model-license-set.scm
@@ -0,0 +1,44 @@
+ (define-module (tests model-license-set)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix utils)
+  #:use-module (guix tests)
+  #:use-module (guix-data-service database)
+  #:use-module (tests mock-inferior)
+  #:use-module (guix-data-service model license-set))
+
+(use-modules (tests driver))
+
+(test-begin "test-model-license-set")
+
+(mock
+ ((guix-data-service model license)
+  inferior-packages->license-data
+  (lambda (inf packages)
+    '((("License 1"
+        "https://gnu.org/licenses/test-1.html"
+        "https://example.com/why-license-1"))
+      (("License 1"
+        "https://gnu.org/licenses/test-1.html"
+        "https://example.com/why-license-1")
+       ("License 2"
+        "https://gnu.org/licenses/test-2.html"
+        "https://example.com/why-license-2")))))
+
+ (with-postgresql-connection
+  (lambda (conn)
+    (with-postgresql-transaction
+     conn
+     (lambda (conn)
+       (test-assert "works"
+         (inferior-packages->license-set-ids conn #f #f)))
+     #:always-rollback? #t)
+
+    (with-postgresql-transaction
+     conn
+     (lambda (conn)
+       (test-equal "works repeatedly"
+         (inferior-packages->license-set-ids conn #f #f)
+         (inferior-packages->license-set-ids conn #f #f)))
+     #:always-rollback? #t))))
+
+(test-end)
diff --git a/tests/model-license.scm b/tests/model-license.scm
new file mode 100644
index 0000000..cdec491
--- /dev/null
+++ b/tests/model-license.scm
@@ -0,0 +1,42 @@
+(define-module (tests model-license)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix utils)
+  #:use-module (guix tests)
+  #:use-module (guix-data-service database)
+  #:use-module (tests mock-inferior)
+  #:use-module (guix-data-service model license))
+
+(test-begin "test-model-license")
+
+(mock
+ ((guix-data-service model license)
+  inferior-packages->license-data
+  (lambda (inf packages)
+    '((("License 1"
+        "https://gnu.org/licenses/test-1.html"
+        "https://example.com/why-license-1"))
+      (("License 1"
+        "https://gnu.org/licenses/test-1.html"
+        "https://example.com/why-license-1")
+       ("License 2"
+        "https://gnu.org/licenses/test-2.html"
+        "https://example.com/why-license-2")))))
+
+ (with-postgresql-connection
+  (lambda (conn)
+    (with-postgresql-transaction
+     conn
+     (lambda (conn)
+       (test-assert "works"
+         (inferior-packages->license-id-lists conn #f #f)))
+     #:always-rollback? #t)
+
+    (with-postgresql-transaction
+     conn
+     (lambda (conn)
+       (test-equal "works repeatedly"
+         (inferior-packages->license-id-lists conn #f #f)
+         (inferior-packages->license-id-lists conn #f #f)))
+     #:always-rollback? #t))))
+
+(test-end)