/[guile]/guile/guile-www/http.scm
ViewVC logotype

Diff of /guile/guile-www/http.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by ttn, Sat Nov 17 01:54:05 2001 UTC revision 1.10 by ttn, Sat Apr 27 01:57:28 2002 UTC
# Line 1  Line 1 
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    
# Line 53  Line 53 
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))
# Line 87  Line 87 
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)
# Line 141  Line 141 
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    
# Line 165  Line 165 
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)
# Line 192  Line 192 
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)
# Line 227  Line 227 
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    
# Line 289  Line 288 
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)
# Line 305  Line 304 
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)

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26