Merge branch 'master' into python-build-system

4 files changed, 191 insertions, 26 deletions

diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index ec30b05ac0..dffff79729 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -23,12 +23,15 @@
   #:use-module (guix hash)
   #:use-module (guix utils)
   #:use-module (guix base32)
-  #:use-module (guix download)
-  #:use-module ((guix build download) #:select (current-terminal-columns))
-  #:use-module ((guix build syscalls) #:select (terminal-columns))
+  #:use-module ((guix download) #:hide (url-fetch))
+  #:use-module ((guix build download)
+                #:select (url-fetch current-terminal-columns))
+  #:use-module ((guix build syscalls)
+                #:select (terminal-columns))
   #:use-module (web uri)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
@@ -39,15 +42,31 @@
 ;;; Command-line options.
 ;;;
 
+(define (download-to-file url file)
+  "Download the file at URI to FILE.  Return FILE."
+  (let ((uri (string->uri url)))
+    (match (uri-scheme uri)
+      ((or 'file #f)
+       (copy-file (uri-path uri) file))
+      (_
+       (url-fetch url file)))
+    file))
+
+(define* (download-to-store* url #:key (verify-certificate? #t))
+  (with-store store
+    (download-to-store store url
+                       #:verify-certificate? verify-certificate?)))
+
 (define %default-options
   ;; Alist of default option values.
   `((format . ,bytevector->nix-base32-string)
-    (verify-certificate? . #t)))
+    (verify-certificate? . #t)
+    (download-proc . ,download-to-store*)))
 
 (define (show-help)
   (display (_ "Usage: guix download [OPTION] URL
-Download the file at URL, add it to the store, and print its store path
-and the hash of its contents.
+Download the file at URL to the store or to the given file, and print its
+file name and the hash of its contents.
 
 Supported formats: 'nix-base32' (default), 'base32', and 'base16'
 ('hex' and 'hexadecimal' can be used as well).\n"))
@@ -56,6 +75,8 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
   (format #t (_ "
       --no-check-certificate
                          do not validate the certificate of HTTPS servers "))
+  (format #f (_ "
+  -o, --output=FILE      download to FILE"))
   (newline)
   (display (_ "
   -h, --help             display this help and exit"))
@@ -84,6 +105,12 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
         (option '("no-check-certificate") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'verify-certificate? #f result)))
+        (option '(#\o "output") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'download-proc
+                              (lambda* (url #:key verify-certificate?)
+                                (download-to-file url arg))
+                              (alist-delete 'download result))))
 
         (option '(#\h "help") #f #f
                 (lambda args
@@ -113,24 +140,17 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
 
   (with-error-handling
     (let* ((opts  (parse-options))
-           (store (open-connection))
            (arg   (or (assq-ref opts 'argument)
                       (leave (_ "no download URI was specified~%"))))
            (uri   (or (string->uri arg)
                       (leave (_ "~a: failed to parse URI~%")
                              arg)))
-           (path  (case (uri-scheme uri)
-                    ((file)
-                     (add-to-store store (basename (uri-path uri))
-                                   #f "sha256" (uri-path uri)))
-                    (else
-                     (parameterize ((current-terminal-columns
-                                     (terminal-columns)))
-                       (download-to-store store (uri->string uri)
-                                          (basename (uri-path uri))
-                                          #:verify-certificate?
-                                          (assoc-ref opts
-                                                     'verify-certificate?))))))
+           (fetch (assq-ref opts 'download-proc))
+           (path  (parameterize ((current-terminal-columns
+                                  (terminal-columns)))
+                    (fetch arg
+                           #:verify-certificate?
+                           (assq-ref opts 'verify-certificate?))))
            (hash  (call-with-input-file
                       (or path
                           (leave (_ "~a: download failed~%")
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index be29e36ce1..9b991786c3 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -67,6 +67,7 @@
             check-home-page
             check-source
             check-source-file-name
+            check-mirror-url
             check-license
             check-vulnerabilities
             check-formatting
@@ -600,6 +601,14 @@ descriptions maintained upstream."
                  (location->string loc) (package-full-name package)
                  (fill-paragraph (escape-quotes upstream) 77 7)))))))
 
+(define (origin-uris origin)
+  "Return the list of URIs (strings) for ORIGIN."
+  (match (origin-uri origin)
+    ((? string? uri)
+     (list uri))
+    ((uris ...)
+     uris)))
+
 (define (check-source package)
   "Emit a warning if PACKAGE has an invalid 'source' field, or if that
 'source' is not reachable."
@@ -616,10 +625,7 @@ descriptions maintained upstream."
   (let ((origin (package-source package)))
     (when (and origin
                (eqv? (origin-method origin) url-fetch))
-      (let* ((strings (origin-uri origin))
-             (uris (if (list? strings)
-                       (map string->uri strings)
-                       (list (string->uri strings)))))
+      (let ((uris (map string->uri (origin-uris origin))))
 
         ;; Just make sure that at least one of the URIs is valid.
         (call-with-values
@@ -659,6 +665,31 @@ descriptions maintained upstream."
                     (_ "the source file name should contain the package name")
                     'source))))
 
+(define (check-mirror-url package)
+  "Check whether PACKAGE uses source URLs that should be 'mirror://'."
+  (define (check-mirror-uri uri)                  ;XXX: could be optimized
+    (let loop ((mirrors %mirrors))
+      (match mirrors
+        (()
+         #t)
+        (((mirror-id mirror-urls ...) rest ...)
+         (match (find (cut string-prefix? <> uri) mirror-urls)
+           (#f
+            (loop rest))
+           (prefix
+            (emit-warning package
+                          (format #f (_ "URL should be \
+'mirror://~a/~a'")
+                                  mirror-id
+                                  (string-drop uri (string-length prefix)))
+                          'source)))))))
+
+  (let ((origin (package-source package)))
+    (when (and (origin? origin)
+               (eqv? (origin-method origin) url-fetch))
+      (let ((uris (origin-uris origin)))
+        (for-each check-mirror-uri uris)))))
+
 (define (check-derivation package)
   "Emit a warning if we fail to compile PACKAGE to a derivation."
   (catch #t
@@ -901,6 +932,10 @@ or a list thereof")
      (description "Validate source URLs")
      (check       check-source))
    (lint-checker
+     (name        'mirror-url)
+     (description "Suggest 'mirror://' URLs")
+     (check       check-mirror-url))
+   (lint-checker
      (name        'source-file-name)
      (description "Validate file names of sources")
      (check       check-source-file-name))
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/scripts/system.scm b/guix/scripts/system.scm
index 71ddccfa61..bb373a6726 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -77,9 +77,6 @@
 ;;; Installation.
 ;;;
 
-;; TODO: Factorize.
-(define references*
-  (store-lift references))
 (define topologically-sorted*
   (store-lift topologically-sorted))