aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile.am2
-rw-r--r--guix-data-service/jobs/load-new-guix-revision.scm9
-rw-r--r--guix-data-service/model/license-set.scm70
-rw-r--r--guix-data-service/model/license.scm132
-rw-r--r--guix-data-service/model/package-metadata.scm53
-rw-r--r--guix-data-service/web/view/html.scm13
-rw-r--r--sqitch/deploy/license_support.sql27
-rw-r--r--sqitch/revert/license_support.sql9
-rw-r--r--sqitch/sqitch.plan1
-rw-r--r--sqitch/verify/license_support.sql7
-rw-r--r--tests/model-license-set.scm44
-rw-r--r--tests/model-license.scm42
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)
generated by cgit v1.2.3 (git 2.25.4) at 2024-05-18 15:12:41 +0000