cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Store license information for packages

Browse source 
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.
This commit is contained in:
Christopher Baines 2019-05-15 08:05:14 +01:00
parent 28c2d46081
commit 16799a34a9
12 changed files with 393 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Makefile.am
View file

@ -46,6 +46,8 @@ SOURCES = \
guix-data-service/model/git-repository.scm \ guix-data-service/model/git-repository.scm \
guix-data-service/model/guix-revision-package-derivation.scm \ guix-data-service/model/guix-revision-package-derivation.scm \
guix-data-service/model/guix-revision.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/location.scm \
guix-data-service/model/package-derivation.scm \ guix-data-service/model/package-derivation.scm \
guix-data-service/model/package-metadata.scm \ guix-data-service/model/package-metadata.scm \

9
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -17,6 +17,7 @@
#:use-module (guix-data-service model guix-revision) #:use-module (guix-data-service model guix-revision)
#:use-module (guix-data-service model package-derivation) #:use-module (guix-data-service model package-derivation)
#:use-module (guix-data-service model guix-revision-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 package-metadata)
#:use-module (guix-data-service model derivation) #:use-module (guix-data-service model derivation)
#:export (process-next-load-new-guix-revision-job #:export (process-next-load-new-guix-revision-job
@ -184,10 +185,16 @@
(lambda () (lambda ()
(deduplicate-inferior-packages (deduplicate-inferior-packages
(inferior-packages inf))))) (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 (packages-metadata-ids
(log-time "fetching inferior package metadata" (log-time "fetching inferior package metadata"
(lambda () (lambda ()
(inferior-packages->package-metadata-ids conn packages)))) (inferior-packages->package-metadata-ids
conn packages package-license-set-ids))))
(package-ids (package-ids
(log-time "getting package-ids" (log-time "getting package-ids"
(lambda () (lambda ()

70
guix-data-service/model/license-set.scm Normal file
View file

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

132
guix-data-service/model/license.scm Normal file
View file

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

53
guix-data-service/model/package-metadata.scm
View file

@ -3,6 +3,7 @@
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (squee) #:use-module (squee)
#:use-module (json)
#:use-module (gcrypt hash) #:use-module (gcrypt hash)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (guix base16) #:use-module (guix base16)
@ -14,7 +15,7 @@
(define (select-package-metadata package-metadata-values) (define (select-package-metadata package-metadata-values)
(define fields (define fields
'("synopsis" "description" "home_page" "location_id")) '("synopsis" "description" "home_page" "location_id" "license_set_id"))
(string-append "SELECT id, " (string-join (map (string-append "SELECT id, " (string-join (map
(lambda (name) (lambda (name)
@ -26,7 +27,8 @@
"JOIN (VALUES " "JOIN (VALUES "
(string-join (map (string-join (map
(match-lambda (match-lambda
((synopsis description home-page location-id) ((synopsis description home-page location-id
license-set-id)
(apply (apply
simple-format simple-format
#f #f
@ -42,7 +44,8 @@
(value->quoted-string-or-null synopsis) (value->quoted-string-or-null synopsis)
(value->quoted-string-or-null description) (value->quoted-string-or-null description)
(value->quoted-string-or-null home-page) (value->quoted-string-or-null home-page)
location-id)))) location-id
license-set-id))))
package-metadata-values) package-metadata-values)
",") ",")
") AS vals (" (string-join fields ", ") ") " ") AS vals (" (string-join fields ", ") ") "
@ -59,7 +62,16 @@
(define query " (define query "
SELECT package_metadata.synopsis, package_metadata.description, SELECT package_metadata.synopsis, package_metadata.description,
package_metadata.home_page, 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 FROM package_metadata
INNER JOIN packages INNER JOIN packages
ON package_metadata.id = packages.package_metadata_id ON package_metadata.id = packages.package_metadata_id
@ -78,21 +90,31 @@ WHERE packages.id IN (
AND packages.name = $2 AND packages.name = $2
AND packages.version = $3") 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) (define (insert-package-metadata metadata-rows)
(string-append "INSERT INTO package_metadata " (string-append "INSERT INTO package_metadata "
"(synopsis, description, home_page, location_id) " "(synopsis, description, home_page, location_id, license_set_id) "
"VALUES " "VALUES "
(string-join (string-join
(map (match-lambda (map (match-lambda
((synopsis description home_page location_id) ((synopsis description home_page
location-id license-set-id)
(string-append (string-append
"(" "("
(value->quoted-string-or-null synopsis) "," (value->quoted-string-or-null synopsis) ","
(value->quoted-string-or-null description) "," (value->quoted-string-or-null description) ","
(value->quoted-string-or-null home_page) "," (value->quoted-string-or-null home_page) ","
location_id location-id ","
license-set-id
")"))) ")")))
metadata-rows) 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 (define package-metadata
(map (lambda (package) (map (lambda (package license-set-id)
(list (inferior-package-synopsis package) (list (inferior-package-synopsis package)
(inferior-package-description package) (inferior-package-description package)
(inferior-package-home-page package) (inferior-package-home-page package)
(location->location-id (location->location-id
conn conn
(inferior-package-location package)))) (inferior-package-location package))
packages)) license-set-id))
packages
license-set-ids))
(let* ((existing-package-metadata-entries (let* ((existing-package-metadata-entries
(exec-query->vhash conn (exec-query->vhash conn
(select-package-metadata package-metadata) (select-package-metadata package-metadata)
(lambda (results) cdr
(cdr (take results 5)))
first)) ;; id)) first)) ;; id))
(missing-package-metadata-entries (missing-package-metadata-entries
(delete-duplicates (delete-duplicates

13
guix-data-service/web/view/html.scm
View file

@ -327,7 +327,8 @@
(div (div
(@ (class "col-sm-12")) (@ (class "col-sm-12"))
,(match package-metadata ,(match package-metadata
(((synopsis description home-page file line column-number)) (((synopsis description home-page file line column-number
licenses))
`(dl `(dl
(@ (class "dl-horizontal")) (@ (class "dl-horizontal"))
(dt "Synopsis") (dt "Synopsis")
@ -355,6 +356,16 @@
", column: " ,column-number ")") ", column: " ,column-number ")")
'()))) '())))
git-repositories))) 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 (div
(@ (class "row")) (@ (class "row"))

27
sqitch/deploy/license_support.sql Normal file
View file

@ -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;

9
sqitch/revert/license_support.sql Normal file
View file

@ -0,0 +1,9 @@
-- Revert guix-data-service:license_support from pg
BEGIN;
DROP TABLE licenses;
DROP TABLE license_sets;
COMMIT;

1
sqitch/sqitch.plan
View file

@ -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 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_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 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

7
sqitch/verify/license_support.sql Normal file
View file

@ -0,0 +1,7 @@
-- Verify guix-data-service:license_support on pg
BEGIN;
-- XXX Add verifications here.
ROLLBACK;

44
tests/model-license-set.scm Normal file
View file

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

42
tests/model-license.scm Normal file
View file

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