06/07: Close the load revision inferior prior to inserting data

[Christopher Baines]

cbaines pushed a commit to branch master
in repository data-service.

commit 097e22ab5e8c59b0ffce1867a54eb0622ab75ce4
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Fri Mar 11 13:07:34 2022 +0000

    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)