From: Chris Hanson Date: Wed, 17 Sep 2008 06:31:54 +0000 (+0000) Subject: Hair up handling of HTTP headers. In new model, there are codecs for X-Git-Tag: 20090517-FFI~139 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a4c0540ca381d86f8d49275fbc96837d56eabe61;p=mit-scheme.git Hair up handling of HTTP headers. In new model, there are codecs for each known header (basically almost all of RFC 2616 at this point). These codecs translate between the string representation of a header value and its internal representation. MAKE-HTTP-HEADER accepts either the string representation or the internal representation. HTTP-HEADER-VALUE always contains the string representation, while HTTP-HEADER-PARSED-VALUE contains the internal representation. If the decoder for a header fails on a particular string represenation, or if there's no decoder for that header, HTTP-HEADER-PARSED-VALUE contains a default object (use DEFAULT-OBJECT? to test for it). Additionally, HTTP requests have been changed so that the METHOD is a string rather than a symbol (that is, "GET" rather than '|GET|). --- diff --git a/v7/src/runtime/http-client.scm b/v7/src/runtime/http-client.scm index a7c9bf3ef..2955a637d 100644 --- a/v7/src/runtime/http-client.scm +++ b/v7/src/runtime/http-client.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: http-client.scm,v 14.7 2008/09/15 05:15:08 cph Exp $ +$Id: http-client.scm,v 14.8 2008/09/17 06:31:45 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -31,46 +31,57 @@ USA. (declare (usual-integrations)) (define (http-get uri headers) - (run-client-method '|GET| uri headers "")) + (http-client-exchange "GET" uri headers "")) (define (http-head uri headers) - (run-client-method '|HEAD| uri headers "")) + (http-client-exchange "HEAD" uri headers "")) (define (http-post uri headers body) - (run-client-method '|POST| uri headers body)) + (http-client-exchange "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 - (add-default-headers headers authority) - body))) +(define (http-client-exchange method uri headers body) + (let ((request (http-client-request method uri headers body))) + (let ((port + (let ((authority (uri-authority uri))) + (open-tcp-stream-socket (uri-authority-host authority) + (or (uri-authority-port authority) 80))))) (write-http-request request port) (let ((response (read-http-response request port))) (close-port port) response)))) +(define (http-client-request method uri headers body) + (guarantee-absolute-uri uri) + (make-http-request method + (make-uri #f + #f + (uri-path uri) + (uri-query uri) + (uri-fragment uri)) + http-version:1.0 + (add-default-headers headers (uri-authority uri)) + body)) + (define (add-default-headers headers authority) (let ((headers (convert-http-headers headers))) - (cons (make-http-header 'HOST (host-string authority)) - (if (http-header 'USER-AGENT headers #f) - headers - (cons (make-http-header 'USER-AGENT default-http-user-agent) - headers))))) - -(define (host-string authority) - (let ((host (uri-authority-host authority)) - (port (uri-authority-port authority))) - (if port - (string-append host ":" (number->string port)) - host))) \ No newline at end of file + (let ((optional + (lambda (name value) + (if (http-header name headers #f) + '() + (list (make-http-header name value)))))) + `(,(make-http-header 'DATE + (universal-time->global-decoded-time + (get-universal-time))) + ,@(optional 'ACCEPT + `((,(make-mime-type 'APPLICATION 'XHTML+XML)) + (,(make-mime-type 'TEXT 'XHTML) (Q . "0.9")) + (,(make-mime-type 'TEXT 'PLAIN) (Q . "0.5")) + (TEXT (Q . "0.1")))) + ,@(optional 'ACCEPT-CHARSET '((US-ASCII) (ISO-8859-1) (UTF-8))) + ,@(optional 'ACCEPT-ENCODING '((IDENTITY))) + ,@(optional 'ACCEPT-LANGUAGE `((EN-US) (EN (Q . "0.9")))) + ,(make-http-header 'HOST + (cons (uri-authority-host authority) + (uri-authority-port authority))) + ,@(optional 'USER-AGENT default-http-user-agent) + ,@headers)))) diff --git a/v7/src/runtime/http-syntax.scm b/v7/src/runtime/http-syntax.scm index 5f87264ea..21bd412cf 100644 --- a/v7/src/runtime/http-syntax.scm +++ b/v7/src/runtime/http-syntax.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: http-syntax.scm,v 1.1 2008/09/15 05:15:12 cph Exp $ +$Id: http-syntax.scm,v 1.2 2008/09/17 06:31:48 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -30,7 +30,7 @@ USA. (declare (usual-integrations)) -;;;; Version +;;;; Versions (define (http-version? object) (and (pair? object) @@ -68,6 +68,9 @@ USA. (write-string "." port) (write (cdr version) port)) +(define-deferred http-version:1.0 (make-http-version 1 0)) +(define-deferred http-version:1.1 (make-http-version 1 1)) + ;;;; Status (define (http-status? object) @@ -89,20 +92,34 @@ USA. (define (write-http-status object port) (write-string (string-pad-left (number->string object) 3 #\0) port)) -;;;; Header +;;;; Headers (define-record-type - (%make-http-header name value) + (%make-header name value parsed-value) http-header? (name http-header-name) - (value http-header-value)) + (value http-header-value) + (parsed-value http-header-parsed-value)) (define-guarantee http-header "HTTP header field") (define (make-http-header name value) (guarantee-http-token name 'MAKE-HTTP-HEADER) - (guarantee-http-text value 'MAKE-HTTP-HEADER) - (%make-http-header name value)) + (let ((defn (header-value-defn name))) + (if defn + (if ((hvdefn-predicate defn) value) + (%make-header name + (call-with-output-string + (lambda (port) + ((hvdefn-writer defn) value port))) + value) + (begin + (guarantee-http-text value 'MAKE-HTTP-HEADER) + (%make-header name value + (%call-parser (hvdefn-parser defn) value)))) + (begin + (guarantee-http-text value 'MAKE-HTTP-HEADER) + (%make-header name value (%unparsed-value)))))) (define (convert-http-headers headers #!optional caller) (guarantee-list headers caller) @@ -134,22 +151,8 @@ USA. (if (and (not h) error?) (error:bad-range-argument name 'HTTP-HEADER)) h)) - -(define (read-http-headers port) - (map (lambda (h) - (make-http-header (rfc2822-header-name h) - (rfc2822-header-value h))) - (read-rfc2822-headers port))) - -(define (write-http-headers headers port) - (guarantee-http-headers headers 'WRITE-HTTP-HEADERS) - (write-rfc2822-headers (map (lambda (h) - (make-rfc2822-header (http-header-name h) - (http-header-value h))) - headers) - port)) -;;;; Token +;;;; Tokens and text (define (http-token? object) (and (interned-symbol? object) @@ -160,6 +163,12 @@ USA. (define (write-http-token token port) (write-string (symbol-name token) port)) +(define (http-token-string? object) + (and (string? object) + (string-is-http-token? object))) + +(define-guarantee http-token-string "HTTP token string") + (define (string-is-http-token? string) (*match-string match-http-token string)) @@ -169,8 +178,6 @@ USA. (define match-http-token (*matcher (+ (char-set char-set:http-token)))) -;;;; Text - (define (http-text? object) (string? object)) @@ -188,7 +195,7 @@ USA. (define (write-comment string port) (write-char #\( port) - (%write-with-quotations string char-set:http-ctext port) + (%write-with-quotations string char-set:http-text port) (write-char #\) port)) (define (%write-with-quotations string unquoted port) @@ -199,54 +206,1413 @@ USA. (if (not (char-set-member? unquoted char)) (write-char #\\ port)) (write-char char port))))) + +(define (comment? string) + (let ((port (open-input-string string))) + (let loop ((level 0)) + (let ((char (read-char port))) + (cond ((eof-object? char) (= level 0)) + ((char=? char #\() (loop (+ level 1))) + ((char=? char #\)) (loop (- level 1))) + (else (loop level))))))) + +;;;; Header I/O + +(define (read-http-headers port) + (let loop ((headers '())) + (let ((string (%read-http-header port))) + (if string + (loop (cons (parse-header string) headers)) + (reverse! headers))))) + +(define (%read-http-header port) + (let ((line (read-line port))) + (if (eof-object? line) + (error "Premature EOF reading header.")) + (if (string-null? line) + #f + (let loop ((lines (list (string-trim-right line)))) + (cond ((char-wsp? (peek-char port)) + (loop (cons (string-trim (read-line port)) lines))) + ((null? (cdr lines)) + (car lines)) + (else + (decorated-string-append "" " " "" (reverse! lines)))))))) + +(define parse-header + (let ((parser + (*parser + (seq (match (+ (char-set char-set:http-token))) + #\: + (noise (* (char-set char-set:wsp))) + (match (* (char-set char-set:http-text))))))) + (lambda (string) + (let ((v (*parse-string parser string))) + (if (not v) + (error "Ill-formed HTTP header:" string)) + (let ((name (intern (vector-ref v 0))) + (value (vector-ref v 1))) + (%make-header name + value + (let ((defn (header-value-defn name))) + (if defn + (%call-parser (hvdefn-parser defn) value) + (%unparsed-value))))))))) + +(define (%call-parser parser value) + (parser value + (lambda (parsed-value) + parsed-value) + (lambda () + (warn "Ill-formed HTTP header value:" value) + (%unparsed-value)))) + +(define (%unparsed-value) + (default-object)) + +(define (write-http-headers headers port) + (guarantee-http-headers headers 'WRITE-HTTP-HEADERS) + (for-each (lambda (header) + (let ((name (http-header-name header))) + (let ((defn (header-value-defn name))) + (if defn + (write-string (hvdefn-name defn) port) + (write-http-token name port)))) + (write-string ": " port) + (write-string (http-header-value header) port) + (newline port)) + headers) + (newline port)) + +;;;; Header element types + +(define (lp:comma-list min-length parse-item) + (let ((ugh (list-parser (* (alt #\, lp:lws))))) + (list-parser + (qualify (lambda (items) + (>= (length items) min-length)) + (encapsulate list + (alt ugh + (? parse-item + ugh + (* #\, + (? lp:lws) + parse-item + ugh)))))))) + +(define (write-comma-list write-elt elts port) + (if (pair? elts) + (begin + (write-elt (car elts) port) + (for-each (lambda (elt) + (write-string ", " port) + (write-elt elt port)) + (cdr elts))))) + +(define lp:token + (list-parser (map intern lp:token-string))) + +(define lp:token-cs + (list-parser (map string->symbol lp:token-string))) + +(define lp:token-string + (list-parser (map token-token->string (match-if token-token?)))) + +(define lp:token+ + (lp:comma-list 1 lp:token)) + +(define (token+? object) + (and (pair? object) + (token*? object))) + +(define lp:token-cs* + (lp:comma-list 0 lp:token-cs)) + +(define (token*? object) + (list-of-type? object http-token?)) + +(define (write-token* tokens port) + (write-comma-list write-http-token tokens port)) + +(define lp:text + (list-parser + (alt lp:token-string + lp:quoted-string))) + +(define lp:quoted-string + (list-parser + (map quoted-string-token->string + (match-if quoted-string-token?)))) + +(define lp:comment + (list-parser + (map comment-token->string + (match-if comment-token?)))) + +(define lp:lws + (list-parser (noise-if lws-token?))) + +(define lp:* + (list-parser (qualify (token= '*) lp:token))) + +(define-integrable (token= token) + (lambda (token*) + (eq? token* token))) + +;;;; Parameters + +(define lp:parameter* + (list-parser + (encapsulate list + (* lp:semicolon + lp:parameter)))) + +(define lp:parameter + (list-parser + (encapsulate cons + (seq lp:token + #\= + lp:text)))) + +(define lp:parameter%* + (list-parser + (encapsulate list + (* lp:semicolon + lp:parameter%)))) + +(define lp:parameter% + (list-parser + (encapsulate cons + (seq lp:token + (alt (seq #\= lp:text) + (values #f)))))) + +(define lp:semicolon + (list-parser + (seq (? lp:lws) + #\; + (? lp:lws)))) + +(define (write-semicolon-sep port) + (write-char #\; port) + (write-char #\space port)) + +(define (http-parameters? object) + (list-of-type? object parameter?)) + +(define (parameter? object) + (pair-of-type? object + http-token? + http-text?)) + +(define (parameter%*? object) + (list-of-type? object parameter%?)) + +(define (parameter%+? object) + (list+-of-type? object parameter%?)) + +(define (parameter%? object) + (pair-of-type? object + http-token? + (lambda (value) + (or (not value) + (http-text? value))))) + +(define (write-parameter* parameters port) + (for-each (lambda (param) + (write-semicolon-sep port) + (write-parameter param port)) + parameters)) + +(define (write-parameter param port) + (write-http-token (car param) port) + (if (cdr param) + (begin + (write-char #\= port) + (write-text (cdr param) port)))) + +(define lp:qparam + (list-parser + (qualify (lambda (p) + (eq? (car p) 'Q)) + lp:parameter))) + +(define (qparam? object) + (and (parameter? object) + (eq? (car object) 'Q))) + +(define lp:opt-qparam + (list-parser + (encapsulate list + (? (seq lp:semicolon + lp:qparam))))) + +(define (opt-qparam? object) + (or (null? object) + (and (pair? object) + (qparam? (car object)) + (null? (cdr object))))) + +;;; Slight misnomer here. This "accept-params" represents the pattern +;;; *( ";" parameter ) [accept-params] + +(define lp:accept-params + (list-parser + (encapsulate list + (seq (* (seq lp:semicolon + (disqualify qparam? lp:parameter))) + (? lp:semicolon + lp:qparam + (* lp:semicolon + lp:parameter%)))))) + +(define (accept-params? value) + (and (list? value) + (let loop ((params value)) + (if (pair? params) + (and (parameter? (car params)) + (if (qparam? (car params)) + (every parameter%? (cdr params)) + (loop (cdr params)))) + #t)))) + +(define (params-are-expectation? object) + (and (pair? object) + (or (cdar object) + (null? (cdr object))))) + +(define lp:nonnegative-integer + (list-parser + (map string->number + (qualify (lambda (string) + (*match-string (*matcher (+ (char-set char-set:numeric))) + string)) + lp:token-string)))) + +(define lp:mime-type + (list-parser + (encapsulate make-mime-type + (seq lp:token + #\/ + lp:token)))) + +(define-deferred parser:http-date + (let ((parser:gmttime (parser:ctime 0))) + (*parser + (map decoded-time->utc + (alt parser:rfc2822-time + parser:rfc850-time + parser:gmttime))))) + +(define (http-date? value) + (and (decoded-time? value) + (eqv? (decoded-time/zone value) 0))) + +(define (write-http-date value port) + (write-decoded-time-as-http value port)) + +(define lp:hostport + (list-parser + (encapsulate (lambda (host port) + (*parse-string parse-hostport + (if port + (string-append host ":" port) + host))) + (seq lp:token-string + (alt (seq #\: lp:token-string) + (values #f)))))) + +(define parse-hostport + (*parser (encapsulate* cons url:parse:hostport))) + +(define (hostport? value) + (pair-of-type? value + string? + (lambda (port) + (or (not port) + (exact-nonnegative-integer? port))))) + +(define (write-hostport value port) + (write-string (car value) port) + (if (cdr value) + (begin + (write-char #\: port) + (write (cdr value) port)))) +(define (language-range? object) + (and (http-token? object) + (token-is-language-range? object))) + +(define (token-is-language-range? token) + (or (eq? token '*) + (token-is-language-tag? token))) + +(define lp:language-tag + (list-parser (qualify token-is-language-tag? lp:token))) + +(define (language-tag? object) + (and (http-token? object) + (token-is-language-tag? object))) + +(define (token-is-language-tag? token) + (*match-string (let ((segment + (*matcher + (n*m 1 8 (char-set char-set:alpha))))) + (*matcher + (seq segment + (* (seq #\- segment))))) + (symbol-name token))) + +(define lp:entity-tag + (list-parser + (encapsulate cons + (seq (alt (encapsulate (lambda () 'WEAK) + (seq (qualify (lambda (s) + (string=? s "W")) + lp:token-string) + #\/)) + (values 'STRONG)) + lp:quoted-string)))) + +(define (entity-tag? value) + (pair-of-type? value + (lambda (type) + (or (eq? type 'WEAK) + (eq? type 'STRONG))) + http-text?)) + +(define (write-entity-tag value port) + (if (eq? (car value) 'WEAK) + (write-string "W/" port)) + (write-quoted-string (cdr value) port)) + +(define lp:entity-tag+ + (lp:comma-list 1 lp:entity-tag)) + +(define (entity-tag+? value) + (list+-of-type? value entity-tag?)) + +(define (write-entity-tag+ value port) + (write-comma-list write-entity-tag value port)) + +(define lp:bytes-unit + (list-parser (qualify (token= 'BYTES) lp:token))) + +(define (bytes-unit? value) + (eq? value 'BYTES)) + +(define lp:byte-range-set + (lp:comma-list 1 + (list-parser + (transform (lambda (string) + (let ((v + (*parse-string + (let ((match-num + (*matcher (+ (char-set char-set:numeric))))) + (*parser + (encapsulate* cons + (alt (seq (match match-num) + #\- + (alt (match match-num) + (values #f))) + (seq (values #f) + #\- + (match match-num)))))) + string))) + (and v + (list (vector-ref v 0))))) + lp:token-string)))) + +(define (byte-range-set? value) + (list+-of-type? value + (lambda (p) + (and (pair? p) + (or (and (exact-nonnegative-integer? (car p)) + (exact-nonnegative-integer? (cdr p))) + (and (exact-nonnegative-integer? (car p)) + (not (cdr p))) + (and (not (car p)) + (exact-nonnegative-integer? (cdr p)))))))) + +(define (write-byte-range-set value port) + (write-comma-list (lambda (p port) + (if (car p) + (begin + (write (car p) port) + (write-char #\- port) + (if (cdr p) + (write (cdr p) port))) + (begin + (write-char #\- port) + (write (cdr p) port)))) + value + port)) + +(define lp:product + (list-parser + (encapsulate cons + (seq lp:token-string + (alt (seq #\/ + lp:token-string) + (values #f)))))) + +(define (product? value) + (pair-of-type? value + http-token-string? + (lambda (x) + (or (not x) + (http-token-string? x))))) + +(define (write-product value port) + (write-string (car value) port) + (if (cdr value) + (begin + (write-char #\/ port) + (write-string (cdr value) port)))) + +(define lp:product/comment-list + (list-parser + (encapsulate list + (seq (alt lp:product + lp:comment) + (* (seq (? lp:lws) + (alt lp:product + lp:comment))))))) + +(define (product/comment-list? value) + (list-of-type? value + (lambda (elt) + (or (product? elt) + (comment? elt))))) + +(define (write-product/comment-list value port) + (let ((write-elt + (lambda (elt port) + (if (product? elt) + (write-product elt port) + (write-comment elt port))))) + (if (pair? value) + (begin + (write-elt (car value) port) + (for-each (lambda (elt) + (write-char #\space port) + (write-elt elt port)) + (cdr value)))))) + +;;;; Tokenization + +(define (string->tokens string) + (tokenizer-state:tokenize (open-input-string string) + (let ((head '()) + (tail '())) + (lambda (#!optional token) + (if (default-object? token) + (let ((tokens head)) + (set! head '()) + (set! tail '()) + tokens) + (let ((tail* (list token))) + (if (pair? tail) + (set-cdr! tail tail*) + (set! head tail*)) + (set! tail tail*) + unspecific)))) + (let ((port (open-output-string))) + (lambda (#!optional char) + (if (default-object? char) + (get-output-string! port) + (write-char char port)))))) + +(define (make-state eof-action else-action . bindings) + (let ((table (make-vector #x100 else-action))) + (do ((bindings bindings (cddr bindings))) + ((not (pair? bindings))) + (let ((key (car bindings)) + (handler (cadr bindings))) + (cond ((char? key) + (vector-set! table (char->integer key) handler)) + ((char-set? key) + (for-each (lambda (char) + (let ((i (char->integer char))) + (if (eq? (vector-ref table i) else-action) + (vector-set! table i handler)))) + (char-set-members key))) + (else + (error:wrong-type-argument key "char or char-set"))))) + (lambda (port emit fifo) + (let ((char (read-char port))) + (if (eof-object? char) + (eof-action port emit fifo) + ((vector-ref table (char->integer char)) char port emit fifo)))))) + +(define-integrable (lws-token? object) + (eqv? object #\space)) + +(define (separator-token? object) + (and (char? object) + (char-set-member? char-set:http-separators object))) + +(define (separator-token->char token) + token) + +(define (token-token? object) + (string? object)) + +(define (token-token->string token) + token) + +(define (quoted-string-token? object) + (pair-of-type? object + (lambda (tag) (eq? tag 'QUOTED-STRING)) + string?)) + +(define (quoted-string-token->string token) + (cdr token)) + +(define (comment-token? object) + (pair-of-type? object + (lambda (tag) (eq? tag 'COMMENT)) + string?)) + +(define (comment-token->string token) + (cdr token)) + +(define-syntax define-tokenizer-state + (sc-macro-transformer + (lambda (form env) + env + (if (and (syntax-match? '(SYMBOL ('EOF + DATUM) + + (EXPRESSION + DATUM)) + (cdr form)) + (let loop ((clauses (cddr form))) + (and (pair? clauses) + (if (eq? (caar clauses) 'ELSE) + (null? (cdr clauses)) + (loop (cdr clauses)))))) + (let ((state (cadr form)) + (eof-clause (caddr form)) + (normal-clauses (except-last-pair (cdddr form))) + (else-clause (last (cdddr form)))) + + (define (compile-rhs clause vars) + (let ((rhs (cdr clause))) + `(LAMBDA (,@vars PORT EMIT FIFO) + ,@vars PORT EMIT FIFO + ,@(map compile-action (except-last-pair rhs)) + ,(let ((ns (last rhs))) + (cond ((eq? ns 'DONE) + '(EMIT)) + ((symbol? ns) + `(,(state->name ns) PORT EMIT FIFO)) + (else ns)))))) + + (define (compile-action action) + (cond ((eq? action 'SAVE-CHAR) '(FIFO CHAR)) + ((eq? action 'UNREAD-CHAR) '(UNREAD-CHAR CHAR PORT)) + (else action))) + + (define (state->name name) + (symbol 'TOKENIZER-STATE: name)) + + `(DEFINE-DEFERRED ,(state->name state) + (MAKE-STATE ,(if eof-clause + (compile-rhs eof-clause '()) + `#F) + ,(compile-rhs else-clause '(CHAR)) + ,@(append-map (lambda (clause) + `(,(car clause) + ,(compile-rhs clause '(CHAR)))) + normal-clauses)))) + (ill-formed-syntax form))))) + +(define-deferred char-set:http-separators + (string->char-set "()<>@,;:\\\"/[]?={} \t")) + +(define-deferred char-set:http-token + (char-set-difference char-set:ascii + (char-set-union char-set:ctls + char-set:http-separators))) + +(define-deferred char-set:http-text + (char-set-invert char-set:ctls)) + +(define-deferred char-set:http-ctext + (char-set-difference char-set:http-text (char-set #\( #\)))) + +(define-deferred char-set:http-qdtext + (char-set-difference char-set:http-text (char-set #\"))) + +(define-deferred char-set:alpha + (char-set-union (ascii-range->char-set #x41 #x5B) + (ascii-range->char-set #x61 #x7B))) + +(define-tokenizer-state tokenize + (eof done) + (char-set:wsp in-wsp) + (char-set:http-token save-char in-token) + (#\" in-quoted-string) + (#\( in-comment) + (#\) (error "Illegal input char:" char)) + (char-set:http-separators (emit char) tokenize) + (else (error "Illegal input char:" char))) + +(define-tokenizer-state in-wsp + (eof done) + (char-set:wsp in-wsp) + (else unread-char (emit #\space) tokenize)) + +(define-tokenizer-state in-token + (eof (emit (fifo)) done) + (char-set:http-token save-char in-token) + (else (emit (fifo)) unread-char tokenize)) + +(define-tokenizer-state in-quoted-string + (eof (error "Premature EOF in quoted string.")) + (char-set:http-qdtext save-char in-quoted-string) + (#\\ in-quoted-string-quotation) + (#\" (emit (cons 'QUOTED-STRING (fifo))) tokenize) + (else (error "Illegal char in quoted string:" char))) + +(define-tokenizer-state in-quoted-string-quotation + (eof (error "Premature EOF in quoted string.")) + (else save-char in-quoted-string)) + +(define (tokenizer-state:in-comment port emit fifo) + ;; Comments aren't context-free, so tokenize them more carefully. + (let ((rc + (lambda () + (let ((char (read-char port))) + (if (eof-object? char) + (error "Premature EOF while reading comment.")) + char)))) + (let loop ((level 1)) + (let ((char (rc))) + (cond ((char=? char #\() + (fifo char) + (loop (+ level 1))) + ((char=? char #\)) + (if (= level 1) + (begin + (emit (cons 'COMMENT (fifo))) + (tokenizer-state:tokenize port emit fifo)) + (begin + (fifo char) + (loop (- level 1))))) + ((char=? char #\\) + (fifo (rc)) + (loop level)) + ((char-set-member? char-set:http-text char) + (fifo char) + (loop level)) + (else + (error "Illegal char in comment:" char))))))) + +;;;; Header definitions + +(define-syntax define-header + (sc-macro-transformer + (lambda (form env) + (if (syntax-match? '(+ EXPRESSION) (cdr form)) + `(ADD-BOOT-INIT! + (LAMBDA () + (DEFINE-HEADER-1 + ,@(map (lambda (expr) + (close-syntax expr env)) + (cdr form))))) + (ill-formed-syntax form))))) + +(define (define-header-1 name parser predicate writer) + (let ((key (intern name)) + (defn (make-hvdefn name parser predicate writer))) + (let ((p (assq key header-value-defns))) + (if p + (set-cdr! p defn) + (begin + (set! header-value-defns + (cons (cons key defn) + header-value-defns)) + unspecific))))) + +(define (header-value-defn name) + (let ((p (assq name header-value-defns))) + (and p + (cdr p)))) + +(define header-value-defns '()) + +(define-structure hvdefn + (name #f read-only #t) + (parser #f read-only #t) + (predicate #f read-only #t) + (writer #f read-only #t)) + +(define ((tokenized-parser parser) string win lose) + (parser (string->tokens string) + (lambda (items vals lose) + (if (null? items) + (begin + (if (not (= (structure-parser-values-length vals) 1)) + (error + "Wrong number of values from HTTP header parser.")) + (win (structure-parser-values-ref vals 0))) + (lose))) + lose)) + +(define ((direct-parser parser) string win lose) + (let ((v (*parse-string parser string))) + (if v + (begin + (if (not (fix:= (vector-length v) 1)) + (error "Wrong number of values from HTTP header parser.")) + (win (vector-ref v 0))) + (lose)))) + +;;;; General headers + +(define-header "Cache-Control" + (tokenized-parser (lp:comma-list 1 lp:parameter%)) + parameter%+? + (lambda (value port) (write-comma-list write-parameter value port))) + +(define-header "Connection" + (tokenized-parser lp:token+) + token+? + write-token*) + +(define-header "Date" + (direct-parser parser:http-date) + http-date? + write-http-date) + +(define-header "Pragma" + (tokenized-parser (lp:comma-list 1 lp:parameter%)) + parameter%+? + (lambda (value port) (write-comma-list write-parameter value port))) + +(define-header "Trailer" + (tokenized-parser lp:token+) + token+? + write-token*) + +(define-header "Transfer-Encoding" + (tokenized-parser + (list-parser + (encapsulate cons + (seq lp:token + lp:parameter*)))) + (lambda (value) + (pair-of-type? value + http-token? + http-parameters?)) + (lambda (value port) + (write-http-token (car value) port) + (write-parameter* (cdr value) port))) + +(define-header "Upgrade" + (tokenized-parser (lp:comma-list 1 lp:product)) + (lambda (value) (list+-of-type? value product?)) + (lambda (value port) (write-comma-list write-product value port))) + +(define-header "Via" + (tokenized-parser + (lp:comma-list 1 + (list-parser + (encapsulate cons + (seq (encapsulate cons + (seq (alt (seq lp:token #\/) + (values #f)) + lp:token)) + lp:lws + (alt lp:hostport + lp:token) + (? (noise (seq (? lp:lws) + lp:comment + (? lp:lws))))))))) + (lambda (value) + (pair-of-type? value + (lambda (received-protocol) + (pair-of-type? received-protocol + (lambda (name) + (or (not name) + (http-token? name))) + http-token?)) + (lambda (received-by) + (or (hostport? received-by) + (http-token? received-by))))) + (lambda (value port) + (let ((received-protocol (car value))) + (if (car received-protocol) + (begin + (write-http-token (car received-protocol) port) + (write-char #\/ port))) + (write-http-token (cdr received-protocol) port)) + (let ((received-by (cdr value))) + (if (hostport? received-by) + (write-hostport received-by port) + (write-http-token received-by port))))) + +(define-header "Warning" + (tokenized-parser + (lp:comma-list 1 + (list-parser + (encapsulate vector + (seq (qualify (lambda (n) (< n 1000)) lp:nonnegative-integer) + #\space + (alt lp:hostport + lp:token) + #\space + lp:quoted-string + (alt (seq #\space + (transform (lambda (string) + (let ((dt + (*parse-string parser:http-date + string))) + (and dt + (list dt)))) + lp:quoted-string)) + (values #f))))))) + (lambda (value) + (vector-of-types? value + (lambda (n) + (and (exact-nonnegative-integer? n) + (< n 1000))) + (lambda (h) + (or (hostport? h) + (http-token? h))) + http-text? + (lambda (dt) + (or (not dt) + (decoded-time? dt))))) + (lambda (value port) + (receive (code agent text date) (vector->values value) + (write-string (string-pad-left (number->string code) 3 #\0) port) + (write-char #\space port) + (if (hostport? agent) + (write-hostport agent port) + (write-http-token agent port)) + (write-char #\space port) + (write-quoted-string text port) + (if date + (begin + (write-char #\space port) + (write-quoted-string (call-with-output-string + (lambda (port) + (write-http-date date port))) + port)))))) + +;;;; Request headers + +(define-header "Accept" + (tokenized-parser + (lp:comma-list 0 + (list-parser + (encapsulate cons + (seq (encapsulate (lambda (t1 t2) + (if (eq? t2 '*) + (if (eq? t1 '*) + #t + t1) + (make-mime-type t1 t2))) + (seq lp:token + #\/ + lp:token)) + lp:accept-params))))) + (lambda (value) + (list-of-type? value + (lambda (elt) + (pair-of-type? elt + (lambda (mt) + (or (mime-type? mt) + (http-token? mt) + (eq? mt #t))) + accept-params?)))) + (lambda (value port) + (write-comma-list (lambda (elt port) + (let ((mt (car elt))) + (cond ((mime-type? mt) + (write-mime-type mt port)) + ((http-token? mt) + (write-http-token mt port) + (write-string "/*" port)) + (else + (write-string "*/*" port)))) + (write-parameter* (cdr elt) port)) + value + port))) + +(define-header "Accept-Charset" + (tokenized-parser + (lp:comma-list 1 + (list-parser + (encapsulate cons + (seq lp:token + lp:opt-qparam))))) + (lambda (value) + (list+-of-type? value + (lambda (elt) + (pair-of-type? elt + http-token? + opt-qparam?)))) + (lambda (value port) + (write-comma-list (lambda (elt port) + (write-http-token (car elt) port) + (write-parameter* (cdr elt) port)) + value + port))) + +(define-header "Accept-Encoding" + (tokenized-parser + (lp:comma-list 1 + (list-parser + (encapsulate cons + (seq lp:token + lp:opt-qparam))))) + (lambda (value) + (list+-of-type? value + (lambda (elt) + (pair-of-type? elt + http-token? + opt-qparam?)))) + (lambda (value port) + (write-comma-list (lambda (elt port) + (write-http-token (car elt) port) + (write-parameter* (cdr elt) port)) + value + port))) + +(define-header "Accept-Language" + (tokenized-parser + (lp:comma-list 1 + (list-parser + (encapsulate cons + (seq (qualify token-is-language-range? lp:token) + lp:opt-qparam))))) + (lambda (value) + (list+-of-type? value + (lambda (elt) + (pair-of-type? elt + language-range? + opt-qparam?)))) + (lambda (value port) + (write-comma-list (lambda (elt port) + (write-http-token (car elt) port) + (write-parameter* (cdr elt) port)) + value + port))) +#; +(define-header "Authorization" + (tokenized-parser + ...) + (lambda (value)) + (lambda (value port))) + +(define-header "Expect" + (tokenized-parser + (lp:comma-list 1 + (list-parser + (qualify params-are-expectation? + lp:parameter%*)))) + (lambda (value) + (list+-of-type? value + (lambda (expectation) + (and (parameter%*? expectation) + (params-are-expectation? expectation))))) + (lambda (value port) + (write-comma-list (lambda (expectation) + (write-parameter* expectation port)) + value + port))) +#; +(define-header "From" + ;; parser is completely different -- it's a mail address. + ... + (lambda (value)) + (lambda (value port))) + +(define-header "Host" + (direct-parser parse-hostport) + (lambda (value) + (pair-of-type? value + string? + (lambda (port) + (or (not port) + (exact-nonnegative-integer? port))))) + (lambda (value port) + (write-string (car value) port) + (if (cdr value) + (begin + (write-char #\: port) + (write (cdr value) port))))) + +(define-header "If-Match" + (tokenized-parser + (list-parser + (alt (qualify (token= '*) lp:token) + lp:entity-tag+))) + (lambda (value) + (or (eq? value '*) + (entity-tag+? value))) + (lambda (value port) + (if (eq? value '*) + (write-http-token value port) + (write-entity-tag+ value port)))) + +(define-header "If-Modified-Since" + (direct-parser parser:http-date) + http-date? + write-http-date) + +(define-header "If-None-Match" + (tokenized-parser + (list-parser + (alt (qualify (token= '*) lp:token) + lp:entity-tag+))) + (lambda (value) + (or (eq? value '*) + (entity-tag+? value))) + (lambda (value port) + (if (eq? value '*) + (write-http-token value port) + (write-entity-tag+ value port)))) + +(define-header "If-Range" + (let ((pe (tokenized-parser lp:entity-tag)) + (pd (direct-parser parser:http-date))) + (lambda (string win lose) + (pe string + win + (lambda () + (pd string win lose))))) + (lambda (value) + (or (entity-tag? value) + (http-date? value))) + (lambda (value port) + (if (entity-tag? value) + (write-entity-tag value port) + (write-http-date value port)))) + +(define-header "If-Unmodified-Since" + (direct-parser parser:http-date) + http-date? + write-http-date) + +(define-header "Max-Forwards" + (tokenized-parser lp:nonnegative-integer) + exact-nonnegative-integer? + write) +#; +(define-header "Proxy-Authorization" + (tokenized-parser + ...) + (lambda (value)) + (lambda (value port))) + +(define-header "Range" + (tokenized-parser + (list-parser + (encapsulate cons + (seq lp:bytes-unit + #\= + lp:byte-range-set)))) + (lambda (value) + (pair-of-type? value + bytes-unit? + byte-range-set?)) + (lambda (value port) + (write-http-token (car value) port) + (write-char #\= port) + (write-byte-range-set (cdr value) port))) + +(define-header "Referer" + (direct-parser + (*parser + (transform (lambda (v) + (if (uri-fragment (vector-ref v 0)) + #f + v)) + (alt parse-absolute-uri + parse-relative-uri)))) + (lambda (value) + (and (uri? value) + (not (uri-fragment value)))) + write-uri) + +(define-header "TE" + (tokenized-parser + (lp:comma-list 0 + (list-parser + (encapsulate cons + (seq lp:token + lp:accept-params))))) + (lambda (value) + (pair-of-type? value + http-token? + accept-params?)) + (lambda (value port) + (write-http-token (car value) port) + (write-parameter* (cdr value) port))) + +(define-header "User-Agent" + (tokenized-parser lp:product/comment-list) + product/comment-list? + write-product/comment-list) + +;;;; Response headers + +(define-header "Accept-Ranges" + (tokenized-parser + (list-parser + (alt (encapsulate (lambda (none) none '()) + (qualify (token= 'NONE) lp:token)) + lp:token+))) + (lambda (value) + (list+-of-type? value http-token?)) + (lambda (value port) + (if (null? value) + (write-http-token 'NONE port) + (write-token* value port)))) + +(define-header "Age" + (tokenized-parser + lp:nonnegative-integer) + exact-nonnegative-integer? + write) + +(define-header "ETag" + (tokenized-parser lp:entity-tag) + entity-tag? + write-entity-tag) + +(define-header "Location" + (direct-parser parse-absolute-uri) + absolute-uri? + write-uri) +#; +(define-header "Proxy-Authenticate" + (tokenized-parser + ...) + (lambda (value)) + (lambda (value port))) + +(define-header "Retry-After" + (direct-parser + (*parser + (alt parser:http-date + (map string->number + (match (+ (char-set char-set:numeric))))))) + (lambda (value) + (or (http-date? value) + (exact-nonnegative-integer? value))) + (lambda (value port) + (if (exact-nonnegative-integer? value) + (write value port) + (write-http-date value port)))) + +(define-header "Server" + (tokenized-parser lp:product/comment-list) + product/comment-list? + write-product/comment-list) + +(define-header "Vary" + (tokenized-parser + (list-parser + (alt (qualify (token= '*) lp:token) + lp:token+))) + (lambda (value) + (or (eq? value '*) + (token+? value))) + (lambda (value port) + (if (eq? value '*) + (write-http-token value port) + (write-token* value port)))) +#; +(define-header "WWW-Authenticate" + (tokenized-parser + ...) + (lambda (value)) + (lambda (value port))) + +;;;; Entity headers + +(define-header "Allow" + (tokenized-parser lp:token-cs*) + token*? + write-token*) + +(define-header "Content-Encoding" + (tokenized-parser lp:token+) + token+? + write-token*) + +(define-header "Content-Language" + (tokenized-parser (lp:comma-list 1 lp:language-tag)) + (lambda (value) (list+-of-type? value language-tag?)) + write-token*) + +(define-header "Content-Length" + (tokenized-parser lp:nonnegative-integer) + exact-nonnegative-integer? + write) + +(define-header "Content-Location" + (direct-parser + (*parser + (alt parse-absolute-uri + parse-relative-uri))) + (lambda (value) + (and (uri? value) + (not (uri-fragment value)))) + write-uri) + +(define-header "Content-MD5" + (lambda (string win lose) + (let ((sum (decode-base64-octets string #f))) + (if (and sum + (= (vector-8b-length sum) 16)) + (win (structure-parser-values sum)) + (lose)))) + (lambda (value) + (and (vector-8b? value) + (= (vector-8b-length value) 16))) + (lambda (value port) + (write-string (string-trim-right (encode-base64-octets value)) port))) + +(define-header "Content-Range" + (tokenized-parser + (list-parser + (encapsulate vector + (seq lp:bytes-unit + #\space + (alt (encapsulate cons + (seq lp:nonnegative-integer + #\- + lp:nonnegative-integer)) + lp:*) + #\/ + (alt lp:nonnegative-integer + lp:*))))) + (lambda (value) + (vector-of-types? value + bytes-unit? + (lambda (rs) + (or (eq? rs '*) + (pair-of-type? rs + exact-nonnegative-integer? + exact-nonnegative-integer?))) + (lambda (il) + (or (eq? il '*) + (exact-nonnegative-integer? il))))) + (lambda (value port) + (receive (unit rs il) (vector->values value) + (write-http-token unit port) + (write-char #\space port) + (if (eq? rs '*) + (write-char #\* port) + (begin + (write (car rs) port) + (write-char #\= port) + (write (cdr rs) port))) + (write-char #\/ port) + (if (eq? il '*) + (write-char #\* port) + (write il port))))) + +(define-header "Content-Type" + (tokenized-parser + (list-parser + (encapsulate cons + (seq lp:mime-type + lp:parameter*)))) + (lambda (value) + (pair-of-type? value + mime-type? + http-parameters?)) + (lambda (value port) + (write-mime-type (car value) port) + (write-parameter* (cdr value) port))) + +(define-header "Expires" + (direct-parser + (*parser + (alt parser:http-date + (map (lambda (s) s #f) + (match (* (char-set char-set:http-text))))))) + (lambda (value) + (or (not value) + (http-date? value))) + (lambda (value port) + (if (not value) + (write-string "0" port) + (write-http-date value port)))) + +(define-header "Last-Modified" + (direct-parser parser:http-date) + http-date? + write-http-date) + +;;;; Utilities + +(define initialize-package! + (let ((environment (the-environment))) + (lambda () + (run-boot-inits! environment)))) + +(define-deferred default-http-user-agent + (list + (cons "MIT-GNU-Scheme" + (let ((s (string-copy (get-subsystem-version-string "release")))) + (let ((end (string-length s))) + (do ((i 0 (+ i 1))) + ((not (< i end))) + (if (not (char-set-member? char-set:http-token + (string-ref s i))) + (string-set! s i #\_)))) + s)))) + +(define (pair-of-type? object car-pred cdr-pred) + (and (pair? object) + (car-pred (car object)) + (cdr-pred (cdr object)))) + +(define (list+-of-type? object predicate) + (and (pair? object) + (list-of-type? object predicate))) + +(define (vector-of-types? object . predicates) + (and (vector? object) + (= (vector-length object) (length predicates)) + (let loop ((predicates predicates) (i 0)) + (if (pair? predicates) + (and ((car predicates) (vector-ref object i)) + (loop (cdr predicates) (+ i 1))) + #t)))) + +(define (vector->values vector) + (apply values (vector->list vector))) + +(define (encode-base64-octets octets) + (call-with-output-string + (lambda (port) + (let ((ctx (encode-base64:initialize port #f))) + (encode-base64:update ctx octets 0 (vector-8b-length octets)) + (encode-base64:finalize ctx))))) + +(define (decode-base64-octets string) + (call-with-current-continuation + (lambda (k) + (bind-condition-handler (list condition-type:decode-base64) + (lambda (condition) + condition + (k #f)) + (lambda () + (call-with-output-octets + (lambda (port) + (port/set-coding port 'BINARY) + (port/set-line-ending port 'BINARY) + (let ((ctx (decode-base64:initialize port #f))) + (decode-base64:update ctx string 0 (string-length string)) + (decode-base64:finalize ctx))))))))) -(define http-version:1.0) -(define http-version:1.1) - -(define char-set:http-separators) -(define char-set:http-token) -(define char-set:http-text) -(define char-set:http-ctext) -(define char-set:http-qdtext) -(define char-set:alpha) -(define default-http-user-agent) - -(define (initialize-package!) - (set! http-version:1.0 (make-http-version 1 0)) - (set! http-version:1.1 (make-http-version 1 1)) - (set! char-set:http-separators - (string->char-set "()<>@,;:\\\"/[]?={} \t")) - (set! char-set:http-token - (char-set-difference char-set:ascii - (char-set-union char-set:ctls - char-set:http-separators))) - (set! char-set:http-text - (char-set-invert char-set:ctls)) - (set! char-set:http-ctext - (char-set-difference char-set:http-text - (char-set #\( #\)))) - (set! char-set:http-qdtext - (char-set-difference char-set:http-text - (char-set #\"))) - (set! char-set:alpha - (char-set-union (ascii-range->char-set #x41 #x5B) - (ascii-range->char-set #x61 #x7B))) - (set! default-http-user-agent - (call-with-output-string - (lambda (output) - (write-string "MIT-GNU-Scheme/" output) - (let ((input - (open-input-string - (get-subsystem-version-string "release")))) - (let loop () - (let ((char (read-char input))) - (if (not (eof-object? char)) - (begin - (write-char (if (char-set-member? char-set:http-token - char) - char - #\_) - output) - (loop))))))))) - unspecific) \ No newline at end of file +;;; Edwin Variables: +;;; lisp-indent/lp:comma-list: 1 +;;; End: diff --git a/v7/src/runtime/httpio.scm b/v7/src/runtime/httpio.scm index 4e2917c5d..eb7952c75 100644 --- a/v7/src/runtime/httpio.scm +++ b/v7/src/runtime/httpio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: httpio.scm,v 14.8 2008/09/16 05:39:00 cph Exp $ +$Id: httpio.scm,v 14.9 2008/09/17 06:31:50 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -45,7 +45,7 @@ USA. (define-guarantee http-request "HTTP request") (define (make-http-request method uri version headers body) - (guarantee-http-token method 'MAKE-HTTP-REQUEST) + (guarantee-http-token-string method 'MAKE-HTTP-REQUEST) (guarantee-http-request-uri uri 'MAKE-HTTP-REQUEST) (guarantee-http-version version 'MAKE-HTTP-REQUEST) (receive (headers body) @@ -153,7 +153,7 @@ USA. (define (write-http-request request port) (%text-mode port) - (write-http-token (http-request-method request) port) + (write-string (http-request-method request) port) (write-string " " port) (let ((uri (http-request-uri request))) (cond ((uri? uri) @@ -226,8 +226,8 @@ USA. (let ((headers (read-http-headers port))) (make-http-response version status reason headers (if (or (non-body-status? status) - (eq? (http-request-method request) - '|HEAD|)) + (string=? (http-request-method request) + "HEAD")) #f (or (%read-delimited-body headers port) (%read-terminal-body headers port) @@ -264,9 +264,9 @@ USA. (define (%read-terminal-body headers port) (and (let ((h (http-header 'CONNECTION headers #f))) (and h - (any (lambda (token) - (string-ci=? token "close")) - (burst-string (http-header-value h) char-set:wsp #t)))) + (let ((v (http-header-parsed-value h))) + (and (not (default-object? v)) + (memq 'CLOSE v))))) (%read-all port))) (define (%no-read-body) @@ -390,44 +390,30 @@ USA. port)) (define (%get-content-type message) - (let ((h (http-message-header 'CONTENT-TYPE message #f))) - (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)))) + (optional-header (http-message-header 'CONTENT-TYPE message #f) + (lambda (v) + (values (car v) + (let ((p (assq 'CHARSET (cdr v)))) + (and p + (let ((coding (intern (cdr p)))) + (and (known-input-port-coding? coding) + coding)))))) + (lambda () + (values (make-mime-type 'APPLICATION 'OCTET-STREAM) + #f)))) (define (%get-content-length headers) - (let ((h (http-header 'CONTENT-LENGTH headers #f))) - (and h - (let ((s (http-header-value h))) - (let ((n (string->number s))) - (if (not (exact-nonnegative-integer? n)) - (error "Malformed content-length value:" s)) - n))))) - -(define parser:http-content-type - (let ((parse-parameter - (*parser - (encapsulate* cons - (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)))))) + (optional-header (http-header 'CONTENT-LENGTH headers #f) + (lambda (n) n) + (lambda () #f))) + +(define (optional-header h win lose) + (if h + (let ((v (http-header-parsed-value h))) + (if (default-object? v) + (lose) + (win v))) + (lose))) (define (http-message-header name message error?) (http-header name (http-message-headers message) error?)) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 5fe36beb4..43fba2f4c 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.682 2008/09/16 05:36:49 cph Exp $ +$Id: runtime.pkg,v 14.683 2008/09/17 06:31:54 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -1799,9 +1799,15 @@ USA. generic-io/peek-char generic-io/read-char generic-io/unread-char + known-input-port-coding? + known-input-port-codings + known-output-port-coding? + known-output-port-codings make-generic-i/o-port make-non-channel-port-sink - make-non-channel-port-source) + make-non-channel-port-source + primary-input-port-codings + primary-output-port-codings) (export (runtime console-i/o-port) input-buffer-contents make-gstate @@ -1815,8 +1821,6 @@ 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) @@ -5199,19 +5203,23 @@ USA. error:not-http-status error:not-http-text error:not-http-token + error:not-http-token-string error:not-http-version guarantee-http-header guarantee-http-headers guarantee-http-status guarantee-http-text guarantee-http-token + guarantee-http-token-string guarantee-http-version http-header http-header-name + http-header-parsed-value http-header-value http-header? http-status? http-text? + http-token-string? http-token? http-version-major http-version-minor @@ -5288,6 +5296,8 @@ USA. (files "http-client") (parent (runtime)) (export () + http-client-exchange + http-client-request http-get http-head http-post)