From 0d9228e549082eabc9311dd4202bd286bc4363e4 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sat, 24 Oct 2020 17:33:10 +0100
Subject: WIP

---
 guix-build-coordinator/agent.scm | 26 +++++++++++++++++----
 guix-build-coordinator/utils.scm | 50 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 72 insertions(+), 4 deletions(-)

diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index dcee91f..850d378 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -134,7 +134,7 @@
                            derivation-substitute-urls
                            non-derivation-substitute-urls
                            derivation-name)
-  (define (find-missing-inputs inputs)
+  (define (find-missing-inputs derivation inputs)
     (let* ((output-paths
             (append-map derivation-input-output-paths inputs))
            (missing-paths
@@ -194,10 +194,28 @@
                       (begin
                         (simple-format
                          (current-error-port)
-                         "error: failed to fetch substitutes for: ~A\n"
+                         "warning: failed to fetch substitutes for: ~A\n"
                          missing-files)
 
-                        missing-files))))))))
+                        (let ((unavailable-outputs
+                               (delete-duplicates
+                                (append-map
+                                 (lambda (missing-output)
+                                   (find-missing-substitutes-for-output
+                                    non-derivation-substitute-urls
+                                    missing-output))
+                                 missing-files))))
+
+                          (simple-format
+                           (current-error-port)
+                           "warning: the following outputs are missing:\n~A\n"
+                           (string-join
+                            (map (lambda (output)
+                                   (string-append
+                                    " - " output))
+                                 unavailable-outputs)))
+
+                          unavailable-outputs)))))))))
 
   (define (delete-outputs derivation)
     (let* ((outputs (derivation-outputs derivation))
@@ -234,7 +252,7 @@
     (match (delete-outputs derivation)
       (#t
        (let ((missing-inputs
-              (find-missing-inputs (derivation-inputs derivation))))
+              (find-missing-inputs derivation (derivation-inputs derivation))))
          (if (null? missing-inputs)
              '((result . success))
              `((result         . failure)
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index ef26d3a..7b38130 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -36,6 +36,7 @@
             call-with-streaming-http-request
             make-chunked-input-port*
 
+            find-missing-substitutes-for-output
             has-substiutes-no-cache?
 
             substitute-derivation
@@ -256,6 +257,55 @@ upcoming chunk."
               (values response
                       body))))))))
 
+(define (find-missing-substitutes-for-output substitute-urls output)
+  (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 output))
+        (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)
+                    (with-exception-handler
+                        (lambda (exn)
+                          (simple-format
+                           (current-error-port)
+                           "error: when deleting substitute cache file: ~A\n"
+                           exn))
+                      (lambda ()
+                        (delete-file cache-file))
+                      #:unwind? #t))))
+              (or directories '())))
+
+  (let ((narinfo
+         (any (lambda (substitute-url)
+                (let ((result (lookup-narinfos substitute-url (list output))))
+                  (if (null? result)
+                      #f
+                      (first result))))
+              substitute-urls)))
+    (if narinfo
+        (append-map
+         (lambda (referenced-output)
+           (peek "REF" referenced-output)
+           (find-missing-substitutes-for-output substitute-urls
+                                                referenced-output))
+         (narinfo-references narinfo))
+        (list output))))
+
 (define (has-substiutes-no-cache? substitute-urls file)
   (define %narinfo-cache-directory
     (if (zero? (getuid))
-- 
cgit v1.2.3