guix
/
data-service
mirror of git://git.savannah.gnu.org/guix/data-service.git
2
0
Fork 0
Code Issues Releases Wiki Activity

Track package replacements 

Start at least looking for package replacements, and storing the
details (particularly the derivation). I'm looking at doing this so that build
servers using the Guix Data Service can build these derivations.
This commit is contained in:
Christopher Baines 2021-07-11 10:44:59 +01:00
parent b4188bda9d
commit af209170f7
8 changed files with 118 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
guix-data-service/jobs/load-new-guix-revision.scm
View File

@ -39,6 +39,7 @@
#:use-module (guix-data-service config)
#:use-module (guix-data-service database)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service model utils)
#:use-module (guix-data-service model build)
#:use-module (guix-data-service model channel-instance)
#:use-module (guix-data-service model channel-news)
@ -765,7 +766,34 @@ WHERE job_id = $1")
(string<? a-name
b-name)))))))
(define (insert-packages conn inf packages)
(define (inferior-packages-plus-replacements inf)
(let* ((packages
;; This isn't perfect, sometimes there can be two packages with the
;; same name and version, but different derivations. Guix will warn
;; about this case though, generally this means only one of the
;; packages should be exported.
(deduplicate-inferior-packages
(inferior-packages inf)))
(replacements (filter-map inferior-package-replacement packages))
(package-id-hash-table (make-hash-table)))
(for-each (lambda (pkg)
(hash-set! package-id-hash-table
(inferior-package-id pkg)
#t))
packages)
(let ((non-exported-replacements
(filter (lambda (pkg)
(eq? #f
(hash-ref package-id-hash-table
(inferior-package-id pkg))))
replacements)))
(append packages non-exported-replacements))))
(define* (insert-packages conn inf packages #:key (process-replacements? #t))
(let* ((package-license-set-ids
(with-time-logging "fetching inferior package license metadata"
(inferior-packages->license-set-ids
@ -777,7 +805,24 @@ WHERE job_id = $1")
(((all-package-metadata-ids new-package-metadata-ids)
(with-time-logging "fetching inferior package metadata"
(inferior-packages->package-metadata-ids
conn inf packages package-license-set-ids))))
conn inf packages package-license-set-ids)))
((package-replacement-package-ids)
(map (lambda (package)
(let ((replacement (inferior-package-replacement package)))
(if (and process-replacements? replacement)
;; I'm not sure if replacements can themselves be
;; replaced, but I do know for sure that there are
;; infinite chains of replacements (python(2)-urllib3
;; in 7c4c781aa40c42d4cd10b8d9482199f3db345e1b for
;; example).
;;
;; This code currently just capures the first level of
;; replacements
(car
(insert-packages conn inf (list replacement)
#:process-replacements? #f))
(cons "integer" NULL))))
packages)))
(unless (null? new-package-metadata-ids)
(with-time-logging "fetching package metadata tsvector entries"
@ -789,7 +834,8 @@ WHERE job_id = $1")
conn
(zip (map inferior-package-name packages)
(map inferior-package-version packages)
all-package-metadata-ids))))))
all-package-metadata-ids
package-replacement-package-ids))))))
(define (insert-lint-warnings conn inferior-package-id->package-database-id
lint-checker-ids
@ -1201,8 +1247,7 @@ WHERE job_id = $1")
(lambda ()
(let* ((packages
(with-time-logging "fetching inferior packages"
(deduplicate-inferior-packages
(inferior-packages inf))))
(inferior-packages-plus-replacements inf)))
(inferior-lint-warnings
(with-time-logging "fetching inferior lint warnings"
(all-inferior-lint-warnings inf store packages)))

20
guix-data-service/model/package-metadata.scm
View File

@ -109,9 +109,16 @@
fields)
" AND ")))
(define (select-package-metadata-by-revision-name-and-version
conn revision-commit-hash name version locale)
(define query "
(define* (select-package-metadata-by-revision-name-and-version
conn
revision-commit-hash
name
version
locale
#:key replacement?)
(define query
(string-append
"
SELECT translated_package_synopsis.synopsis, translated_package_synopsis.locale,
translated_package_descriptions.description, translated_package_descriptions.locale,
package_metadata.home_page,
@ -179,7 +186,12 @@ WHERE packages.id IN (
WHERE guix_revisions.commit = $1
)
AND packages.name = $2
AND packages.version = $3")
AND packages.version = $3"
(if replacement?
"
AND packages.replacement_package_id IS NOT NULL"
"
AND packages.replacement_package_id IS NULL")))
(map
(match-lambda

8
guix-data-service/model/package.scm
View File

@ -162,7 +162,9 @@ WITH revision_packages AS (
WHERE guix_revisions.commit = $1
)
), search_results AS (
SELECT DISTINCT ON (packages.name) packages.name,
SELECT DISTINCT ON
(packages.name, packages.version, packages.replacement_package_id)
packages.name,
packages.version, package_synopsis.synopsis,
package_synopsis.locale AS synopsis_locale,
package_descriptions.description,
@ -195,7 +197,7 @@ WITH revision_packages AS (
OR
package_metadata_tsvectors.synopsis_and_description @@ plainto_tsquery($2)
)
ORDER BY name,
ORDER BY name, packages.version, packages.replacement_package_id,
CASE WHEN package_metadata_tsvectors.locale = 'en_US.UTF-8' THEN 2
WHEN package_metadata_tsvectors.locale = $3 THEN 1
ELSE 0
@ -265,7 +267,7 @@ RETURNING id"))
(insert-missing-data-and-return-all-ids
conn
"packages"
'(name version package_metadata_id)
'(name version package_metadata_id replacement_package_id)
package-entries))
(define (select-package-versions-for-revision conn

16
sqitch/deploy/packages_replacement.sql Normal file
View File

@ -0,0 +1,16 @@
-- Deploy guix-data-service:packages_replacement to pg
BEGIN;
ALTER TABLE packages
ADD COLUMN replacement_package_id integer REFERENCES packages (id);
ALTER TABLE packages DROP CONSTRAINT packages_pkey;
ALTER TABLE packages ADD PRIMARY KEY (id);
CREATE UNIQUE INDEX packages_not_null_replacement_package_id_idx
ON packages (name, version, package_metadata_id, replacement_package_id);
CREATE UNIQUE INDEX packages_null_replacement_package_id_idx
ON packages (name, version, package_metadata_id) WHERE replacement_package_id IS NULL;
COMMIT;

7
sqitch/revert/packages_replacement.sql Normal file
View File

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

1
sqitch/sqitch.plan
View File

@ -81,3 +81,4 @@ remove_guix_revisions_store_path 2021-02-02T20:06:18Z Christopher Baines <mail@c
systems_table 2021-04-22T08:12:10Z Christopher Baines <mail@cbaines.net> # Add a systems table
some_indexes 2021-05-17T17:36:38Z Christopher Baines <mail@cbaines.net> # Add some indexes
package_metadata_location_id_index 2021-05-27T19:51:13Z Canan Talayhan <canan.t.talayhan@gmail.com> # Add index for location id
packages_replacement 2021-04-24T04:52:57Z Christopher Baines <mail@cbaines.net> # Add packages.replacement_package_id

7
sqitch/verify/packages_replacement.sql Normal file
View File

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

22
tests/model-package.scm
View File

@ -53,7 +53,8 @@
`(("en_US.UTF-8" . "Fake description")))))
(with-mock-inferior-packages
(lambda ()
(use-modules (guix-data-service model package)
(use-modules (guix-data-service model utils)
(guix-data-service model package)
(guix-data-service model git-repository)
(guix-data-service model guix-revision)
(guix-data-service model package-metadata))
@ -71,12 +72,16 @@
conn
""
mock-inferior-packages
(test-license-set-ids conn))))
(test-license-set-ids conn)))
(package-replacement-package-ids
(make-list (length mock-inferior-packages)
(cons "integer" NULL))))
(match (inferior-packages->package-ids
conn
(zip (map mock-inferior-package-name mock-inferior-packages)
(map mock-inferior-package-version mock-inferior-packages)
package-metadata-ids))
package-metadata-ids
package-replacement-package-ids))
((x) (number? x))))))
#:always-rollback? #t)
@ -87,18 +92,23 @@
conn
""
mock-inferior-packages
(test-license-set-ids conn))))
(test-license-set-ids conn)))
(package-replacement-package-ids
(make-list (length mock-inferior-packages)
(cons "integer" NULL))))
(test-equal
(inferior-packages->package-ids
conn
(zip (map mock-inferior-package-name mock-inferior-packages)
(map mock-inferior-package-version mock-inferior-packages)
package-metadata-ids))
package-metadata-ids
package-replacement-package-ids))
(inferior-packages->package-ids
conn
(zip (map mock-inferior-package-name mock-inferior-packages)
(map mock-inferior-package-version mock-inferior-packages)
package-metadata-ids)))))
package-metadata-ids
package-replacement-package-ids)))))
#:always-rollback? #t))))))
(test-end)