diff options
| -rw-r--r-- | guix-download.in | 74 | ||||
| -rw-r--r-- | guix/download.scm | 3 | ||||
| -rw-r--r-- | 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; |