From 639c6ff183bda97947dcb0a618fc6ad1ffdb1f88 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 28 Apr 2023 22:33:41 +0200
Subject: Further tweak fetching narinfos

Move the batching to the database, which should reduce memory usage while
removing the limit on the number of fetched narinfos.
---
 guix-data-service/model/nar.scm   |  29 +++++++----
 guix-data-service/substitutes.scm | 102 +++++++++++++++++++++-----------------
 2 files changed, 76 insertions(+), 55 deletions(-)

diff --git a/guix-data-service/model/nar.scm b/guix-data-service/model/nar.scm
index 7cf1f31..662a5ad 100644
--- a/guix-data-service/model/nar.scm
+++ b/guix-data-service/model/nar.scm
@@ -381,7 +381,9 @@ ORDER BY COUNT(*) DESC")
           build-server-id
           guix-revision-commits
           #:key
-          build-success-after)
+          build-success-after
+          after-id
+          (limit 2000))
   (define query
     (string-append
      "
@@ -440,16 +442,25 @@ WHERE derivation_output_details.path NOT IN (
                        ",")
           ")
   )"))
+     (if after-id
+         (string-append
+          "
+  AND derivation_output_details.id > " after-id)
+         "")
      "
-ORDER BY derivation_output_details.id DESC
-LIMIT 100000"))
+ORDER BY derivation_output_details.id ASC"
+     (if limit
+         (string-append
+          "
+LIMIT " (number->string limit))
+         "")))
 
-  (map car (exec-query conn
-                       query
-                       `(,(number->string build-server-id)
-                         ,@(if build-success-after
-                               (list (date->string build-success-after "~1 ~3"))
-                               '())))))
+  (exec-query conn
+              query
+              `(,(number->string build-server-id)
+                ,@(if build-success-after
+                      (list (date->string build-success-after "~1 ~3"))
+                      '()))))
 
 (define (select-nars-for-output conn output-file-name)
   (define query
diff --git a/guix-data-service/substitutes.scm b/guix-data-service/substitutes.scm
index 3867568..d0e0a6a 100644
--- a/guix-data-service/substitutes.scm
+++ b/guix-data-service/substitutes.scm
@@ -50,7 +50,6 @@
               (simple-format #t "\nQuerying ~A\n" url)
               (catch #t
                 (lambda ()
-                  (simple-format #t "\nFetching narinfo files\n")
                   (fetch-narinfo-files conn id url revision-commits
                                        #:specific-outputs
                                        outputs))
@@ -69,56 +68,67 @@
 (define* (fetch-narinfo-files conn build-server-id build-server-url
                               revision-commits
                               #:key specific-outputs)
-  (define outputs
-    (or specific-outputs
-        (select-outputs-without-known-nar-entries
-         conn
-         build-server-id
-         revision-commits
-         #:build-success-after
-         (if (null? revision-commits)
-             (time-utc->date
-              (subtract-duration (current-time)
-                                 (make-time time-duration 0 (* 60 5)))
-              0)                        ; tz-offset
-             #f))))
+  (let loop ((last-id #f)
+             (requests 0)
+             (success-responses 0))
+    (let ((outputs-chunk
+           (or specific-outputs
+               (select-outputs-without-known-nar-entries
+                conn
+                build-server-id
+                revision-commits
+                #:build-success-after
+                (if (null? revision-commits)
+                    (time-utc->date
+                     (subtract-duration (current-time)
+                                        (make-time time-duration 0 (* 60 5)))
+                     0)                        ; tz-offset
+                    #f)
+                #:after-id last-id))))
 
-  (simple-format #t "Querying ~A outputs\n"
-                 (length outputs))
+      (unless (null? outputs-chunk)
+        (let* ((narinfos
+                (lookup-narinfos (string-trim-right build-server-url #\/)
+                                 (map car outputs-chunk)))
+               (narinfos-count
+                (length narinfos))
+               (total-requested
+                (+ requests (length outputs-chunk)))
+               (total-narinfos
+                (+ success-responses narinfos-count)))
 
-  (chunk-for-each!
-   (lambda (outputs-chunk)
-     (let ((narinfos
-            (lookup-narinfos (string-trim-right build-server-url #\/)
-                             outputs-chunk)))
+          (simple-format #t "Fetched ~A narinfos from ~A (total requested: ~A, total narinfos: ~A)\n"
+                         (length narinfos)
+                         build-server-url
+                         total-requested
+                         total-narinfos)
 
-       (simple-format #t "Got ~A narinfo files\n"
-                      (length narinfos))
+          (let ((filtered-narinfos
+                 (filter-map
+                  (lambda (narinfo)
+                    (if (> (narinfo-size narinfo)
+                           %narinfo-max-size)
+                        (begin
+                          (simple-format (current-error-port)
+                                         "narinfo ~A has excessive size ~A\n"
+                                         (narinfo-path narinfo)
+                                         (narinfo-size narinfo))
+                          #f)
+                        narinfo))
+                  narinfos)))
 
-       (let ((filtered-narinfos
-              (filter-map
-               (lambda (narinfo)
-                 (if (> (narinfo-size narinfo)
-                        %narinfo-max-size)
-                     (begin
-                       (simple-format (current-error-port)
-                                      "narinfo ~A has excessive size ~A\n"
-                                      (narinfo-path narinfo)
-                                      (narinfo-size narinfo))
-                       #f)
-                     narinfo))
-               narinfos)))
-
-         (unless (null? filtered-narinfos)
-           (with-postgresql-transaction
-            conn
-            (lambda (conn)
-              (record-narinfo-details-and-return-ids
+            (unless (null? filtered-narinfos)
+              (with-postgresql-transaction
                conn
-               build-server-id
-               filtered-narinfos)))))))
-   2000
-   outputs))
+               (lambda (conn)
+                 (record-narinfo-details-and-return-ids
+                  conn
+                  build-server-id
+                  filtered-narinfos)))))
+
+          (loop (second (last outputs-chunk))
+                total-requested
+                total-narinfos))))))
 
 (define (start-substitute-query-thread)
   (call-with-new-thread
-- 
cgit v1.2.3