Commit | Line | Data |
---|---|---|
680c8c5a AW |
1 | ;;; Web client |
2 | ||
0bb3f946 | 3 | ;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. |
680c8c5a AW |
4 | |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
18 | ;; 02110-1301 USA | |
19 | ||
20 | ;;; Commentary: | |
21 | ;;; | |
22 | ;;; (web client) is a simple HTTP URL fetcher for Guile. | |
23 | ;;; | |
24 | ;;; In its current incarnation, (web client) is synchronous. If you | |
25 | ;;; want to fetch a number of URLs at once, probably the best thing to | |
26 | ;;; do is to write an event-driven URL fetcher, similar in structure to | |
27 | ;;; the web server. | |
28 | ;;; | |
29 | ;;; Another option, good but not as performant, would be to use threads, | |
fe0c202c | 30 | ;;; possibly via a thread pool. |
680c8c5a AW |
31 | ;;; |
32 | ;;; Code: | |
33 | ||
34 | (define-module (web client) | |
35 | #:use-module (rnrs bytevectors) | |
36 | #:use-module (ice-9 binary-ports) | |
990b11c5 | 37 | #:use-module (ice-9 iconv) |
680c8c5a AW |
38 | #:use-module (ice-9 rdelim) |
39 | #:use-module (web request) | |
40 | #:use-module (web response) | |
41 | #:use-module (web uri) | |
23cf330c | 42 | #:use-module (web http) |
b9d72498 | 43 | #:use-module (srfi srfi-1) |
76702cdc MW |
44 | #:use-module (srfi srfi-9) |
45 | #:use-module (srfi srfi-9 gnu) | |
23cf330c MW |
46 | #:export (current-http-proxy |
47 | open-socket-for-uri | |
91e693a8 | 48 | http-get |
990b11c5 AW |
49 | http-get* |
50 | http-head | |
51 | http-post | |
52 | http-put | |
53 | http-delete | |
54 | http-trace | |
55 | http-options)) | |
680c8c5a | 56 | |
23cf330c MW |
57 | (define current-http-proxy |
58 | (make-parameter (let ((proxy (getenv "http_proxy"))) | |
59 | (and (not (equal? proxy "")) | |
60 | proxy)))) | |
61 | ||
990b11c5 AW |
62 | (define (ensure-uri uri-or-string) |
63 | (cond | |
64 | ((string? uri-or-string) (string->uri uri-or-string)) | |
65 | ((uri? uri-or-string) uri-or-string) | |
66 | (else (error "Invalid URI" uri-or-string)))) | |
67 | ||
68 | (define (open-socket-for-uri uri-or-string) | |
2663411b | 69 | "Return an open input/output port for a connection to URI." |
23cf330c MW |
70 | (define http-proxy (current-http-proxy)) |
71 | (define uri (ensure-uri (or http-proxy uri-or-string))) | |
2663411b | 72 | (define addresses |
d74fcce9 | 73 | (let ((port (uri-port uri))) |
b9d72498 LC |
74 | (delete-duplicates |
75 | (getaddrinfo (uri-host uri) | |
76 | (cond (port => number->string) | |
18c44b29 AW |
77 | ((uri-scheme uri) => symbol->string) |
78 | (else (error "Not an absolute URI" uri))) | |
b9d72498 LC |
79 | (if port |
80 | AI_NUMERICSERV | |
81 | 0)) | |
82 | (lambda (ai1 ai2) | |
83 | (equal? (addrinfo:addr ai1) (addrinfo:addr ai2)))))) | |
2663411b LC |
84 | |
85 | (let loop ((addresses addresses)) | |
86 | (let* ((ai (car addresses)) | |
b9d72498 LC |
87 | (s (with-fluids ((%default-port-encoding #f)) |
88 | ;; Restrict ourselves to TCP. | |
89 | (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP)))) | |
2663411b LC |
90 | (catch 'system-error |
91 | (lambda () | |
92 | (connect s (addrinfo:addr ai)) | |
93 | ||
94 | ;; Buffer input and output on this port. | |
95 | (setvbuf s _IOFBF) | |
23cf330c MW |
96 | ;; If we're using a proxy, make a note of that. |
97 | (when http-proxy (set-http-proxy-port?! s #t)) | |
2663411b LC |
98 | s) |
99 | (lambda args | |
100 | ;; Connection failed, so try one of the other addresses. | |
f865ffaa | 101 | (close s) |
b9d72498 | 102 | (if (null? (cdr addresses)) |
2663411b | 103 | (apply throw args) |
f865ffaa | 104 | (loop (cdr addresses)))))))) |
680c8c5a | 105 | |
990b11c5 | 106 | (define (extend-request r k v . additional) |
76702cdc MW |
107 | (let ((r (set-field r (request-headers) |
108 | (assoc-set! (copy-tree (request-headers r)) | |
109 | k v)))) | |
990b11c5 AW |
110 | (if (null? additional) |
111 | r | |
112 | (apply extend-request r additional)))) | |
113 | ||
114 | ;; -> request body | |
115 | (define (sanitize-request request body) | |
116 | "\"Sanitize\" the given request and body, ensuring that they are | |
117 | complete and coherent. This method is most useful for methods that send | |
118 | data to the server, like POST, but can be used for any method. Return | |
119 | two values: a request and a bytevector, possibly the same ones that were | |
120 | passed as arguments. | |
121 | ||
122 | If BODY is a string, encodes the string to a bytevector, in an encoding | |
123 | appropriate for REQUEST. Adds a ‘content-length’ and ‘content-type’ | |
124 | header, as necessary. | |
125 | ||
126 | If BODY is a procedure, it is called with a port as an argument, and the | |
127 | output collected as a bytevector. In the future we might try to instead | |
128 | use a compressing, chunk-encoded port, and call this procedure later. | |
129 | Authors are advised not to rely on the procedure being called at any | |
130 | particular time. | |
131 | ||
132 | Note that we rely on the request itself already having been validated, | |
133 | as is the case by default with a request returned by `build-request'." | |
134 | (cond | |
135 | ((not body) | |
136 | (let ((length (request-content-length request))) | |
137 | (if length | |
3b2226ec MW |
138 | ;; FIXME make this stricter: content-length header should be |
139 | ;; prohibited if there's no body, even if the content-length | |
140 | ;; is 0. | |
990b11c5 AW |
141 | (unless (zero? length) |
142 | (error "content-length, but no body")) | |
143 | (when (assq 'transfer-encoding (request-headers request)) | |
144 | (error "transfer-encoding not allowed with no body"))) | |
145 | (values request #vu8()))) | |
146 | ((string? body) | |
147 | (let* ((type (request-content-type request '(text/plain))) | |
148 | (declared-charset (assq-ref (cdr type) 'charset)) | |
149 | (charset (or declared-charset "utf-8"))) | |
150 | (sanitize-request | |
151 | (if declared-charset | |
152 | request | |
153 | (extend-request request 'content-type | |
154 | `(,@type (charset . ,charset)))) | |
155 | (string->bytevector body charset)))) | |
156 | ((procedure? body) | |
157 | (let* ((type (request-content-type request | |
158 | '(text/plain))) | |
159 | (declared-charset (assq-ref (cdr type) 'charset)) | |
160 | (charset (or declared-charset "utf-8"))) | |
161 | (sanitize-request | |
162 | (if declared-charset | |
163 | request | |
164 | (extend-request request 'content-type | |
165 | `(,@type (charset . ,charset)))) | |
166 | (call-with-encoded-output-string charset body)))) | |
167 | ((not (bytevector? body)) | |
168 | (error "unexpected body type")) | |
169 | (else | |
170 | (values (let ((rlen (request-content-length request)) | |
171 | (blen (bytevector-length body))) | |
172 | (cond | |
173 | (rlen (if (= rlen blen) | |
174 | request | |
175 | (error "bad content-length" rlen blen))) | |
990b11c5 AW |
176 | (else (extend-request request 'content-length blen)))) |
177 | body)))) | |
680c8c5a | 178 | |
680c8c5a AW |
179 | (define (decode-response-body response body) |
180 | ;; `body' is either #f or a bytevector. | |
181 | (cond | |
182 | ((not body) body) | |
183 | ((bytevector? body) | |
184 | (let ((rlen (response-content-length response)) | |
185 | (blen (bytevector-length body))) | |
186 | (cond | |
187 | ((and rlen (not (= rlen blen))) | |
188 | (error "bad content-length" rlen blen)) | |
189 | ((response-content-type response) | |
190 | => (lambda (type) | |
191 | (cond | |
ee2d8741 | 192 | ((text-content-type? (car type)) |
990b11c5 AW |
193 | ;; RFC 2616 3.7.1: "When no explicit charset parameter is |
194 | ;; provided by the sender, media subtypes of the "text" | |
195 | ;; type are defined to have a default charset value of | |
196 | ;; "ISO-8859-1" when received via HTTP." | |
197 | (bytevector->string body (or (assq-ref (cdr type) 'charset) | |
198 | "iso-8859-1"))) | |
680c8c5a AW |
199 | (else body)))) |
200 | (else body)))) | |
201 | (else | |
202 | (error "unexpected body type" body)))) | |
203 | ||
990b11c5 AW |
204 | ;; We could expose this to user code if there is demand. |
205 | (define* (request uri #:key | |
206 | (body #f) | |
207 | (port (open-socket-for-uri uri)) | |
55e29bb5 | 208 | (method 'GET) |
990b11c5 AW |
209 | (version '(1 . 1)) |
210 | (keep-alive? #f) | |
211 | (headers '()) | |
212 | (decode-body? #t) | |
213 | (streaming? #f) | |
214 | (request | |
215 | (build-request | |
216 | (ensure-uri uri) | |
217 | #:method method | |
218 | #:version version | |
219 | #:headers (if keep-alive? | |
220 | headers | |
221 | (cons '(connection close) headers)) | |
222 | #:port port))) | |
223 | (call-with-values (lambda () (sanitize-request request body)) | |
224 | (lambda (request body) | |
225 | (let ((request (write-request request port))) | |
226 | (when body | |
227 | (write-request-body request body)) | |
228 | (force-output (request-port request)) | |
229 | (let ((response (read-response port))) | |
230 | (cond | |
55e29bb5 | 231 | ((eq? (request-method request) 'HEAD) |
990b11c5 AW |
232 | (unless keep-alive? |
233 | (close-port port)) | |
234 | (values response #f)) | |
235 | (streaming? | |
236 | (values response | |
237 | (response-body-port response | |
238 | #:keep-alive? keep-alive? | |
239 | #:decode? decode-body?))) | |
240 | (else | |
241 | (let ((body (read-response-body response))) | |
242 | (unless keep-alive? | |
243 | (close-port port)) | |
244 | (values response | |
245 | (if decode-body? | |
246 | (decode-response-body response body) | |
247 | body)))))))))) | |
248 | ||
249 | (define* (http-get uri #:key | |
250 | (body #f) | |
251 | (port (open-socket-for-uri uri)) | |
252 | (version '(1 . 1)) (keep-alive? #f) | |
253 | ;; #:headers is the new name of #:extra-headers. | |
254 | (extra-headers #f) (headers (or extra-headers '())) | |
255 | (decode-body? #t) (streaming? #f)) | |
06883ae0 DH |
256 | "Connect to the server corresponding to URI and ask for the |
257 | resource, using the ‘GET’ method. If you already have a port open, | |
258 | pass it as PORT. The port will be closed at the end of the | |
259 | request unless KEEP-ALIVE? is true. Any extra headers in the | |
990b11c5 AW |
260 | alist HEADERS will be added to the request. |
261 | ||
dc871261 | 262 | If BODY is not ‘#f’, a message body will also be sent with the HTTP |
990b11c5 AW |
263 | request. If BODY is a string, it is encoded according to the |
264 | content-type in HEADERS, defaulting to UTF-8. Otherwise BODY should be | |
dc871261 | 265 | a bytevector, or ‘#f’ for no body. Although it's allowed to send a |
990b11c5 AW |
266 | message body along with any request, usually only POST and PUT requests |
267 | have bodies. See ‘http-put’ and ‘http-post’ documentation, for more. | |
06883ae0 DH |
268 | |
269 | If DECODE-BODY? is true, as is the default, the body of the | |
270 | response will be decoded to string, if it is a textual content-type. | |
990b11c5 AW |
271 | Otherwise it will be returned as a bytevector. |
272 | ||
273 | However, if STREAMING? is true, instead of eagerly reading the response | |
274 | body from the server, this function only reads off the headers. The | |
275 | response body will be returned as a port on which the data may be read. | |
276 | Unless KEEP-ALIVE? is true, the port will be closed after the full | |
277 | response body has been read. | |
278 | ||
279 | Returns two values: the response read from the server, and the response | |
280 | body as a string, bytevector, #f value, or as a port (if STREAMING? is | |
281 | true)." | |
282 | (when extra-headers | |
283 | (issue-deprecation-warning | |
284 | "The #:extra-headers argument to http-get has been renamed to #:headers. " | |
285 | "Please update your code.")) | |
55e29bb5 | 286 | (request uri #:method 'GET #:body body |
990b11c5 AW |
287 | #:port port #:version version #:keep-alive? keep-alive? |
288 | #:headers headers #:decode-body? decode-body? | |
289 | #:streaming? streaming?)) | |
290 | ||
291 | (define* (http-get* uri #:key | |
292 | (body #f) | |
293 | (port (open-socket-for-uri uri)) | |
294 | (version '(1 . 1)) (keep-alive? #f) | |
295 | ;; #:headers is the new name of #:extra-headers. | |
296 | (extra-headers #f) (headers (or extra-headers '())) | |
91e693a8 | 297 | (decode-body? #t)) |
990b11c5 | 298 | "Deprecated in favor of (http-get #:streaming? #t)." |
170410b6 AW |
299 | (issue-deprecation-warning |
300 | "`http-get*' has been deprecated. " | |
301 | "Instead, use `http-get' with the #:streaming? #t keyword argument.") | |
990b11c5 AW |
302 | (http-get uri #:body body |
303 | #:port port #:version version #:keep-alive? keep-alive? | |
304 | #:headers headers #:decode-body? #t #:streaming? #t)) | |
305 | ||
306 | (define-syntax-rule (define-http-verb http-verb method doc) | |
307 | (define* (http-verb uri #:key | |
308 | (body #f) | |
309 | (port (open-socket-for-uri uri)) | |
310 | (version '(1 . 1)) | |
311 | (keep-alive? #f) | |
312 | (headers '()) | |
313 | (decode-body? #t) | |
314 | (streaming? #f)) | |
315 | doc | |
316 | (request uri | |
317 | #:body body #:method method | |
318 | #:port port #:version version #:keep-alive? keep-alive? | |
319 | #:headers headers #:decode-body? decode-body? | |
320 | #:streaming? streaming?))) | |
321 | ||
322 | (define-http-verb http-head | |
55e29bb5 | 323 | 'HEAD |
990b11c5 AW |
324 | "Fetch message headers for the given URI using the HTTP \"HEAD\" |
325 | method. | |
326 | ||
327 | This function is similar to ‘http-get’, except it uses the \"HEAD\" | |
328 | method. See ‘http-get’ for full documentation on the various keyword | |
329 | arguments that are accepted by this function. | |
330 | ||
dc871261 | 331 | Returns two values: the resulting response, and ‘#f’. Responses to HEAD |
990b11c5 AW |
332 | requests do not have a body. The second value is only returned so that |
333 | other procedures can treat all of the http-foo verbs identically.") | |
334 | ||
335 | (define-http-verb http-post | |
55e29bb5 | 336 | 'POST |
990b11c5 AW |
337 | "Post data to the given URI using the HTTP \"POST\" method. |
338 | ||
339 | This function is similar to ‘http-get’, except it uses the \"POST\" | |
340 | method. See ‘http-get’ for full documentation on the various keyword | |
341 | arguments that are accepted by this function. | |
342 | ||
343 | Returns two values: the resulting response, and the response body.") | |
344 | ||
345 | (define-http-verb http-put | |
55e29bb5 | 346 | 'PUT |
990b11c5 AW |
347 | "Put data at the given URI using the HTTP \"PUT\" method. |
348 | ||
349 | This function is similar to ‘http-get’, except it uses the \"PUT\" | |
350 | method. See ‘http-get’ for full documentation on the various keyword | |
351 | arguments that are accepted by this function. | |
352 | ||
353 | Returns two values: the resulting response, and the response body.") | |
354 | ||
355 | (define-http-verb http-delete | |
55e29bb5 | 356 | 'DELETE |
990b11c5 AW |
357 | "Delete data at the given URI using the HTTP \"DELETE\" method. |
358 | ||
359 | This function is similar to ‘http-get’, except it uses the \"DELETE\" | |
360 | method. See ‘http-get’ for full documentation on the various keyword | |
361 | arguments that are accepted by this function. | |
362 | ||
363 | Returns two values: the resulting response, and the response body.") | |
364 | ||
365 | (define-http-verb http-trace | |
55e29bb5 | 366 | 'TRACE |
990b11c5 AW |
367 | "Send an HTTP \"TRACE\" request. |
368 | ||
369 | This function is similar to ‘http-get’, except it uses the \"TRACE\" | |
370 | method. See ‘http-get’ for full documentation on the various keyword | |
371 | arguments that are accepted by this function. | |
372 | ||
373 | Returns two values: the resulting response, and the response body.") | |
374 | ||
375 | (define-http-verb http-options | |
55e29bb5 | 376 | 'OPTIONS |
990b11c5 AW |
377 | "Query characteristics of an HTTP resource using the HTTP \"OPTIONS\" |
378 | method. | |
379 | ||
380 | This function is similar to ‘http-get’, except it uses the \"OPTIONS\" | |
381 | method. See ‘http-get’ for full documentation on the various keyword | |
382 | arguments that are accepted by this function. | |
383 | ||
384 | Returns two values: the resulting response, and the response body.") |