Avoid using has-substitutes? if one isn't available

Because 404's for substitutes are cached for 3 hours (I think this is the
current behaviour in Guix), this can mean that even though a substitute might
become available, you migth have to wait up to 3 hours to be able to use it.

To try and avoid this circumstance, check if a substitute is available without
using the daemon, and only ask it if there should be one available.

2 files changed, 51 insertions, 6 deletions

diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index 518b02c..9db7e10 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -90,12 +90,19 @@
             (remove file-exists? output-paths))
            (path-substitutes
             (with-store store
-              (set-build-options store
-                                 #:substitute-urls substitute-urls)
-
-              (map (lambda (file)
-                     (has-substitutes? store file))
-                   missing-paths))))
+              (set-build-options store #:substitute-urls substitute-urls)
+
+            (map (lambda (file)
+                   (and
+                    (has-substiutes-no-cache? substitute-urls file)
+                    (if (has-substitutes? store file)
+                        #t
+                        (begin
+                          (simple-format
+                           #t "warning: a substitute should be available for ~A, but the daemon claims it's not\n"
+                           file)
+                          #f))))
+                 missing-paths))))
 
       (if (member #f path-substitutes)
           (fold (lambda (file substitute-available? result)
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 585e33b..445c90e 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -1,6 +1,8 @@
 (define-module (guix-build-coordinator utils)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-60)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 threads)
@@ -18,9 +20,12 @@
   #:use-module (fibers)
   #:use-module (fibers channels)
   #:use-module (guix pki)
+  #:use-module (guix utils)
+  #:use-module (guix config)
   #:use-module (guix store)
   #:use-module (guix status)
   #:use-module (guix base64)
+  #:use-module (guix scripts substitute)
   #:export (make-worker-thread-channel
             call-with-worker-thread
 
@@ -30,6 +35,8 @@
             call-with-streaming-http-request
             make-chunked-input-port*
 
+            has-substiutes-no-cache?
+
             substitute-derivation
 
             narinfo-string))
@@ -276,6 +283,37 @@ upcoming chunk."
           (values response
                   body))))))
 
+(define (has-substiutes-no-cache? substitute-urls file)
+  (define %narinfo-cache-directory
+    (if (zero? (getuid))
+        (or (and=> (getenv "XDG_CACHE_HOME")
+                   (cut string-append <> "/guix/substitute"))
+            (string-append %state-directory "/substitute/cache"))
+        (string-append (cache-directory #:ensure? #f) "/substitute")))
+
+  ;; Because there's no control over the caching of 404 lookups, and I'd
+  ;; rather not reach inside and monkey patch the Guix code, just delete any
+  ;; cache files
+  (let ((hash-part (store-path-hash-part file))
+        (directories
+         (scandir %narinfo-cache-directory
+                  (lambda (s) (= (string-length s) 52)))))
+
+    (for-each (lambda (directory)
+                (let ((cache-file
+                       (string-append
+                        %narinfo-cache-directory "/"
+                        directory "/" hash-part)))
+                  (when (file-exists? cache-file)
+                    (delete-file cache-file))))
+              directories))
+
+  (let ((narinfos
+         (append-map (lambda (substitute-url)
+                       (lookup-narinfos substitute-url (list file)))
+                     substitute-urls)))
+    (not (null? (peek narinfos)))))
+
 (define* (substitute-derivation derivation-name
                                 #:key substitute-urls)
   (catch #t