guix/scripts/perform-download.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix scripts perform-download)
  20   #:use-module (guix ui)
  21   #:use-module (guix derivations)
  22   #:use-module ((guix store) #:select (derivation-path? store-path?))
  23   #:use-module (guix build download)
  24   #:use-module (ice-9 match)
  25   #:export (guix-perform-download))
  26
  27 ;; This program is a helper for the daemon's 'download' built-in builder.
  28
  29 (define-syntax derivation-let
  30   (syntax-rules ()
  31     ((_ drv ((id name) rest ...) body ...)
  32      (let ((id (assoc-ref (derivation-builder-environment-vars drv)
  33                           name)))
  34        (derivation-let drv (rest ...) body ...)))
  35     ((_ drv () body ...)
  36      (begin body ...))))
  37
  38 (define %user-module
  39   ;; Module in which content-address mirror procedures are evaluated.
  40   (let ((module (make-fresh-user-module)))
  41     (module-use! module (resolve-interface '(guix base32)))
  42     module))
  43
  44 (define* (perform-download drv #:optional output)
  45   "Perform the download described by DRV, a fixed-output derivation, to
  46 OUTPUT.
  47
  48 Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the
  49 actual output is different from that when we're doing a 'bmCheck' or
  50 'bmRepair' build."
  51   (derivation-let drv ((url "url")
  52                        (output* "out")
  53                        (executable "executable")
  54                        (mirrors "mirrors")
  55                        (content-addressed-mirrors "content-addressed-mirrors"))
  56     (unless url
  57       (leave (_ "~a: missing URL~%") (derivation-file-name drv)))
  58
  59     (let* ((output     (or output output*))
  60            (url        (call-with-input-string url read))
  61            (drv-output (assoc-ref (derivation-outputs drv) "out"))
  62            (algo       (derivation-output-hash-algo drv-output))
  63            (hash       (derivation-output-hash drv-output)))
  64       (unless (and algo hash)
  65         (leave (_ "~a is not a fixed-output derivation~%")
  66                (derivation-file-name drv)))
  67
  68       ;; We're invoked by the daemon, which gives us write access to OUTPUT.
  69       (when (url-fetch url output
  70                        #:mirrors (if mirrors
  71                                      (call-with-input-file mirrors read)
  72                                      '())
  73                        #:content-addressed-mirrors
  74                        (if content-addressed-mirrors
  75                            (call-with-input-file content-addressed-mirrors
  76                              (lambda (port)
  77                                (eval (read port) %user-module)))
  78                            '())
  79                        #:hashes `((,algo . ,hash))
  80
  81                        ;; Since DRV's output hash is known, X.509 certificate
  82                        ;; validation is pointless.
  83                        #:verify-certificate? #f)
  84         (when (and executable (string=? executable "1"))
  85           (chmod output #o755))))))
  86
  87 (define (assert-low-privileges)
  88   (when (zero? (getuid))
  89     (leave (_ "refusing to run with elevated privileges (UID ~a)~%")
  90            (getuid))))
  91
  92 (define (guix-perform-download . args)
  93   "Perform the download described by the given fixed-output derivation.
  94
  95 This is an \"out-of-band\" download in that this code is executed directly by
  96 the daemon and not explicitly described as an input of the derivation.  This
  97 allows us to sidestep bootstrapping problems, such downloading the source code
  98 of GnuTLS over HTTPS, before we have built GnuTLS.  See
  99 <http://bugs.gnu.org/22774>."
 100
 101   ;; This program must be invoked by guix-daemon under an unprivileged UID to
 102   ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code
 103   ;; execution via the content-addressed mirror procedures.  (That means we
 104   ;; exclude users who did not pass '--build-users-group'.)
 105   (with-error-handling
 106     (match args
 107       (((? derivation-path? drv) (? store-path? output))
 108        (assert-low-privileges)
 109        (perform-download (call-with-input-file drv read-derivation)
 110                          output))
 111       (((? derivation-path? drv))                 ;backward compatibility
 112        (assert-low-privileges)
 113        (perform-download (call-with-input-file drv read-derivation)))
 114       (("--version")
 115        (show-version-and-exit))
 116       (x
 117        (leave
 118         (_ "fixed-output derivation and output file name expected~%"))))))
 119
 120 ;; Local Variables:
 121 ;; eval: (put 'derivation-let 'scheme-indent-function 2)
 122 ;; End:
 123
 124 ;; perform-download.scm ends here