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

@@ -814,36 +814,77 @@ WHERE job_id = $1")
 
     deduplicated-packages))
 
-(define* (insert-packages conn inf packages #:key (process-replacements? #t))
+(define* (all-inferior-packages-data inf packages #:key (process-replacements? #t))
-  (let* ((package-license-set-ids
+  (let* ((package-license-data
           (with-time-logging "fetching inferior package license metadata"
-            (inferior-packages->license-set-ids
+            (inferior-packages->license-data inf packages)))
-             conn
+         (package-metadata
-             (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
+            (map
-              conn inf packages package-license-set-ids)))
+             (lambda (package)
-         ((package-replacement-package-ids)
+               (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 (and process-replacements? replacement)
+                       (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
+                           ;; This code currently just capures the first level
-                       ;; replacements
+                           ;; of replacements
-                       (car
+                           (first
-                        (insert-packages conn inf (list replacement)
+                            (all-inferior-packages-data
+                             inf
+                             (list replacement)
                              #:process-replacements? #f))
-                       (cons "integer" NULL))))
+                           #f)))
-               packages)))
+                   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
+         (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"
@@ -853,10 +894,10 @@ WHERE job_id = $1")
     (with-time-logging "getting package-ids"
       (inferior-packages->package-ids
        conn
-         (zip (map inferior-package-name packages)
+       (zip (assq-ref inferior-packages-data 'names)
-              (map inferior-package-version packages)
+            (assq-ref inferior-packages-data 'versions)
             all-package-metadata-ids
-              package-replacement-package-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

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
+                                                 package-metadata
-                                                 packages
                                                  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)
+   '(home_page
-   (map (match-lambda
+     location_id
-          ((home-page location-id license-set-id package_description_set_id package_synopsis_set_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-description-data->package-description-set-id
-                 package_synopsis_set_id)))
+                  conn
-        package-metadata)
+                  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

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,13 +52,7 @@
 
     (inferior-packages->license-set-ids conn license-id-lists)))
 
-(mock
+(with-mock-inferior-packages
- ((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)
@@ -64,9 +71,7 @@
            (match
                (inferior-packages->package-metadata-ids
                 conn
-                 ""
+                mock-package-metadata
-                 (list mock-inferior-package-foo
-                       mock-inferior-package-foo-2)
                 (test-license-set-ids conn))
              ((x) (number? x))))
          #:always-rollback? #t))
@@ -77,16 +82,12 @@
          (test-equal "inferior-packages->package-metadata-ids"
            (inferior-packages->package-metadata-ids
             conn
-             ""
+            mock-package-metadata
-             (list mock-inferior-package-foo
-                   mock-inferior-package-foo-2)
             (test-license-set-ids conn))
            (inferior-packages->package-metadata-ids
             conn
-             ""
+            mock-package-metadata
-             (list mock-inferior-package-foo
-                   mock-inferior-package-foo-2)
             (test-license-set-ids conn)))
-          #:always-rollback? #t)))))))
+         #:always-rollback? #t))))))
 
 (test-end)

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
+(define mock-package-metadata
- ((guix-data-service model package-metadata)
+  (map (lambda (mock-inf-pkg)
-  inferior-packages->translated-package-descriptions-and-synopsis
+         (list
-  (lambda (inferior inferior-package)
+          (mock-inferior-package-home-page mock-inf-pkg)
-    (cons `(("en_US.UTF-8" . "Fake synopsis"))
+          (mock-inferior-package-location mock-inf-pkg)
-          `(("en_US.UTF-8" . "Fake description")))))
+          `(("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)
+   (use-modules (guix-data-service model package)
-                (guix-data-service model package)
                 (guix-data-service model git-repository)
                 (guix-data-service model guix-revision)
                 (guix-data-service model package-metadata))
@@ -68,10 +71,10 @@
        conn
        (lambda (conn)
          (test-assert "inferior-packages->package-ids works once"
-           (let ((package-metadata-ids (inferior-packages->package-metadata-ids
+           (let ((package-metadata-ids
+                  (inferior-packages->package-metadata-ids
                    conn
-                                        ""
+                   mock-package-metadata
-                                        mock-inferior-packages
                    (test-license-set-ids conn)))
                  (package-replacement-package-ids
                   (make-list (length mock-inferior-packages)
@@ -88,10 +91,10 @@
       (with-postgresql-transaction
        conn
        (lambda (conn)
-         (let ((package-metadata-ids (inferior-packages->package-metadata-ids
+         (let ((package-metadata-ids
+                (inferior-packages->package-metadata-ids
                  conn
-                                      ""
+                 mock-package-metadata
-                                      mock-inferior-packages
                  (test-license-set-ids conn)))
                (package-replacement-package-ids
                 (make-list (length mock-inferior-packages)
@@ -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)