Keep less derivation files open when reading derivations

This probably isn't the main problem with having too many open files, but it
might help avoid bursts of open files.

5 files changed, 30 insertions, 11 deletions

diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index 68f9b86..5eeacdc 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -277,7 +277,7 @@
       (define (get-compressed-outputs store)
         (let ((outputs
                (derivation-outputs
-                (read-derivation-from-file derivation-name))))
+                (read-derivation-from-file* derivation-name))))
           (for-each
            (match-lambda
              ((_ . output)
@@ -354,7 +354,7 @@
                 (report-build-start coordinator-interface
                                     build-id
                                     #:log (build-log-procedure lgr build-id))
-                (let* ((derivation (read-derivation-from-file derivation-name))
+                (let* ((derivation (read-derivation-from-file* derivation-name))
                        (result (perform-build lgr store build-id derivation))
                        ;; TODO Check this handles timezones right
                        (end-time (localtime (time-second (current-time)) "UTC"))
@@ -862,7 +862,7 @@ but the guix-daemon claims it's unavailable"
          (if (valid-path? store derivation-name)
              (begin
                (add-temp-root store derivation-name)
-               (read-derivation-from-file derivation-name))
+               (read-derivation-from-file* derivation-name))
              (and
               (with-exception-handler
                   (lambda (exn)
@@ -886,7 +886,7 @@ but the guix-daemon claims it's unavailable"
                    #:delay (random 15))
                   #t)
                 #:unwind? #t)
-              (read-derivation-from-file derivation-name)))))
+              (read-derivation-from-file* derivation-name)))))
     (if derivation
         (begin
           (log-msg lgr 'DEBUG
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 66f0a9c..4c1702d 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -448,7 +448,7 @@
               (lambda ()
                 (substitute-derivation derivation-file
                                        #:substitute-urls substitute-urls))))
-           (read-derivation-from-file derivation-file))
+           (read-derivation-from-file* derivation-file))
 
          (let ((submit-build-result
                 (call-with-delay-logging
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 859fd44..255fca7 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -552,7 +552,7 @@
                        (ensure-all-related-derivation-outputs-have-builds? #f)
                        (tags '())
                        defer-until
-                       (read-drv read-derivation-from-file))
+                       (read-drv read-derivation-from-file*))
   (define datastore (build-coordinator-datastore build-coordinator))
 
   (define (build-for-derivation-exists?)
diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm
index 77a59a0..fef3bd6 100644
--- a/guix-build-coordinator/hooks.scm
+++ b/guix-build-coordinator/hooks.scm
@@ -141,7 +141,7 @@
                                        derivation-substitute-urls)
                 (add-temp-root store drv-name))
 
-              (let* ((drv (read-derivation-from-file drv-name))
+              (let* ((drv (read-derivation-from-file* drv-name))
                      (drv-sources
                       (derivation-sources drv))
                      (referenced-source-files
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 06c22c6..197c002 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -66,6 +66,8 @@
             find-missing-substitutes-for-output
             has-substiutes-no-cache?
 
+            read-derivation-from-file*
+
             substitute-derivation
             read-derivation-through-substitutes
 
@@ -461,6 +463,23 @@
                 (error (simple-format #f "could not substitute ~A\n"
                                       derivation-name)))))))))
 
+(define read-derivation-from-file*
+  (let ((%derivation-cache
+         (@@ (guix derivations) %derivation-cache)))
+    (lambda (file)
+      (or (and file (hash-ref %derivation-cache file))
+          (let ((drv
+                 ;; read-derivation can call read-derivation-from-file, so to
+                 ;; avoid having many open files when reading a derivation with
+                 ;; inputs, read it in to a string first.
+                 (call-with-input-string
+                     (call-with-input-file file
+                       get-string-all)
+                   (lambda (port)
+                     (read-derivation port read-derivation-from-file*)))))
+            (hash-set! %derivation-cache file drv)
+            drv)))))
+
 (define %derivation-cache
   (make-doubly-weak-hash-table))
 
@@ -551,13 +570,13 @@
           (error "could not fetch narinfo"))))
 
   (with-store store
-    (define (read-derivation-from-file* derivation-name)
+    (define (read-derivation-from-file/custom derivation-name)
       (or (hash-ref %derivation-cache derivation-name)
 
           ;; Try the local store
           (and (file-exists? derivation-name)
                (valid-path? store derivation-name)
-               (read-derivation-from-file derivation-name))
+               (read-derivation-from-file* derivation-name))
 
           ;; Otherwise try the network
           (let ((drv
@@ -566,7 +585,7 @@
                   (lambda (port)
                     (set-port-filename! port derivation-name)
                     (read-derivation port
-                                     read-derivation-from-file*)))))
+                                     read-derivation-from-file/custom)))))
 
             (hash-set! %derivation-cache
                        derivation-name
@@ -574,7 +593,7 @@
 
             drv)))
 
-    (read-derivation-from-file* derivation-name)))
+    (read-derivation-from-file/custom derivation-name)))
 
 (define* (narinfo-string store-path hash size references
                          compressed-files