perform-download: Use (ice-9 sandbox) for mirrors.

"guix perform-download" is used to implement the daemon's "download" and
"git-download" builtin builders.  Because these are builtins, it runs without
any additional isolation beyond merely running as a build user.  In such a
context, allowing arbitrary user-supplied code to be evaluated will easily
lead to the build user being taken over, which can then be used to corrupt
future builds, enable exploitation of certain vulnerabilities, and in the case
of the rootless daemon completely take over guix-daemon.

Use (ice-9 sandbox) to ensure that only safe bindings are available during the
evaluation of the content-addressed-mirrors file.

* guix/perform-download.scm (%safe-bindings, %sandbox-module): new variables.
  (syntax-noop): new syntax.
  (eval-content-addressed-mirrors, assert-store-file,
   call-with-input-file/no-symlinks): new procedures.
  (perform-download): use assert-store-file to ensure files are in the store
  before being read.  Use call-with-input-file/no-symlinks for opening
  untrusted files.  Use eval-content-addressed-mirrors to evaluate the
  content-addressed-mirrors file.

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

guix/scripts/perform-download.scm

@@ -21,11 +21,16 @@
   #:use-module (guix scripts)
   #:use-module (guix derivations)
   #:use-module ((guix store) #:select (derivation-path? store-path?))
+  #:use-module ((guix build utils) #:select (store-file-name?
+                                             strip-store-file-name))
   #:autoload   (guix build download) (%download-methods url-fetch)
   #:autoload   (guix build git) (git-fetch-with-fallback)
   #:autoload   (guix config) (%git)
   #:use-module (ice-9 match)
-  #:export (guix-perform-download))
+  #:use-module (ice-9 sandbox)
+  #:export (guix-perform-download
+            ;; exported so that eval-in-sandbox can find this
+            syntax-noop))
 
 ;; This program is a helper for the daemon's 'download' built-in builder.
 
@@ -38,16 +43,68 @@
     ((_ drv () body ...)
      (begin body ...))))
 
-(define %user-module
-  ;; Module in which content-address mirror procedures are evaluated.
-  (let ((module (make-fresh-user-module)))
-    (module-use! module (resolve-interface '(guix base32)))
-    module))
+(define-syntax-rule (syntax-noop ...) #t)
+
+;; Bindings to be made available in the sandbox in which mirror procedures are
+;; evaluated.  We opt for a somewhat conservative selection.
+(define %safe-bindings
+  `( ;; Historically used, must be available for backwards compatibility
+    ((guile)
+     lambda begin define string-append symbol->string list quote
+     (noop . module-autoload!)
+     (noop . current-module))
+    ((guix base16) bytevector->base16-string base16-string->bytevector)
+    ((guix base32)
+     bytevector->base32-string bytevector->nix-base32-string
+     base32-string->bytevector nix-base32-string->bytevector)
+    ((guix scripts perform-download)
+     (syntax-noop . use-modules))
+    ;; Potentially useful for custom content-addressed-mirrors and future
+    ;; changes
+    ((guile) symbol?)
+    ((rnrs bytevectors)
+     bytevector? bytevector=? bytevector-length bytevector-u8-ref
+     bytevector->u8-list u8-list->bytevector utf8->string)
+    ,@core-bindings
+    ,@string-bindings
+    ,@list-bindings
+    ,@pair-bindings
+    ,@alist-bindings
+    ,@iteration-bindings
+    ,@number-bindings
+    ,@predicate-bindings))
+
+(define %sandbox-module
+  (make-sandbox-module %safe-bindings))
+
 (define* (read/safe #:optional (port (current-input-port)))
   (with-fluids ((read-eval? #f))
     (parameterize ((read-hash-procedures '()))
       (read port))))
 
+(define (eval-content-addressed-mirrors content-addressed-mirrors file algo hash)
+  "Evaluate the expression CONTENT-ADDRESSED-MIRRORS in a sandbox, and produce
+a list of wrapper procedures for safely calling the list of procedures that
+CONTENT-ADDRESSED-MIRRORS evaluates to."
+  (map const
+       (eval-in-sandbox `(map (lambda (proc)
+                                (proc ,file ',algo ,hash))
+                              (let ()
+                                ,content-addressed-mirrors))
+                        #:bindings %safe-bindings
+                        #:module %sandbox-module)))
+
+(define (assert-store-file file)
+  "Canonicalize FILE and exit if the result is not in the store.  Return the
+result of canonicalization."
+  (let ((canon (canonicalize-path file)))
+    (unless (store-file-name? canon)
+      (leave (G_ "~S is not in the store~%") canon))
+    canon))
+
+(define (call-with-input-file/no-symlinks file proc)
+  (call-with-port (open file (logior O_NOFOLLOW O_RDONLY))
+    proc))
 
 (define* (perform-download drv output
                            #:key print-build-trace?)
@@ -65,7 +122,13 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
     (unless url
       (leave (G_ "~a: missing URL~%") (derivation-file-name drv)))
 
-    (let* ((url        (call-with-input-string url read/safe))
+    (let* ((mirrors
+            (and=> mirrors assert-store-file))
+           (content-addressed-mirrors
+            (and=> content-addressed-mirrors assert-store-file))
+           (disarchive-mirrors
+            (and=> disarchive-mirrors assert-store-file))
+           (url        (call-with-input-string url read/safe))
            (drv-output (assoc-ref (derivation-outputs drv) "out"))
            (algo       (derivation-output-hash-algo drv-output))
            (hash       (derivation-output-hash drv-output)))
@@ -77,17 +140,26 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
               (url-fetch url output
                          #:print-build-trace? print-build-trace?
                          #:mirrors (if mirrors
-                                       (call-with-input-file mirrors read/safe)
+                                       (call-with-input-file/no-symlinks
+                                           mirrors
+                                         read/safe)
                                        '())
                          #:content-addressed-mirrors
                          (if content-addressed-mirrors
-                             (call-with-input-file content-addressed-mirrors
+                             (call-with-input-file/no-symlinks
+                                 content-addressed-mirrors
                                (lambda (port)
-                                 (eval (read/safe port) %user-module)))
+                                 (eval-content-addressed-mirrors
+                                  (read/safe port)
+                                  (strip-store-file-name output)
+                                  algo
+                                  hash)))
                              '())
                          #:disarchive-mirrors
                          (if disarchive-mirrors
-                             (call-with-input-file disarchive-mirrors read/safe)
+                             (call-with-input-file/no-symlinks
+                                 disarchive-mirrors
+                               read/safe)
                              '())
                          #:hashes `((,algo . ,hash))
 
@@ -165,8 +237,7 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
   (read-hash-procedures '())
 
   ;; This program must be invoked by guix-daemon under an unprivileged UID to
-  ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code
-  ;; execution via the content-addressed mirror procedures.  (That means we
+  ;; prevent things downloading from 'file:///etc/shadow'.  (That means we
   ;; exclude users who did not pass '--build-users-group'.)
   (with-error-handling
     (match args