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

Store and display the location of packages

Browse source 
Store the location a package can be found at, and display this on the package
page.

If available, link off to the git repository containing the package.
This commit is contained in:
Christopher Baines 2019-05-13 21:02:53 +01:00
parent 9aaab6b751
commit 7341d17254
15 changed files with 217 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

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

13
guix-data-service/model/git-repository.scm
View file

@ -4,6 +4,7 @@
#:export (all-git-repositories
git-repository-id->url
git-repository-url->git-repository-id
git-repositories-containing-commit
guix-revisions-and-jobs-for-git-repository))
@ -56,3 +57,15 @@ ORDER BY 1 DESC NULLS FIRST, 2 DESC LIMIT 10;")
conn
query
(list git-repository-id)))
(define (git-repositories-containing-commit conn commit)
(define query
"
SELECT id, label, url, cgit_url_base
FROM git_repositories WHERE id IN (
SELECT git_repository_id
FROM git_branches
WHERE commit = $1
)")
(exec-query conn query (list commit)))

54
guix-data-service/model/location.scm Normal file
View file

@ -0,0 +1,54 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
;;; as published by the Free Software Foundation, either version 3 of
;;; the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (guix-data-service model location)
#:use-module (ice-9 match)
#:use-module (guix utils)
#:use-module (squee)
#:export (location->location-id))
(define select-existing-location
(string-append
"SELECT id "
"FROM locations "
"WHERE file = $1 AND line = $2 AND column_number = $3"))
(define insert-location
(string-append
"INSERT INTO locations "
"(file, line, column_number) VALUES "
"($1, $2, $3) "
"RETURNING id"))
(define (location->location-id conn location)
(match location
(($ <location> file line column)
(match (exec-query conn
select-existing-location
(list file
(number->string line)
(number->string column)))
(((id))
(string->number id))
(()
(string->number
(caar
(exec-query conn
insert-location
(list file
(number->string line)
(number->string column))))))))))

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

@ -7,36 +7,64 @@
#:use-module (rnrs bytevectors)
#:use-module (guix base16)
#:use-module (guix inferior)
#:use-module (guix-data-service model location)
#:use-module (guix-data-service model utils)
#:export (select-package-metadata-by-revision-name-and-version
inferior-packages->package-metadata-ids))
(define (select-package-metadata package-metadata-values)
(string-append "SELECT id, package_metadata.synopsis, "
"package_metadata.description, package_metadata.home_page "
(define fields
'("synopsis" "description" "home_page" "location_id"))
(string-append "SELECT id, " (string-join (map
(lambda (name)
(string-append
"package_metadata." name))
fields)
", ") " "
"FROM package_metadata "
"JOIN (VALUES "
(string-join (map (lambda (field-values)
(string-join (map
(match-lambda
((synopsis description home-page location-id)
(apply
simple-format
#f "(~A, ~A, ~A)"
(map value->quoted-string-or-null
field-values)))
#f
(string-append
"("
(string-join
(list-tabulate
(length fields)
(lambda (n) "~A"))
",")
")")
(list
(value->quoted-string-or-null synopsis)
(value->quoted-string-or-null description)
(value->quoted-string-or-null home-page)
location-id))))
package-metadata-values)
",")
") AS vals (synopsis, description, home_page) "
"ON package_metadata.synopsis = vals.synopsis AND "
"package_metadata.description = vals.description AND "
"package_metadata.home_page = vals.home_page"))
") AS vals (" (string-join fields ", ") ") "
"ON "
(string-join
(map (lambda (field)
(string-append
"package_metadata." field " = vals." field))
fields)
" AND ")))
(define (select-package-metadata-by-revision-name-and-version
conn revision-commit-hash name version)
(define query "
SELECT package_metadata.synopsis, package_metadata.description,
package_metadata.home_page
package_metadata.home_page,
locations.file, locations.line, locations.column_number
FROM package_metadata
INNER JOIN packages
ON package_metadata.id = packages.package_metadata_id
LEFT OUTER JOIN locations
ON package_metadata.location_id = locations.id
WHERE packages.id IN (
SELECT package_derivations.package_id
FROM package_derivations
@ -54,16 +82,18 @@ WHERE packages.id IN (
(define (insert-package-metadata metadata-rows)
(string-append "INSERT INTO package_metadata "
"(synopsis, description, home_page) "
"(synopsis, description, home_page, location_id) "
"VALUES "
(string-join
(map (match-lambda
((synopsis description home_page)
((synopsis description home_page location_id)
(string-append
"("
(value->quoted-string-or-null synopsis) ","
(value->quoted-string-or-null description) ","
(value->quoted-string-or-null home_page) ")")))
(value->quoted-string-or-null home_page) ","
(number->string location_id)
")")))
metadata-rows)
",")
" RETURNING id"
@ -75,14 +105,17 @@ WHERE packages.id IN (
(map (lambda (package)
(list (inferior-package-synopsis package)
(inferior-package-description package)
(inferior-package-home-page package)))
(inferior-package-home-page package)
(location->location-id
conn
(inferior-package-location package))))
packages))
(let* ((existing-package-metadata-entries
(exec-query->vhash conn
(select-package-metadata package-metadata)
(lambda (results)
(cdr (take results 4)))
(cdr (take results 5)))
first)) ;; id))
(missing-package-metadata-entries
(delete-duplicates

8
guix-data-service/web/controller.scm
View file

@ -176,7 +176,10 @@
conn
commit-hash
name
version)))
version))
(git-repositories
(git-repositories-containing-commit conn
commit-hash)))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@ -202,7 +205,8 @@
name
version
metadata
derivations))))))
derivations
git-repositories))))))
(define (render-compare-unknown-commit mime-types
conn

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

@ -302,7 +302,7 @@
(define (view-revision-package-and-version revision-commit-hash name version
package-metadata
derivations)
derivations git-repositories)
(layout
#:extra-headers
'((cache-control . ((max-age . 60))))
@ -327,7 +327,7 @@
(div
(@ (class "col-sm-12"))
,(match package-metadata
(((synopsis description home-page))
(((synopsis description home-page file line column-number))
`(dl
(@ (class "dl-horizontal"))
(dt "Synopsis")
@ -335,8 +335,27 @@
(dt "Description")
(dd ,(stexi->shtml (texi-fragment->stexi description)))
(dt "Home page")
(dd (a (@ (href ,home-page))
,home-page)))))))
(dd (a (@ (href ,home-page)) ,home-page))
,@(if (and file (not (string-null? file))
(not (null? git-repositories)))
`((dt "Location")
(dd ,@(map
(match-lambda
((id label url cgit-url-base)
(if
(and cgit-url-base
(not (string-null? cgit-url-base)))
`(a (@ (href
,(string-append
cgit-url-base "tree/"
file "?id=" revision-commit-hash
"#n" line)))
,file
" (line: " ,line
", column: " ,column-number ")")
'())))
git-repositories)))
'()))))))
(div
(@ (class "row"))
(div

7
sqitch/deploy/add_git_repositories_cgit_url_base.sql Normal file
View file

@ -0,0 +1,7 @@
-- Deploy guix-data-service:add_git_repositories_cgit_url_base to pg
BEGIN;
ALTER TABLE git_repositories ADD COLUMN cgit_url_base character varying;
COMMIT;

20
sqitch/deploy/add_location_information.sql Normal file
View file

@ -0,0 +1,20 @@
-- Deploy guix-data-service:add_location_information to pg
BEGIN;
CREATE TABLE locations (
id integer GENERATED BY DEFAULT AS IDENTITY,
file character varying NOT NULL,
line integer NOT NULL,
column_number integer NOT NULL,
CONSTRAINT file_line_column PRIMARY KEY(file, line, column_number),
UNIQUE (id)
);
ALTER TABLE package_metadata ADD COLUMN location_id integer REFERENCES locations(id);
ALTER TABLE package_metadata DROP CONSTRAINT synopsis_description_home_page;
ALTER TABLE package_metadata ADD CONSTRAINT synopsis_description_home_page_location_id UNIQUE (synopsis, description, home_page, location_id);
COMMIT;

7
sqitch/revert/add_git_repositories_cgit_url_base.sql Normal file
View file

@ -0,0 +1,7 @@
-- Revert guix-data-service:add_git_repositories_cgit_url_base from pg
BEGIN;
ALTER TABLE git_repositories DROP COLUMN cgit_url_base;
COMMIT;

7
sqitch/revert/add_location_information.sql Normal file
View file

@ -0,0 +1,7 @@
-- Revert guix-data-service:add_location_information from pg
BEGIN;
-- XXX Add DDLs here.
COMMIT;

2
sqitch/sqitch.plan
View file

@ -8,3 +8,5 @@ initial_import 2019-04-13T13:06:28Z Christopher Baines <mail@cbaines.net> # Impo
git_repositories 2019-05-04T19:03:38Z Christopher Baines <mail@cbaines.net> # Add a git_repositories table
git_branches 2019-05-05T14:53:12Z Christopher Baines <mail@cbaines.net> # Add a git_branches table
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

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

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

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

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

10
tests/mock-inferior.scm
View file

@ -9,6 +9,7 @@
mock-inferior-package-synopsis
mock-inferior-package-description
mock-inferior-package-home-page
mock-inferior-package-location
with-mock-inferior-packages))
@ -19,7 +20,8 @@
(version mock-inferior-package-version)
(synopsis mock-inferior-package-synopsis)
(description mock-inferior-package-description)
(home-page mock-inferior-package-home-page))
(home-page mock-inferior-package-home-page)
(location mock-inferior-package-location))
(define (with-mock-inferior-packages f)
(mock
@ -42,4 +44,8 @@
((guix inferior)
inferior-package-home-page
mock-inferior-package-home-page)
(f)))))))
(mock
((guix inferior)
inferior-package-location
mock-inferior-package-location)
(f))))))))

4
tests/model-package-metadata.scm
View file

@ -1,6 +1,7 @@
(define-module (test-model-package-metadata)
#:use-module (ice-9 match)
#:use-module (srfi srfi-64)
#:use-module (guix utils)
#:use-module (tests mock-inferior)
#:use-module (guix-data-service database))
@ -12,7 +13,8 @@
(version "2")
(synopsis "Foo")
(description "Foo description")
(home-page "https://example.com")))
(home-page "https://example.com")
(location (location "file.scm" 5 0))))
(with-mock-inferior-packages
(lambda ()