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