Merge branch 'master' into core-updates

Conflicts:
	gnu/packages/make-bootstrap.scm

8 files changed, 141 insertions, 19 deletions

diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm
index af54f51419..85a3c697e3 100644
--- a/guix/build-system/trivial.scm
+++ b/guix/build-system/trivial.scm
@@ -54,7 +54,7 @@ ignored."
                               search-paths native-search-paths)
   "Like `trivial-build', but in a cross-compilation context."
   (build-expression->derivation store name system
-                                `(begin (define %target ,target) ,builder)
+                                `(let ((%target ,target)) ,builder)
                                 (append native-inputs inputs)
                                 #:outputs outputs
                                 #:modules modules
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 53e6b2363c..dcce0bfc89 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -28,7 +28,9 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
-  #:export (url-fetch))
+  #:export (url-fetch
+            progress-proc
+            uri-abbreviation))
 
 ;;; Commentary:
 ;;;
diff --git a/guix/derivations.scm b/guix/derivations.scm
index cf329819c4..3c433a2685 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -469,8 +469,9 @@ in SIZE bytes."
               (drv    (make-derivation outputs inputs sources
                                        system builder args env-vars)))
          (sha256
-          (string->utf8 (call-with-output-string
-                         (cut write-derivation drv <>))))))))))
+          (with-fluids ((%default-port-encoding "UTF-8"))
+            (string->utf8 (call-with-output-string
+                           (cut write-derivation drv <>)))))))))))
 
 (define (store-path type hash name)               ; makeStorePath
   "Return the store path for NAME/HASH/TYPE."
diff --git a/guix/download.scm b/guix/download.scm
index 99353be8b0..fc6c815792 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -148,7 +148,14 @@
        "ftp://ftp.osuosl.org/pub/CPAN/"
        "ftp://ftp.nara.wide.ad.jp/pub/CPAN/"
        "http://mirrors.163.com/cpan/"
-       "ftp://cpan.mirror.ac.za/"))))
+       "ftp://cpan.mirror.ac.za/")
+      (imagemagick       ; from http://www.imagemagick.org/script/download.php
+       "http://mirror.checkdomain.de/imagemagick/"
+       "ftp://gd.tuwien.ac.at/pub/graphics/ImageMagick/"
+       "http://www.imagemagick.org/download"
+       "ftp://mirror.searchdaimon.com/ImageMagick"
+       "http://mirror.is.co.za/pub/imagemagick/"
+       "ftp://mirror.aarnet.edu.au/pub/imagemagick/"))))
 
 (define (gnutls-derivation store system)
   "Return the GnuTLS derivation for SYSTEM."
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index cecb68ec36..77ec7635de 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -51,6 +51,8 @@ Invoke the garbage collector.\n"))
   (display (_ "
       --references       list the references of PATHS"))
   (display (_ "
+  -R, --requisites       list the requisites of PATHS"))
+  (display (_ "
       --referrers        list the referrers of PATHS"))
   (newline)
   (display (_ "
@@ -128,6 +130,10 @@ interpreted."
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-references
                               (alist-delete 'action result))))
+        (option '(#\R "requisites") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'action 'list-requisites
+                              (alist-delete 'action result))))
         (option '("referrers") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-referrers
@@ -189,6 +195,8 @@ interpreted."
          (delete-paths store paths))
         ((list-references)
          (list-relatives references))
+        ((list-requisites)
+         (list-relatives requisites))
         ((list-referrers)
          (list-relatives referrers))
         ((list-dead)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 69b7efd154..11301ccff2 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -846,9 +846,13 @@ more information.~%"))
                                                   (current-error-port)
                                                   (%make-void-port "w"))))
                                 (build-derivations (%store) (list prof-drv)))
-                              (begin
+                              (let ((count (length packages)))
                                 (switch-symlinks name prof)
                                 (switch-symlinks profile name)
+                                (format #t (N_ "~a package in profile~%"
+                                               "~a packages in profile~%"
+                                               count)
+                                        count)
                                 (display-search-paths packages
                                                       profile))))))))))
 
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 13c382877b..271a22541a 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -24,12 +24,15 @@
   #:use-module (guix records)
   #:use-module (guix nar)
   #:use-module ((guix build utils) #:select (mkdir-p))
+  #:use-module ((guix build download)
+                #:select (progress-proc uri-abbreviation))
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 format)
   #:use-module (ice-9 ftw)
+  #:use-module (ice-9 binary-ports)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
@@ -117,7 +120,38 @@ pairs."
           (else
            (error "unmatched line" line)))))
 
