1 |
;;;; www/http.scm: HTTP client library for Guile. |
;;; www/http.scm --- HTTP client library for Guile |
2 |
|
|
3 |
;;;; Copyright (C) 1997,2001 Free Software Foundation, Inc. |
;; Copyright (C) 1997,2001,2002 Free Software Foundation, Inc. |
4 |
;;;; |
;; |
5 |
;;;; This program is free software; you can redistribute it and/or modify |
;; This program is free software; you can redistribute it and/or modify |
6 |
;;;; it under the terms of the GNU General Public License as published by |
;; it under the terms of the GNU General Public License as published by |
7 |
;;;; the Free Software Foundation; either version 2, or (at your option) |
;; the Free Software Foundation; either version 2, or (at your option) |
8 |
;;;; any later version. |
;; any later version. |
9 |
;;;; |
;; |
10 |
;;;; This program is distributed in the hope that it will be useful, |
;; This program is distributed in the hope that it will be useful, |
11 |
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
12 |
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
13 |
;;;; GNU General Public License for more details. |
;; GNU General Public License for more details. |
14 |
;;;; |
;; |
15 |
;;;; You should have received a copy of the GNU General Public License |
;; You should have received a copy of the GNU General Public License |
16 |
;;;; along with this software; see the file COPYING. If not, write to |
;; along with this software; see the file COPYING. If not, write to |
17 |
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
18 |
;;;; Boston, MA 02111-1307 USA |
;; Boston, MA 02111-1307 USA |
19 |
;;;; |
;; |
20 |
|
|
21 |
;;; Commentary: |
;;; Commentary: |
22 |
|
|
53 |
(define-public http:version "HTTP/1.0") ; bump up to 1.1 when ready |
(define-public http:version "HTTP/1.0") ; bump up to 1.1 when ready |
54 |
(define-public http:user-agent "GuileHTTP 0.1") |
(define-public http:user-agent "GuileHTTP 0.1") |
55 |
|
|
56 |
;;; An HTTP message is represented by a vector: |
;; An HTTP message is represented by a vector: |
57 |
;;; #(VERSION STATUS-CODE STATUS-TEXT HEADERS BODY) |
;; #(VERSION STATUS-CODE STATUS-TEXT HEADERS BODY) |
58 |
;;; |
;; |
59 |
;;; Each of VERSION, STATUS-CODE, STATUS-TEXT are strings. HEADERS |
;; Each of VERSION, STATUS-CODE, STATUS-TEXT are strings. HEADERS |
60 |
;;; is an alist of headers and their contents. BODY is a single string. |
;; is an alist of headers and their contents. BODY is a single string. |
61 |
|
|
62 |
(define (http:make-message version statcode stattext headers body) |
(define (http:make-message version statcode stattext headers body) |
63 |
(vector version statcode stattext headers body)) |
(vector version statcode stattext headers body)) |
64 |
|
|
65 |
;;;; HTTP status predicates. |
;;;; HTTP status predicates. |
66 |
;;; |
|
67 |
;;; (http:message-version MSG) |
;; (http:message-version MSG) |
68 |
;;; Returns the HTTP version in use in HTTP message MSG. |
;; Returns the HTTP version in use in HTTP message MSG. |
69 |
;;; |
;; |
70 |
;;; (http:message-status-code MSG) |
;; (http:message-status-code MSG) |
71 |
;;; Returns the status code returned in HTTP message MSG. |
;; Returns the status code returned in HTTP message MSG. |
72 |
;;; |
;; |
73 |
;;; (http:message-status-text MSG) |
;; (http:message-status-text MSG) |
74 |
;;; Returns the text of the status line from HTTP message MSG. |
;; Returns the text of the status line from HTTP message MSG. |
75 |
;;; |
;; |
76 |
;;; (http:message-status-ok? STATUS) |
;; (http:message-status-ok? STATUS) |
77 |
;;; Returns #t if status code STATUS indicates a successful request, |
;; Returns #t if status code STATUS indicates a successful request, |
78 |
;;; #f otherwise. |
;; #f otherwise. |
79 |
|
|
80 |
(define-public (http:message-version msg) (vector-ref msg 0)) |
(define-public (http:message-version msg) (vector-ref msg 0)) |
81 |
(define-public (http:message-status-code msg) (vector-ref msg 1)) |
(define-public (http:message-status-code msg) (vector-ref msg 1)) |
87 |
|
|
88 |
(define-public (http:message-body msg) (vector-ref msg 4)) |
(define-public (http:message-body msg) (vector-ref msg 4)) |
89 |
|
|
90 |
;;; HTTP response headers functions |
;; HTTP response headers functions |
91 |
;;; |
;; |
92 |
;;; An HTTP message header is represented here by a pair. The CAR is a |
;; An HTTP message header is represented here by a pair. The CAR is a |
93 |
;;; symbol representing the header name, and the CDR is a string |
;; symbol representing the header name, and the CDR is a string |
94 |
;;; containing the header text. E.g.: |
;; containing the header text. E.g.: |
95 |
;;; |
;; |
96 |
;;; '((date . "Thu, 29 May 1997 23:48:27 GMT") |
;; '((date . "Thu, 29 May 1997 23:48:27 GMT") |
97 |
;;; (server . "NCSA/1.5.1") |
;; (server . "NCSA/1.5.1") |
98 |
;;; (last-modified . "Tue, 06 May 1997 18:32:03 GMT") |
;; (last-modified . "Tue, 06 May 1997 18:32:03 GMT") |
99 |
;;; (content-type . "text/html") |
;; (content-type . "text/html") |
100 |
;;; (content-length . "8097")) |
;; (content-length . "8097")) |
101 |
;;; |
;; |
102 |
;;; Note: these symbols are all lowercase, although the original headers |
;; Note: these symbols are all lowercase, although the original headers |
103 |
;;; were mixed-case. Clients using this library should keep this in |
;; were mixed-case. Clients using this library should keep this in |
104 |
;;; mind, since Guile symbols are case-sensitive. |
;; mind, since Guile symbols are case-sensitive. |
105 |
;;; |
;; |
106 |
;;; FIXME: should headers with known semantics be parsed automatically? |
;; FIXME: should headers with known semantics be parsed automatically? |
107 |
;;; I.e. should the Content-Length header automatically get string->number? |
;; I.e. should the Content-Length header automatically get string->number? |
108 |
;;; Should Date and Last-Modified headers be run through strptime? |
;; Should Date and Last-Modified headers be run through strptime? |
109 |
;;; It is advantageous to keep headers in a uniform format, but it may |
;; It is advantageous to keep headers in a uniform format, but it may |
110 |
;;; be convenient to parse headers that have unambiguous meanings. |
;; be convenient to parse headers that have unambiguous meanings. |
111 |
;;; |
;; |
112 |
;;; (http:message-headers MSG) |
;; (http:message-headers MSG) |
113 |
;;; Returns a list of the headers from HTTP message MSG. |
;; Returns a list of the headers from HTTP message MSG. |
114 |
;;; (http:message-header HEADER MSG) |
;; (http:message-header HEADER MSG) |
115 |
;;; Return the header field named HEADER from HTTP message MSG, or |
;; Return the header field named HEADER from HTTP message MSG, or |
116 |
;;; #f if no such header is present in the message. |
;; #f if no such header is present in the message. |
117 |
|
|
118 |
(define-public (http:message-headers msg) (vector-ref msg 3)) |
(define-public (http:message-headers msg) (vector-ref msg 3)) |
119 |
(define-public (http:message-header header msg) |
(define-public (http:message-header header msg) |
141 |
|
|
142 |
|
|
143 |
;;; HTTP connection management functions. |
;;; HTTP connection management functions. |
144 |
;;; |
|
145 |
;;; Open connections are cached on hostname in the connection-table. |
;; Open connections are cached on hostname in the connection-table. |
146 |
;;; If an HTTP connection is already open to a particular host and TCP port, |
;; If an HTTP connection is already open to a particular host and TCP port, |
147 |
;;; looking up the hostname and port number in connection-table will yield |
;; looking up the hostname and port number in connection-table will yield |
148 |
;;; a Scheme port that may be used to communicate with that server. |
;; a Scheme port that may be used to communicate with that server. |
149 |
|
|
150 |
(define connection-table '()) |
(define connection-table '()) |
151 |
|
|
165 |
|
|
166 |
|
|
167 |
;;; HTTP methods. |
;;; HTTP methods. |
168 |
;;; |
|
169 |
;;; Common methods: GET, POST etc. |
;; Common methods: GET, POST etc. |
170 |
|
|
171 |
(define-public (http:get url) |
(define-public (http:get url) |
172 |
;; FIXME: if http:open returns an old connection that has been |
;; FIXME: if http:open returns an old connection that has been |
173 |
;; closed remotely, this will fail. |
;; closed remotely, this will fail. |
174 |
(http:request "GET" url)) |
(http:request "GET" url)) |
175 |
|
|
176 |
;;; Connection-oriented functions: |
;; Connection-oriented functions: |
177 |
;;; |
;; |
178 |
;;; (http:open HOST [PORT]) |
;; (http:open HOST [PORT]) |
179 |
;;; Return an HTTP connection to HOST on TCP port PORT (default 80). |
;; Return an HTTP connection to HOST on TCP port PORT (default 80). |
180 |
;;; If an open connection already exists, use it; otherwise, create |
;; If an open connection already exists, use it; otherwise, create |
181 |
;;; a new socket. |
;; a new socket. |
182 |
|
|
183 |
(define-public (http:open host . args) |
(define-public (http:open host . args) |
184 |
(let ((port (cond ((null? args) 80) |
(let ((port (cond ((null? args) 80) |
192 |
(add-open-connection! host port sock) |
(add-open-connection! host port sock) |
193 |
sock)))) |
sock)))) |
194 |
|
|
195 |
;;; (http:request METHOD URL [HEADERS [BODY]]) |
;; (http:request METHOD URL [HEADERS [BODY]]) |
196 |
;;; Submit an HTTP request. |
;; Submit an HTTP request. |
197 |
;;; URL is a structure returned by url:parse. |
;; URL is a structure returned by url:parse. |
198 |
;;; METHOD is the name of some HTTP method, e.g. "GET" or "POST". |
;; METHOD is the name of some HTTP method, e.g. "GET" or "POST". |
199 |
;;; The optional HEADERS and BODY arguments are lists of strings |
;; The optional HEADERS and BODY arguments are lists of strings |
200 |
;;; which describe HTTP messages. The `Content-Length' header |
;; which describe HTTP messages. The `Content-Length' header |
201 |
;;; is calculated automatically and should not be supplied. |
;; is calculated automatically and should not be supplied. |
202 |
;;; |
;; |
203 |
;;; Example usage: |
;; Example usage: |
204 |
;;; (http:request "get" parsed-url |
;; (http:request "get" parsed-url |
205 |
;;; (list "User-Agent: GuileHTTP 0.1" |
;; (list "User-Agent: GuileHTTP 0.1" |
206 |
;;; "Content-Type: text/plain")) |
;; "Content-Type: text/plain")) |
207 |
;;; (http:request "post" parsed-url |
;; (http:request "post" parsed-url |
208 |
;;; (list "User-Agent: GuileHTTP 0.1" |
;; (list "User-Agent: GuileHTTP 0.1" |
209 |
;;; "Content-Type: unknown/x-www-form-urlencoded") |
;; "Content-Type: unknown/x-www-form-urlencoded") |
210 |
;;; (list "search=Gosper" |
;; (list "search=Gosper" |
211 |
;;; "case=no" |
;; "case=no" |
212 |
;;; "max_hits=50")) |
;; "max_hits=50")) |
213 |
|
|
214 |
(define-public (http:request method url . args) |
(define-public (http:request method url . args) |
215 |
(let ((host (url:host url)) |
(let ((host (url:host url)) |
216 |
(tcp-port (or (url:port url) 80)) |
(tcp-port (or (url:port url) 80)) |
217 |
(path (string-append "/" (or (url:path url) "")))) |
(path (format #f "/~A" (or (url:path url) "")))) |
218 |
(let ((sock (http:open host tcp-port)) |
(let ((sock (http:open host tcp-port)) |
219 |
(request (string-append method " " path " " http:version)) |
(request (format #f "~A ~A ~A" method path http:version)) |
220 |
(headers (if (pair? args) (car args) '())) |
(headers (if (pair? args) (car args) '())) |
221 |
(body (if (and (pair? args) (pair? (cdr args))) |
(body (if (and (pair? args) (pair? (cdr args))) |
222 |
(cadr args) |
(cadr args) |
227 |
(+ 2 (string-length line))) ; + 2 for CRLF |
(+ 2 (string-length line))) ; + 2 for CRLF |
228 |
body))) |
body))) |
229 |
(headers (if (positive? content-length) |
(headers (if (positive? content-length) |
230 |
(cons (string-append "Content-Length: " |
(cons (format #f "Content-Length: ~A" content-length) |
|
(number->string content-length)) |
|
231 |
headers) |
headers) |
232 |
headers))) |
headers))) |
233 |
|
|
288 |
|
|
289 |
|
|
290 |
|
|
291 |
;;;; System interface cruft & string funcs |
;;; System interface cruft & string funcs |
292 |
|
|
293 |
(define (read-n-chars num . port-arg) |
(define (read-n-chars num . port-arg) |
294 |
(let ((p (if (null? port-arg) |
(let ((p (if (null? port-arg) |
304 |
(apply display line p) |
(apply display line p) |
305 |
(apply display "\r\n" p)) |
(apply display "\r\n" p)) |
306 |
|
|
307 |
;;; (sans-trailing-whitespace STR) |
;; (sans-trailing-whitespace STR) |
308 |
;;; These are defined in module (ice-9 string-fun), so this code |
;; These are defined in module (ice-9 string-fun), so this code |
309 |
;;; will prob. be discarded when the module system and boot-9 |
;; will prob. be discarded when the module system and boot-9 |
310 |
;;; settle down. |
;; settle down. |
311 |
|
|
312 |
(define (sans-trailing-whitespace s) |
(define (sans-trailing-whitespace s) |
313 |
(let ((st 0) |
(let ((st 0) |