#| -*- Scheme -*-
-$Id: ed-ffi.scm,v 1.41 2008/07/19 01:41:16 cph Exp $
+$Id: ed-ffi.scm,v 1.42 2008/08/24 07:20:01 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
("hash" (runtime hash))
("hashtb" (runtime hash-table))
("histry" (runtime history))
+ ("html-form-codec" (runtime html-form-codec))
+ ("http-client" (runtime http-client))
+ ("httpio" (runtime http-i/o))
("illdef" (runtime illegal-definitions))
("infstr" (runtime compiler-info))
("infutl" (runtime compiler-info))
("regexp" (runtime regular-expression))
("rep" (runtime rep))
("rexp" (runtime rexp))
+ ("rfc2822-headers" (runtime rfc2822-headers))
("rgxcmp" (runtime regular-expression-compiler))
("savres" (runtime save/restore))
("scan" (runtime scode-scan))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: html-form-codec.scm,v 14.1 2008/08/24 07:20:03 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; Codecs for HTML forms
+;;; package: (runtime html-form-codec)
+
+;;; Assumption: octets less than #x80 are ASCII.
+
+(declare (usual-integrations))
+\f
+;;;; Decoder
+
+(define (decode-www-form-urlencoded octets start end)
+ (call-with-input-octets octets start end
+ (lambda (input)
+ (port/set-coding input 'us-ascii)
+ (port/set-line-ending input 'crlf)
+ (let loop ((data '()))
+ (let ((char (read-char input)))
+ (if (eof-object? char)
+ (reverse! data)
+ (begin
+ (unread-char char input)
+ (let ((name (decode-segment input #t)))
+ (loop
+ (cons (cons name (decode-segment input #f))
+ data))))))))))
+
+(define (decode-segment input name?)
+ (call-with-output-string
+ (lambda (output)
+ (let ((out
+ (if name?
+ (lambda (char)
+ (write-char (if (fix:< (char->integer char) #x80)
+ (char-downcase char)
+ char)
+ output))
+ (lambda (char)
+ (write-char char output))))
+ (digit
+ (lambda ()
+ (let ((char (read-char input)))
+ (if (eof-object? char)
+ (error "Incomplete %-escape in HTML form data."))
+ (or (char->digit char 16)
+ (error "Illegal character in % escape:" char))))))
+ (let loop ()
+ (let ((char (read-char input)))
+ (cond ((eof-object? char)
+ (if name?
+ (error
+ "Improperly terminated name in HTML form data.")))
+ ((or (char-unreserved? char)
+ (char=? char #\newline))
+ (out char)
+ (loop))
+ ((char=? char #\=)
+ (if (not name?)
+ (error "Char in illegal position in HTML form data:"
+ char)))
+ ((or (char=? char #\&)
+ (char=? char #\;))
+ (if name?
+ (error "Char in illegal position in HTML form data:"
+ char)))
+ ((char=? char #\+)
+ (out #\space)
+ (loop))
+ ((char=? char #\%)
+ (let ((d1 (digit)))
+ (out (integer->char (+ (* 16 d1) (digit)))))
+ (loop))
+ (else
+ (error "Illegal character in HTML form data:" char)))))))))
+\f
+;;;; Encoder
+
+(define (encode-www-form-urlencoded data)
+ (guarantee-list-of-type data
+ (lambda (p)
+ (and (pair? p)
+ (interned-symbol? (car p))
+ (string? (cdr p))))
+ "HTML form data alist"
+ 'encode-www-form-urlencoded)
+ (call-with-output-octets
+ (lambda (port)
+ (port/set-coding port 'us-ascii)
+ (port/set-line-ending port 'crlf)
+ (let ((write-datum
+ (lambda (datum)
+ (encode-segment (symbol-name (car datum)) port)
+ (write-char #\= port)
+ (encode-segment (cdr datum) port))))
+ (if (pair? data)
+ (begin
+ (write-datum (car data))
+ (do ((data (cdr data) (cdr data)))
+ ((not (pair? data)))
+ (write-char #\& port)
+ (write-datum (car data)))))))))
+
+(define (encode-segment string port)
+ (let ((end (string-length string)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i end)))
+ (encode-octet (string-ref string 0) port))))
+
+(define (encode-octet char port)
+ (cond ((char-unreserved? char)
+ (write-char char port))
+ ((char=? char #\space)
+ (write-char #\+ port))
+ ((char=? char #\newline)
+ (write-char #\return port)
+ (write-char #\linefeed port))
+ (else
+ (let ((octet (char->integer char)))
+ (write-char #\% port)
+ (write-char (digit->char (fix:lsh (fix:and octet #xF0) -4) 16) port)
+ (write-char (digit->char (fix:and octet #x0F) 16) port)))))
+
+(define (char-unreserved? char)
+ (char-set-member? char-set:unreserved char))
+
+(define char-set:unreserved)
+
+(define (initialize-package!)
+ (set! char-set:unreserved
+ (char-set-difference char-set:ascii
+ (char-set-union char-set:ctls
+ (string->char-set " +%=&;"))))
+ unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Id: http-client.scm,v 14.3 2006/11/04 20:16:47 riastradh Exp $
+$Id: http-client.scm,v 14.4 2008/08/24 07:20:08 cph Exp $
-Copyright 2006 Taylor R. Campbell
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
|#
-;;;; HTTP 1.0 Client Abstraction
+;;;; HTTP 1.0 client
+;;; package: (runtime http-client)
(declare (usual-integrations))
\f
-(define (call-with-http-response:entity-request method request-uri
- header-fields content
- receiver)
- (receive (request-uri host port) (decompose-http-request-uri request-uri)
- (call-with-http-connection host port
- (lambda (connection)
- (send-http-request connection method request-uri header-fields content)
- (receiver (receive-http-response connection)
- (http-connection/socket connection))))))
-
-(define (default-http-uri-authority)
- ;++ implement a nice hook here
- #f)
-
-(define (decompose-http-request-uri request-uri)
- (cond ((or (uri-authority request-uri)
- (default-http-uri-authority))
- => (lambda (authority)
- (values (make-uri #f ;No scheme
- #f ;No authority
- (uri-path request-uri)
- (uri-query request-uri)
- (uri-fragment request-uri))
- (uri-authority-host authority)
- (or (uri-authority-port authority)
- "www"))))
- (else
- (error "Can't figure out what host to send HTTP request to:"
- request-uri))))
-
-(define (call-with-http-response:get request-uri header-fields receiver)
- (call-with-http-response:entity-request 'GET request-uri header-fields #f
- receiver))
-
-(define (call-with-http-response:post request-uri header-fields content
- receiver)
- (call-with-http-response:entity-request 'POST request-uri header-fields
- content
- receiver))
-
-(define (http-head request-uri header-fields)
- (call-with-http-response:entity-request 'HEAD request-uri header-fields #f
- (lambda (http-response input-port)
- input-port ;ignore
- http-response)))
-
-(define (http-get request-uri header-fields)
- (call-with-http-response:get request-uri header-fields
- (lambda (http-response input-port)
- (values http-response (read-http-entity http-response input-port)))))
-
-(define (http-post request-uri header-fields content)
- (call-with-http-response:post request-uri header-fields content
- (lambda (http-response input-port)
- (values http-response (read-http-entity http-response input-port)))))
-
-(define (read-http-entity http-response port)
- (or (let ((header-fields (http-response/header-fields http-response)))
- (cond ((rfc822:first-header-field 'CONNECTION header-fields)
- => (lambda (header-field)
- (and (string-ci=? (rfc822:header-field-value header-field)
- "close")
- (read-all port))))
- ((rfc822:first-header-field 'CONTENT-LENGTH header-fields)
- => (lambda (header-field)
- (cond ((number->string
- (rfc822:header-field-value header-field)
- 10)
- => (lambda (content-length)
- (read-string-of-length content-length port)))
- (else #f))))
- (else #f)))
- (begin
- (warn "Unable to determine entity length of response:" http-response)
- #f)))
-\f
-;;;; HTTP Connections
-
-;++ implement persistent connection pool
-
-(define-structure (http-connection
- (conc-name http-connection/))
- host
- port
- socket
- ;; marked-for-close? ; set to true if `Connection: close'
- )
-
-(define (call-with-http-connection host port receiver)
- (let* ((connection (open-http-connection host port))
- (value (receiver connection)))
- (close-http-connection connection)
- value))
-
-(define (open-http-connection host port)
- (guarantee-string host 'OPEN-HTTP-CONNECTION)
- ;++ We'd like to be able to handle other named ports, but we can't.
- (if (not (or (equal? port "www")
- (and (integer? port)
- (exact? port)
- (<= 0 port 65535))))
- (error:wrong-type-argument port
- "Internet port number"
- 'OPEN-HTTP-CONNECTION))
- (make-http-connection host port (open-tcp-stream-socket host port)))
-
-(define (http-connection-open? connection)
- (let ((socket (http-connection/socket connection)))
- (and (channel-open? (port/input-channel socket))
- (channel-open? (port/output-channel socket)))))
-
-(define (close-http-connection connection)
- (close-port (http-connection/socket connection)))
-
-(define (http-connection/host-string connection)
- (let ((host (http-connection/host connection))
- (port (http-connection/port connection)))
- (if (equal? port "www")
- host
- (string-append host ":" (number->string port 10)))))
-
-(define (send-http-request connection method request-uri header-fields content)
- (write-http-request method
- request-uri
- (adjoin-http-header-fields
- `((HOST ,(http-connection/host-string connection)))
- header-fields
- (if (string? content)
- `((CONTENT-LENGTH
- ,(number->string (string-length content)
- 10)))
- '()))
- content
- (http-connection/socket connection)))
-
-(define (receive-http-response connection)
- (read-http-response (http-connection/socket connection)))
-\f
-;;;; HTTP Requests
-
-(define (write-http-request method request-uri header-fields content port)
- (write-http-request-line method request-uri port)
- (rfc822:write-header-fields header-fields port)
- (write-http-content content port)
- (flush-output port))
-
-(define (write-http-request-line method request-uri port)
- (write-http-method method port)
- (write-char #\space port)
- (write-http-request-uri request-uri port)
- (write-char #\space port)
- (write-string "HTTP/" port)
- (write-http-version http-version port)
- (newline port))
-
-(define (write-http-method method port)
- (write-string (cond ((symbol? method) (string-upcase (symbol-name method)))
- ((string? method) method)
- (else
- (error:wrong-type-datum method "HTTP request method")))
- port))
-
-(define (write-http-request-uri request-uri port)
- (cond ((eq? '* request-uri) (write-char #\* port))
- ((uri? request-uri) (write-uri request-uri port))
- ((string? request-uri) (write-string request-uri port))
- ((and (pair? request-uri)
- (list-of-type? request-uri string?))
- (for-each (lambda (path-component)
- (write-char #\/ port)
- (write-string path-component port))
- request-uri))
- (else
- (error:wrong-type-datum request-uri "HTTP request URI"))))
-
-(define (write-http-content content port)
- (cond ((procedure? content) (content port))
- ((string? content) (write-string content port))
- ((not content) unspecific)
- (else (error:wrong-type-datum content "HTTP content"))))
-\f
-;;;; HTTP Responses
-
-(define-structure (http-response
- (conc-name http-response/))
- version
- status-type
- status-code
- reason
- header-fields
- )
-
-(define (http-response/first-header-field http-response name)
- (rfc822:first-header-field (http-response/header-fields http-response)
- name))
-
-(define (http-response/all-header-fields http-response name)
- (rfc822:all-header-fields (http-response/header-fields http-response)
- name))
-
-(define (read-http-response port)
- (receive (http-version status-type status-code reason)
- (read-http-status-line port)
- (let ((header-fields (rfc822:read-header-fields port)))
- (make-http-response http-version
- status-type
- status-code
- reason
- header-fields))))
-
-(define (read-http-status-line port)
- (let ((vector (http-parser:status-line (input-port->parser-buffer port))))
- (let ((http-version (vector-ref vector 0))
- (status-code (vector-ref vector 1))
- (reason (vector-ref vector 2)))
- (values http-version
- (case (quotient status-code 100)
- ((1) 'INFORMATIONAL)
- ((2) 'SUCCESS)
- ((3) 'REDIRECTION)
- ((4) 'CLIENT-ERROR)
- ((5) 'SERVER-ERROR)
- (else #f))
- status-code
- reason))))
-
-(define http-parser:status-line
- (*parser
- (seq "HTTP/"
- http-parser:version
- #\space
- http-parser:status-code
- #\space
- (match (* (not-char #\newline)))
- ;; This is optional for the bizarre potential usage of this
- ;; parser outside of the HTTP client.
- (? #\newline))))
-
-(define http-parser:version
- (*parser
- (encapsulate (lambda (vector)
- (make-http-version
- (string->number (vector-ref vector 0) 10)
- (string->number (vector-ref vector 1) 10)))
- (seq (match (+ (char-set char-set:numeric)))
- "."
- (match (+ (char-set char-set:numeric)))))))
-
-(define http-parser:status-code
- (*parser
- (map (lambda (status-code)
- (string->number status-code 10))
- (match (n*n 3 (char-set char-set:numeric))))))
-\f
-;;;; HTTP Version
-
-(define (make-http-version major minor)
- (guarantee-exact-nonnegative-integer major 'MAKE-HTTP-VERSION)
- (guarantee-exact-nonnegative-integer minor 'MAKE-HTTP-VERSION)
- (cons major minor))
-
-(define (http-version? object)
- (and (pair? object)
- (exact-nonnegative-integer? (car object))
- (exact-nonnegative-integer? (cdr object))))
-
-(define-guarantee http-version "HTTP version")
-
-(define (http-version=? a b)
- (guarantee-http-version a 'HTTP-VERSION=?)
- (guarantee-http-version b 'HTTP-VERSION=?)
- (and (= (car a) (car b))
- (= (cdr a) (cdr b))))
-
-(define (http-version<? a b)
- (guarantee-http-version a 'HTTP-VERSION<?)
- (guarantee-http-version b 'HTTP-VERSION<?)
- (or (< (car a) (car b))
- (and (= (car a) (car b))
- (< (cdr a) (cdr b)))))
-
-(define (write-http-version version port)
- (write (car version) port)
- (write-char #\. port)
- (write (cdr version) port))
-
-(define http-version (make-http-version 1 0))
-\f
-;;;; Random Utilities
-
-(define (read-all input-port)
- (call-with-output-string
- (lambda (output-port)
- (let ((buffer (string-allocate #x100)))
- (let loop ()
- (let ((octets (read-string! buffer input-port)))
- (if (fix:> octets 0)
- (begin
- (write-substring buffer 0 octets output-port)
- (loop)))))))))
-
-(define (read-string-of-length length input-port)
- (let* ((string (string-allocate length))
- (octets (read-substring! string 0 length input-port)))
- (if (fix:< octets length)
- (string-head string octets)
- string)))
-\f
-;;;; RFC 822 Header Fields
-
-;;; This should be moved into the run-time library along with Edwin's
-;;; RFC 822 support, and something ought to be done about RFC 2822.
-;;; Some day.
-
-(define (valid-http-header-field? obj)
- (rfc822:header-field? obj))
-
-(define (rfc822:header-field? obj)
- (and (pair? obj)
- (symbol? (car obj))
- (let ((name (symbol-name (car obj))))
- (rfc822:header-field-name? name 0 (string-length name)))
- (pair? (cdr obj))
- (string? (cadr obj))
- (null? (cddr obj))))
-
-(define-guarantee rfc822:header-field "RFC 822 header field")
-
-(define (rfc822:header-field-name? string start end)
- (and (fix:< start end)
- (not (substring-find-next-char-in-set
- string start end rfc822:char-set:not-header-constituents))))
-
-(define (rfc822:make-header-field name value) (list name value))
-(define (rfc822:header-field-name header) (car header))
-(define (rfc822:header-field-value header) (cadr header))
-
-(define (rfc822:first-header-field name header-fields)
- (assq name header-fields))
-
-(define (rfc822:all-header-fields name header-fields)
- (keep-matching-items header-fields
- (lambda (header-field)
- (eq? (rfc822:header-field-name header-field)
- name))))
-
-(define (adjoin-http-header-fields left header-fields right)
- (let ((clean (lambda (other-header-fields)
- (delete-matching-items other-header-fields
- (lambda (header-field)
- (and (rfc822:first-header-field
- (rfc822:header-field-name header-field)
- header-fields)
- #t))))))
- (append (clean left) header-fields (clean right))))
-\f
-;;;;; RFC 822 Header Field Output
-
-(define (rfc822:header-field->string header-field)
- (call-with-output-string
- (lambda (port)
- (rfc822:write-header-field header-field port))))
-
-(define (rfc822:header-fields->string header-fields)
- (call-with-output-string
- (lambda (port)
- (rfc822:write-header-fields header-fields port))))
-
-(define (rfc822:write-header-field header-field port)
- (rfc822:write-header-field-name (rfc822:header-field-name header-field) port)
- (write-string ": " port)
- (let* ((value (rfc822:header-field-value header-field))
- (end (string-length value)))
- (let loop ((start 0))
- (cond ((substring-find-next-char value start end #\newline)
- => (lambda (index)
- (write-substring value start index port)
- (newline port)
- (write-char #\space port)
- (loop (fix:+ index 1))))
- (else
- (write-substring value start end port)
- (newline port))))))
-
-(define (rfc822:write-header-field-name name port)
- (let* ((name (if (symbol? name)
- (symbol-name name)
- name))
- (end (string-length name)))
- (if (not (char-alphabetic? (string-ref name 0)))
- (write-string name port)
- (let loop ((start 0))
- (write-char (char-upcase (string-ref name start)) port)
- (cond ((substring-find-next-char name (fix:+ start 1) end #\-)
- => (lambda (index)
- (write-substring name
- (fix:+ start 1)
- (fix:+ index 1)
- port)
- (loop (fix:+ index 1))))
- (else
- (write-substring name (fix:+ start 1) end port)))))))
-
-(define (rfc822:write-header-fields header-fields port)
- (for-each (lambda (header-field)
- (rfc822:write-header-field header-field port))
- header-fields)
- (newline port))
-\f
-;;;;; RFC 822 Header Field Input
-
-(define (rfc822:string->header-fields string)
- (vector->list
- (rfc822:parser:header-fields
- (string->parser-buffer string))))
-
-(define (rfc822:read-header-fields input-port)
- (vector->list
- (rfc822:parser:header-fields
- (input-port->parser-buffer input-port))))
-
-(define rfc822:parser:header-fields
- (*parser
- (seq (* (seq rfc822:parser:header-field #\newline))
- #\newline)))
-
-(define rfc822:parser:header-field
- (*parser
- (encapsulate (lambda (vector)
- (rfc822:make-header-field
- (vector-ref vector 0)
- (decorated-string-append
- "" (string #\newline) ""
- (map string-trim
- (subvector->list vector 1 (vector-length vector))))))
- (seq (map intern (match rfc822:matcher:header-field-name))
- ":"
- (match rfc822:matcher:header-field-line-content)
- (* (match rfc822:matcher:header-field-continuation-line))))))
-
-(define rfc822:matcher:header-field-name
- (*matcher (* (char-set rfc822:char-set:header-constituents))))
-
-(define rfc822:char-set:header-constituents
- (char-set-difference (ascii-range->char-set 33 127)
- (char-set #\:)))
-
-(define rfc822:char-set:not-header-constituents
- (char-set-invert rfc822:char-set:header-constituents))
-
-(define rfc822:matcher:header-field-line-content
- (*matcher (* (not-char #\newline))))
-
-(define rfc822:matcher:header-field-continuation-line
- (*matcher
- (seq #\newline
- (+ (char-set rfc822:char-set:lwsp))
- rfc822:matcher:header-field-line-content)))
-
-(define rfc822:char-set:lwsp (char-set #\space #\tab))
+(define (http-get uri headers)
+ (run-client-method '|GET| uri headers ""))
+
+(define (http-head uri headers)
+ (run-client-method '|HEAD| uri headers ""))
+
+(define (http-post uri headers body)
+ (run-client-method '|POST| uri headers body))
+
+(define (run-client-method method uri headers body)
+ (guarantee-absolute-uri uri)
+ (let* ((authority (uri-authority uri))
+ (port
+ (open-tcp-stream-socket (uri-authority-host authority)
+ (or (uri-authority-port authority) 80))))
+ (let ((request
+ (make-http-request method
+ (make-uri #f
+ #f
+ (uri-path uri)
+ (uri-query uri)
+ (uri-fragment uri))
+ http-version:1.0
+ (cons (make-rfc2822-header
+ 'host
+ (host-string authority))
+ (if (first-rfc2822-header 'user-agent
+ headers)
+ headers
+ (cons (make-rfc2822-header
+ 'user-agent
+ default-user-agent)
+ headers)))
+ body)))
+ (write-http-request request port)
+ (let ((response (read-http-response request port)))
+ (close-port port)
+ response))))
+
+(define (host-string authority)
+ (let ((host (uri-authority-host authority))
+ (port (uri-authority-port authority)))
+ (if port
+ (string-append host ":" (number->string port))
+ host)))
+
+(define default-user-agent)
+
+(define (initialize-package!)
+ (set! default-user-agent
+ (string-append "MIT_GNU_Scheme/"
+ (get-subsystem-version-string "release")))
+ unspecific)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: httpio.scm,v 14.1 2008/08/24 07:20:08 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; HTTP I/O
+;;; package: (runtime http-i/o)
+
+;;; Assumptions:
+;;; Transfer coding is assumed to always be "identity".
+
+(declare (usual-integrations))
+\f
+(define-record-type <http-request>
+ (%make-http-request method uri version headers body)
+ http-request?
+ (method http-request-method)
+ (uri http-request-uri)
+ (version http-request-version)
+ (headers http-request-headers)
+ (body http-request-body))
+
+(define-guarantee http-request "HTTP request")
+
+(define (make-http-request method uri version headers body)
+ (guarantee-http-token method 'MAKE-HTTP-REQUEST)
+ (guarantee-http-uri uri 'MAKE-HTTP-REQUEST)
+ (guarantee-http-version version 'MAKE-HTTP-REQUEST)
+ (receive (headers body)
+ (guarantee-headers&body headers body 'MAKE-HTTP-REQUEST)
+ (%make-http-request method uri version headers body)))
+
+(define-record-type <http-response>
+ (%make-http-response version status reason headers body)
+ http-response?
+ (version http-response-version)
+ (status http-response-status)
+ (reason http-response-reason)
+ (headers http-response-headers)
+ (body http-response-body))
+
+(define-guarantee http-response "HTTP response")
+
+(define (make-http-response version status reason headers body)
+ (guarantee-http-version version 'MAKE-HTTP-RESPONSE)
+ (guarantee-http-status status 'MAKE-HTTP-RESPONSE)
+ (guarantee-http-text reason 'MAKE-HTTP-RESPONSE)
+ (receive (headers body)
+ (guarantee-headers&body headers body 'MAKE-HTTP-RESPONSE)
+ (%make-http-response version status reason headers body)))
+
+(define (guarantee-headers&body headers body caller)
+ (let ((headers (convert-http-headers headers caller)))
+ (if body
+ (begin
+ (guarantee-string body caller)
+ (let ((n (%get-content-length headers))
+ (m (vector-8b-length body)))
+ (if n
+ (begin
+ (if (not (= n m))
+ (error:bad-range-argument body caller))
+ (values headers body))
+ (values (cons (make-rfc2822-header 'CONTENT-LENGTH
+ (number->string m))
+ headers)
+ body))))
+ (values headers ""))))
+
+(define (convert-http-headers headers caller)
+ (guarantee-list headers caller)
+ (map (lambda (header)
+ (cond ((http-header? header)
+ header)
+ ((and (pair? header)
+ (http-token? (car header))
+ (http-text? (cdr header)))
+ (make-rfc2822-header (car header) (cdr header)))
+ ((and (pair? header)
+ (http-token? (car header))
+ (pair? (cdr header))
+ (http-text? (cadr header))
+ (null? (cddr header)))
+ (make-rfc2822-header (car header) (cadr header)))
+ (else
+ (error:not-http-header header caller))))
+ headers))
+\f
+(define (simple-http-request? object)
+ (and (http-request? object)
+ (not (http-request-version object))))
+
+(define-guarantee simple-http-request "simple HTTP request")
+
+(define (make-simple-http-request uri)
+ (guarantee-simple-http-uri uri 'MAKE-HTTP-REQUEST)
+ (%make-http-request '|GET| uri #f '() ""))
+
+(define (simple-http-response? object)
+ (and (http-response? object)
+ (not (http-response-version object))))
+
+(define-guarantee simple-http-response "simple HTTP response")
+
+(define (make-simple-http-response body)
+ (guarantee-string body 'MAKE-SIMPLE-HTTP-RESPONSE)
+ (%make-http-response #f 200 (http-status-description 200) '() body))
+
+(define (http-entity? object)
+ (or (http-request? object)
+ (http-response? object)))
+
+(define-guarantee http-entity "HTTP entity")
+
+(define (http-entity-headers entity)
+ (cond ((http-request? entity) (http-request-headers entity))
+ ((http-response? entity) (http-response-headers entity))
+ (else (error:not-http-entity entity 'HTTP-ENTITY-HEADERS))))
+
+(define (http-entity-body entity)
+ (cond ((http-request? entity) (http-request-body entity))
+ ((http-response? entity) (http-response-body entity))
+ (else (error:not-http-entity entity 'HTTP-ENTITY-BODY))))
+
+(define (http-token? object)
+ (and (interned-symbol? object)
+ (not (eq? object '||))
+ (string-in-char-set? (symbol-name object) char-set:token)))
+
+(define-guarantee http-token "HTTP token")
+
+(define (http-uri? object)
+ (or (absolute-uri? object)
+ (simple-http-uri? object)))
+
+(define-guarantee http-uri "HTTP URI")
+
+(define (simple-http-uri? object)
+ (and (relative-uri? object)
+ (not (uri-authority object))
+ (uri-path-absolute? (uri-path object))))
+
+(define-guarantee simple-http-uri "simple HTTP URI")
+\f
+(define (http-version? object)
+ (and (pair? object)
+ (exact-positive-integer? (car object))
+ (exact-nonnegative-integer? (cdr object))))
+
+(define-guarantee http-version "HTTP version")
+
+(define (make-http-version major minor)
+ (guarantee-exact-positive-integer major 'MAKE-HTTP-VERSION)
+ (guarantee-exact-nonnegative-integer minor 'MAKE-HTTP-VERSION)
+ (cons major minor))
+
+(define (http-version-major v)
+ (guarantee-http-version v 'HTTP-VERSION-MAJOR)
+ (car v))
+
+(define (http-version-minor v)
+ (guarantee-http-version v 'HTTP-VERSION-MINOR)
+ (cdr v))
+
+(define (http-version=? v1 v2)
+ (guarantee-http-version v1 'HTTP-VERSION=?)
+ (guarantee-http-version v2 'HTTP-VERSION=?)
+ (and (= (car v1) (car v2))
+ (= (cdr v1) (cdr v2))))
+
+(define (http-version<? v1 v2)
+ (guarantee-http-version v1 'HTTP-VERSION<?)
+ (guarantee-http-version v2 'HTTP-VERSION<?)
+ (if (< (car v1) (car v2))
+ #t
+ (and (= (car v1) (car v2))
+ (< (cdr v1) (cdr v2)))))
+
+(define (http-status? object)
+ (and (exact-nonnegative-integer? object)
+ (>= object 100)
+ (< object 600)))
+
+(define-guarantee http-status "HTTP status code")
+
+(define (http-header? object)
+ (and (rfc2822-header? object)
+ (http-token? (rfc2822-header-name object))
+ (http-text? (rfc2822-header-value object))))
+
+(define-guarantee http-header "HTTP header field")
+
+(define (http-text? object)
+ (and (string? object)
+ (string-in-char-set? object char-set:text)))
+
+(define-guarantee http-text "HTTP text")
+\f
+;;;; Output
+
+(define (%text-mode port)
+ (port/set-coding port 'US-ASCII)
+ (port/set-line-ending port 'CRLF))
+
+(define (%binary-mode port)
+ (port/set-coding port 'BINARY)
+ (port/set-line-ending port 'BINARY))
+
+(define (write-http-request request port)
+ (%text-mode port)
+ (write-token (http-request-method request) port)
+ (write-string " " port)
+ (write-uri (http-request-uri request) port)
+ (if (http-request-version request)
+ (begin
+ (write-string " " port)
+ (write-version (http-request-version request) port)
+ (newline port)
+ (write-rfc2822-headers (http-request-headers request) port)
+ (%binary-mode port)
+ (write-string (http-request-body request) port))
+ (begin
+ (newline port)))
+ (flush-output port))
+
+(define (write-http-response response port)
+ (if (http-response-version response)
+ (begin
+ (%text-mode port)
+ (write-version (http-response-version response) port)
+ (write-string " " port)
+ (write (http-response-status response) port)
+ (write-string " " port)
+ (write-string (http-response-reason response) port)
+ (newline port)
+ (write-rfc2822-headers (http-response-headers response) port)))
+ (%binary-mode port)
+ (write-string (http-response-body response) port)
+ (flush-output port))
+
+(define (write-token token port)
+ (write-string (string-upcase (symbol->string token)) port))
+
+(define (write-version version port)
+ (write-string "HTTP/" port)
+ (write (car version) port)
+ (write-string "." port)
+ (write (cdr version) port))
+\f
+;;;; Input
+
+(define (read-simple-http-request port)
+ (%text-mode port)
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ line
+ (make-simple-http-request
+ (parse-line parse-simple-request line "simple HTTP request")))))
+
+(define (read-simple-http-response port)
+ (make-simple-http-response (%read-all port)))
+
+(define (read-http-request port)
+ (%text-mode port)
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ line
+ (receive (method uri version)
+ (parse-line parse-request-line line "HTTP request line")
+ (let ((headers (read-rfc2822-headers port)))
+ (make-http-request method uri version headers
+ (or (%read-delimited-body headers port)
+ (%no-read-body))))))))
+
+(define (read-http-response request port)
+ (%text-mode port)
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ #f
+ (receive (version status reason)
+ (parse-line parse-response-line line "HTTP response line")
+ (let ((headers (read-rfc2822-headers port)))
+ (make-http-response version status reason headers
+ (if (or (non-body-status? status)
+ (eq? (http-request-method request)
+ '|HEAD|))
+ #f
+ (or (%read-delimited-body headers port)
+ (%read-terminal-body headers port)
+ (%no-read-body)))))))))
+
+(define (parse-line parser line description)
+ (let ((v (*parse-string parser line)))
+ (if (not v)
+ (error (string-append "Malformed " description ":") line))
+ (if (fix:= (vector-length v) 1)
+ (vector-ref v 0)
+ (apply values (vector->list v)))))
+\f
+(define parse-simple-request
+ (*parser
+ (seq "GET"
+ (noise match-wsp)
+ parse-uri-no-authority)))
+
+(define parse-request-line
+ (*parser
+ (seq (map string->symbol
+ (match (+ (char-set char-set:token))))
+ (noise match-wsp)
+ parse-uri-no-authority
+ (noise match-wsp)
+ parse-version)))
+
+(define parse-response-line
+ (*parser
+ (seq parse-version
+ (noise match-wsp)
+ parse-status-code
+ (noise match-wsp)
+ (match (* (char-set char-set:text))))))
+
+(define parse-version
+ (*parser
+ (encapsulate (lambda (v)
+ (make-http-version (vector-ref v 0)
+ (vector-ref v 1)))
+ (seq "HTTP/"
+ (map string->number
+ (match (seq (char-set char-set:non-zero-digit)
+ (* (char-set char-set:digit)))))
+ "."
+ (map string->number
+ (match (* (char-set char-set:digit))))))))
+
+(define parse-status-code
+ (*parser
+ (map string->number
+ (match (seq (char-set char-set:status-major)
+ (char-set char-set:digit)
+ (char-set char-set:digit))))))
+
+(define match-wsp
+ (*matcher (+ (char-set char-set:wsp))))
+\f
+(define (%read-all port)
+ (%binary-mode port)
+ (call-with-output-octets
+ (lambda (output)
+ (let ((buffer (make-vector-8b #x1000)))
+ (let loop ()
+ (let ((n (read-string! buffer port)))
+ (if (> n 0)
+ (begin
+ (write-substring buffer 0 n output)
+ (loop)))))))))
+
+(define (%read-delimited-body headers port)
+ (let ((n (%get-content-length headers)))
+ (and n
+ (begin
+ (%binary-mode port)
+ (call-with-output-octets
+ (lambda (output)
+ (let ((buffer (make-vector-8b #x1000)))
+ (let loop ((n n))
+ (if (> n 0)
+ (let ((m (read-string! buffer port)))
+ (if (= m 0)
+ (error "Premature EOF in HTTP entity body."))
+ (write-substring buffer 0 m output)
+ (loop (- n m))))))))))))
+
+(define (%get-content-length headers)
+ (let ((h (first-rfc2822-header 'CONTENT-LENGTH headers)))
+ (and h
+ (let ((s (rfc2822-header-value h)))
+ (let ((n (string->number s)))
+ (if (not (exact-nonnegative-integer? n))
+ (error "Malformed content-length value:" s))
+ n)))))
+
+(define (%read-terminal-body headers port)
+ (and (let ((h (first-rfc2822-header 'CONNECTION headers)))
+ (and h
+ (any (lambda (token)
+ (string-ci=? token "close"))
+ (burst-string (rfc2822-header-value h) char-set:wsp #t))))
+ (%read-all port)))
+
+(define (%no-read-body)
+ (error "Unable to determine HTTP entity body length."))
+\f
+;;;; Syntax
+
+(define (string-in-char-set? string char-set)
+ (let ((end (string-length string)))
+ (let loop ((i 0))
+ (if (fix:< i end)
+ (and (char-set-member? char-set (string-ref string i))
+ (loop (fix:+ i 1)))
+ #t))))
+
+(define char-set:text)
+(define char-set:token)
+(define char-set:digit)
+(define char-set:non-zero-digit)
+(define char-set:status-major)
+(define http-version:1.0)
+(define http-version:1.1)
+
+(define (initialize-package!)
+ (set! char-set:text
+ (char-set-difference char-set:ascii char-set:ctls))
+ (set! char-set:token
+ (char-set-difference char-set:text
+ (string->char-set "()<>@,;:\\\"/[]?={} \t")))
+ (set! char-set:digit
+ (string->char-set "0123456789"))
+ (set! char-set:non-zero-digit
+ (string->char-set "123456789"))
+ (set! char-set:status-major
+ (string->char-set "12345"))
+ (set! http-version:1.0 (make-http-version 1 0))
+ (set! http-version:1.1 (make-http-version 1 1))
+ unspecific)
+\f
+;;;; Status descriptions
+
+(define (http-status-description code)
+ (guarantee-http-status code 'HTTP-STATUS-DESCRIPTION)
+ (let loop ((low 0) (high (vector-length known-status-codes)))
+ (if (< low high)
+ (let ((index (quotient (+ low high) 2)))
+ (let ((p (vector-ref known-status-codes index)))
+ (cond ((< code (car p)) (loop low index))
+ ((> code (car p)) (loop (+ index 1) high))
+ (else (cdr p)))))
+ "(Unknown)")))
+
+(define known-status-codes
+ '#((100 . "Continue")
+ (101 . "Switching Protocols")
+ (200 . "OK")
+ (201 . "Created")
+ (202 . "Accepted")
+ (203 . "Non-Authoritative Information")
+ (204 . "No Content")
+ (205 . "Reset Content")
+ (206 . "Partial Content")
+ (300 . "Multiple Choices")
+ (301 . "Moved Permanently")
+ (302 . "Found")
+ (303 . "See Other")
+ (304 . "Not Modified")
+ (305 . "Use Proxy")
+ (306 . "(Unused)")
+ (307 . "Temporary Redirect")
+ (400 . "Bad Request")
+ (401 . "Unauthorized")
+ (402 . "Payment Required")
+ (403 . "Forbidden")
+ (404 . "Not Found")
+ (405 . "Method Not Allowed")
+ (406 . "Not Acceptable")
+ (407 . "Proxy Authentication Required")
+ (408 . "Request Timeout")
+ (409 . "Conflict")
+ (410 . "Gone")
+ (411 . "Length Required")
+ (412 . "Precondition Failed")
+ (413 . "Request Entity Too Large")
+ (414 . "Request-URI Too Long")
+ (415 . "Unsupported Media Type")
+ (416 . "Requested Range Not Satisfiable")
+ (417 . "Expectation Failed")
+ (500 . "Internal Server Error")
+ (501 . "Not Implemented")
+ (502 . "Bad Gateway")
+ (503 . "Service Unavailable")
+ (504 . "Gateway Timeout")
+ (505 . "HTTP Version Not Supported")))
+
+(define (non-body-status? status)
+ (or (<= 100 status 199)
+ (= status 204)
+ (= status 304)))
+\f
+(define (http-entity-body-port entity)
+ (let ((port (open-input-octets (http-entity-body entity))))
+ (receive (type coding) (http-content-type entity)
+ (cond ((eq? (mime-type/top-level type) 'TEXT)
+ (port/set-coding port (or coding 'TEXT))
+ (port/set-line-ending port 'TEXT))
+ ((and (eq? (mime-type/top-level type) 'APPLICATION)
+ (let ((sub (mime-type/subtype type)))
+ (or (eq? sub 'XML)
+ (string-suffix-ci? "+xml" (symbol-name sub)))))
+ (port/set-coding port (or coding 'UTF-8))
+ (port/set-line-ending port 'XML-1.0))
+ (coding
+ (port/set-coding port coding)
+ (port/set-line-ending port 'TEXT))
+ (else
+ (port/set-coding port 'BINARY)
+ (port/set-line-ending port 'BINARY))))
+ port))
+
+(define (http-content-type entity)
+ (let ((h (first-http-header 'CONTENT-TYPE entity)))
+ (if h
+ (let ((s (rfc2822-header-value h)))
+ (let ((v (*parse-string parser:http-content-type s)))
+ (if (not v)
+ (error "Malformed content-type value:" s))
+ (values (vector-ref v 0)
+ (let ((p (assq 'CHARSET (vector-ref v 1))))
+ (and p
+ (let ((coding (intern (cdr p))))
+ (and (known-input-coding? coding)
+ coding)))))))
+ (values (make-mime-type 'APPLICATION 'OCTET-STREAM)
+ #f))))
+
+(define parser:http-content-type
+ (let ((parse-parameter
+ (*parser
+ (encapsulate (lambda (v)
+ (cons (vector-ref v 0)
+ (vector-ref v 1)))
+ (seq ";"
+ (noise (* (char-set char-set:wsp)))
+ parser:mime-token
+ "="
+ (alt (match matcher:mime-token)
+ parser:rfc2822-quoted-string))))))
+ (*parser
+ (seq parser:mime-type
+ (encapsulate vector->list
+ (* parse-parameter))))))
+
+(define (http-content-length entity)
+ (%get-content-length (http-entity-headers entity)))
+
+(define (first-http-header name entity)
+ (first-rfc2822-header name (http-entity-headers entity)))
+
+(define (all-http-headers name entity)
+ (all-rfc2822-headers name (http-entity-headers entity)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: make.scm,v 14.116 2008/07/19 01:41:16 cph Exp $
+$Id: make.scm,v 14.117 2008/08/24 07:20:09 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; More debugging
((RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES! #f)
(RUNTIME URI)
+ (RUNTIME RFC2822-HEADERS)
+ (RUNTIME HTTP-I/O)
(RUNTIME HTTP-CLIENT)
+ (RUNTIME HTML-FORM-CODEC)
(RUNTIME WIN32-REGISTRY)))
\f
(let ((obj (file->object "site" #t #f)))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rfc2822-headers.scm,v 14.1 2008/08/24 07:20:09 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; RFC 2822 headers
+;;; package: (runtime rfc2822-headers)
+
+(declare (usual-integrations))
+\f
+(define (make-rfc2822-header name value)
+ (guarantee-header-name name 'make-rfc2822-header)
+ (guarantee-header-value value 'make-rfc2822-header)
+ (make-header name value))
+
+(define-record-type <rfc2822-header>
+ (make-header name value)
+ rfc2822-header?
+ (name rfc2822-header-name)
+ (value rfc2822-header-value))
+
+(define-guarantee rfc2822-header "RFC 2822 header field")
+
+(set-record-type-unparser-method! <rfc2822-header>
+ (simple-unparser-method 'rfc2822-header
+ (lambda (header)
+ (list (rfc2822-header-name header)))))
+
+(define (header-name? object)
+ (and (interned-symbol? object)
+ (not (eq? object '||))
+ (string-in-char-set? (symbol-name object) char-set:rfc2822-name)))
+
+(define-guarantee header-name "RFC 2822 header-field name")
+
+(define (header-value? object)
+ (and (string? object)
+ (string-in-char-set? object char-set:rfc2822-text)))
+
+(define-guarantee header-value "RFC 2822 header-field value")
+
+(define (string-in-char-set? string char-set)
+ (let ((end (string-length string)))
+ (let loop ((i 0))
+ (if (fix:< i end)
+ (and (char-set-member? char-set (string-ref string i))
+ (loop (fix:+ i 1)))
+ #t))))
+
+(define (guarantee-rfc2822-headers object #!optional caller)
+ (guarantee-list-of-type object
+ rfc2822-header?
+ "list of RFC 2822 header fields"
+ caller))
+
+(define (first-rfc2822-header name headers)
+ (guarantee-rfc2822-headers headers 'FIRST-RFC2822-HEADER)
+ (find (lambda (header)
+ (eq? (rfc2822-header-name header) name))
+ headers))
+
+(define (all-rfc2822-headers name headers)
+ (guarantee-rfc2822-headers headers 'ALL-RFC2822-HEADERS)
+ (filter (lambda (header)
+ (eq? (rfc2822-header-name header) name))
+ headers))
+\f
+;;;;; Output
+
+(define (rfc2822-headers->string headers)
+ (call-with-output-string
+ (lambda (port)
+ (write-rfc2822-headers headers port))))
+
+(define (write-rfc2822-headers headers port)
+ (guarantee-rfc2822-headers headers 'WRITE-RFC2822-HEADERS)
+ (for-each (lambda (header)
+ (write-header header port))
+ headers)
+ (newline port))
+
+(define (write-header header port)
+ (write-name (rfc2822-header-name header) port)
+ (write-string ": " port)
+ ;; Needs to handle line folding someday, but that requires
+ ;; understanding details of the header structure.
+ (write-string (rfc2822-header-value header) port)
+ (newline port))
+
+(define (write-name name port)
+ (let* ((name (symbol-name name))
+ (end (string-length name)))
+ (if (char-alphabetic? (string-ref name 0))
+ (letrec
+ ((start-word
+ (lambda (i)
+ (if (fix:< i end)
+ (begin
+ (write-char (char-upcase (string-ref name i)) port)
+ (finish-word (fix:+ i 1))))))
+ (finish-word
+ (lambda (i)
+ (if (fix:< i end)
+ (let ((char (string-ref name i))
+ (i (fix:+ i 1)))
+ (write-char char port)
+ (if (char=? char #\-)
+ (start-word i)
+ (finish-word i)))))))
+ (start-word 0))
+ (write-string name port))))
+\f
+;;;;; Input
+
+(define (string->rfc2822-headers string)
+ (call-with-input-string string read-rfc2822-headers))
+
+(define (read-rfc2822-headers port)
+ (let loop ((headers '()))
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ (parse-error port "Premature EOF reading header fields."))
+ (let ((end (string-length line)))
+ (cond ((fix:= end 0)
+ (map (lambda (p)
+ (make-rfc2822-header (car p) (cdr p)))
+ (reverse! headers)))
+ ((char-wsp? (string-ref line 0))
+ (if (not (pair? headers))
+ (parse-error port
+ "Unmatched header continuation in request:"
+ line))
+ (let ((h (car headers)))
+ (set-cdr! h
+ (string-append (cdr h)
+ " "
+ (trim-wsp line 0 end))))
+ (loop headers))
+ (else
+ (loop
+ (cons (let ((colon (string-find-next-char line #\:)))
+ (if (not colon)
+ (parse-error port
+ "Missing colon in header field:"
+ line))
+ (let ((name (intern (string-head line colon))))
+ (guarantee-header-name name)
+ (cons name
+ (trim-wsp line (fix:+ colon 1) end))))
+ headers))))))))
+
+(define (trim-wsp string start end)
+ (let* ((start*
+ (let loop ((i start))
+ (if (and (fix:< i end)
+ (char-wsp? (string-ref string i)))
+ (loop (fix:+ i 1))
+ i)))
+ (end*
+ (let loop ((i end))
+ (if (and (fix:> i start*)
+ (char-wsp? (string-ref string (fix:- i 1))))
+ (loop (fix:- i 1))
+ i))))
+ (let ((string
+ (if (and (fix:= start* 0)
+ (fix:= end* (string-length string)))
+ string
+ (substring string start* end*))))
+ (guarantee-header-value string)
+ string)))
+
+(define (char-wsp? char)
+ (char-set-member? char-set:wsp char))
+\f
+;;;; Quotation
+
+(define (quote-rfc2822-text string #!optional start end)
+ (let ((input (open-input-string string start end))
+ (output (open-output-string)))
+ (let loop ((quote? #f))
+ (let ((char (read-char input)))
+ (cond ((eof-object? char)
+ (let ((s (get-output-string output)))
+ (if quote?
+ (string-append "\"" s "\"")
+ s)))
+ ((char-set-member? char-set:rfc2822-qtext char)
+ (write-char char output)
+ (loop quote?))
+ ((char-set-member? char-set:rfc2822-text char)
+ (write-char #\\ output)
+ (write-char char output)
+ (loop #t))
+ (else
+ (error:bad-range-argument string 'quote-rfc2822-string)))))))
+
+(define parser:rfc2822-quoted-string
+ (*parser
+ (seq "\""
+ (map (lambda (string)
+ (call-with-output-string
+ (lambda (output)
+ (let ((input (open-input-string string)))
+ (let loop ()
+ (let ((char (read-char input)))
+ (if (not (eof-object? char))
+ (begin
+ (write-char (if (char=? char #\\)
+ (read-char input)
+ char)
+ output)
+ (loop)))))))))
+ (match (* (alt (char-set char-set:rfc2822-qtext)
+ (seq "\\" (char-set char-set:rfc2822-text))))))
+ "\"")))
+\f
+;;;; Initialization
+
+(define char-set:rfc2822-name)
+(define char-set:rfc2822-text)
+(define char-set:rfc2822-qtext)
+
+(define condition-type:rfc2822-parse-error)
+(define parse-error)
+
+(define (initialize-package!)
+ (set! char-set:rfc2822-name
+ (char-set-difference char-set:ascii
+ (char-set-union char-set:ctls
+ (char-set #\space #\:)
+ char-set:upper-case)))
+ (set! char-set:rfc2822-text
+ (char-set-difference char-set:ascii
+ (char-set #\null #\linefeed #\return)))
+ (set! char-set:rfc2822-qtext
+ (char-set-difference char-set:rfc2822-text
+ (char-set #\tab #\space #\delete #\\ #\")))
+ (set! condition-type:rfc2822-parse-error
+ (make-condition-type 'RFC2822-PARSE-ERROR
+ condition-type:port-error
+ '(MESSAGE IRRITANTS)
+ (lambda (condition port)
+ (write-string "Error while parsing RFC 2822 headers: " port)
+ (format-error-message (access-condition condition 'MESSAGE)
+ (access-condition condition 'IRRITANTS)
+ port))))
+ (set! parse-error
+ (let ((signal
+ (condition-signaller condition-type:rfc2822-parse-error
+ '(PORT MESSAGE IRRITANTS)
+ standard-error-handler)))
+ (lambda (port message . irritants)
+ (signal port message irritants))))
+ unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.659 2008/08/21 01:00:46 cph Exp $
+$Id: runtime.pkg,v 14.660 2008/08/24 07:20:11 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
output-buffer-using-binary-denormalizer?
port-input-buffer
port-output-buffer)
+ (export (runtime http-i/o)
+ known-input-coding?)
(initialization (initialize-package!)))
(define-package (runtime gensym)
parse-partial-uri
parse-relative-uri
parse-uri
+ parse-uri-no-authority
partial-uri->string
partial-uri-authority
partial-uri-extra
write-uri)
(initialization (initialize-package!)))
-(define-package (runtime http-client)
- (files "http-client")
+(define-package (runtime rfc2822-headers)
+ (files "rfc2822-headers")
(parent (runtime))
(export ()
- adjoin-http-header-fields
- call-with-http-connection
- call-with-http-response:entity-request
- call-with-http-response:get
- call-with-http-response:post
- close-http-connection
+ all-rfc2822-headers
+ char-set:rfc2822-name
+ char-set:rfc2822-qtext
+ char-set:rfc2822-text
+ condition-type:rfc2822-parse-error
+ error:not-rfc2822-header
+ first-rfc2822-header
+ guarantee-rfc2822-header
+ make-rfc2822-header
+ parser:rfc2822-quoted-string
+ quote-rfc2822-text
+ read-rfc2822-headers
+ rfc2822-header-name
+ rfc2822-header-value
+ rfc2822-header?
+ rfc2822-headers->string
+ string->rfc2822-headers
+ write-rfc2822-headers)
+ (initialization (initialize-package!)))
+
+(define-package (runtime http-i/o)
+ (files "httpio")
+ (parent (runtime))
+ (export ()
+ all-http-headers
+ error:not-http-entity
+ error:not-http-header
+ error:not-http-request
+ error:not-http-response
+ error:not-http-status
+ error:not-http-text
+ error:not-http-token
+ error:not-http-uri
+ error:not-http-version
+ error:not-simple-http-request
+ error:not-simple-http-response
+ error:not-simple-http-uri
+ first-http-header
+ guarantee-http-entity
+ guarantee-http-header
+ guarantee-http-request
+ guarantee-http-response
+ guarantee-http-status
+ guarantee-http-text
+ guarantee-http-token
+ guarantee-http-uri
guarantee-http-version
- http-connection?
- http-connection/host
- http-connection/host-string
- http-connection/port
- http-connection/socket
- http-connection-open?
- http-get
- http-head
- http-post
- http-parser:status-code
- http-parser:status-line
- http-parser:version
+ guarantee-simple-http-request
+ guarantee-simple-http-response
+ guarantee-simple-http-uri
+ http-content-length
+ http-content-type
+ http-entity-body
+ http-entity-body-port
+ http-entity-headers
+ http-entity?
+ http-header?
+ http-request-body
+ http-request-headers
+ http-request-method
+ http-request-uri
+ http-request-version
+ http-request?
+ http-response-body
+ http-response-headers
+ http-response-reason
+ http-response-status
+ http-response-version
http-response?
- http-response/first-header-field
- http-response/all-header-fields
- http-response/header-fields
- http-response/reason
- http-response/status-code
- http-response/status-type
- http-response/version
- http-version
- http-version?
- http-version=?
+ http-status-description
+ http-status?
+ http-text?
+ http-token?
+ http-uri?
+ http-version-major
+ http-version-minor
+ http-version:1.0
+ http-version:1.1
http-version<?
+ http-version=?
+ http-version?
+ make-http-request
+ make-http-response
make-http-version
- open-http-connection
- read-http-entity
+ make-simple-http-request
+ make-simple-http-response
+ parser:http-content-type
+ read-http-request
read-http-response
- receive-http-response
- send-http-request
- valid-http-header-field?
+ read-simple-http-request
+ read-simple-http-response
+ simple-http-request?
+ simple-http-response?
+ simple-http-uri?
write-http-request
- ))
+ write-http-response)
+ (initialization (initialize-package!)))
+
+(define-package (runtime http-client)
+ (files "http-client")
+ (parent (runtime))
+ (export ()
+ http-get
+ http-head
+ http-post)
+ (initialization (initialize-package!)))
+
+(define-package (runtime html-form-codec)
+ (files "html-form-codec")
+ (parent (runtime))
+ (export ()
+ decode-www-form-urlencoded
+ encode-www-form-urlencoded)
+ (initialization (initialize-package!)))
(define-package (runtime postgresql)
(file-case options
#| -*-Scheme-*-
-$Id: url.scm,v 1.54 2008/07/19 01:41:17 cph Exp $
+$Id: url.scm,v 1.55 2008/08/24 07:20:12 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
,@(if (%uri-fragment uri)
`((fragment ,(%uri-fragment uri)))
'()))))
+
+(define (uri-prefix prefix)
+ (guarantee-utf8-string prefix 'URI-PREFIX)
+ (lambda (suffix)
+ (guarantee-utf8-string suffix 'URI-PREFIX)
+ (string->absolute-uri (string-append prefix suffix))))
\f
;;;; Merging
(vector-ref v 3)
(vector-ref v 4)))
-(define (uri-prefix prefix)
- (guarantee-utf8-string prefix 'URI-PREFIX)
- (lambda (suffix)
- (guarantee-utf8-string suffix 'URI-PREFIX)
- (string->absolute-uri (string-append prefix suffix))))
+(define parse-uri-no-authority
+ (*parser
+ (encapsulate encapsulate-uri
+ (seq (values #f #f)
+ parser:path-only))))
\f
(define parser:uri
(*parser
(define parser:relative-part
(*parser
(alt (seq "//" parser:authority parser:path-abempty)
- (seq (values #f) parser:path-absolute)
- (seq (values #f) parser:path-noscheme)
- (seq (values #f) parser:path-empty))))
+ (seq (values #f) parser:path-only))))
+
+(define parser:path-only
+ (*parser
+ (alt parser:path-absolute
+ parser:path-noscheme
+ parser:path-empty)))
(define parser:scheme
(*parser
projects / mit-scheme.git / commitdiff