From 16799a34a96bfa240b3eb47d75c935afab8c51a1 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 15 May 2019 08:05:14 +0100 Subject: 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. --- Makefile.am | 2 + guix-data-service/jobs/load-new-guix-revision.scm | 9 +- guix-data-service/model/license-set.scm | 70 ++++++++++++ guix-data-service/model/license.scm | 132 ++++++++++++++++++++++ guix-data-service/model/package-metadata.scm | 53 ++++++--- guix-data-service/web/view/html.scm | 13 ++- sqitch/deploy/license_support.sql | 27 +++++ sqitch/revert/license_support.sql | 9 ++ sqitch/sqitch.plan | 1 + sqitch/verify/license_support.sql | 7 ++ tests/model-license-set.scm | 44 ++++++++ tests/model-license.scm | 42 +++++++ 12 files changed, 393 insertions(+), 16 deletions(-) create mode 100644 guix-data-service/model/license-set.scm create mode 100644 guix-data-service/model/license.scm create mode 100644 sqitch/deploy/license_support.sql create mode 100644 sqitch/revert/license_support.sql create mode 100644 sqitch/verify/license_support.sql create mode 100644 tests/model-license-set.scm create mode 100644 tests/model-license.scm 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 # Add a remove_package_metadata_sha1_hash 2019-05-12T10:37:40Z Christopher Baines # Remove the sha1_hash field from package_metadata add_location_information 2019-05-12T20:27:48Z Christopher Baines # Add locations table and location to package_metadata add_git_repositories_cgit_url_base 2019-05-13T18:45:14Z Christopher Baines # Add cgit_url_base to git_repositories +license_support 2019-05-13T20:37:40Z Christopher Baines # 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) -- cgit v1.2.3