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:
parent
352ec143de
commit
ec4d308a9e
|
@ -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))
|
||||
|
|
|
@ -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:
|
||||
;;;
|
||||
|
|
|
@ -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;
|
||||
|
|
Loading…
Reference in New Issue