328 lines
12 KiB
Scheme
328 lines
12 KiB
Scheme
; Module header is generated automatically
|
|
#cs(module http mzscheme
|
|
(require (lib "defmacro.ss"))
|
|
(require "common.ss")
|
|
(require "myenv.ss")
|
|
(require "mime.ss")
|
|
(require "srfi-12.ss")
|
|
(require "util.ss")
|
|
(require (lib "string.ss" "srfi/13"))
|
|
|
|
;************************************************************************
|
|
;
|
|
; HyperText Transport Protocol (HTTP) support
|
|
;
|
|
; This code implements the basic flow of a HTTP transaction, as defined in
|
|
; a HTTP 1.1 document [RFC 2068]. That is, this code performs:
|
|
; - opening of an HTTP connection (directly or via a proxy),
|
|
; - sending of a request,
|
|
; - listening to a reply,
|
|
; - analyzing of the return code,
|
|
; - parsing of the response headers,
|
|
; - dispatching to handle reply's data,
|
|
; - closing of the connection.
|
|
;
|
|
; INTERFACE
|
|
; http-transaction REQ-METHOD REQ-URL REQ-PARMS RESPONSE-HANDLER
|
|
;
|
|
; REQ-METHOD: a string, typically "GET" or "POST", although many others
|
|
; may be allowed. It's up to a particular server to accept or reject
|
|
; a request.
|
|
;
|
|
; REQ-URL: an absolute URL of the HTTP server
|
|
;
|
|
; REQ-PARMS: an associative list, a list of (name . value) pairs. The list
|
|
; may be regarded as "keyword arguments" of the http-transaction
|
|
; procedure. The following enumerates the supported "keyword parameters".
|
|
; All of them are optional: if omitted or specified with a value #f,
|
|
; a suitable default value will be used.
|
|
; http-proxy: a string of the form "proxyname" or "proxyname:proxyport"
|
|
; or (#f or omitted) if no proxy is needed.
|
|
; Here "proxyname" is the name or the IP address of an HTTP
|
|
; proxy
|
|
; user-agent: a string identifying the user agent
|
|
; http-req: a list or a procedure
|
|
; If it is a list, it should be a list of pairs
|
|
; (http-header-name . http-header-value)
|
|
; for additional HTTP headers to include in the request.
|
|
; If http-req is a procedure, it is invoked with one
|
|
; argument, the communication port to the HTTP server.
|
|
; The procedure is expected to write as many HTTP headers as it
|
|
; wishes, _followed by an empty line_ and optionally the
|
|
; request body.
|
|
; logger: a procedure PORT MESSAGE OTHER-MESSAGES*
|
|
; The procedure is called on several occasions to tell
|
|
; the progress of the transaction
|
|
;
|
|
; RESPONSE-HANDLER: a procedure RESP-CODE RESP-HEADERS RESP-PORT
|
|
; RESP-CODE is a number, which is one of the HTTP codes, e.g.,
|
|
; 200, 304, 404, or 500, etc.
|
|
; RESP-HEADERS: HTTP headers from the server response,
|
|
; a list of pairs (http-header-name . http-header-val).
|
|
; http-header-name is an upper-cased symbol.
|
|
; In addition to the standard header names defined in the
|
|
; HTTP recommendation, a special pair
|
|
; (HTTP-RESPONSE . the-whole-response-line)
|
|
; contains the entire HTTP response line.
|
|
; RESP-PORT: an input port from which to read the body of the reply,
|
|
; if any.
|
|
; RESPONSE-HANDLER should close the RESP-PORT. The result of the
|
|
; RESPONSE-HANDLER becomes the result of the HTTP transaction.
|
|
;
|
|
; EXCEPTIONS
|
|
; The function http-transaction may abort with the following condition:
|
|
; make-property-condition 'HTTP-TRANSACTION 'REASON reason 'HEADERS headers
|
|
; where reason is a symbol: 'NO-REPLY, 'BAD-REQ-URL, 'BAD-RESP-LINE,
|
|
; 'headers' is the list of the headers read so far or '(),
|
|
; In addition, I/O conditions (such as i/o error, connection-refused, etc.)
|
|
; may be raised by the runtime system.
|
|
;
|
|
; The procedure http-transaction establishes the connection to a HTTP server
|
|
; or a proxy, sends the request line and the mandatory headers (Host: and
|
|
; Connection:) as well as User-Agent: and other headers as specified in the
|
|
; REQ-PARMS. Afterwards, we flush the stream and wait for the reply.
|
|
; Upon receiving the reply, we parse the response line, the response
|
|
; headers, and then invoke the RESPONSE-HANDLER to handle the rest.
|
|
;
|
|
; IMPORT
|
|
; The standard prelude: myenv.scm or its variations for particular Scheme
|
|
; systems.
|
|
; Functions declared in files util.scm and mime.scm
|
|
; SRFI-12 exception handling SRFI is assumed
|
|
; EXPORT
|
|
; http-transaction
|
|
;
|
|
; This code is rather similar to HTTP.cc
|
|
;
|
|
; See vhttp.scm for the validation tests, which can also serve as
|
|
; use cases.
|
|
;
|
|
; $Id: http.scm,v 2.0 2002/08/23 19:36:25 oleg Exp oleg $
|
|
;^^^^^^^^^^^^^^^^^^^^^
|
|
|
|
;;(include "myenv.scm")
|
|
; The standard prelude and SRFI-12 are assumed
|
|
; See http://pobox.com/~oleg/ftp/Scheme/
|
|
; for myenv.scm and other input parsing functions used
|
|
; in the present code. Again, see vhttp.scm how to run this code
|
|
|
|
;-------
|
|
; A system-dependent part
|
|
; Opening, closing and shutting down TCP connections and flushing the
|
|
; ports
|
|
; open-tcp-connection hostname::string port-number::int -> (i-port . o-port)
|
|
; flush-output-port port -> void
|
|
; shutdown-sender port -> void ; shutdown the sending part of the connection
|
|
;
|
|
; These functions are necessarily platform- and system-specific
|
|
|
|
(cond-expand
|
|
(gambit
|
|
; For Gambit 4
|
|
(define (open-tcp-connection host port-number)
|
|
(assert (integer? port-number) (positive? port-number))
|
|
(let ((p (open-tcp-client
|
|
(list server-address: host
|
|
port-number: port-number))))
|
|
(cons p p)))
|
|
(define flush-output-port force-output)
|
|
(define close-tcp-connection close-port)
|
|
|
|
; DL: by analogue with Gambit 3
|
|
(define shutdown-sender force-output)
|
|
|
|
; Previous version for Gambit 3
|
|
; ; The Gambit implementation relies on internal Gambit procedures,
|
|
; ; whose names start with ##
|
|
; ; Such identifiers cannot be _read_ on many other systems
|
|
; ; The following macro constructs Gambit-specific ids on the fly
|
|
; (define-macro (_gid id)
|
|
; (string->symbol (string-append "##" (symbol->string id))))
|
|
; (define (open-tcp-connection host port-number)
|
|
; (assert (integer? port-number) (positive? port-number))
|
|
; (let ((io-port ((_gid open-input-output-file)
|
|
; (string-append "tcp://" host ":"
|
|
; (number->string port-number)))))
|
|
; (cons io-port io-port)))
|
|
; (define flush-output-port flush-output)
|
|
; (define shutdown-sender flush-output)
|
|
)
|
|
(bigloo
|
|
(define (open-tcp-connection host port-number)
|
|
(let ((sock (make-client-socket host port-number)))
|
|
(cons (socket-input sock) (socket-output sock))))
|
|
; flush-output-port is built-in
|
|
(define shutdown-sender close-output-port)
|
|
)
|
|
((or plt chicken)
|
|
(define (open-tcp-connection host port-number)
|
|
(call-with-values
|
|
(lambda () (tcp-connect host port-number))
|
|
(lambda (input-port output-port)
|
|
(cons input-port output-port))))
|
|
(define flush-output-port flush-output)
|
|
(define shutdown-sender close-output-port)
|
|
)
|
|
)
|
|
;^^^^^^^
|
|
|
|
|
|
; syntax: define-def ident assoc-list defaultvalue
|
|
; Bind a variable ident to a value found in an assoc list.
|
|
; assoc-list is a list of pairs (symbol . value)
|
|
; We look up 'ident' in the assoc-list, and bind it to the found value, unless
|
|
; the latter is #f.
|
|
; If the lookup fails, the defaultvalue is used.
|
|
|
|
(define-macro (define-def ident assoc-list defaultvalue)
|
|
`(define ,ident
|
|
(or
|
|
(cond
|
|
((assq ',ident ,assoc-list) => cdr)
|
|
(else #f))
|
|
,defaultvalue)))
|
|
|
|
; The body of the function.
|
|
; The function is written as a collection of mutually-recursive
|
|
; procedures that implement a transactional FSM.
|
|
|
|
(define (http-transaction req-method req-url req-parms response-handler)
|
|
|
|
; expected keyword arguments and their default values
|
|
(define-def http-proxy req-parms #f)
|
|
(define-def user-agent req-parms "Scheme-HTTP/1.0")
|
|
(define-def http-req req-parms '())
|
|
(define-def logger req-parms
|
|
(lambda (port msg . other-msgs) (cerr msg other-msgs nl)))
|
|
|
|
(define CRLF (string (integer->char 13) (integer->char 10)))
|
|
|
|
(define (die reason headers port)
|
|
(if port (close-output-port port))
|
|
(abort (make-property-condition 'HTTP-TRANSACTION
|
|
'REASON reason 'HEADERS headers)))
|
|
|
|
; re-throw the exception exc as a HTTP-TRANSACTION exception
|
|
(define (die-again exc reason headers port)
|
|
(if port (close-output-port port))
|
|
(abort (make-composite-condition
|
|
(make-property-condition
|
|
'HTTP-TRANSACTION 'REASON reason 'HEADERS headers)
|
|
exc)))
|
|
|
|
; Open a connection, send the request, and if successful,
|
|
; invoke the read-resp-status-line on the opened http-port.
|
|
(define (make-req schema dummy host resource)
|
|
(let* ((target-host (or http-proxy host))
|
|
(target-addr-lst (string-split target-host '(#\:)))
|
|
(target-host-proper (car target-addr-lst))
|
|
(target-port
|
|
(if (pair? (cdr target-addr-lst))
|
|
(string->integer (cadr target-addr-lst) 0
|
|
(string-length (cadr target-addr-lst)))
|
|
80))
|
|
(dummy (logger #f "Connecting to " target-host-proper ":"
|
|
target-port))
|
|
; prevent hacking
|
|
(dummy (if (string-index target-host-proper #\|)
|
|
(error "Bad target addr: " target-host-proper)))
|
|
(http-ports (open-tcp-connection target-host-proper target-port))
|
|
(http-i-port (car http-ports))
|
|
(http-o-port (cdr http-ports))
|
|
)
|
|
|
|
(for-each
|
|
(lambda (str) (display str http-o-port))
|
|
`(,req-method " "
|
|
; if the proxy is set, request the full REQ-URL; otherwise,
|
|
; send only the relative URL
|
|
,@(if http-proxy (list req-url) (list "/" resource))
|
|
" HTTP/1.0" ,CRLF
|
|
"Host: " ,host ,CRLF
|
|
"User-agent: " ,user-agent ,CRLF
|
|
"Connection: close" ,CRLF))
|
|
(if (procedure? http-req)
|
|
(http-req http-o-port) ; let the user write other headers
|
|
(begin
|
|
(for-each (lambda (header-name-value)
|
|
(display (car header-name-value) http-o-port)
|
|
(write-char #\: http-o-port)
|
|
(display (cdr header-name-value) http-o-port)
|
|
(display CRLF http-o-port))
|
|
http-req)
|
|
(display CRLF http-o-port) ; An empty line ends headers
|
|
))
|
|
(flush-output-port http-o-port)
|
|
(shutdown-sender http-o-port)
|
|
(logger http-o-port "sent request. Now listening for the response...")
|
|
(read-resp-status-line http-i-port)))
|
|
|
|
|
|
; Read the first line of the server's response, something like
|
|
; HTTP/1.x 200 OK
|
|
; and extract the response code
|
|
; Invoke
|
|
; read-headers http-i-port resp-code
|
|
; '(HTTP-RESPONSE . the-whole-response-line)
|
|
; or raise an exception if the response line is absent or invalid
|
|
(define (read-resp-status-line http-port)
|
|
(let* ((resp-line (read-line http-port))
|
|
(dummy (logger http-port "Got response :" resp-line))
|
|
(resp-headers (list (cons 'HTTP-RESPONSE resp-line))))
|
|
(cond
|
|
((eof-object? resp-line)
|
|
(die 'NO-REPLY '() http-port))
|
|
((not (string-prefix? "HTTP/1." resp-line))
|
|
(die 'BAD-RESP-LINE resp-headers http-port))
|
|
(else
|
|
(let* ((resp-line-parts (string-split resp-line '() 3))
|
|
(resp-code
|
|
(and (pair? resp-line-parts)
|
|
(pair? (cdr resp-line-parts))
|
|
(string->integer (cadr resp-line-parts) 0
|
|
(string-length (cadr resp-line-parts)))))
|
|
)
|
|
(if resp-code
|
|
(read-headers http-port resp-code resp-headers)
|
|
(die 'BAD-RESP-LINE resp-headers http-port)))))))
|
|
|
|
|
|
; read-headers http-port resp-code init-resp-headers
|
|
; The http-port is positioned after the response line.
|
|
; The procedure reads HTTP response headers and adds them to
|
|
; init-resp-headers.
|
|
; On success, the procedure exits to response-handler, passing
|
|
; it the response code, the read headers and the http-port. The
|
|
; port is positioned after the empty line that terminates the headers.
|
|
(define (read-headers http-port resp-code init-resp-headers)
|
|
(let ((headers
|
|
(with-exception-handler
|
|
(lambda (exc)
|
|
(die-again exc 'BAD-HEADER init-resp-headers http-port))
|
|
(lambda ()
|
|
(MIME:read-headers http-port)))))
|
|
(response-handler resp-code (append init-resp-headers headers)
|
|
http-port)))
|
|
|
|
; parse the req-url and exit either to make-req, or to
|
|
; the response-handler to handle the error
|
|
(let ((url-parts (string-split req-url '(#\/) 4)))
|
|
; this stub is added by Dmitry Lizorkin for handling URIs consisting of
|
|
; just a schema and a host, say, "http://www.plt-scheme.org"
|
|
(let ((url-parts
|
|
(if (and (string=? "http:" (car url-parts))
|
|
(= 3 (length url-parts)))
|
|
(append url-parts '(""))
|
|
url-parts)))
|
|
(cond
|
|
((not (= 4 (length url-parts)))
|
|
(die 'BAD-REQ-URL '() #f))
|
|
((string=? "http:" (car url-parts))
|
|
(apply make-req url-parts))
|
|
(else
|
|
(die 'UNSUPPORTED-SCHEMA '() #f)
|
|
))))
|
|
)
|
|
|
|
(provide (all-defined)))
|