Merge branch 'master' into core-updates

2 files changed, 149 insertions, 192 deletions

diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm
new file mode 100644
index 0000000000..13f01fb1e8
--- /dev/null
+++ b/guix/build/download-nar.scm
@@ -0,0 +1,125 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 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 build download-nar)
+  #:use-module (guix build download)
+  #:use-module (guix build utils)
+  #:use-module (guix serialization)
+  #:use-module (guix zlib)
+  #:use-module (guix progress)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:export (download-nar))
+
+;;; Commentary:
+;;;
+;;; Download a normalized archive or "nar", similar to what 'guix substitute'
+;;; does.  The intent here is to use substitute servers as content-addressed
+;;; mirrors of VCS checkouts.  This is mostly useful for users who have
+;;; disabled substitutes.
+;;;
+;;; Code:
+
+(define (urls-for-item item)
+  "Return the fallback nar URL for ITEM--e.g.,
+\"/gnu/store/cabbag3…-foo-1.2-checkout\"."
+  ;; Here we hard-code nar URLs without checking narinfos.  That's probably OK
+  ;; though.
+  ;; TODO: Use HTTPS?  The downside is the extra dependency.
+  (let ((bases '("http://mirror.hydra.gnu.org/guix"
+                 "http://berlin.guixsd.org"))
+        (item  (basename item)))
+    (append (map (cut string-append <> "/nar/gzip/" item) bases)
+            (map (cut string-append <> "/nar/" item) bases))))
+
+(define (restore-gzipped-nar port item size)
+  "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to
+ITEM."
+  ;; Since PORT is typically a non-file port (for instance because 'http-get'
+  ;; returns a delimited port), create a child process so we're back to a file
+  ;; port that can be passed to 'call-with-gzip-input-port'.
+  (match (pipe)
+    ((input . output)
+     (match (primitive-fork)
+       (0
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (close-port output)
+            (close-port port)
+            (catch #t
+              (lambda ()
+                (call-with-gzip-input-port input
+                  (cut restore-file <> item)))
+              (lambda (key . args)
+                (print-exception (current-error-port)
+                                 (stack-ref (make-stack #t) 1)
+                                 key args)
+                (primitive-exit 1))))
+          (lambda ()
+            (primitive-exit 0))))
+       (child
+        (close-port input)
+        (dump-port* port output
+                    #:reporter (progress-reporter/file item size
+                                                       #:abbreviation
+                                                       store-path-abbreviation))
+        (close-port output)
+        (newline)
+        (match (waitpid child)
+          ((_ . status)
+           (unless (zero? status)
+             (error "nar decompression failed" status)))))))))
+
+(define (download-nar item)
+  "Download and extract the normalized archive for ITEM.  Return #t on
+success, #f otherwise."
+  ;; Let progress reports go through.
+  (setvbuf (current-error-port) _IONBF)
+  (setvbuf (current-output-port) _IONBF)
+
+  (let loop ((urls (urls-for-item item)))
+    (match urls
+      ((url rest ...)
+       (format #t "Trying content-addressed mirror at ~a...~%"
+               (uri-host (string->uri url)))
+       (let-values (((port size)
+                     (catch #t
+                       (lambda ()
+                         (http-fetch (string->uri url)))
+                       (lambda args
+                         (values #f #f)))))
+         (if (not port)
+             (loop rest)
+             (begin
+               (if size
+                   (format #t "Downloading from ~a (~,2h MiB)...~%" url
+                           (/ size (expt 2 20.)))
+                   (format #t "Downloading from ~a...~%" url))
+               (if (string-contains url "/gzip")
+                   (restore-gzipped-nar port item size)
+                   (begin
+                     ;; FIXME: Add progress report.
+                     (restore-file port item)
+                     (close-port port)))
+               #t))))
+      (()
+       #f))))
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 9490f48055..61c9c6d3f1 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,7 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
-;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -27,7 +26,7 @@
   #:use-module (guix base64)
   #:use-module (guix ftp-client)
   #:use-module (guix build utils)
-  #:use-module (guix utils)
+  #:use-module (guix progress)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
@@ -39,14 +38,13 @@
   #:use-module (ice-9 format)
   #:export (open-socket-for-uri
             open-connection-for-uri
+            http-fetch
             %x509-certificate-directory
             close-connection
             resolve-uri-reference
             maybe-expand-mirrors
             url-fetch
             byte-count->string
-            current-terminal-columns
-            progress-reporter/file
             uri-abbreviation
             nar-uri-abbreviation
             store-path-abbreviation))
@@ -61,69 +59,6 @@
   ;; Size of the HTTP receive buffer.
   65536)
 
-(define current-terminal-columns
-  ;; Number of columns of the terminal.
-  (make-parameter 80))
-
-(define (nearest-exact-integer x)
-  "Given a real number X, return the nearest exact integer, with ties going to
-the nearest exact even integer."
-  (inexact->exact (round x)))
-
-(define (duration->seconds duration)
-  "Return the number of seconds represented by DURATION, a 'time-duration'
-object, as an inexact number."
-  (+ (time-second duration)
-     (/ (time-nanosecond duration) 1e9)))
-
-(define (seconds->string duration)
-  "Given DURATION in seconds, return a string representing it in 'mm:ss' or
-'hh:mm:ss' format, as needed."
-  (if (not (number? duration))
-      "00:00"
-      (let* ((total-seconds (nearest-exact-integer duration))
-             (extra-seconds (modulo total-seconds 3600))
-             (num-hours     (quotient total-seconds 3600))
-             (hours         (and (positive? num-hours) num-hours))
-             (mins          (quotient extra-seconds 60))
-             (secs          (modulo extra-seconds 60)))
-        (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs))))
-
-(define (byte-count->string size)
-  "Given SIZE in bytes, return a string representing it in a human-readable
-way."
-  (let ((KiB 1024.)
-        (MiB (expt 1024. 2))
-        (GiB (expt 1024. 3))
-        (TiB (expt 1024. 4)))
-    (cond
-     ((< size KiB) (format #f "~dB"     (nearest-exact-integer size)))
-     ((< size MiB) (format #f "~dKiB"   (nearest-exact-integer (/ size KiB))))
-     ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
-     ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
-     (else         (format #f "~,3fTiB" (/ size TiB))))))
-
-(define* (progress-bar % #:optional (bar-width 20))
-  "Return % as a string representing an ASCII-art progress bar.  The total
-width of the bar is BAR-WIDTH."
-  (let* ((fraction (/ % 100))
-         (filled   (inexact->exact (floor (* fraction bar-width))))
-         (empty    (- bar-width filled)))
-    (format #f "[~a~a]"
-            (make-string filled #\#)
-            (make-string empty #\space))))
-
-(define (string-pad-middle left right len)
-  "Combine LEFT and RIGHT with enough padding in the middle so that the
-resulting string has length at least LEN (it may overflow).  If the string
-does not overflow, the last char in RIGHT will be flush with the LEN
-column."
-  (let* ((total-used (+ (string-length left)
-                        (string-length right)))
-         (num-spaces (max 1 (- len total-used)))
-         (padding    (make-string num-spaces #\space)))
-    (string-append left padding right)))
-
 (define* (ellipsis #:optional (port (current-output-port)))
   "Make a rough guess at whether Unicode's HORIZONTAL ELLIPSIS can be written
 in PORT's encoding, and return either that or ASCII dots."
@@ -142,105 +77,6 @@ Otherwise return STORE-PATH."
                        (string-drop base 32)))
       store-path))
 
-(cond-expand
-  (guile-2.2
-   ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
-   ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
-   (define time-monotonic time-tai))
-  (else #t))
-
-
-;; TODO: replace '(@ (guix build utils) dump-port))'.
-(define* (dump-port* in out
-                     #:key (buffer-size 16384)
-                     (reporter (make-progress-reporter noop noop noop)))
-  "Read as much data as possible from IN and write it to OUT, using chunks of
-BUFFER-SIZE bytes.  After each successful transfer of BUFFER-SIZE bytes or
-less, report the total number of bytes transferred to the REPORTER, which
-should be a <progress-reporter> object."
-  (define buffer
-    (make-bytevector buffer-size))
-
-  (call-with-progress-reporter reporter
-    (lambda (report)
-      (let loop ((total 0)
-                 (bytes (get-bytevector-n! in buffer 0 buffer-size)))
-        (or (eof-object? bytes)
-            (let ((total (+ total bytes)))
-              (put-bytevector out buffer 0 bytes)
-              (report total)
-              (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))
-
-(define (rate-limited proc interval)
-  "Return a procedure that will forward the invocation to PROC when the time
-elapsed since the previous forwarded invocation is greater or equal to
-INTERVAL (a time-duration object), otherwise does nothing and returns #f."
-  (let ((previous-at #f))
-    (lambda args
-      (let* ((now (current-time time-monotonic))
-             (forward-invocation (lambda ()
-                                   (set! previous-at now)
-                                   (apply proc args))))
-        (if previous-at
-            (let ((elapsed (time-difference now previous-at)))
-              (if (time>=? elapsed interval)
-                  (forward-invocation)
-                  #f))
-            (forward-invocation))))))
-
-(define* (progress-reporter/file file size
-                                 #:optional (log-port (current-output-port))
-                                 #:key (abbreviation basename))
-  "Return a <progress-reporter> object to show the progress of FILE's download,
-which is SIZE bytes long.  The progress report is written to LOG-PORT, with
-ABBREVIATION used to shorten FILE for display."
-  (let ((start-time (current-time time-monotonic))
-        (transferred 0))
-    (define (render)
-      "Write the progress report to LOG-PORT."
-      (define elapsed
-        (duration->seconds
-         (time-difference (current-time time-monotonic) start-time)))
-      (if (number? size)
-          (let* ((%  (* 100.0 (/ transferred size)))
-                 (throughput (/ transferred elapsed))
-                 (left       (format #f " ~a  ~a"
-                                     (abbreviation file)
-                                     (byte-count->string size)))
-                 (right      (format #f "~a/s ~a ~a~6,1f%"
-                                     (byte-count->string throughput)
-                                     (seconds->string elapsed)
-                                     (progress-bar %) %)))
-            (display "\r\x1b[K" log-port)
-            (display (string-pad-middle left right
-                                        (current-terminal-columns))
-                     log-port)
-            (flush-output-port log-port))
-          (let* ((throughput (/ transferred elapsed))
-                 (left       (format #f " ~a"
-                                     (abbreviation file)))
-                 (right      (format #f "~a/s ~a | ~a transferred"
-                                     (byte-count->string throughput)
-                                     (seconds->string elapsed)
-                                     (byte-count->string transferred))))
-            (display "\r\x1b[K" log-port)
-            (display (string-pad-middle left right
-                                        (current-terminal-columns))
-                     log-port)
-            (flush-output-port log-port))))
-
-    (progress-reporter
-     (start render)
-     ;; Report the progress every 300ms or longer.
-     (report
-      (let ((rate-limited-render
-             (rate-limited render (make-time time-monotonic 300000000 0))))
-        (lambda (value)
-          (set! transferred value)
-          (rate-limited-render))))
-     ;; Don't miss the last report.
-     (stop render))))
-
 (define* (uri-abbreviation uri #:optional (max-length 42))
   "If URI's string representation is larger than MAX-LENGTH, return an
 abbreviation of URI showing the scheme, host, and basename of the file."
@@ -745,11 +581,11 @@ Return the resulting target URI."
                     #:query    (uri-query    ref)
                     #:fragment (uri-fragment ref)))))
 
-(define* (http-fetch uri file #:key timeout (verify-certificate? #t))
-  "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if
-the connection could not be established in less than TIMEOUT seconds.  Return
-FILE on success.  When VERIFY-CERTIFICATE? is true, verify HTTPS
-certificates; otherwise simply ignore them."
+(define* (http-fetch uri #:key timeout (verify-certificate? #t))
+  "Return an input port containing the data at URI, and the expected number of
+bytes available or #f.  When TIMEOUT is true, bail out if the connection could
+not be established in less than TIMEOUT seconds.  When VERIFY-CERTIFICATE? is
+true, verify HTTPS certificates; otherwise simply ignore them."
 
   (define headers
     `(;; Some web sites, such as http://dist.schmorp.de, would block you if
@@ -774,28 +610,15 @@ certificates; otherwise simply ignore them."
                                           #:timeout timeout
                                           #:verify-certificate?
                                           verify-certificate?))
-                ((resp bv-or-port)
+                ((resp port)
                  (http-get uri #:port connection #:decode-body? #f
                            #:streaming? #t
                            #:headers headers))
                 ((code)
-                 (response-code resp))
-                ((size)
-                 (response-content-length resp)))
+                 (response-code resp)))
     (case code
       ((200)                                      ; OK
-       (begin
-         (call-with-output-file file
-           (lambda (p)
-             (if (port? bv-or-port)
-                 (begin
-                   (dump-port* bv-or-port p
-                               #:buffer-size %http-receive-buffer-size
-                               #:reporter (progress-reporter/file
-                                           (uri-abbreviation uri) size))
-                   (newline))
-                 (put-bytevector p bv-or-port))))
-         file))
+       (values port (response-content-length resp)))
       ((301                                       ; moved permanently
         302                                       ; found (redirection)
         303                                       ; see other
@@ -805,7 +628,7 @@ certificates; otherwise simply ignore them."
          (format #t "following redirection to `~a'...~%"
                  (uri->string uri))
          (close connection)
-         (http-fetch uri file
+         (http-fetch uri
                      #:timeout timeout
                      #:verify-certificate? verify-certificate?)))
       (else
@@ -876,10 +699,19 @@ otherwise simply ignore them."
             file (uri->string uri))
     (case (uri-scheme uri)
       ((http https)
-       (false-if-exception* (http-fetch uri file
-                                        #:verify-certificate?
-                                        verify-certificate?
-                                        #:timeout timeout)))
+       (false-if-exception*
+        (let-values (((port size)
+                      (http-fetch uri
+                                  #:verify-certificate? verify-certificate?
+                                  #:timeout timeout)))
+          (call-with-output-file file
+            (lambda (output)
+              (dump-port* port output
+                          #:buffer-size %http-receive-buffer-size
+                          #:reporter (progress-reporter/file
+                                      (uri-abbreviation uri) size))
+              (newline)))
+          #t)))
       ((ftp)
        (false-if-exception* (ftp-fetch uri file
                                        #:timeout timeout)))