guix/scripts/perform-download.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018, 2020 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 scripts)
  22   #:use-module (guix derivations)
  23   #:use-module ((guix store) #:select (derivation-path? store-path?))
  24   #:use-module (guix build download)
  25   #:use-module (ice-9 match)
  26   #:export (guix-perform-download))
  27
  28 ;; This program is a helper for the daemon's 'download' built-in builder.
  29
  30 (define-syntax derivation-let
  31   (syntax-rules ()
  32     ((_ drv ((id name) rest ...) body ...)
  33      (let ((id (assoc-ref (derivation-builder-environment-vars drv)
  34                           name)))
  35        (derivation-let drv (rest ...) body ...)))
  36     ((_ drv () body ...)
  37      (begin body ...))))
  38
  39 (define %user-module
  40   ;; Module in which content-address mirror procedures are evaluated.
  41   (let ((module (make-fresh-user-module)))
  42     (module-use! module (resolve-interface '(guix base32)))
  43     module))
  44
  45 (define* (perform-download drv #:optional output
  46                            #:key print-build-trace?)
  47   "Perform the download described by DRV, a fixed-output derivation, to
  48 OUTPUT.
  49
  50 Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the
  51 actual output is different from that when we're doing a 'bmCheck' or
  52 'bmRepair' build."
  53   (derivation-let drv ((url "url")
  54                        (output* "out")
  55                        (executable "executable")
  56                        (mirrors "mirrors")
  57                        (content-addressed-mirrors "content-addressed-mirrors"))
  58     (unless url
  59       (leave (G_ "~a: missing URL~%") (derivation-file-name drv)))
  60
  61     (let* ((output     (or output output*))
  62            (url        (call-with-input-string url read))
  63            (drv-output (assoc-ref (derivation-outputs drv) "out"))
  64            (algo       (derivation-output-hash-algo drv-output))
  65            (hash       (derivation-output-hash drv-output)))
  66       (unless (and algo hash)
  67         (leave (G_ "~a is not a fixed-output derivation~%")
  68                (derivation-file-name drv)))
  69
  70       ;; We're invoked by the daemon, which gives us write access to OUTPUT.
  71       (when (url-fetch url output
  72                        #:print-build-trace? print-build-trace?
  73                        #:mirrors (if mirrors
  74                                      (call-with-input-file mirrors read)
  75                                      '())
  76                        #:content-addressed-mirrors
  77                        (if content-addressed-mirrors
  78                            (call-with-input-file content-addressed-mirrors
  79                              (lambda (port)
  80                                (eval (read port) %user-module)))
  81                            '())
  82                        #:hashes `((,algo . ,hash))
  83
  84                        ;; Since DRV's output hash is known, X.509 certificate
  85                        ;; validation is pointless.
  86                        #:verify-certificate? #f)
  87         (when (and executable (string=? executable "1"))
  88           (chmod output #o755))))))
  89
  90 (define (assert-low-privileges)
  91   (when (zero? (getuid))
  92     (leave (G_ "refusing to run with elevated privileges (UID ~a)~%")
  93            (getuid))))
  94
  95 (define-command (guix-perform-download . args)
  96   (category internal)
  97   (synopsis "perform download described by fixed-output derivations")
  98
  99   ;; This is an "out-of-band" download in that this code is executed directly
 100   ;; by the daemon and not explicitly described as an input of the derivation.
 101   ;; This allows us to sidestep bootstrapping problems, such as downloading
 102   ;; the source code of GnuTLS over HTTPS before we have built GnuTLS.  See
 103   ;; <https://bugs.gnu.org/22774>.
 104
 105   (define print-build-trace?
 106     (match (getenv "_NIX_OPTIONS")
 107       (#f #f)
 108       (str (string-contains str "print-extended-build-trace=1"))))
 109
 110   ;; This program must be invoked by guix-daemon under an unprivileged UID to
 111   ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code
 112   ;; execution via the content-addressed mirror procedures.  (That means we
 113   ;; exclude users who did not pass '--build-users-group'.)
 114   (with-error-handling
 115     (match args
 116       (((? derivation-path? drv) (? store-path? output))
 117        (assert-low-privileges)
 118        (perform-download (read-derivation-from-file drv)
 119                          output
 120                          #:print-build-trace? print-build-trace?))
 121       (((? derivation-path? drv))                 ;backward compatibility
 122        (assert-low-privileges)
 123        (perform-download (read-derivation-from-file drv)
 124                          #:print-build-trace? print-build-trace?))
 125       (("--version")
 126        (show-version-and-exit))
 127       (x
 128        (leave
 129         (G_ "fixed-output derivation and output file name expected~%"))))))
 130
 131 ;; Local Variables:
 132 ;; eval: (put 'derivation-let 'scheme-indent-function 2)
 133 ;; End:
 134
 135 ;; perform-download.scm ends here