diff options
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 133 | ||||
| -rw-r--r-- | guix-data-service/model/package-metadata.scm | 54 | ||||
| -rw-r--r-- | tests/model-package-metadata.scm | 93 | ||||
| -rw-r--r-- | tests/model-package.scm | 41 |
4 files changed, 183 insertions, 138 deletions
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index 9814c64..c516a89 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -814,49 +814,90 @@ WHERE job_id = $1") deduplicated-packages)) -(define* (insert-packages conn inf packages #:key (process-replacements? #t)) - (let* ((package-license-set-ids +(define* (all-inferior-packages-data inf packages #:key (process-replacements? #t)) + (let* ((package-license-data (with-time-logging "fetching inferior package license metadata" - (inferior-packages->license-set-ids - conn - (inferior-packages->license-id-lists - conn - (inferior-packages->license-data inf packages)))))) - (let*-values - (((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))) - ((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))) + (inferior-packages->license-data inf packages))) + (package-metadata + (with-time-logging "fetching inferior package metadata" + (map + (lambda (package) + (let ((translated-package-descriptions-and-synopsis + (inferior-packages->translated-package-descriptions-and-synopsis + inf package))) + (list (non-empty-string-or-false + (inferior-package-home-page package)) + (inferior-package-location package) + (car translated-package-descriptions-and-synopsis) + (cdr translated-package-descriptions-and-synopsis)))) + packages))) + (package-replacement-data + (if process-replacements? + (map (lambda (package) + (let ((replacement (inferior-package-replacement package))) + (if 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 + (first + (all-inferior-packages-data + inf + (list replacement) + #:process-replacements? #f)) + #f))) + packages) + #f))) - (unless (null? new-package-metadata-ids) - (with-time-logging "fetching package metadata tsvector entries" - (insert-package-metadata-tsvector-entries - conn new-package-metadata-ids))) + `((names . ,(map inferior-package-name packages)) + (versions . ,(map inferior-package-version packages)) + (license-data . ,package-license-data) + (metadata . ,package-metadata) + (replacemnets . ,package-replacement-data)))) - (with-time-logging "getting package-ids" - (inferior-packages->package-ids +(define (insert-packages conn inferior-packages-data) + (let*-values + (((package-license-set-ids) + (inferior-packages->license-set-ids conn - (zip (map inferior-package-name packages) - (map inferior-package-version packages) - all-package-metadata-ids - package-replacement-package-ids)))))) + (inferior-packages->license-id-lists + conn + (assq-ref inferior-packages-data 'license-data)))) + ((all-package-metadata-ids new-package-metadata-ids) + (with-time-logging "inserting package metadata entries" + (inferior-packages->package-metadata-ids + conn + (assq-ref inferior-packages-data 'metadata) + package-license-set-ids))) + ((replacement-ids) + (or (and=> (assq-ref inferior-packages-data 'replacements) + (lambda (all-replacement-data) + (with-time-logging "inserting package replacements" + (map (lambda (replacement-data) + (if replacement-data + (first + (insert-packages conn (list replacement-data))) + (cons "integer" NULL))) + all-replacement-data)))) + (make-list (length package-license-set-ids) + (cons "integer" NULL))))) + + (unless (null? new-package-metadata-ids) + (with-time-logging "fetching package metadata tsvector entries" + (insert-package-metadata-tsvector-entries + conn new-package-metadata-ids))) + + (with-time-logging "getting package-ids" + (inferior-packages->package-ids + conn + (zip (assq-ref inferior-packages-data 'names) + (assq-ref inferior-packages-data 'versions) + all-package-metadata-ids + replacement-ids))))) (define (insert-lint-warnings conn inferior-package-id->package-database-id lint-checker-ids @@ -1289,7 +1330,14 @@ WHERE job_id = $1") (all-inferior-package-derivations store inf packages))) (inferior-system-tests (with-time-logging "getting inferior system tests" - (all-inferior-system-tests inf store)))) + (all-inferior-system-tests inf store))) + (packages-data + (with-time-logging "getting all inferior package data" + (all-inferior-packages-data inf packages)))) + + (simple-format + #t "debug: finished loading information from inferior\n") + (close-inferior inf) (with-time-logging "acquiring advisory transaction lock: load-new-guix-revision-inserts" @@ -1298,7 +1346,7 @@ WHERE job_id = $1") (obtain-advisory-transaction-lock conn 'load-new-guix-revision-inserts)) (let* ((package-ids - (insert-packages conn inf packages)) + (insert-packages conn packages-data)) (inferior-package-id->package-database-id (let ((lookup-table (alist->hashq-table @@ -1316,9 +1364,6 @@ WHERE job_id = $1") "error: inferior-package-id->package-database-id: ~A missing\n" inferior-id))))))) - (simple-format - #t "debug: finished loading information from inferior\n") - (close-inferior inf) (when inferior-lint-warnings (let* ((lint-checker-ids diff --git a/guix-data-service/model/package-metadata.scm b/guix-data-service/model/package-metadata.scm index 030ad4f..9593b49 100644 --- a/guix-data-service/model/package-metadata.scm +++ b/guix-data-service/model/package-metadata.scm @@ -389,43 +389,39 @@ WHERE packages.id IN ( (insert-package-description-set conn package-description-ids)))))) (define (inferior-packages->package-metadata-ids conn - inferior - packages + package-metadata license-set-ids) - (define package-metadata - (map (lambda (package license-set-id) - (let ((translated-package-descriptions-and-synopsis - (inferior-packages->translated-package-descriptions-and-synopsis - inferior package))) - (list (non-empty-string-or-false - (inferior-package-home-page package)) - (location->location-id - conn - (inferior-package-location package)) - license-set-id - (package-description-data->package-description-set-id - conn - (car translated-package-descriptions-and-synopsis)) - (package-synopsis-data->package-synopsis-set-id - conn - (cdr translated-package-descriptions-and-synopsis))))) - packages - license-set-ids)) - (insert-missing-data-and-return-all-ids conn "package_metadata" - '(home_page location_id license_set_id package_description_set_id package_synopsis_set_id) - (map (match-lambda - ((home-page location-id license-set-id package_description_set_id package_synopsis_set_id) + '(home_page + location_id + license_set_id + package_description_set_id + package_synopsis_set_id) + + (map (match-lambda* + (((home-page + location + package-description-data + package-synopsis-data) + license-set-id) + (list (if (string? home-page) home-page NULL) - location-id + (location->location-id + conn + location) license-set-id - package_description_set_id - package_synopsis_set_id))) - package-metadata) + (package-description-data->package-description-set-id + conn + package-description-data) + (package-synopsis-data->package-synopsis-set-id + conn + package-synopsis-data)))) + package-metadata + license-set-ids) ;; There can be duplicated entires in package-metadata, for example where ;; you have one package definition which interits from another, and just ;; overrides the version and the source, the package_metadata entries for diff --git a/tests/model-package-metadata.scm b/tests/model-package-metadata.scm index 2e67233..407b7d2 100644 --- a/tests/model-package-metadata.scm +++ b/tests/model-package-metadata.scm @@ -29,6 +29,19 @@ (home-page #f) (location #f))) +(define mock-inferior-packages + (list mock-inferior-package-foo + mock-inferior-package-foo-2)) + +(define mock-package-metadata + (map (lambda (mock-inf-pkg) + (list + (mock-inferior-package-home-page mock-inf-pkg) + (mock-inferior-package-location mock-inf-pkg) + `(("en_US.UTF-8" . "Fake synopsis")) + `(("en_US.UTF-8" . "Fake description")))) + mock-inferior-packages)) + (define (test-license-set-ids conn) (let ((license-id-lists (inferior-packages->license-id-lists @@ -39,54 +52,42 @@ (inferior-packages->license-set-ids conn license-id-lists))) -(mock - ((guix-data-service model package-metadata) - inferior-packages->translated-package-descriptions-and-synopsis - (lambda (inferior inferior-package) - (cons `(("en_US.UTF-8" . "Fake synopsis")) - `(("en_US.UTF-8" . "Fake description"))))) - (with-mock-inferior-packages - (lambda () - (use-modules (guix-data-service model package) - (guix-data-service model git-repository) - (guix-data-service model guix-revision) - (guix-data-service model package-metadata)) +(with-mock-inferior-packages + (lambda () + (use-modules (guix-data-service model package) + (guix-data-service model git-repository) + (guix-data-service model guix-revision) + (guix-data-service model package-metadata)) - (with-postgresql-connection - "test-model-package-metadata" - (lambda (conn) - (check-test-database! conn) + (with-postgresql-connection + "test-model-package-metadata" + (lambda (conn) + (check-test-database! conn) - (test-assert "inferior-packages->package-metadata-ids" - (with-postgresql-transaction - conn - (lambda (conn) - (match - (inferior-packages->package-metadata-ids - conn - "" - (list mock-inferior-package-foo - mock-inferior-package-foo-2) - (test-license-set-ids conn)) - ((x) (number? x)))) - #:always-rollback? #t)) + (test-assert "inferior-packages->package-metadata-ids" + (with-postgresql-transaction + conn + (lambda (conn) + (match + (inferior-packages->package-metadata-ids + conn + mock-package-metadata + (test-license-set-ids conn)) + ((x) (number? x)))) + #:always-rollback? #t)) - (with-postgresql-transaction - conn - (lambda (conn) - (test-equal "inferior-packages->package-metadata-ids" - (inferior-packages->package-metadata-ids - conn - "" - (list mock-inferior-package-foo - mock-inferior-package-foo-2) - (test-license-set-ids conn)) - (inferior-packages->package-metadata-ids - conn - "" - (list mock-inferior-package-foo - mock-inferior-package-foo-2) - (test-license-set-ids conn))) - #:always-rollback? #t))))))) + (with-postgresql-transaction + conn + (lambda (conn) + (test-equal "inferior-packages->package-metadata-ids" + (inferior-packages->package-metadata-ids + conn + mock-package-metadata + (test-license-set-ids conn)) + (inferior-packages->package-metadata-ids + conn + mock-package-metadata + (test-license-set-ids conn))) + #:always-rollback? #t)))))) (test-end) diff --git a/tests/model-package.scm b/tests/model-package.scm index a0fdc45..814a6e1 100644 --- a/tests/model-package.scm +++ b/tests/model-package.scm @@ -5,6 +5,7 @@ #:use-module (guix utils) #:use-module (guix tests) #:use-module (tests mock-inferior) + #:use-module (guix-data-service model utils) #:use-module (guix-data-service model license) #:use-module (guix-data-service model license-set) #:use-module (guix-data-service model package) @@ -45,16 +46,18 @@ (list mock-inferior-package-foo mock-inferior-package-foo-2)) -(mock - ((guix-data-service model package-metadata) - inferior-packages->translated-package-descriptions-and-synopsis - (lambda (inferior inferior-package) - (cons `(("en_US.UTF-8" . "Fake synopsis")) - `(("en_US.UTF-8" . "Fake description"))))) +(define mock-package-metadata + (map (lambda (mock-inf-pkg) + (list + (mock-inferior-package-home-page mock-inf-pkg) + (mock-inferior-package-location mock-inf-pkg) + `(("en_US.UTF-8" . "Fake synopsis")) + `(("en_US.UTF-8" . "Fake description")))) + mock-inferior-packages)) + (with-mock-inferior-packages (lambda () - (use-modules (guix-data-service model utils) - (guix-data-service model package) + (use-modules (guix-data-service model package) (guix-data-service model git-repository) (guix-data-service model guix-revision) (guix-data-service model package-metadata)) @@ -68,11 +71,11 @@ conn (lambda (conn) (test-assert "inferior-packages->package-ids works once" - (let ((package-metadata-ids (inferior-packages->package-metadata-ids - conn - "" - mock-inferior-packages - (test-license-set-ids conn))) + (let ((package-metadata-ids + (inferior-packages->package-metadata-ids + conn + mock-package-metadata + (test-license-set-ids conn))) (package-replacement-package-ids (make-list (length mock-inferior-packages) (cons "integer" NULL)))) @@ -88,11 +91,11 @@ (with-postgresql-transaction conn (lambda (conn) - (let ((package-metadata-ids (inferior-packages->package-metadata-ids - conn - "" - mock-inferior-packages - (test-license-set-ids conn))) + (let ((package-metadata-ids + (inferior-packages->package-metadata-ids + conn + mock-package-metadata + (test-license-set-ids conn))) (package-replacement-package-ids (make-list (length mock-inferior-packages) (cons "integer" NULL)))) @@ -109,6 +112,6 @@ (map mock-inferior-package-version mock-inferior-packages) package-metadata-ids package-replacement-package-ids))))) - #:always-rollback? #t)))))) + #:always-rollback? #t))))) (test-end) |