From 196e3b5c2e047d03b40aaa229192ff9cdc99fa2a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 24 Aug 2008 07:20:12 +0000 Subject: [PATCH] Replace http-client.scm with new HTTP support. The new mechanism is slightly lower level than the old, but it provides support for servers and is slightly smarter about encoding. THIS WILL BREAK EXISTING USERS OF HTTP-CLIENT --- v7/src/runtime/ed-ffi.scm | 6 +- v7/src/runtime/html-form-codec.scm | 158 ++++++++ v7/src/runtime/http-client.scm | 522 +++----------------------- v7/src/runtime/httpio.scm | 571 +++++++++++++++++++++++++++++ v7/src/runtime/make.scm | 5 +- v7/src/runtime/rfc2822-headers.scm | 277 ++++++++++++++ v7/src/runtime/runtime.pkg | 151 ++++++-- v7/src/runtime/url.scm | 28 +- 8 files changed, 1207 insertions(+), 511 deletions(-) create mode 100644 v7/src/runtime/html-form-codec.scm create mode 100644 v7/src/runtime/httpio.scm create mode 100644 v7/src/runtime/rfc2822-headers.scm diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm index c8459f74c..5dd335e75 100644 --- a/v7/src/runtime/ed-ffi.scm +++ b/v7/src/runtime/ed-ffi.scm @@ -1,6 +1,6 @@ #| -*- 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, @@ -81,6 +81,9 @@ USA. ("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)) @@ -130,6 +133,7 @@ USA. ("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)) diff --git a/v7/src/runtime/html-form-codec.scm b/v7/src/runtime/html-form-codec.scm new file mode 100644 index 000000000..b84a89afd --- /dev/null +++ b/v7/src/runtime/html-form-codec.scm @@ -0,0 +1,158 @@ +#| -*-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)) + +;;;; 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))))))))) + +;;;; 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 diff --git a/v7/src/runtime/http-client.scm b/v7/src/runtime/http-client.scm index 0405135f9..68c7fb2d8 100644 --- a/v7/src/runtime/http-client.scm +++ b/v7/src/runtime/http-client.scm @@ -1,8 +1,10 @@ #| -*-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. @@ -23,467 +25,61 @@ USA. |# -;;;; HTTP 1.0 Client Abstraction +;;;; HTTP 1.0 client +;;; package: (runtime http-client) (declare (usual-integrations)) -(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))) - -;;;; 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))) - -;;;; 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")))) - -;;;; 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)))))) - -;;;; 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 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))) - -;;;; 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)))) - -;;;;; 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)) - -;;;;; 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 diff --git a/v7/src/runtime/httpio.scm b/v7/src/runtime/httpio.scm new file mode 100644 index 000000000..c975020ea --- /dev/null +++ b/v7/src/runtime/httpio.scm @@ -0,0 +1,571 @@ +#| -*-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)) + +(define-record-type + (%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 + (%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)) + +(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") + +(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= 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") + +;;;; 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)) + +;;;; 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))))) + +(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)))) + +(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.")) + +;;;; 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) + +;;;; 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))) + +(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 diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 3e0ae166e..95f054d7a 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -512,7 +512,10 @@ USA. ;; 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))) (let ((obj (file->object "site" #t #f))) diff --git a/v7/src/runtime/rfc2822-headers.scm b/v7/src/runtime/rfc2822-headers.scm new file mode 100644 index 000000000..e1df0415e --- /dev/null +++ b/v7/src/runtime/rfc2822-headers.scm @@ -0,0 +1,277 @@ +#| -*-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)) + +(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 + (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! + (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)) + +;;;;; 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)))) + +;;;;; 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)) + +;;;; 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)))))) + "\""))) + +;;;; 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 diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 76f8a186b..d4b5eaa7c 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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, @@ -1784,6 +1784,8 @@ USA. 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) @@ -5045,6 +5047,7 @@ USA. parse-partial-uri parse-relative-uri parse-uri + parse-uri-no-authority partial-uri->string partial-uri-authority partial-uri-extra @@ -5122,50 +5125,124 @@ USA. 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-versionabsolute-uri (string-append prefix suffix)))) ;;;; Merging @@ -390,11 +396,11 @@ USA. (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)))) (define parser:uri (*parser @@ -430,9 +436,13 @@ USA. (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 -- 2.25.1