From ec4d308a9e306e8784c324a2f8511e27c50f9dff Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 13 Nov 2012 22:57:36 +0100
Subject: guix-download: Use code from (guix build download).

* guix-download.in (http-fetch, ftp-fetch): Remove.
  (fetch-and-store): Replace `uri' parameter with `name', for the output
  file name.  Redirect the output of `fetch' to the error port.
  (guix-download): Call `url-fetch' for all URI schemes except `file'.
  Handle PATH equal to #f.
* guix/download.scm: Export `%mirrors'.
* tests/guix-download.sh: Change erroneous URL, because URLs at
  example.com are all valid redirections.
---
 guix-download.in       | 74 ++++++++++++++++++--------------------------------
 guix/download.scm      |  3 +-
 tests/guix-download.sh |  2 +-
 3 files changed, 29 insertions(+), 50 deletions(-)

diff --git a/guix-download.in b/guix-download.in
index cd4ad1b71b..f76396b97c 100644
--- a/guix-download.in
+++ b/guix-download.in
@@ -30,14 +30,13 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
 ;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix-download)
-  #:use-module (web uri)
-  #:use-module (web client)
-  #:use-module (web response)
   #:use-module (guix ui)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix base32)
-  #:use-module (guix ftp-client)
+  #:use-module ((guix download) #:select (%mirrors))
+  #:use-module (guix build download)
+  #:use-module (web uri)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -58,43 +57,18 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
       (lambda ()
         (false-if-exception (delete-file template))))))
 
-(define (http-fetch url port)
-  "Fetch from URL over HTTP and write the result to PORT."
-  (let*-values (((response data) (http-get url #:decode-body? #f))
-                ((code) (response-code response)))
-    (if (= code 200)
-        (put-bytevector port data)
-        (leave (_ "failed to download from `~a': ~a: ~a~%")
-               (uri->string url)
-               code (response-reason-phrase response)))))
-
-(define (ftp-fetch url port)
-  "Fetch from URL over FTP and write the result to PORT."
-  (let* ((conn (ftp-open (uri-host url)
-                         (or (uri-port url) 21)))
-         (dir  (dirname (uri-path url)))
-         (file (basename (uri-path url)))
-         (in   (ftp-retr conn file dir)))
-    (define len 65536)
-    (define buffer
-      (make-bytevector len))
-
-    (let loop ((count (get-bytevector-n! in buffer 0 len)))
-      (if (eof-object? count)
-          (ftp-close conn)
-          (begin
-            (put-bytevector port buffer 0 count)
-            (loop (get-bytevector-n! in buffer 0 len)))))))
-
-(define (fetch-and-store store fetch uri)
-  "Call FETCH for URI, and pass it an output port to write to; eventually,
-copy data from that port to STORE.  Return the resulting store path."
+(define (fetch-and-store store fetch name)
+  "Call FETCH for URI, and pass it the name of a file to write to; eventually,
+copy data from that port to STORE, under NAME.  Return the resulting
+store path."
   (call-with-temporary-output-file
-   (lambda (name port)
-     (fetch uri port)
-     (close port)
-     (add-to-store store (basename (uri-path uri))
-                   #t #f "sha256" name))))
+   (lambda (temp port)
+     (let ((result
+            (parameterize ((current-output-port (current-error-port)))
+              (fetch temp))))
+       (close port)
+       (and result
+            (add-to-store store name #t #f "sha256" temp))))))
 
 ;;;
 ;;; Command-line options.
@@ -168,19 +142,23 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
 
   (let* ((opts  (parse-options))
          (store (open-connection))
-         (uri   (or (string->uri (assq-ref opts 'argument))
+         (arg   (assq-ref opts 'argument))
+         (uri   (or (string->uri arg)
                     (leave (_ "guix-download: ~a: failed to parse URI~%")
-                           (assq-ref opts 'argument))))
-         (path (case (uri-scheme uri)
-                  ((http) (fetch-and-store store uri http-fetch))
-                  ((ftp)  (fetch-and-store store uri ftp-fetch))
+                           arg)))
+         (path  (case (uri-scheme uri)
                   ((file)
                    (add-to-store store (basename (uri-path uri))
                                  #t #f "sha256" (uri-path uri)))
                   (else
-                   (leave (_ "guix-download: ~a: unsupported URI scheme~%")
-                          (uri-scheme uri)))))
-         (hash  (call-with-input-file path
+                   (fetch-and-store store
+                                    (cut url-fetch arg <>
+                                         #:mirrors %mirrors)
+                                    (basename (uri-path uri))))))
+         (hash  (call-with-input-file
+                    (or path
+                        (leave (_ "guix-download: ~a: download failed~%")
+                               arg))
                   (compose sha256 get-bytevector-all)))
          (fmt   (assq-ref opts 'format)))
     (format #t "~a~%~a~%" path (fmt hash))
diff --git a/guix/download.scm b/guix/download.scm
index 27f58139b3..6a5d1e1fe2 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -23,7 +23,8 @@
   #:use-module ((guix store) #:select (derivation-path?))
   #:use-module (guix utils)
   #:use-module (srfi srfi-26)
-  #:export (url-fetch))
+  #:export (%mirrors
+            url-fetch))
 
 ;;; Commentary:
 ;;;
diff --git a/tests/guix-download.sh b/tests/guix-download.sh
index e756600404..3c0c6dc7cf 100644
--- a/tests/guix-download.sh
+++ b/tests/guix-download.sh
@@ -23,7 +23,7 @@
 guix-download --version
 
 # Make sure it fails here.
-if guix-download http://www.example.com/does-not-exist
+if guix-download http://does.not/exist
 then false; else true; fi
 
 if guix-download unknown://some/where;
-- 
cgit 1.4.1