09/10: substitute: Honor all the specified server URLs.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 55b2fc18772a512a2227757423e55dc6c7523113
Author: Ludovic Courtès <address@hidden>
Date:   Wed Oct 28 10:11:43 2015 +0100

    substitute: Honor all the specified server URLs.
    
    * guix/scripts/substitute.scm (lookup-narinfos/diverse): New procedure.
      (lookup-narinfo): Use it.
      (process-query): Change #:cache-url to #:cache-urls.
      [valid?]: Remove 'narinfo?' check, which is no longer necessary.
      Use 'lookup-narinfos/diverse' instead of 'lookup-narinfos'.
      (process-substitution): Change #:cache-url to #:cache-urls.
      (%cache-url): Rename to...
      (%cache-urls): ... this.  Turn into a list.
      (guix-substitute): Remove 'getaddrinfo' test with early exit.  Adjust
      calls to 'process-query' and 'process-substitution'.
    * tests/substitute.scm: Change '%cache-url' to '%cache-urls'.
---
 guix/scripts/substitute.scm |   83 +++++++++++++++++++++++--------------------
 tests/substitute.scm        |    4 +-
 2 files changed, 46 insertions(+), 41 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 34fee58..964df94 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -72,6 +72,7 @@
             assert-valid-narinfo
 
             lookup-narinfos
+            lookup-narinfos/diverse
             read-narinfo
             write-narinfo
             guix-substitute))
@@ -610,11 +611,32 @@ information is available locally."
         (let ((missing (fetch-narinfos cache missing)))
           (append cached (or missing '()))))))
 
-(define (lookup-narinfo cache path)
-  "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was
-found."
-  (match (lookup-narinfos cache (list path))
-    ((answer) answer)))
+(define (lookup-narinfos/diverse caches paths)
+  "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
+That is, when a cache lacks a narinfo, look it up in the next cache, and so
+on.  Return a list of narinfos for PATHS or a subset thereof."
+  (let loop ((caches caches)
+             (paths  paths)
+             (result '()))
+    (match paths
+      (()                                         ;we're done
+       result)
+      (_
+       (match caches
+         ((cache rest ...)
+          (let* ((narinfos (lookup-narinfos cache paths))
+                 (hits     (map narinfo-path narinfos))
+                 (missing  (lset-difference string=? paths hits))) ;XXX: perf
+            (loop rest missing (append narinfos result))))
+         (()                                      ;that's it
+          result))))))
+
+(define (lookup-narinfo caches path)
+  "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
+was found."
+  (match (lookup-narinfos/diverse caches (list path))
+    ((answer) answer)
+    (_        #f)))
 
 (define (remove-expired-cached-narinfos directory)
   "Remove expired narinfo entries from DIRECTORY.  The sole purpose of this
@@ -756,34 +778,34 @@ expected by the daemon."
           (or (narinfo-size narinfo) 0)))
 
 (define* (process-query command
-                        #:key cache-url acl)
+                        #:key cache-urls acl)
   "Reply to COMMAND, a query as written by the daemon to this process's
 standard input.  Use ACL as the access-control list against which to check
 authorized substitutes."
   (define (valid? obj)
-    (and (narinfo? obj) (valid-narinfo? obj acl)))
+    (valid-narinfo? obj acl))
 
   (match (string-tokenize command)
     (("have" paths ..1)
-     ;; Return the subset of PATHS available in CACHE-URL.
-     (let ((substitutable (lookup-narinfos cache-url paths)))
+     ;; Return the subset of PATHS available in CACHE-URLS.
+     (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
        (for-each (lambda (narinfo)
                    (format #t "~a~%" (narinfo-path narinfo)))
                  (filter valid? substitutable))
        (newline)))
     (("info" paths ..1)
-     ;; Reply info about PATHS if it's in CACHE-URL.
-     (let ((substitutable (lookup-narinfos cache-url paths)))
+     ;; Reply info about PATHS if it's in CACHE-URLS.
+     (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
        (for-each display-narinfo-data (filter valid? substitutable))
        (newline)))
     (wtf
      (error "unknown `--query' command" wtf))))
 
 (define* (process-substitution store-item destination
-                               #:key cache-url acl)
-  "Substitute STORE-ITEM (a store file name) from CACHE-URL, and write it to
+                               #:key cache-urls acl)
+  "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
 DESTINATION as a nar file.  Verify the substitute against ACL."
-  (let* ((narinfo (lookup-narinfo cache-url store-item))
+  (let* ((narinfo (lookup-narinfo cache-urls store-item))
          (uri     (narinfo-uri narinfo)))
     ;; Make sure it is signed and everything.
     (assert-valid-narinfo narinfo acl)
@@ -880,21 +902,16 @@ found."
         b
         first)))
 
-(define %cache-url
+(define %cache-urls
   (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client
                      (find-daemon-option "substitute-urls"))          ;admin
                 string-tokenize)
-    ((url)
-     url)
-    ((head tail ..1)
-     ;; Currently we don't handle multiple substitute URLs.
-     (warning (_ "these substitute URLs will not be used:~{ ~a~}~%")
-              tail)
-     head)
+    ((urls ...)
+     urls)
     (#f
      ;; This can only happen when this script is not invoked by the
      ;; daemon.
-     "http://hydra.gnu.org";)))
+     '("http://hydra.gnu.org";))))
 
 (define (guix-substitute . args)
   "Implement the build daemon's substituter protocol."
@@ -905,20 +922,8 @@ found."
   ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
   ;; when we know we cannot substitute, but we must emit a newline on stdout
   ;; when everything is alright.
-  (let ((uri (string->uri %cache-url)))
-    (case (uri-scheme uri)
-      ((http)
-       ;; Exit gracefully if there's no network access.
-       (let ((host (uri-host uri)))
-         (catch 'getaddrinfo-error
-           (lambda ()
-             (getaddrinfo host))
-           (lambda (key error)
-             (warning (_ "failed to look up host '~a' (~a), \
-substituter disabled~%")
-                      host (gai-strerror error))
-             (exit 0)))))
-      (else #t)))
+  (when (null? %cache-urls)
+    (exit 0))
 
   ;; Say hello (see above.)
   (newline)
@@ -933,13 +938,13 @@ substituter disabled~%")
             (or (eof-object? command)
                 (begin
                   (process-query command
-                                 #:cache-url %cache-url
+                                 #:cache-urls %cache-urls
                                  #:acl acl)
                   (loop (read-line)))))))
        (("--substitute" store-path destination)
         ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
         (process-substitution store-path destination
-                              #:cache-url %cache-url
+                              #:cache-urls %cache-urls
                               #:acl (current-acl)))
        (("--version")
         (show-version-and-exit "guix substitute"))
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 8569812..9d907e7 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -167,8 +167,8 @@ a file for NARINFO."
   (call-with-narinfo narinfo (lambda () body ...)))
 
 ;; Transmit these options to 'guix substitute'.
-(set! (@@ (guix scripts substitute) %cache-url)
-      (getenv "GUIX_BINARY_SUBSTITUTE_URL"))
+(set! (@@ (guix scripts substitute) %cache-urls)
+  (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
 
 (test-equal "query narinfo without signature"
   ""                                              ; not substitutable