-(define* (fetch uri #:key (buffered? #t))
+(define %fetch-timeout
+  ;; Number of seconds after which networking is considered "slow".
+  3)
+
+(define-syntax-rule (with-timeout duration handler body ...)
+  "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
+again."
+  (begin
+    (sigaction SIGALRM
+      (lambda (signum)
+        (sigaction SIGALRM SIG_DFL)
+        handler))
+    (alarm duration)
+    (call-with-values
+        (lambda ()
+          (let try ()
+            (catch 'system-error
+              (lambda ()
+                body ...)
+              (lambda args
+                ;; The SIGALRM triggers EINTR.  When that happens, try again.
+                ;; Note: SA_RESTART cannot be used because of
+                ;; <http://bugs.gnu.org/14640>.
+                (if (= EINTR (system-error-errno args))
+                    (try)
+                    (apply throw args))))))
+      (lambda result
+        (alarm 0)
+        (sigaction SIGALRM SIG_DFL)
+        (apply values result)))))
+
+(define* (fetch uri #:key (buffered? #t) (timeout? #t))
   "Return a binary input port to URI and the number of bytes it's expected to
 provide."
   (case (uri-scheme uri)
@@ -127,7 +161,21 @@ provide."
          (setvbuf port _IONBF))
        (values port (stat:size (stat port)))))
     ((http)
-     (http-fetch uri #:text? #f #:buffered? buffered?))))
+     ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once.  So
+     ;; honor TIMEOUT? to disable the timeout when fetching a nar.
+     ;;
+     ;; Test this with:
+     ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
+     ;; and then cancel with:
+     ;;   sudo tc qdisc del dev eth0 root
+     (with-timeout (if (or timeout? (version>? (version) "2.0.5"))
+                       %fetch-timeout
+                       0)
+       (begin
+         (warning (_ "while fetching ~a: server is unresponsive~%")
+                  (uri->string uri))
+         (warning (_ "try `--no-substitutes' if the problem persists~%")))
+       (http-fetch uri #:text? #f #:buffered? buffered?)))))
 
 (define-record-type <cache>
   (%make-cache url store-directory wants-mass-query?)
@@ -353,7 +401,8 @@ indefinitely."
       (cute write (time-second now) <>))))
 
 (define (decompressed-port compression input)
-  "Return an input port where INPUT is decompressed according to COMPRESSION."
+  "Return an input port where INPUT is decompressed according to COMPRESSION,
+along with a list of PIDs to wait for."
   (match compression
     ("none"  (values input '()))
     ("bzip2" (filtered-port `(,%bzip2 "-dc") input))
@@ -361,6 +410,24 @@ indefinitely."
     ("gzip"  (filtered-port `(,%gzip "-dc") input))
     (else    (error "unsupported compression scheme" compression))))
 
+(define (progress-report-port report-progress port)
+  "Return a port that calls REPORT-PROGRESS every time something is read from
+PORT.  REPORT-PROGRESS is a two-argument procedure such as that returned by
+`progress-proc'."
+  (define total 0)
+  (define (read! bv start count)
+    (let ((n (match (get-bytevector-n! port bv start count)
+               ((? eof-object?) 0)
+               (x x))))
+      (set! total (+ total n))
+      (report-progress total (const n))
+      ;; XXX: We're not in control, so we always return anyway.
+      n))
+
+  (make-custom-binary-input-port "progress-port-proc"
+                                 read! #f #f
+                                 (cut close-port port)))
+
 (define %cache-url
   (or (getenv "GUIX_BINARY_SUBSTITUTE_URL")
       "http://hydra.gnu.org"))
@@ -442,19 +509,25 @@ indefinitely."
         ;; Tell the daemon what the expected hash of the Nar itself is.
         (format #t "~a~%" (narinfo-hash narinfo))
 
+        (format (current-error-port) "downloading `~a' from `~a'...~%"
+                store-path (uri->string uri))
         (let*-values (((raw download-size)
-                       (fetch uri #:buffered? #f))
+                       ;; Note that Hydra currently generates Nars on the fly
+                       ;; and doesn't specify a Content-Length, so
+                       ;; DOWNLOAD-SIZE is #f in practice.
+                       (fetch uri #:buffered? #f #:timeout? #f))
+                      ((progress)
+                       (let* ((comp     (narinfo-compression narinfo))
+                              (dl-size  (or download-size
+                                            (and (equal? comp "none")
+                                                 (narinfo-size narinfo))))
+                              (progress (progress-proc (uri-abbreviation uri)
+                                                       dl-size
+                                                       (current-error-port))))
+                         (progress-report-port progress raw)))
                       ((input pids)
                        (decompressed-port (narinfo-compression narinfo)
-                                          raw)))
-          ;; Note that Hydra currently generates Nars on the fly and doesn't
-          ;; specify a Content-Length, so DOWNLOAD-SIZE is #f in practice.
-          (format (current-error-port)
-                  (_ "downloading `~a' from `~a'~:[~*~; (~,1f KiB)~]...~%")
-                  store-path (uri->string uri)
-                  download-size
-                  (and=> download-size (cut / <> 1024.0)))
-
+                                          progress)))
           ;; Unpack the Nar at INPUT into DESTINATION.
           (restore-file input destination)
           (every (compose zero? cdr waitpid) pids))))
@@ -464,6 +537,7 @@ indefinitely."
 
 ;;; Local Variable:
 ;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1)
+;;; eval: (put 'with-timeout 'scheme-indent-function 1)
 ;;; End:
 
 ;;; substitute-binary.scm ends here
diff --git a/guix/store.scm b/guix/store.scm
index d15ba1275f..57e1ca06aa 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -31,6 +31,7 @@
   #:use-module (srfi srfi-39)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 vlist)
   #:export (%daemon-socket-file
 
             nix-server?
@@ -70,6 +71,7 @@
             substitutable-path-info
 
             references
+            requisites
             referrers
             valid-derivers
             query-derivation-outputs
@@ -493,6 +495,30 @@ file name.  Return #t on success."
              "Return the list of references of PATH."
              store-path-list))
 
+(define* (fold-path store proc seed path
+                    #:optional (relatives (cut references store <>)))
+  "Call PROC for each of the RELATIVES of PATH, exactly once, and return the
+result formed from the successive calls to PROC, the first of which is passed
+SEED."
+  (let loop ((paths  (list path))
+             (result seed)
+             (seen   vlist-null))
+    (match paths
+      ((path rest ...)
+       (if (vhash-assoc path seen)
+           (loop rest result seen)
+           (let ((seen   (vhash-cons path #t seen))
+                 (rest   (append rest (relatives path)))
+                 (result (proc path result)))
+             (loop rest result seen))))
+      (()
+       result))))
+
+(define (requisites store path)
+  "Return the requisites of PATH, including PATH---i.e., its closure (all its
+references, recursively)."
+  (fold-path store cons '() path))
+
 (define referrers
   (operation (query-referrers (store-path path))
              "Return the list of path that refer to PATH."