Commit | Line | Data |
---|---|---|
1c9e7d65 | 1 | ;;; GNU Guix --- Functional package management for GNU |
706e9e57 | 2 | ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> |
04dec194 | 3 | ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> |
c28606bd | 4 | ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. |
1c9e7d65 LC |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
3b8258c5 | 21 | (define-module (guix http-client) |
1424a96e | 22 | #:use-module (guix utils) |
1c9e7d65 LC |
23 | #:use-module (web uri) |
24 | #:use-module (web client) | |
25 | #:use-module (web response) | |
26 | #:use-module (srfi srfi-11) | |
706e9e57 LC |
27 | #:use-module (srfi srfi-34) |
28 | #:use-module (srfi srfi-35) | |
1c9e7d65 LC |
29 | #:use-module (rnrs io ports) |
30 | #:use-module (rnrs bytevectors) | |
31 | #:use-module (guix ui) | |
32 | #:use-module (guix utils) | |
04dec194 | 33 | #:use-module ((guix build download) #:select (resolve-uri-reference)) |
706e9e57 LC |
34 | #:export (&http-get-error |
35 | http-get-error? | |
36 | http-get-error-uri | |
37 | http-get-error-code | |
38 | http-get-error-reason | |
39 | ||
40 | open-socket-for-uri | |
bb7dcaea | 41 | http-fetch)) |
1c9e7d65 LC |
42 | |
43 | ;;; Commentary: | |
44 | ;;; | |
706e9e57 LC |
45 | ;;; HTTP client portable among Guile versions, and with proper error condition |
46 | ;;; reporting. | |
1c9e7d65 LC |
47 | ;;; |
48 | ;;; Code: | |
49 | ||
706e9e57 LC |
50 | ;; HTTP GET error. |
51 | (define-condition-type &http-get-error &error | |
52 | http-get-error? | |
53 | (uri http-get-error-uri) ; URI | |
54 | (code http-get-error-code) ; integer | |
55 | (reason http-get-error-reason)) ; string | |
56 | ||
57 | ||
776463ba | 58 | (define-syntax when-guile<=2.0.5-or-otherwise-broken |
1424a96e LC |
59 | (lambda (s) |
60 | (syntax-case s () | |
61 | ((_ body ...) | |
62 | ;; Always emit BODY, regardless of VERSION, because sometimes this code | |
63 | ;; might be compiled with a recent Guile and run with 2.0.5---e.g., | |
64 | ;; when using "guix pull". | |
65 | #'(begin body ...))))) | |
66 | ||
776463ba | 67 | (when-guile<=2.0.5-or-otherwise-broken |
c28606bd LC |
68 | ;; Backport of Guile commits 312e79f8 ("Add HTTP Chunked Encoding support to |
69 | ;; web modules.") and 00d3ecf2 ("http: Do not buffer HTTP chunks.") | |
1424a96e LC |
70 | |
71 | (use-modules (ice-9 rdelim)) | |
72 | ||
776463ba LC |
73 | (define %web-http |
74 | (resolve-module '(web http))) | |
75 | ||
1424a96e LC |
76 | ;; Chunked Responses |
77 | (define (read-chunk-header port) | |
78 | (let* ((str (read-line port)) | |
79 | (extension-start (string-index str (lambda (c) (or (char=? c #\;) | |
80 | (char=? c #\return))))) | |
81 | (size (string->number (if extension-start ; unnecessary? | |
82 | (substring str 0 extension-start) | |
83 | str) | |
84 | 16))) | |
85 | size)) | |
86 | ||
1424a96e LC |
87 | (define* (make-chunked-input-port port #:key (keep-alive? #f)) |
88 | "Returns a new port which translates HTTP chunked transfer encoded | |
89 | data from PORT into a non-encoded format. Returns eof when it has | |
90 | read the final chunk from PORT. This does not necessarily mean | |
91 | that there is no more data on PORT. When the returned port is | |
92 | closed it will also close PORT, unless the KEEP-ALIVE? is true." | |
1424a96e LC |
93 | (define (close) |
94 | (unless keep-alive? | |
95 | (close-port port))) | |
c28606bd LC |
96 | |
97 | (define chunk-size 0) ;size of the current chunk | |
98 | (define remaining 0) ;number of bytes left from the current chunk | |
99 | (define finished? #f) ;did we get all the chunks? | |
100 | ||
1424a96e LC |
101 | (define (read! bv idx to-read) |
102 | (define (loop to-read num-read) | |
103 | (cond ((or finished? (zero? to-read)) | |
104 | num-read) | |
c28606bd LC |
105 | ((zero? remaining) ;get a new chunk |
106 | (let ((size (read-chunk-header port))) | |
107 | (set! chunk-size size) | |
108 | (set! remaining size) | |
109 | (if (zero? size) | |
110 | (begin | |
111 | (set! finished? #t) | |
112 | num-read) | |
113 | (loop to-read num-read)))) | |
114 | (else ;read from the current chunk | |
115 | (let* ((ask-for (min to-read remaining)) | |
116 | (read (get-bytevector-n! port bv (+ idx num-read) | |
117 | ask-for))) | |
118 | (if (eof-object? read) | |
119 | (begin ;premature termination | |
120 | (set! finished? #t) | |
121 | num-read) | |
122 | (let ((left (- remaining read))) | |
123 | (set! remaining left) | |
124 | (when (zero? left) | |
125 | ;; We're done with this chunk; read CR and LF. | |
126 | (get-u8 port) (get-u8 port)) | |
127 | (loop (- to-read read) | |
128 | (+ num-read read)))))))) | |
1424a96e | 129 | (loop to-read 0)) |
c28606bd | 130 | |
1424a96e LC |
131 | (make-custom-binary-input-port "chunked input port" read! #f #f close)) |
132 | ||
776463ba LC |
133 | ;; Chunked encoding support in Guile <= 2.0.11 would load whole chunks in |
134 | ;; memory---see <http://bugs.gnu.org/19939>. | |
135 | (when (module-variable %web-http 'read-chunk-body) | |
136 | (module-set! %web-http 'make-chunked-input-port make-chunked-input-port)) | |
137 | ||
0cc0095f LC |
138 | (define (make-delimited-input-port port len keep-alive?) |
139 | "Return an input port that reads from PORT, and makes sure that | |
140 | exactly LEN bytes are available from PORT. Closing the returned port | |
141 | closes PORT, unless KEEP-ALIVE? is true." | |
142 | (define bytes-read 0) | |
143 | ||
144 | (define (fail) | |
145 | ((@@ (web response) bad-response) | |
146 | "EOF while reading response body: ~a bytes of ~a" | |
147 | bytes-read len)) | |
148 | ||
149 | (define (read! bv start count) | |
150 | ;; Read at most LEN bytes in total. HTTP/1.1 doesn't say what to do | |
151 | ;; when a server provides more than the Content-Length, but it seems | |
152 | ;; wise to just stop reading at LEN. | |
153 | (let ((count (min count (- len bytes-read)))) | |
154 | (let loop ((ret (get-bytevector-n! port bv start count))) | |
155 | (cond ((eof-object? ret) | |
156 | (if (= bytes-read len) | |
157 | 0 ; EOF | |
158 | (fail))) | |
159 | ((and (zero? ret) (> count 0)) | |
160 | ;; Do not return zero since zero means EOF, so try again. | |
161 | (loop (get-bytevector-n! port bv start count))) | |
162 | (else | |
163 | (set! bytes-read (+ bytes-read ret)) | |
164 | ret))))) | |
165 | ||
166 | (define close | |
167 | (and (not keep-alive?) | |
168 | (lambda () | |
169 | (close port)))) | |
170 | ||
171 | (make-custom-binary-input-port "delimited input port" read! #f #f close)) | |
172 | ||
173 | (unless (guile-version>? "2.0.9") | |
174 | ;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more | |
175 | ;; than what 'content-length' says. See Guile commit 802a25b. | |
176 | (module-set! (resolve-module '(web response)) | |
177 | 'make-delimited-input-port make-delimited-input-port)) | |
178 | ||
1424a96e LC |
179 | (define (read-response-body* r) |
180 | "Reads the response body from @var{r}, as a bytevector. Returns | |
181 | @code{#f} if there was no response body." | |
182 | (define bad-response | |
183 | (@@ (web response) bad-response)) | |
184 | ||
185 | (if (member '(chunked) (response-transfer-encoding r)) | |
186 | (let ((chunk-port (make-chunked-input-port (response-port r) | |
187 | #:keep-alive? #t))) | |
188 | (get-bytevector-all chunk-port)) | |
189 | (let ((nbytes (response-content-length r))) | |
61ef22f4 LC |
190 | ;; Backport of Guile commit 84dfde82ae8f6ec247c1c147c1e2ae50b207bad9 |
191 | ;; ("fix response-body-port for responses without content-length"). | |
192 | (if nbytes | |
193 | (let ((bv (get-bytevector-n (response-port r) nbytes))) | |
194 | (if (= (bytevector-length bv) nbytes) | |
195 | bv | |
196 | (bad-response "EOF while reading response body: ~a bytes of ~a" | |
197 | (bytevector-length bv) nbytes))) | |
198 | (get-bytevector-all (response-port r)))))) | |
1424a96e LC |
199 | |
200 | ;; Install this patch only on Guile 2.0.5. | |
7db3ff4a | 201 | (unless (guile-version>? "2.0.5") |
1424a96e LC |
202 | (module-set! (resolve-module '(web response)) |
203 | 'read-response-body read-response-body*))) | |
204 | ||
89be37a5 LC |
205 | ;; XXX: Work around <http://bugs.gnu.org/13095>, present in Guile |
206 | ;; up to 2.0.7. | |
207 | (module-define! (resolve-module '(web client)) | |
208 | 'shutdown (const #f)) | |
1424a96e | 209 | |
bb7dcaea LC |
210 | (define* (open-socket-for-uri uri #:key (buffered? #t)) |
211 | "Return an open port for URI. When BUFFERED? is false, the returned port is | |
212 | unbuffered." | |
a68d976b LC |
213 | (define rmem-max |
214 | ;; The maximum size for a receive buffer on Linux, see socket(7). | |
215 | "/proc/sys/net/core/rmem_max") | |
216 | ||
217 | (define buffer-size | |
218 | (if (file-exists? rmem-max) | |
219 | (call-with-input-file rmem-max read) | |
220 | 126976)) ; the default for Linux, per 'rmem_default' | |
221 | ||
bb7dcaea | 222 | (let ((s ((@ (web client) open-socket-for-uri) uri))) |
a68d976b LC |
223 | ;; Work around <http://bugs.gnu.org/15368> by restoring a decent |
224 | ;; buffer size. | |
225 | (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size) | |
bb7dcaea LC |
226 | (unless buffered? |
227 | (setvbuf s _IONBF)) | |
228 | s)) | |
229 | ||
230 | (define* (http-fetch uri #:key port (text? #f) (buffered? #t)) | |
1c9e7d65 LC |
231 | "Return an input port containing the data at URI, and the expected number of |
232 | bytes available or #f. If TEXT? is true, the data at URI is considered to be | |
101d9f3f | 233 | textual. Follow any HTTP redirection. When BUFFERED? is #f, return an |
706e9e57 LC |
234 | unbuffered port, suitable for use in `filtered-port'. |
235 | ||
236 | Raise an '&http-get-error' condition if downloading fails." | |
1c9e7d65 | 237 | (let loop ((uri uri)) |
bb7dcaea LC |
238 | (let ((port (or port |
239 | (open-socket-for-uri uri | |
240 | #:buffered? buffered?)))) | |
241 | (let*-values (((resp data) | |
242 | ;; Try hard to use the API du jour to get an input port. | |
243 | ;; On Guile 2.0.5 and before, we can only get a string or | |
244 | ;; bytevector, and not an input port. Work around that. | |
7db3ff4a | 245 | (if (guile-version>? "2.0.7") |
bb7dcaea LC |
246 | (http-get uri #:streaming? #t #:port port) ; 2.0.9+ |
247 | (if (defined? 'http-get*) | |
248 | (http-get* uri #:decode-body? text? | |
249 | #:port port) ; 2.0.7 | |
250 | (http-get uri #:decode-body? text? | |
251 | #:port port)))) ; 2.0.5- | |
252 | ((code) | |
253 | (response-code resp))) | |
254 | (case code | |
255 | ((200) | |
256 | (let ((len (response-content-length resp))) | |
257 | (cond ((not data) | |
258 | (begin | |
259 | ;; Guile 2.0.5 and earlier did not support chunked | |
260 | ;; transfer encoding, which is required for instance when | |
261 | ;; fetching %PACKAGE-LIST-URL (see | |
262 | ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>). | |
263 | ;; Normally the `when-guile<=2.0.5' block above fixes | |
264 | ;; that, but who knows what could happen. | |
265 | (warning (_ "using Guile ~a, which does not support ~s encoding~%") | |
266 | (version) | |
267 | (response-transfer-encoding resp)) | |
268 | (leave (_ "download failed; use a newer Guile~%") | |
269 | uri resp))) | |
270 | ((string? data) ; `http-get' from 2.0.5- | |
271 | (values (open-input-string data) len)) | |
272 | ((bytevector? data) ; likewise | |
273 | (values (open-bytevector-input-port data) len)) | |
274 | (else ; input port | |
275 | (values data len))))) | |
276 | ((301 ; moved permanently | |
277 | 302) ; found (redirection) | |
04dec194 | 278 | (let ((uri (resolve-uri-reference (response-location resp) uri))) |
bb7dcaea LC |
279 | (close-port port) |
280 | (format #t (_ "following redirection to `~a'...~%") | |
281 | (uri->string uri)) | |
282 | (loop uri))) | |
283 | (else | |
706e9e57 LC |
284 | (raise (condition (&http-get-error |
285 | (uri uri) | |
286 | (code code) | |
287 | (reason (response-reason-phrase resp))) | |
288 | (&message | |
289 | (message "download failed")))))))))) | |
1c9e7d65 | 290 | |
3b8258c5 | 291 | ;;; http-client.scm ends here |