scripts: substitute: restrict where "file://" URIs can be used [security fix].

There are two potential places where file:// URIs could be used in 'guix
substitute':
1. The substitute urls, which are used for fetching narinfos.  These can come
   from the daemon, via daemon option "substitute-urls", from the client, via
   daemon option "untrusted-substitute-urls", or from 'guix discover'.  The
   latter two must not be allowed to provide file:// URIs, since that could be
   used to cause the daemon to read private files, files in /proc or /dev,
   etc, and various parts of those files may show up in the backtrace from
   'guix substitute'.

2. The narinfos themselves, which may offer arbitrarily many URIs to download
   the nar of the store item in question.  These URIs do not need to be
   in the signed portion of the narinfo, so they may be attacker-controlled.
   These should also not be allowed to provide file:// URIs, with the sole
   exception being in the case of the test suite for the sake of simplifying
   the tests.

To accomplish this, we error out of 'guix substitute' if
"untrusted-substitute-urls" includes a file:// URI, and we filter out all
file:// URIs from those provided by 'guix discover'.  We also ignore all
narinfos containing file:// URIs unless '%allow-unsafe-substitute-uris?' is #t.

* guix/scripts/substitute.scm (%allow-unsafe-substitute-uris?,
  %allow-unsafe-narinfo-uris?): new parameters.
  (process-substitution, process-substitution/fallback): honor
  '%allow-unsafe-substitute-uris?'.
  (uri-safe?, narinfo-uris-safe?, assert-safe-uris): new procedures.
  (%default-substitute-urls): use assert-safe-uris for the
  "untrusted-substitute-urls" daemon option.
  (%local-substitute-urls): filter out file:// URIs.
* tests/substitute.scm ("file:// URI prohibited by default"): new test.  Set
  '%allow-unsafe-substitute-uris?' to #t after it finishes.

Change-Id: I34d7e58b5a01c7cc61b52fcd61b547bba2ce4300
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

2 files changed, 100 insertions, 35 deletions

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 455f5a23461..49f5389fe27 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -58,6 +58,7 @@
   #:use-module (web response)
   #:use-module (guix http-client)
   #:export (%allow-unauthenticated-substitutes?
+            %allow-unsafe-substitute-uris?
             %reply-file-descriptor
 
             substitute-urls
@@ -90,6 +91,19 @@ disabled!~%"))
    (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
           (cut string-ci=? <> "yes"))))
 
+(define %allow-unsafe-substitute-uris?
+  ;; Whether to allow substitutes with a "file://" URI.  These are useful for
+  ;; testing purposes but should never be allowed otherwise, as the URIs
+  ;; contained in narinfos are not signed and could point to any
+  ;; attacker-controlled location.  Use GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES
+  ;; as a way to tell when we're testing.
+  (make-parameter (%allow-unauthenticated-substitutes?)))
+
+(define %allow-unsafe-narinfo-uris?
+  ;; Like %allow-unsafe-substitute-uris?, but affecting the urls used to fetch
+  ;; narinfos.
+  (make-parameter (%allow-unauthenticated-substitutes?)))
+
 (define (at-most max-length lst)
   "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
 return its MAX-LENGTH first elements and its tail."
@@ -368,6 +382,21 @@ server certificates."
                     (drain-input socket)
                     socket))))))))
 
