summaryrefslogtreecommitdiff
path: root/guix-download.in
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2012-11-13 22:57:36 +0100
committerLudovic Courtès <ludo@gnu.org>2012-11-13 23:04:21 +0100
commitec4d308a9e306e8784c324a2f8511e27c50f9dff (patch)
tree73af7484ae7288c032eac7ce3966b96b818e17f0 /guix-download.in
parent352ec143de32e751286590ff51c40f5a32c7fa87 (diff)
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.
Diffstat (limited to 'guix-download.in')
-rw-r--r--guix-download.in74
1 files changed, 26 insertions, 48 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))