diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/scripts/perform-download.scm | 113 | ||||
| -rw-r--r-- | guix/ui.scm | 3 |
2 files changed, 115 insertions, 1 deletions
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm new file mode 100644 index 0000000000..0d2e7089aa --- /dev/null +++ b/guix/scripts/perform-download.scm @@ -0,0 +1,113 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts perform-download) + #:use-module (guix ui) + #:use-module (guix derivations) + #:use-module ((guix store) #:select (derivation-path?)) + #:use-module (guix build download) + #:use-module (ice-9 match) + #:export (guix-perform-download)) + +;; This program is a helper for the daemon's 'download' built-in builder. + +(define-syntax derivation-let + (syntax-rules () + ((_ drv ((id name) rest ...) body ...) + (let ((id (assoc-ref (derivation-builder-environment-vars drv) + name))) + (derivation-let drv (rest ...) body ...))) + ((_ 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 (perform-download drv) + "Perform the download described by DRV, a fixed-output derivation." + (derivation-let drv ((url "url") + (output "out") + (executable "executable") + (mirrors "mirrors") + (content-addressed-mirrors "content-addressed-mirrors")) + (unless url + (leave (_ "~a: missing URL~%") (derivation-file-name drv))) + + (let* ((url (call-with-input-string url read)) + (drv-output (assoc-ref (derivation-outputs drv) "out")) + (algo (derivation-output-hash-algo drv-output)) + (hash (derivation-output-hash drv-output))) + (unless (and algo hash) + (leave (_ "~a is not a fixed-output derivation~%") + (derivation-file-name drv))) + + ;; We're invoked by the daemon, which gives us write access to OUTPUT. + (when (url-fetch url output + #:mirrors (if mirrors + (call-with-input-file mirrors read) + '()) + #:content-addressed-mirrors + (if content-addressed-mirrors + (call-with-input-file content-addressed-mirrors + (lambda (port) + (eval (read port) %user-module))) + '()) + #:hashes `((,algo . ,hash)) + + ;; Since DRV's output hash is known, X.509 certificate + ;; validation is pointless. + #:verify-certificate? #f) + (when (and executable (string=? executable "1")) + (chmod output #o755)))))) + +(define (assert-low-privileges) + (when (zero? (getuid)) + (leave (_ "refusing to run with elevated privileges (UID ~a)~%") + (getuid)))) + +(define (guix-perform-download . args) + "Perform the download described by the given fixed-output derivation. + +This is an \"out-of-band\" download in that this code is executed directly by +the daemon and not explicitly described as an input of the derivation. This +allows us to sidestep bootstrapping problems, such downloading the source code +of GnuTLS over HTTPS, before we have built GnuTLS. See +<http://bugs.gnu.org/22774>." + (with-error-handling + (match args + (((? derivation-path? drv)) + ;; 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 exclude users who did not pass + ;; '--build-users-group'.) + (assert-low-privileges) + (perform-download (call-with-input-file drv read-derivation))) + (("--version") + (show-version-and-exit)) + (x + (leave (_ "fixed-output derivation name expected~%")))))) + +;; Local Variables: +;; eval: (put 'derivation-let 'scheme-indent-function 2) +;; End: + +;; perform-download.scm ends here diff --git a/guix/ui.scm b/guix/ui.scm index 9af8648211..b9fbbfd0e3 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1184,7 +1184,8 @@ optionally contain a version number and an output name, as in these examples: (define (show-guix-help) (define (internal? command) - (member command '("substitute" "authenticate" "offload"))) + (member command '("substitute" "authenticate" "offload" + "perform-download"))) (format #t (_ "Usage: guix COMMAND ARGS... Run COMMAND with ARGS.\n")) |