diff options
Diffstat (limited to 'guix/scripts/perform-download.scm')
| -rw-r--r-- | guix/scripts/perform-download.scm | 116 |
1 files changed, 99 insertions, 17 deletions
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 5079d0ea71..f74aa83f0d 100644 --- a/guix/scripts/perform-download.scm +++ b/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,11 +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?) @@ -60,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)) + (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))) @@ -68,21 +136,30 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or (when (parameterize ((%download-methods (and download-methods (call-with-input-string download-methods - read)))) + read/safe)))) (url-fetch url output #:print-build-trace? print-build-trace? #:mirrors (if mirrors - (call-with-input-file mirrors read) + (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 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) + (call-with-input-file/no-symlinks + disarchive-mirrors + read/safe) '()) #:hashes `((,algo . ,hash)) @@ -108,9 +185,9 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or (unless commit (leave (G_ "~a: missing Git commit~%") (derivation-file-name drv))) - (let* ((url (call-with-input-string url read)) + (let* ((url (call-with-input-string url read/safe)) (recursive? (and recursive? - (call-with-input-string recursive? read))) + (call-with-input-string recursive? read/safe))) (drv-output (assoc-ref (derivation-outputs drv) "out")) (algo (derivation-output-hash-algo drv-output)) (hash (derivation-output-hash drv-output))) @@ -123,7 +200,7 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or (parameterize ((%download-methods (and download-methods (call-with-input-string download-methods - read)))) + read/safe)))) ;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are ;; different, hence the #:item argument below. (git-fetch-with-fallback url commit output @@ -153,9 +230,14 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or (#f #f) (str (string-contains str "print-extended-build-trace=1")))) + ;; We read untrusted input, best to be sure this is #f! + (fluid-set! read-eval? #f) + ;; ... and out of an abundance of caution, remove the ability to use '#.' + ;; constructs entirely + (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 |