From e9d9ff5025ea042dde94ba0687b4fc9170a60abc Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 15 Sep 2008 05:15:23 +0000 Subject: [PATCH] Split "http-io.scm" to create new file "http-syntax.scm". I'm currently working on the latter, so this minimizes the difference between the trunk and my code. --- v7/src/runtime/ed-ffi.scm | 3 +- v7/src/runtime/http-client.scm | 43 ++--- v7/src/runtime/http-syntax.scm | 252 +++++++++++++++++++++++++++ v7/src/runtime/httpio.scm | 310 +++++++++------------------------ v7/src/runtime/make.scm | 4 +- v7/src/runtime/runtime.pkg | 77 ++++---- 6 files changed, 397 insertions(+), 292 deletions(-) create mode 100644 v7/src/runtime/http-syntax.scm diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm index 74ef16774..b16e68889 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.44 2008/09/07 04:33:12 cph Exp $ +$Id: ed-ffi.scm,v 1.45 2008/09/15 05:15:05 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -83,6 +83,7 @@ USA. ("histry" (runtime history)) ("html-form-codec" (runtime html-form-codec)) ("http-client" (runtime http-client)) + ("http-syntax" (runtime http-syntax)) ("httpio" (runtime http-i/o)) ("illdef" (runtime illegal-definitions)) ("infstr" (runtime compiler-info)) diff --git a/v7/src/runtime/http-client.scm b/v7/src/runtime/http-client.scm index 7518ec8a8..a7c9bf3ef 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.6 2008/08/26 04:21:54 cph Exp $ +$Id: http-client.scm,v 14.7 2008/09/15 05:15: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, @@ -53,45 +53,24 @@ USA. (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))) + (add-default-headers headers authority) body))) (write-http-request request port) (let ((response (read-http-response request port))) (close-port port) response)))) +(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))) - -(define default-user-agent) - -(define (initialize-package!) - (set! default-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 - (if (char-set-member? char-set:http-token char) - (write-char char output) - (write-char #\_ output)) - (loop))))))))) - unspecific) \ No newline at end of file + host))) \ No newline at end of file diff --git a/v7/src/runtime/http-syntax.scm b/v7/src/runtime/http-syntax.scm new file mode 100644 index 000000000..5f87264ea --- /dev/null +++ b/v7/src/runtime/http-syntax.scm @@ -0,0 +1,252 @@ +#| -*-Scheme-*- + +$Id: http-syntax.scm,v 1.1 2008/09/15 05:15:12 cph Exp $ + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 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 syntax +;;; package: (runtime http-syntax) + +(declare (usual-integrations)) + +;;;; Version + +(define (http-version? object) + (and (pair? object) + (exact-nonnegative-integer? (car object)) + (exact-nonnegative-integer? (cdr object)))) + +(define-guarantee http-version "HTTP version") + +(define (make-http-version major minor) (cons major minor)) +(define (http-version-major v) (car v)) +(define (http-version-minor v) (cdr v)) + +(define (http-version=? v1 v2) + (and (= (car v1) (car v2)) + (= (cdr v1) (cdr v2)))) + +(define (http-versionnumber + (match (+ (char-set char-set:numeric)))) + "." + (map string->number + (match (+ (char-set char-set:numeric)))))))) + +(define (write-http-version version port) + (write-string "HTTP/" port) + (write (car version) port) + (write-string "." port) + (write (cdr version) port)) + +;;;; Status + +(define (http-status? object) + (and (exact-nonnegative-integer? object) + (< object 1000))) + +(define-guarantee http-status "HTTP status code") + +(define (http-status-major status) + (modulo status 100)) + +(define parse-http-status + (*parser + (map string->number + (match (seq (char-set char-set:numeric) + (char-set char-set:numeric) + (char-set char-set:numeric)))))) + +(define (write-http-status object port) + (write-string (string-pad-left (number->string object) 3 #\0) port)) + +;;;; Header + +(define-record-type + (%make-http-header name value) + http-header? + (name http-header-name) + (value http-header-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)) + +(define (convert-http-headers headers #!optional caller) + (guarantee-list headers caller) + (map (lambda (header) + (cond ((http-header? header) + header) + ((and (pair? header) + (http-token? (car header)) + (string? (cdr header))) + (make-http-header (car header) (cdr header))) + ((and (pair? header) + (http-token? (car header)) + (pair? (cdr header)) + (string? (cadr header)) + (null? (cddr header))) + (make-http-header (car header) (cadr header))) + (else + (error:not-http-header header caller)))) + headers)) + +(define (guarantee-http-headers object #!optional caller) + (guarantee-list-of-type object http-header? "HTTP headers" caller)) + +(define (http-header name headers error?) + (let ((h + (find (lambda (header) + (eq? (http-header-name header) name)) + headers))) + (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 + +(define (http-token? object) + (and (interned-symbol? object) + (string-is-http-token? (symbol-name object)))) + +(define-guarantee http-token "HTTP token") + +(define (write-http-token token port) + (write-string (symbol-name token) port)) + +(define (string-is-http-token? string) + (*match-string match-http-token string)) + +(define parse-http-token + (*parser (map intern (match match-http-token)))) + +(define match-http-token + (*matcher (+ (char-set char-set:http-token)))) + +;;;; Text + +(define (http-text? object) + (string? object)) + +(define-guarantee http-text "HTTP text") + +(define (write-text string port) + (if (string-is-http-token? string) + (write-string string port) + (write-quoted-string string port))) + +(define (write-quoted-string string port) + (write-char #\" port) + (%write-with-quotations string char-set:http-qdtext port) + (write-char #\" port)) + +(define (write-comment string port) + (write-char #\( port) + (%write-with-quotations string char-set:http-ctext port) + (write-char #\) port)) + +(define (%write-with-quotations string unquoted port) + (let ((n (string-length string))) + (do ((i 0 (fix:+ i 1))) + ((not (fix:< i n))) + (let ((char (string-ref string i))) + (if (not (char-set-member? unquoted char)) + (write-char #\\ port)) + (write-char char port))))) + + +(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 diff --git a/v7/src/runtime/httpio.scm b/v7/src/runtime/httpio.scm index 33842692a..00bfe7401 100644 --- a/v7/src/runtime/httpio.scm +++ b/v7/src/runtime/httpio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: httpio.scm,v 14.6 2008/08/27 04:58:09 cph Exp $ +$Id: httpio.scm,v 14.7 2008/09/15 05:15:17 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -72,41 +72,22 @@ USA. (%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)) + (guarantee-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-http-header 'CONTENT-LENGTH + (number->string m)) + headers) + body)))) + (values headers ""))) (define (simple-http-request? object) (and (http-request? object) @@ -144,13 +125,6 @@ USA. ((http-response? message) (http-response-body message)) (else (error:not-http-message message 'HTTP-MESSAGE-BODY)))) -(define (http-token? object) - (and (interned-symbol? object) - (not (eq? object '||)) - (string-in-char-set? (symbol-name object) char-set:http-token))) - -(define-guarantee http-token "HTTP token") - (define (http-request-uri? object) (or (simple-http-request-uri? object) (absolute-uri? object) @@ -168,63 +142,10 @@ USA. (define-guarantee simple-http-request-uri "simple HTTP URI") -(define (http-version? object) - (and (pair? object) - (exact-nonnegative-integer? (car object)) - (exact-nonnegative-integer? (cdr object)))) - -(define-guarantee http-version "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-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-versionstring token)) port)) - -(define (write-version version port) - (write-string "HTTP/" port) - (write (car version) port) - (write-string "." port) - (write (cdr version) port)) ;;;; Input @@ -292,7 +204,7 @@ USA. line (receive (method uri version) (parse-line parse-request-line line "HTTP request line") - (let ((headers (read-rfc2822-headers port))) + (let ((headers (read-http-headers port))) (make-http-request method uri version headers (or (%read-delimited-body headers port) (%no-read-body)))))))) @@ -304,7 +216,7 @@ USA. #f (receive (version status reason) (parse-line parse-response-line line "HTTP response line") - (let ((headers (read-rfc2822-headers port))) + (let ((headers (read-http-headers port))) (make-http-response version status reason headers (if (or (non-body-status? status) (eq? (http-request-method request) @@ -314,65 +226,6 @@ USA. (%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-path-absolute))) - -(define parse-request-line - (*parser - (seq (map string->symbol - parse-http-token) - (noise match-wsp) - (alt (match "*") - parse-absolute-uri - parse-uri-path-absolute - parse-uri-authority) - (noise match-wsp) - parse-version))) - -(define parse-http-token - (*parser (match (+ (char-set char-set:http-token))))) - -(define parse-response-line - (*parser - (seq parse-version - (noise match-wsp) - parse-status-code - (noise match-wsp) - (match (* (char-set char-set:http-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 (+ (char-set char-set:numeric)))) - "." - (map string->number - (match (+ (char-set char-set:numeric)))))))) - -(define parse-status-code - (*parser - (map string->number - (match (seq (char-set char-set:numeric) - (char-set char-set:numeric) - (char-set char-set:numeric)))))) - -(define match-wsp - (*matcher (+ (char-set char-set:wsp)))) - (define (%read-all port) (%binary-mode port) (call-with-output-octets @@ -401,50 +254,52 @@ USA. (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 (let ((h (http-header 'CONNECTION headers #f))) (and h (any (lambda (token) (string-ci=? token "close")) - (burst-string (rfc2822-header-value h) char-set:wsp #t)))) + (burst-string (http-header-value h) char-set:wsp #t)))) (%read-all port))) (define (%no-read-body) (error "Unable to determine HTTP message 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:http-text) -(define char-set:http-token) -(define http-version:1.0) -(define http-version:1.1) - -(define (initialize-package!) - (set! char-set:http-text - (char-set-difference char-set:ascii char-set:ctls)) - (set! char-set:http-token - (char-set-difference char-set:http-text - (string->char-set "()<>@,;:\\\"/[]?={} \t"))) - (set! http-version:1.0 (make-http-version 1 0)) - (set! http-version:1.1 (make-http-version 1 1)) - unspecific) +;;;; Request and response lines + +(define parse-request-line + (*parser + (seq (map string->symbol + (match (+ (char-set char-set:http-token)))) + " " + (alt (match "*") + parse-absolute-uri + parse-uri-path-absolute + parse-uri-authority) + " " + parse-http-version))) + +(define parse-response-line + (*parser + (seq parse-http-version + " " + parse-http-status + " " + (match (* (char-set char-set:http-text)))))) + +(define parse-simple-request + (*parser + (seq (map string->symbol (match "GET")) + " " + parse-uri-path-absolute))) + +(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))))) ;;;; Status descriptions @@ -509,7 +364,7 @@ USA. (define (http-message-body-port message) (let ((port (open-input-octets (http-message-body message)))) - (receive (type coding) (http-content-type message) + (receive (type coding) (%get-content-type message) (cond ((eq? (mime-type/top-level type) 'TEXT) (port/set-coding port (or coding 'TEXT)) (port/set-line-ending port 'TEXT)) @@ -527,8 +382,8 @@ USA. (port/set-line-ending port 'BINARY)))) port)) -(define (http-content-type message) - (let ((h (first-http-header 'CONTENT-TYPE message))) +(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))) @@ -543,28 +398,29 @@ USA. (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 (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)))))) + (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)))))) -(define (http-content-length message) - (%get-content-length (http-message-headers message))) - -(define (first-http-header name message) - (first-rfc2822-header name (http-message-headers message))) - -(define (all-http-headers name message) - (all-rfc2822-headers name (http-message-headers message))) \ No newline at end of file +(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/make.scm b/v7/src/runtime/make.scm index 6005b006e..6868d92bb 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.118 2008/08/31 07:28:05 cph Exp $ +$Id: make.scm,v 14.119 2008/09/15 05:15:20 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -518,7 +518,7 @@ USA. ((RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES! #f) (RUNTIME URI) (RUNTIME RFC2822-HEADERS) - (RUNTIME HTTP-I/O) + (RUNTIME HTTP-SYNTAX) (RUNTIME HTTP-CLIENT) (RUNTIME HTML-FORM-CODEC) (RUNTIME WIN32-REGISTRY))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 28e472d52..9a2f8ae77 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.678 2008/09/09 16:28:19 cph Exp $ +$Id: runtime.pkg,v 14.679 2008/09/15 05:15:23 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -5183,45 +5183,75 @@ USA. write-rfc2822-headers) (initialization (initialize-package!))) -(define-package (runtime http-i/o) - (files "httpio") +(define-package (runtime http-syntax) + (files "http-syntax") (parent (runtime)) (export () - all-http-headers + char-set:http-text char-set:http-token - error:not-http-message + convert-http-headers + default-http-user-agent error:not-http-header - error:not-http-request - error:not-http-request-uri - error:not-http-response error:not-http-status error:not-http-text error:not-http-token error:not-http-version + guarantee-http-header + guarantee-http-headers + guarantee-http-status + guarantee-http-text + guarantee-http-token + guarantee-http-version + http-header + http-header-name + http-header-value + http-header? + http-status? + http-text? + http-token? + http-version-major + http-version-minor + http-version:1.0 + http-version:1.1 + http-version