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.

5 files changed, 261 insertions, 16 deletions

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