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.
This commit is contained in:
Ludovic Courtès 2012-11-13 22:57:36 +01:00
parent 352ec143de
commit ec4d308a9e
3 changed files with 29 additions and 50 deletions

View File

@ -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))

View File

@ -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:
;;;

View File

@ -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;