Merge branch 'master' into core-updates

5 files changed, 194 insertions, 149 deletions

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 7fd05da189..d593b5a8a7 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -118,6 +118,9 @@ options handled by 'set-build-options-from-command-line', and listed in
   (display (_ "
       --no-substitutes   build instead of resorting to pre-built substitutes"))
   (display (_ "
+      --substitute-urls=URLS
+                         fetch substitute from URLS if they are authorized"))
+  (display (_ "
       --no-build-hook    do not attempt to offload builds via the build hook"))
   (display (_ "
       --max-silent-time=SECONDS
@@ -141,6 +144,8 @@ options handled by 'set-build-options-from-command-line', and listed in
                      #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1)
                      #:fallback? (assoc-ref opts 'fallback?)
                      #:use-substitutes? (assoc-ref opts 'substitutes?)
+                     #:substitute-urls (or (assoc-ref opts 'substitute-urls)
+                                           %default-substitute-urls)
                      #:use-build-hook? (assoc-ref opts 'build-hook?)
                      #:max-silent-time (assoc-ref opts 'max-silent-time)
                      #:timeout (assoc-ref opts 'timeout)
@@ -177,6 +182,13 @@ options handled by 'set-build-options-from-command-line', and listed in
                          (alist-cons 'substitutes? #f
                                      (alist-delete 'substitutes? result))
                          rest)))
+        (option '("substitute-urls") #t #f
+                (lambda (opt name arg result . rest)
+                  (apply values
+                         (alist-cons 'substitute-urls
+                                     (string-tokenize arg)
+                                     (alist-delete 'substitute-urls result))
+                         rest)))
         (option '("no-build-hook") #f #f
                 (lambda (opt name arg result . rest)
                   (apply values
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 3740b71d5e..6dc5b68f95 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -34,8 +34,6 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
   #:use-module (web uri)
-  #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
   #:use-module ((guix build download)
                 #:select (maybe-expand-mirrors
                           open-connection-for-uri))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 0baba91981..95aae2a372 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -25,6 +25,7 @@
   #:use-module (guix records)
   #:use-module (guix serialization)
   #:use-module (guix hash)
+  #:use-module (guix base32)
   #:use-module (guix base64)
   #:use-module (guix pk-crypto)
   #:use-module (guix pki)
@@ -184,37 +185,29 @@ to the caller without emitting an error message."
                  (setvbuf port _IONBF)))
              (http-fetch uri #:text? #f #:port port))))))))
 
-(define-record-type <cache>
-  (%make-cache url store-directory wants-mass-query?)
-  cache?
-  (url               cache-url)
-  (store-directory   cache-store-directory)
-  (wants-mass-query? cache-wants-mass-query?))
-
-(define (open-cache url)
-  "Open the binary cache at URL.  Return a <cache> object on success, or #f on
-failure."
-  (define (download-cache-info url)
+(define-record-type <cache-info>
+  (%make-cache-info url store-directory wants-mass-query?)
+  cache-info?
+  (url               cache-info-url)
+  (store-directory   cache-info-store-directory)
+  (wants-mass-query? cache-info-wants-mass-query?))
+
+(define (download-cache-info url)
+  "Download the information for the cache at URL.  Return a <cache-info>
+object on success, or #f on failure."
+  (define (download url)
     ;; Download the `nix-cache-info' from URL, and return its contents as an
     ;; list of key/value pairs.
     (and=> (false-if-exception (fetch (string->uri url)))
            fields->alist))
 
-  (and=> (download-cache-info (string-append url "/nix-cache-info"))
+  (and=> (download (string-append url "/nix-cache-info"))
          (lambda (properties)
            (alist->record properties
-                          (cut %make-cache url <...>)
+                          (cut %make-cache-info url <...>)
                           '("StoreDir" "WantMassQuery")))))
 
-(define-syntax-rule (open-cache* url)
-  "Delayed variant of 'open-cache' that also lets the user know that they're
-gonna have to wait."
-  (delay (begin
-           (format (current-error-port)
-                   (_ "updating list of substitutes from '~a'...\r")
-                   url)
-           (open-cache url))))
-
+
 (define-record-type <narinfo>
   (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
                  references deriver system signature contents)
@@ -379,20 +372,23 @@ the cache STR originates form."
           (make-time time-monotonic 0 date)))
 
 
-(define (narinfo-cache-file path)
-  "Return the name of the local file that contains an entry for PATH."
+(define (narinfo-cache-file cache-url path)
+  "Return the name of the local file that contains an entry for PATH.  The
+entry is stored in a sub-directory specific to CACHE-URL."
   (string-append %narinfo-cache-directory "/"
-                 (store-path-hash-part path)))
-
-(define (cached-narinfo path)
-  "Check locally if we have valid info about PATH.  Return two values: a
-Boolean indicating whether we have valid cached info, and that info, which may
-be either #f (when PATH is unavailable) or the narinfo for PATH."
+                 (bytevector->base32-string (sha256 (string->utf8 cache-url)))
+                 "/" (store-path-hash-part path)))
+
+(define (cached-narinfo cache-url path)
+  "Check locally if we have valid info about PATH coming from CACHE-URL.
+Return two values: a Boolean indicating whether we have valid cached info, and
+that info, which may be either #f (when PATH is unavailable) or the narinfo
+for PATH."
   (define now
     (current-time time-monotonic))
 
   (define cache-file
-    (narinfo-cache-file path))
+    (narinfo-cache-file cache-url path))
 
   (catch 'system-error
     (lambda ()
@@ -418,9 +414,9 @@ be either #f (when PATH is unavailable) or the narinfo for PATH."
     (lambda _
       (values #f #f))))
 
-(define (cache-narinfo! cache path narinfo)
-  "Cache locally NARNIFO for PATH, which originates from CACHE.  NARINFO may
-be #f, in which case it indicates that PATH is unavailable at CACHE."
+(define (cache-narinfo! cache-url path narinfo)
+  "Cache locally NARNIFO for PATH, which originates from CACHE-URL.  NARINFO
+may be #f, in which case it indicates that PATH is unavailable at CACHE-URL."
   (define now
     (current-time time-monotonic))
 
@@ -430,9 +426,12 @@ be #f, in which case it indicates that PATH is unavailable at CACHE."
               (date ,(time-second now))
               (value ,(and=> narinfo narinfo->string))))
 
-  (with-atomic-file-output (narinfo-cache-file path)
-    (lambda (out)
-      (write (cache-entry (cache-url cache) narinfo) out)))
+  (let ((file (narinfo-cache-file cache-url path)))
+    (mkdir-p (dirname file))
+    (with-atomic-file-output file
+      (lambda (out)
+        (write (cache-entry cache-url narinfo) out))))
+
   narinfo)
 
 (define (narinfo-request cache-url path)
@@ -491,11 +490,8 @@ if file doesn't exist, and the narinfo otherwise."
           #f
           (apply throw args)))))
 
-(define (fetch-narinfos cache paths)
-  "Retrieve all the narinfos for PATHS from CACHE and return them."
-  (define url
-    (cache-url cache))
-
+(define (fetch-narinfos url paths)
+  "Retrieve all the narinfos for PATHS from the cache at URL and return them."
   (define update-progress!
     (let ((done 0))
       (lambda ()
@@ -513,7 +509,7 @@ if file doesn't exist, and the narinfo otherwise."
       (case (response-code response)
         ((200)                                     ; hit
          (let ((narinfo (read-narinfo port url #:size len)))
-           (cache-narinfo! cache (narinfo-path narinfo) narinfo)
+           (cache-narinfo! url (narinfo-path narinfo) narinfo)
            (update-progress!)
            narinfo))
         ((404)                                     ; failure
@@ -522,7 +518,7 @@ if file doesn't exist, and the narinfo otherwise."
            (if len
                (get-bytevector-n port len)
                (read-to-eof port))
-           (cache-narinfo! cache
+           (cache-narinfo! url
                            (find (cut string-contains <> hash-part) paths)
                            #f)
            (update-progress!))
@@ -533,7 +529,12 @@ if file doesn't exist, and the narinfo otherwise."
              (read-to-eof port))
          #f))))
 
-  (and (string=? (cache-store-directory cache) (%store-prefix))
+  (define cache-info
+    (download-cache-info url))
+
+  (and cache-info
+       (string=? (cache-info-store-directory cache-info)
+                 (%store-prefix))
        (let ((uri (string->uri url)))
          (case (and=> uri uri-scheme)
            ((http)
@@ -559,7 +560,7 @@ information is available locally."
   (let-values (((cached missing)
                 (fold2 (lambda (path cached missing)
                          (let-values (((valid? value)
-                                       (cached-narinfo path)))
+                                       (cached-narinfo cache path)))
                            (if valid?
                                (values (cons value cached) missing)
                                (values cached (cons path missing)))))
@@ -568,11 +569,8 @@ information is available locally."
                        paths)))
     (if (null? missing)
         cached
-        (let* ((cache   (force cache))
-               (missing (if cache
-                            (fetch-narinfos cache missing)
-                            '())))
-          (append cached missing)))))
+        (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
@@ -580,8 +578,8 @@ found."
   (match (lookup-narinfos cache (list path))
     ((answer) answer)))
 
-(define (remove-expired-cached-narinfos)
-  "Remove expired narinfo entries from the cache.  The sole purpose of this
+(define (remove-expired-cached-narinfos directory)
+  "Remove expired narinfo entries from DIRECTORY.  The sole purpose of this
 function is to make sure `%narinfo-cache-directory' doesn't grow
 indefinitely."
   (define now
@@ -605,16 +603,25 @@ indefinitely."
         #t)))
 
   (for-each (lambda (file)
-              (let ((file (string-append %narinfo-cache-directory
-                                         "/" file)))
+              (let ((file (string-append directory "/" file)))
                 (when (expired? file)
                   ;; Wrap in `false-if-exception' because FILE might have been
                   ;; deleted in the meantime (TOCTTOU).
                   (false-if-exception (delete-file file)))))
-            (scandir %narinfo-cache-directory
+            (scandir directory
                      (lambda (file)
                        (= (string-length file) 32)))))
 
+(define (narinfo-cache-directories)
+  "Return the list of narinfo cache directories (one per cache URL.)"
+  (map (cut string-append %narinfo-cache-directory "/" <>)
+       (scandir %narinfo-cache-directory
+                (lambda (item)
+                  (and (not (member item '("." "..")))
+                       (file-is-directory?
+                        (string-append %narinfo-cache-directory
+                                       "/" item)))))))
+
 (define (maybe-remove-expired-cached-narinfo)
   "Remove expired narinfo entries from the cache if deemed necessary."
   (define now
@@ -628,8 +635,10 @@ indefinitely."
          (call-with-input-file expiry-file read))
         0))
 
-  (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay)
-    (remove-expired-cached-narinfos)
+  (when (obsolete? last-expiry-date now
+                   %narinfo-expired-cache-entry-removal-delay)
+    (for-each remove-expired-cached-narinfos
+              (narinfo-cache-directories))
     (call-with-output-file expiry-file
       (cute write (time-second now) <>))))
 
@@ -690,6 +699,95 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
 
 
 ;;;
+;;; Daemon/substituter protocol.
+;;;
+
+(define (display-narinfo-data narinfo)
+  "Write to the current output port the contents of NARINFO is the format
+expected by the daemon."
+  (format #t "~a\n~a\n~a\n"
+          (narinfo-path narinfo)
+          (or (and=> (narinfo-deriver narinfo)
+                     (cute string-append (%store-prefix) "/" <>))
+              "")
+          (length (narinfo-references narinfo)))
+  (for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
+            (narinfo-references narinfo))
+  (format #t "~a\n~a\n"
+          (or (narinfo-file-size narinfo) 0)
+          (or (narinfo-size narinfo) 0)))
+
+(define* (process-query command
+                        #:key cache-url 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)))
+
+  (match (string-tokenize command)
+    (("have" paths ..1)
+     ;; Return the subset of PATHS available in CACHE-URL.
+     (let ((substitutable (lookup-narinfos cache-url 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)))
+       (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
+DESTINATION as a nar file.  Verify the substitute against ACL."
+  (let* ((narinfo (lookup-narinfo cache-url store-item))
+         (uri     (narinfo-uri narinfo)))
+    ;; Make sure it is signed and everything.
+    (assert-valid-narinfo narinfo acl)
+
+    ;; Tell the daemon what the expected hash of the Nar itself is.
+    (format #t "~a~%" (narinfo-hash narinfo))
+
+    (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%"
+            store-item
+
+            ;; Use the Nar size as an estimate of the installed size.
+            (narinfo-size narinfo)
+            (and=> (narinfo-size narinfo)
+                   (cute / <> (expt 2. 20))))
+    (let*-values (((raw download-size)
+                   ;; Note that Hydra currently generates Nars on the fly
+                   ;; and doesn't specify a Content-Length, so
+                   ;; DOWNLOAD-SIZE is #f in practice.
+                   (fetch uri #:buffered? #f #:timeout? #f))
+                  ((progress)
+                   (let* ((comp     (narinfo-compression narinfo))
+                          (dl-size  (or download-size
+                                        (and (equal? comp "none")
+                                             (narinfo-size narinfo))))
+                          (progress (progress-proc (uri-abbreviation uri)
+                                                   dl-size
+                                                   (current-error-port))))
+                     (progress-report-port progress raw)))
+                  ((input pids)
+                   (decompressed-port (and=> (narinfo-compression narinfo)
+                                             string->symbol)
+                                      progress)))
+      ;; Unpack the Nar at INPUT into DESTINATION.
+      (restore-file input destination)
+
+      ;; Skip a line after what 'progress-proc' printed.
+      (newline (current-error-port))
+
+      (every (compose zero? cdr waitpid) pids))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -737,12 +835,15 @@ substitutes may be unavailable\n")))))
 found."
   (assoc-ref (daemon-options) option))
 
+(define-syntax-rule (or* a b)
+  (let ((first a))
+    (if (or (not first) (string-null? first))
+        b
+        first)))
+
 (define %cache-url
-  (match (and=> ;; TODO: Uncomment the following lines when multiple
-                ;; substitute sources are supported.
-                ;; (find-daemon-option "untrusted-substitute-urls") ;client
-                ;; " "
-                (find-daemon-option "substitute-urls")          ;admin
+  (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client
+                     (find-daemon-option "substitute-urls"))          ;admin
                 string-tokenize)
     ((url)
      url)
@@ -788,94 +889,19 @@ substituter disabled~%")
    (with-error-handling                           ; for signature errors
      (match args
        (("--query")
-        (let ((cache (open-cache* %cache-url))
-              (acl   (current-acl)))
-          (define (valid? obj)
-            (and (narinfo? obj) (valid-narinfo? obj acl)))
-
+        (let ((acl (current-acl)))
           (let loop ((command (read-line)))
             (or (eof-object? command)
                 (begin
-                  (match (string-tokenize command)
-                    (("have" paths ..1)
-                     ;; Return the subset of PATHS available in CACHE.
-                     (let ((substitutable
-                            (if cache
-                                (lookup-narinfos cache 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.
-                     (let ((substitutable
-                            (if cache
-                                (lookup-narinfos cache paths)
-                                '())))
-                       (for-each (lambda (narinfo)
-                                   (format #t "~a\n~a\n~a\n"
-                                           (narinfo-path narinfo)
-                                           (or (and=> (narinfo-deriver narinfo)
-                                                      (cute string-append
-                                                            (%store-prefix) "/"
-                                                            <>))
-                                               "")
-                                           (length (narinfo-references narinfo)))
-                                   (for-each (cute format #t "~a/~a~%"
-                                                   (%store-prefix) <>)
-                                             (narinfo-references narinfo))
-                                   (format #t "~a\n~a\n"
-                                           (or (narinfo-file-size narinfo) 0)
-                                           (or (narinfo-size narinfo) 0)))
-                                 (filter valid? substitutable))
-                       (newline)))
-                    (wtf
-                     (error "unknown `--query' command" wtf)))
+                  (process-query command
+                                 #:cache-url %cache-url
+                                 #:acl acl)
                   (loop (read-line)))))))
        (("--substitute" store-path destination)
         ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
-        (let* ((cache   (open-cache* %cache-url))
-               (narinfo (lookup-narinfo cache store-path))
-               (uri     (narinfo-uri narinfo)))
-          ;; Make sure it is signed and everything.
-          (assert-valid-narinfo narinfo)
-
-          ;; Tell the daemon what the expected hash of the Nar itself is.
-          (format #t "~a~%" (narinfo-hash narinfo))
-
-          (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%"
-                  store-path
-
-                  ;; Use the Nar size as an estimate of the installed size.
-                  (narinfo-size narinfo)
-                  (and=> (narinfo-size narinfo)
-                         (cute / <> (expt 2. 20))))
-          (let*-values (((raw download-size)
-                         ;; Note that Hydra currently generates Nars on the fly
-                         ;; and doesn't specify a Content-Length, so
-                         ;; DOWNLOAD-SIZE is #f in practice.
-                         (fetch uri #:buffered? #f #:timeout? #f))
-                        ((progress)
-                         (let* ((comp     (narinfo-compression narinfo))
-                                (dl-size  (or download-size
-                                              (and (equal? comp "none")
-                                                   (narinfo-size narinfo))))
-                                (progress (progress-proc (uri-abbreviation uri)
-                                                         dl-size
-                                                         (current-error-port))))
-                           (progress-report-port progress raw)))
-                        ((input pids)
-                         (decompressed-port (and=> (narinfo-compression narinfo)
-                                                   string->symbol)
-                                            progress)))
-            ;; Unpack the Nar at INPUT into DESTINATION.
-            (restore-file input destination)
-
-            ;; Skip a line after what 'progress-proc' printed.
-            (newline (current-error-port))
-
-            (every (compose zero? cdr waitpid) pids))))
+        (process-substitution store-path destination
+                              #:cache-url %cache-url
+                              #:acl (current-acl)))
        (("--version")
         (show-version-and-exit "guix substitute"))
        (("--help")
@@ -883,7 +909,6 @@ substituter disabled~%")
        (opts
         (leave (_ "~a: unrecognized options~%") opts))))))
 
-
 ;;; Local Variables:
 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
 ;;; End:
diff --git a/guix/store.scm b/guix/store.scm
index 39e5faf6c8..132b8a3ac4 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -37,6 +37,7 @@
   #:use-module (ice-9 popen)
   #:export (%daemon-socket-file
             %gc-roots-directory
+            %default-substitute-urls
 
             nix-server?
             nix-server-major-version
diff --git a/guix/tests.scm b/guix/tests.scm
index 16b8cc7f8a..cd8eda2f60 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -36,6 +36,7 @@
             network-reachable?
             shebang-too-long?
             mock
+            %test-substitute-urls
             %substitute-directory
             with-derivation-narinfo
             with-derivation-substitute
@@ -49,6 +50,12 @@
 ;;;
 ;;; Code:
 
+(define %test-substitute-urls
+  ;; URLs where to look for substitutes during tests.
+  (make-parameter
+   (or (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") list)
+       '())))
+
 (define (open-connection-for-tests)
   "Open a connection to the build daemon for tests purposes and return it."
   (guard (c ((nix-error? c)
@@ -57,7 +64,9 @@
              #f))
     (let ((store (open-connection)))
       ;; Make sure we build everything by ourselves.
-      (set-build-options store #:use-substitutes? #f)
+      (set-build-options store
+                         #:use-substitutes? #f
+                         #:substitute-urls (%test-substitute-urls))
 
       ;; Use the bootstrap Guile when running tests, so we don't end up
       ;; building everything in the temporary test store.