You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

114 lines
4.6 KiB

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