+(define (uri-safe? uri)
+  "Return a boolean indicating whether URI, which is either a uri or its
+string representation, is generally safe to use without requiring any trust."
+  (let ((uri (if (uri? uri)
+                 uri
+                 (string->uri uri))))
+    (and uri
+         (case (uri-scheme uri)
+           ((#f file) #f)
+           (else #t)))))
+
+(define (narinfo-uris-safe? narinfo)
+  (or (%allow-unsafe-substitute-uris?)
+      (every uri-safe? (narinfo-uris narinfo))))
+
 (define* (process-substitution/fallback narinfo destination
                                         #:key cache-urls acl
                                         deduplicate? print-build-trace?
@@ -391,9 +420,10 @@ way to download the nar."
                                #:open-connection
                                open-connection-for-uri/cached)
          ((alternate)
-          (if (or (equivalent-narinfo? narinfo alternate)
-                  (valid-narinfo? alternate acl)
-                  (%allow-unauthenticated-substitutes?))
+          (if (and (narinfo-uris-safe? alternate)
+                   (or (equivalent-narinfo? narinfo alternate)
+                       (valid-narinfo? alternate acl)
+                       (%allow-unauthenticated-substitutes?)))
               (guard (c ((or (http-get-error? c)
                              (network-error? c))
                          (when (http-get-error? c)
@@ -429,6 +459,16 @@ PORT."
                         (const #t)
                         (cut valid-narinfo? <> acl))))
 
+  (define (fallback)
+    (process-substitution/fallback narinfo destination
+                                   #:cache-urls cache-urls
+                                   #:acl acl
+                                   #:deduplicate? deduplicate?
+                                   #:print-build-trace?
+                                   print-build-trace?
+                                   #:fast-decompression?
+                                   fast-decompression?))
+
   (unless narinfo
     (raise
      (formatted-message
@@ -437,33 +477,30 @@ PORT."
 
   (let ((expected-hash
          actual-hash
-         (guard
-             (c ((or (http-get-error? c)
-                     (network-error? c))
-                 (when (http-get-error? c)
-                   (warning (G_ "download from '~a' failed: ~a, ~s~%")
-                            (uri->string (http-get-error-uri c))
-                            (http-get-error-code c)
-                            (http-get-error-reason c)))
-                 (format
-                  (current-error-port)
-                  (G_ "retrying download of '~a' with other substitute URLs...~%")
-                  store-item)
-                 (process-substitution/fallback narinfo destination
-                                                #:cache-urls cache-urls
-                                                #:acl acl
-                                                #:deduplicate? deduplicate?
-                                                #:print-build-trace?
-                                                print-build-trace?
-                                                #:fast-decompression?
-                                                fast-decompression?)))
-           (download-nar narinfo destination
-                         #:deduplicate? deduplicate?
-                         #:print-build-trace? print-build-trace?
-                         #:fast-decompression? fast-decompression?
-                         #:open-connection-for-uri
-                         open-connection-for-uri/cached
-                         #:keep-alive? #t))))
+         (cond
+          ((narinfo-uris-safe? narinfo)
+           (guard
+               (c ((or (http-get-error? c)
+                       (network-error? c))
+                   (when (http-get-error? c)
+                     (warning (G_ "download from '~a' failed: ~a, ~s~%")
+                              (uri->string (http-get-error-uri c))
+                              (http-get-error-code c)
+                              (http-get-error-reason c)))
+                   (format
+                    (current-error-port)
+                    (G_ "retrying download of '~a' with other substitute URLs...~%")
+                    store-item)
+                   (fallback)))
+             (download-nar narinfo destination
+                           #:deduplicate? deduplicate?
+                           #:print-build-trace? print-build-trace?
+                           #:fast-decompression? fast-decompression?
+                           #:open-connection-for-uri
+                           open-connection-for-uri/cached
+                           #:keep-alive? #t)))
+          (else
+           (fallback)))))
     (values narinfo
             expected-hash
             actual-hash)))
@@ -519,10 +556,17 @@ substitutes may be unavailable\n")))))
 found."
       (assoc-ref (force options) option))))
 
+(define (assert-safe-uris uris)
+  (unless (or (%allow-unsafe-narinfo-uris?)
+              (every uri-safe? uris))
+    (leave (G_ "unsafe or invalid URI in ~S~%") uris))
+  uris)
+
 (define %default-substitute-urls
-  (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client
-                    (find-daemon-option "substitute-urls"))          ;admin
-                string-tokenize)
+  (match (or (and=> (find-daemon-option "untrusted-substitute-urls") ;client
+                    (compose assert-safe-uris string-tokenize))
+             (and=> (find-daemon-option "substitute-urls") ;admin
+                    string-tokenize))
     ((urls ...)
      urls)
     (#f
@@ -558,8 +602,9 @@ is shorter than MAX elements, then it is directly returned."
   (let* ((option (find-daemon-option "discover"))
          (discover? (and option (string=? option "true"))))
     (if discover?
-     (randomize-substitute-urls (read-substitute-urls))
-     '())))
+        (randomize-substitute-urls (filter uri-safe?
+                                           (read-substitute-urls)))
+        '())))
 
 (define substitute-urls
   ;; List of substitute URLs.
diff --git a/tests/substitute.scm b/tests/substitute.scm
index cd75d56b981..10b74db084e 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -206,6 +206,26 @@ a file for NARINFO."
 ;; daemon.
 (%reply-file-descriptor #f)
 
+(test-equal "file:// URI prohibited by default"
+  "not-found\n"
+  (with-output-to-string
+    (lambda ()
+      (%allow-unsafe-substitute-uris? #f)
+      (let ((narinfo %narinfo))
+        (with-narinfo (string-append narinfo "Signature: "
+                                     (signature-field narinfo) "\n")
+          (call-with-temporary-directory
+           (lambda (directory)
+             (with-input-from-string (string-append
+                                      "substitute " (%store-prefix)
+                                      "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo "
+                                      directory "/shouldnotbewritten\n")
+               (lambda ()
+                 (guix-substitute "--substitute"))))))))))
+
+;; Allow these for ease of testing for the rest of the tests
+(%allow-unsafe-substitute-uris? #t)
+
 
 (test-equal "query narinfo without signature"
   ""                                              ; not substitutable