From 097e22ab5e8c59b0ffce1867a54eb0622ab75ce4 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 11 Mar 2022 13:07:34 +0000 Subject: Close the load revision inferior prior to inserting data This means that the lock can be acquired after closing the inferior, freeing the large amount of memory that the inferior process is probably using. --- guix-data-service/jobs/load-new-guix-revision.scm | 137 ++++++++++++++-------- guix-data-service/model/package-metadata.scm | 54 ++++----- tests/model-package-metadata.scm | 93 +++++++-------- tests/model-package.scm | 41 ++++--- 4 files changed, 185 insertions(+), 140 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))) - - (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 + (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))) + + `((names . ,(map inferior-package-name packages)) + (versions . ,(map inferior-package-version packages)) + (license-data . ,package-license-data) + (metadata . ,package-metadata) + (replacemnets . ,package-replacement-data)))) + +(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) -- cgit v1.2.3