1 files changed, 113 insertions, 0 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