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.master
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/>.
|
;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(define-module (guix-download)
|
(define-module (guix-download)
|
||||||
#:use-module (web uri)
|
|
||||||
#:use-module (web client)
|
|
||||||
#:use-module (web response)
|
|
||||||
#:use-module (guix ui)
|
#:use-module (guix ui)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix base32)
|
#: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 (ice-9 match)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
|
@ -58,43 +57,18 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(false-if-exception (delete-file template))))))
|
(false-if-exception (delete-file template))))))
|
||||||
|
|
||||||
(define (http-fetch url port)
|
(define (fetch-and-store store fetch name)
|
||||||
"Fetch from URL over HTTP and write the result to PORT."
|
"Call FETCH for URI, and pass it the name of a file to write to; eventually,
|
||||||
(let*-values (((response data) (http-get url #:decode-body? #f))
|
copy data from that port to STORE, under NAME. Return the resulting
|
||||||
((code) (response-code response)))
|
store path."
|
||||||
(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."
|
|
||||||
(call-with-temporary-output-file
|
(call-with-temporary-output-file
|
||||||
(lambda (name port)
|
(lambda (temp port)
|
||||||
(fetch uri port)
|
(let ((result
|
||||||
(close port)
|
(parameterize ((current-output-port (current-error-port)))
|
||||||
(add-to-store store (basename (uri-path uri))
|
(fetch temp))))
|
||||||
#t #f "sha256" name))))
|
(close port)
|
||||||
|
(and result
|
||||||
|
(add-to-store store name #t #f "sha256" temp))))))
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Command-line options.
|
;;; Command-line options.
|
||||||
|
@ -168,19 +142,23 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
|
||||||
|
|
||||||
(let* ((opts (parse-options))
|
(let* ((opts (parse-options))
|
||||||
(store (open-connection))
|
(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~%")
|
(leave (_ "guix-download: ~a: failed to parse URI~%")
|
||||||
(assq-ref opts 'argument))))
|
arg)))
|
||||||
(path (case (uri-scheme uri)
|
(path (case (uri-scheme uri)
|
||||||
((http) (fetch-and-store store uri http-fetch))
|
|
||||||
((ftp) (fetch-and-store store uri ftp-fetch))
|
|
||||||
((file)
|
((file)
|
||||||
(add-to-store store (basename (uri-path uri))
|
(add-to-store store (basename (uri-path uri))
|
||||||
#t #f "sha256" (uri-path uri)))
|
#t #f "sha256" (uri-path uri)))
|
||||||
(else
|
(else
|
||||||
(leave (_ "guix-download: ~a: unsupported URI scheme~%")
|
(fetch-and-store store
|
||||||
(uri-scheme uri)))))
|
(cut url-fetch arg <>
|
||||||
(hash (call-with-input-file path
|
#: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)))
|
(compose sha256 get-bytevector-all)))
|
||||||
(fmt (assq-ref opts 'format)))
|
(fmt (assq-ref opts 'format)))
|
||||||
(format #t "~a~%~a~%" path (fmt hash))
|
(format #t "~a~%~a~%" path (fmt hash))
|
||||||
|
|
|
@ -23,7 +23,8 @@
|
||||||
#:use-module ((guix store) #:select (derivation-path?))
|
#:use-module ((guix store) #:select (derivation-path?))
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:export (url-fetch))
|
#:export (%mirrors
|
||||||
|
url-fetch))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
|
|
@ -23,7 +23,7 @@
|
||||||
guix-download --version
|
guix-download --version
|
||||||
|
|
||||||
# Make sure it fails here.
|
# 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
|
then false; else true; fi
|
||||||
|
|
||||||
if guix-download unknown://some/where;
|
if guix-download unknown://some/where;
|
||||||
|
|
Reference in New Issue