From: "Ludovic Courtès" <ludo@gnu.org>
To: 28709@debbugs.gnu.org
Subject: bug#28709: [PATCH 2/4] download: Make 'http-fetch' public.
Date: Tue, 17 Oct 2017 10:48:05 +0200 [thread overview]
Message-ID: <20171017084807.15901-3-ludo@gnu.org> (raw)
In-Reply-To: <20171017084807.15901-1-ludo@gnu.org>
* guix/build/download.scm (http-fetch): Remove 'file' parameter. Change
to return an input port and the content-length. Make public.
(url-fetch): Adjust accordingly.
---
guix/build/download.scm | 44 ++++++++++++++++++++++----------------------
1 file changed, 22 insertions(+), 22 deletions(-)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index e227ae598..3b89f9412 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -39,6 +39,7 @@
#:use-module (ice-9 format)
#:export (open-socket-for-uri
open-connection-for-uri
+ http-fetch
%x509-certificate-directory
close-connection
resolve-uri-reference
@@ -745,11 +746,11 @@ Return the resulting target URI."
#:query (uri-query ref)
#:fragment (uri-fragment ref)))))
-(define* (http-fetch uri file #:key timeout (verify-certificate? #t))
- "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if
-the connection could not be established in less than TIMEOUT seconds. Return
-FILE on success. When VERIFY-CERTIFICATE? is true, verify HTTPS
-certificates; otherwise simply ignore them."
+(define* (http-fetch uri #:key timeout (verify-certificate? #t))
+ "Return an input port containing the data at URI, and the expected number of
+bytes available or #f. When TIMEOUT is true, bail out if the connection could
+not be established in less than TIMEOUT seconds. When VERIFY-CERTIFICATE? is
+true, verify HTTPS certificates; otherwise simply ignore them."
(define headers
`(;; Some web sites, such as http://dist.schmorp.de, would block you if
@@ -779,20 +780,10 @@ certificates; otherwise simply ignore them."
#:streaming? #t
#:headers headers))
((code)
- (response-code resp))
- ((size)
- (response-content-length resp)))
+ (response-code resp)))
(case code
((200) ; OK
- (begin
- (call-with-output-file file
- (lambda (p)
- (dump-port* port p
- #:buffer-size %http-receive-buffer-size
- #:reporter (progress-reporter/file
- (uri-abbreviation uri) size))
- (newline)))
- file))
+ (values port (response-content-length resp)))
((301 ; moved permanently
302 ; found (redirection)
303 ; see other
@@ -802,7 +793,7 @@ certificates; otherwise simply ignore them."
(format #t "following redirection to `~a'...~%"
(uri->string uri))
(close connection)
- (http-fetch uri file
+ (http-fetch uri
#:timeout timeout
#:verify-certificate? verify-certificate?)))
(else
@@ -873,10 +864,19 @@ otherwise simply ignore them."
file (uri->string uri))
(case (uri-scheme uri)
((http https)
- (false-if-exception* (http-fetch uri file
- #:verify-certificate?
- verify-certificate?
- #:timeout timeout)))
+ (false-if-exception*
+ (let-values (((port size)
+ (http-fetch uri
+ #:verify-certificate? verify-certificate?
+ #:timeout timeout)))
+ (call-with-output-file file
+ (lambda (output)
+ (dump-port* port output
+ #:buffer-size %http-receive-buffer-size
+ #:reporter (progress-reporter/file
+ (uri-abbreviation uri) size))
+ (newline)))
+ #t)))
((ftp)
(false-if-exception* (ftp-fetch uri file
#:timeout timeout)))
--
2.14.2
next prev parent reply other threads:[~2017-10-17 8:49 UTC|newest]
Thread overview: 8+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-10-04 21:49 bug#28709: Content-addressed mirrors for Git checkouts Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 1/4] download: Remove old-Guile leftovers Ludovic Courtès
2017-10-17 8:48 ` Ludovic Courtès [this message]
2017-10-17 8:48 ` bug#28709: [PATCH 3/4] Add (guix progress) Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 4/4] download: Download a nar when a VCS checkout fails Ludovic Courtès
2017-10-18 17:58 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Christopher Baines
2017-10-19 21:26 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20171017084807.15901-3-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=28709@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.