From d489e3e0b3f1404178e4db43bc1ff85fbd55a59a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sun, 4 Jun 2006 22:04:29 +0000 Subject: [PATCH] revamping request parsing for filenames svn: r3217 --- collects/web-server/dispatch-host.ss | 2 +- collects/web-server/dispatch-log.ss | 2 +- collects/web-server/dispatch-passwords.ss | 2 +- collects/web-server/dispatch-servlets.ss | 13 +- collects/web-server/private/request.ss | 246 ++++++++++++++++++++++ collects/web-server/request-parsing.ss | 234 -------------------- collects/web-server/request-structs.ss | 59 ++++-- collects/web-server/response.ss | 2 +- collects/web-server/servlet-helpers.ss | 86 ++++---- collects/web-server/url.ss | 2 +- collects/web-server/util.ss | 27 +-- collects/web-server/web-server-unit.ss | 2 +- 12 files changed, 346 insertions(+), 331 deletions(-) create mode 100644 collects/web-server/private/request.ss delete mode 100644 collects/web-server/request-parsing.ss diff --git a/collects/web-server/dispatch-host.ss b/collects/web-server/dispatch-host.ss index 1c084c8c8a..7efd3e02e4 100644 --- a/collects/web-server/dispatch-host.ss +++ b/collects/web-server/dispatch-host.ss @@ -7,5 +7,5 @@ (define interface-version 'v1) (define (gen-dispatcher lookup-dispatcher) (lambda (conn req) - (let* ([host (get-host (request-uri req) (request-headers req))]) + (let* ([host (get-host (request-uri req) (request-headers/raw req))]) ((lookup-dispatcher host) conn req))))) \ No newline at end of file diff --git a/collects/web-server/dispatch-log.ss b/collects/web-server/dispatch-log.ss index fd3e63083c..a8782477e6 100644 --- a/collects/web-server/dispatch-log.ss +++ b/collects/web-server/dispatch-log.ss @@ -15,7 +15,7 @@ [(parenthesized-default) (let ([log-message (gen-log-message log-format log-path)]) (lambda (conn req) - (let ([host (get-host (request-uri req) (request-headers req))]) + (let ([host (get-host (request-uri req) (request-headers/raw req))]) (log-message (request-host-ip req) (request-client-ip req) (request-method req) diff --git a/collects/web-server/dispatch-passwords.ss b/collects/web-server/dispatch-passwords.ss index 539c8fcbe4..a26f212a65 100644 --- a/collects/web-server/dispatch-passwords.ss +++ b/collects/web-server/dispatch-passwords.ss @@ -22,7 +22,7 @@ (lambda (conn req) (let-values ([(uri method path) (decompose-request req)]) (cond - [(access-denied? method path (request-headers req) (read-password-cache)) + [(access-denied? method path (request-headers/raw req) (read-password-cache)) => (lambda (realm) (adjust-connection-timeout! conn password-connection-timeout) (request-authentication conn method uri diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index 8224a35a3d..11ad642e9e 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -40,9 +40,6 @@ '() (list "ignored")) meth)] [else - (set-request-bindings/raw! - req - (read-bindings/handled conn meth uri (request-headers req))) (cond [(continuation-url? uri) => (match-lambda @@ -50,15 +47,7 @@ (invoke-servlet-continuation conn req instance-id k-id salt)])] [else (servlet-content-producer/path conn req uri)])])) - - ;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string)) - ;; read the bindings and handle any exceptions - (define (read-bindings/handled conn meth uri headers) - (with-handlers ([exn? (lambda (e) - (output-response/method conn (responders-servlet-loading uri e) meth) - '())]) - (read-bindings conn meth uri headers))) - + ;; servlet-content-producer/path: connection request url -> void ;; This is not a continuation url so the loading behavior is determined ;; by the url path. Build the servlet path and then load the servlet diff --git a/collects/web-server/private/request.ss b/collects/web-server/private/request.ss new file mode 100644 index 0000000000..52f94fac45 --- /dev/null +++ b/collects/web-server/private/request.ss @@ -0,0 +1,246 @@ +(module request mzscheme + (require (lib "contract.ss") + (lib "plt-match.ss") + (lib "url.ss" "net") + (lib "list.ss")) + (require "../util.ss" + "../connection-manager.ss" + "../request-structs.ss") + + (provide/contract + [read-request ((connection? number? ((input-port?) . ->* . (string? string?))) . ->* . (request? boolean?))]) + + ;; ************************************************** + ;; read-request: connection number (input-port -> string string) -> request boolean? + ;; read the request line, and the headers, determine if the connection should + ;; be closed after servicing the request and build a request structure + (define (read-request conn host-port port-addresses) + (call-with-semaphore + (connection-mutex conn) + (lambda () + (define ip + (connection-i-port conn)) + (define-values (method uri major minor) + (read-request-line ip)) + (define headers + (read-headers ip)) + (define-values (host-ip client-ip) + (port-addresses ip)) + (define bindings + (read-bindings conn method uri headers)) + (values + (make-request method uri headers bindings + host-ip host-port client-ip) + (close-connection? headers major minor + client-ip host-ip))))) + + ;; ************************************************** + ;; close-connection? + + ; close-connection? : (listof (cons symbol bytes)) number number string string -> boolean + ; determine if this connection should be closed after serving the response + (define close-connection? + (let ([rx (byte-regexp #"[cC][lL][oO][sS][eE]")]) + (lambda (headers major minor client-ip host-ip) + (or (< major 1) + (and (= major 1) (= minor 0)) + (match (headers-assq #"Connection" headers) + [(struct header (f v)) + (regexp-match rx v)] + [#f + #f]) + (msie-from-local-machine? headers client-ip host-ip))))) + + ; msie-from-local-machine? : table str str -> bool + ; to work around a bug in MSIE for documents < 265 bytes when connecting from the local + ; machine. The server could pad the response as MSIIS does, but closing the connection works, too. + ; We do not check for version numbers since IE 6 under windows is 5.2 under macosX + (define msie-from-local-machine? + (let ([rx (byte-regexp #"MSIE")]) + (lambda (headers client-ip host-ip) + (and (string=? host-ip client-ip) + (match + (or (headers-assq #"HTTP_USER_AGENT" headers) + (headers-assq #"User-Agent" headers)) + [(struct header (f v)) + (and (regexp-match rx v) + #t)] + [#f + #f]))))) + + ;; ************************************************** + ;; read-request-line + (define match-method + (let ([rx (byte-regexp #"^([^ ]+) (.+) HTTP/([0-9]+)\\.([0-9]+)$")]) + (lambda (a) (regexp-match rx a)))) + + ; read-request-line : iport -> symbol url number number + ; to read in the first line of an http request, AKA the "request line" + ; effect: in case of errors, complain [MF: where] and close the ports + (define (read-request-line ip) + (define line (read-bytes-line ip 'any)) + (if (eof-object? line) + (network-error 'read-request "http input closed abruptly") + (cond + [(match-method line) + => (match-lambda + [(list _ method url major minor) + (values (lowercase-symbol! (bytes->string/utf-8 method)) + (string->url (bytes->string/utf-8 url)) + (string->number (bytes->string/utf-8 major)) + (string->number (bytes->string/utf-8 minor)))])] + [else (network-error 'read-request "malformed request ~a" line)]))) + + ;; ************************************************** + ;; read-headers + (define match-colon + (let ([rx (byte-regexp (bytes-append #"^([^:]*):[ " (bytes 9) #"]*(.*)"))]) + (lambda (a) (regexp-match rx a)))) + + ; read-headers : iport -> (listof (cons symbol bytes)) + (define (read-headers in) + (let read-header () + (define l (read-bytes-line in 'any)) + (cond + [(eof-object? l) null] + [(zero? (bytes-length l)) null] + [(match-colon l) + => (match-lambda + [(list _ field value) + (list* (make-header field (read-one-head in value)) + (read-header))])] + [else (network-error 'read-headers "malformed header")]))) + + ; read-one-head : iport bytes -> bytes + (define (read-one-head in rhs) + (match (peek-byte in) + [(or 32 9) ;(or (eq? c #\space) (eq? c #\tab)) + ; (read-bytes-line in 'any) can't return eof + ; because we just checked with peek-char + ; Spidey: FLOW + (read-one-head in (bytes-append rhs (read-bytes-line in 'any)))] + [_ rhs])) + + ;; ************************************************** + ;; read-bindings + (define INPUT-BUFFER-SIZE 4096) + (define (read-to-eof in) + (define b (read-bytes INPUT-BUFFER-SIZE in)) + (if (eof-object? b) + empty + (list* b (read-to-eof in)))) + + (define FILE-FORM-REGEXP (byte-regexp #"multipart/form-data; *boundary=(.*)")) + + ;; read-bindings: connection symbol url (listof header?) -> (or/c (listof binding?) string?) + (define (read-bindings conn meth uri headers) + (match meth + ['get + (map (match-lambda + [(list-rest k v) + (make-binding:form (string->bytes/utf-8 k) + (string->bytes/utf-8 v))]) + (url-query uri))] + ['post + (define content-type (headers-assq #"Content-Type" headers)) + (define in (connection-i-port conn)) + (cond + [(and content-type (regexp-match FILE-FORM-REGEXP (header-value content-type))) + => (match-lambda + [(list _ content-boundary) + (map (match-lambda + [(struct mime-part (headers contents)) + (define rhs (header-value (headers-assq #"Content-Disposition" headers))) + (match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs) + (regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs)) + [(list #f #f) + (network-error 'reading-bindings "Couldn't extract form field name for file upload")] + [(list #f (list _ _ f0 f1)) + (make-binding:form (or f0 f1) (apply bytes-append contents))] + [(list (list _ _ f00 f01) (list _ _ f10 f11)) + (make-binding:file (or f10 f11) (or f00 f01) (apply bytes-append contents))])]) + (read-mime-multipart content-boundary in))])] + [else + (match (headers-assq #"Content-Length" headers) + [(struct header (_ value)) + (cond + [(string->number (bytes->string/utf-8 value)) + => (lambda (len) + (parse-bindings (read-bytes len in)))] + [else + (network-error 'read-bindings "Post request contained a non-numeric content-length")])] + [#f + (parse-bindings (apply bytes-append (read-to-eof in)))])])] + [meth + empty])) + + ;; parse-bindings : bytes? -> (listof binding?) + (define (parse-bindings raw) + (define len (bytes-length raw)) + (let loop ([start 0]) + (let find= ([key-end start]) + (if (>= key-end len) + empty + (if (eq? (bytes-ref raw key-end) (char->integer #\=)) + (let find-amp ([amp-end (add1 key-end)]) + (if (or (= amp-end len) (eq? (bytes-ref raw amp-end) (char->integer #\&))) + (list* (make-binding:form + (subbytes raw start key-end) + (string->bytes/utf-8 + (translate-escapes + (bytes->string/utf-8 + (subbytes raw (add1 key-end) amp-end))))) + (loop (add1 amp-end))) + (find-amp (add1 amp-end)))) + (find= (add1 key-end))))))) + + ;; ************************************************** + ;; read-mime-multipart + + ; mime-part : (listof header?) * (listof bytes?) + (define-struct mime-part (headers contents)) + (define CR-NL #"#\return#\newline") + (define (construct-mime-part headers body) + (make-mime-part + headers + (match body + [(list) + (list)] + [(list-rest fst rst) + (list* fst + (foldr (lambda (byt acc) + (list* CR-NL byt acc)) + empty + rst))]))) + + ; read-mime-multipart : bytes iport -> (listof part) + (define (read-mime-multipart boundary in) + (define boundary-len (bytes-length boundary)) + (define start-boundary (bytes-append #"--" boundary)) + (define end-boundary (bytes-append start-boundary #"--")) + (let skip-preamble () + (define line (read-bytes-line in 'return-linefeed)) + (cond + [(bytes=? line start-boundary) + (let read-parts () + (define headers (read-headers in)) + (let read-mime-part-body + ([more-k (lambda (contents) + (list* (construct-mime-part + headers contents) + (read-parts)))] + [end-k (lambda (contents) + (list (construct-mime-part + headers contents)))]) + (define line (read-bytes-line in 'return-linefeed)) + (cond + [(bytes=? line start-boundary) + (more-k empty)] + [(bytes=? line end-boundary) + (end-k empty)] + [else + (read-mime-part-body + (lambda (x) (more-k (list* line x))) + (lambda (x) (end-k (list* line x))))])))] + [(bytes=? line end-boundary) null] + [else (skip-preamble)])))) \ No newline at end of file diff --git a/collects/web-server/request-parsing.ss b/collects/web-server/request-parsing.ss deleted file mode 100644 index 9c18a7347b..0000000000 --- a/collects/web-server/request-parsing.ss +++ /dev/null @@ -1,234 +0,0 @@ -(module request-parsing mzscheme - (require (lib "contract.ss") - (lib "url.ss" "net") - (lib "list.ss") - "util.ss" - "connection-manager.ss" - (lib "port.ss") - "request-structs.ss") - (provide (all-from "request-structs.ss")) - - ;; path-prefix: (listof string) - ;; The part of the URL path that maps to the servlet - ;; path-suffix: (listof string) - ;; The part of the URL path that gets passed to the servlet as arguments. - - (provide/contract - [read-request ((connection? number? ((input-port?) . ->* . (string? string?))) . ->* . (request? boolean?))] - [read-bindings (connection? symbol? url? (listof header?) - . -> . (or/c (listof binding?) string?))]) - - - ;; ************************************************** - ;; read-request: connection number (input-port -> string string) -> request boolean? - ;; read the request line, and the headers, determine if the connection should - ;; be closed after servicing the request and build a request structure - (define (read-request conn host-port port-addresses) - (call-with-semaphore - (connection-mutex conn) - (lambda () - (let ([ip (connection-i-port conn)]) - (let-values ([(method uri major-version minor-version) - (read-request-line ip)]) - (let ([headers (read-headers ip)]) - (let-values ([(host-ip client-ip) (port-addresses ip)]) - (values - (make-request method uri headers '() host-ip host-port client-ip) - (close-connection? - headers major-version minor-version client-ip host-ip))))))))) - - ;; ************************************************** - ;; close-connection? - - ; close-connection? : (listof (cons symbol bytes)) number number string string -> boolean - ; determine if this connection should be closed after serving the response - (define (close-connection? headers major minor client-ip host-ip) - (or (< major 1) - (and (= major 1) (= minor 0)) - (cond - [(assq 'connection headers) - => (lambda (x) (string-ci=? "close" (bytes->string/utf-8 (cdr x))))] - [else #f]) - (msie-from-local-machine? headers client-ip host-ip))) - - ; : table str str -> bool - ; to work around a bug in MSIE for documents < 265 bytes when connecting from the local - ; machine. The server could pad the response as MSIIS does, but closing the connection works, too. - ; We do not check for version numbers since IE 6 under windows is 5.2 under macosX - (define (msie-from-local-machine? headers client-ip host-ip) - (and (string=? host-ip client-ip) - (cond - [(or (assq 'HTTP_USER_AGENT headers) - (assq 'user-agent headers)) - => (lambda (client) - (and (regexp-match MSIE-regexp (cdr client)) - #t))] - [else #f]))) - - (define MSIE-regexp (regexp "MSIE")) - - ;; ************************************************** - ;; read-request-line - - ; Method = (or/c 'get 'post 'head 'put 'delete 'trace) - (define METHOD:REGEXP - (byte-regexp #"^(GET|HEAD|POST|PUT|DELETE|TRACE) (.+) HTTP/([0-9]+)\\.([0-9]+)$")) - - (define (match-method x) - (regexp-match METHOD:REGEXP x)) - ;:(define match-method (type: (str -> (or/c false (list str str str str str))))) - - - ; read-request-line : iport -> symbol url number number - ; to read in the first line of an http request, AKA the "request line" - ; effect: in case of errors, complain [MF: where] and close the ports - (define (read-request-line ip) - (let ([line (read-bytes-line ip 'any)]) - (if (eof-object? line) - (network-error 'read-request "http input closed abruptly") - (cond - [(match-method line) - => (lambda (x) - (values - (lowercase-symbol! (list-ref x 1)) - (string->url (bytes->string/utf-8 (list-ref x 2))) - (string->number (bytes->string/utf-8 (list-ref x 3))) - (string->number (bytes->string/utf-8 (list-ref x 4)))))] - [else (network-error 'read-request "malformed request ~a" line)])))) - - - - ;; ************************************************** - ;; read-headers - - ;(define COLON:REGEXP (regexp (format "^([^:]*):[ ~a]*(.*)" #\tab))) - (define COLON:REGEXP (byte-regexp (bytes-append #"^([^:]*):[ " (bytes 9) #"]*(.*)"))) - - (define (match-colon s) - (regexp-match COLON:REGEXP s)) - ;:(define match-colon (type: (str -> (or/c false (list str str str))))) - - - ; read-headers : iport -> (listof (cons symbol bytes)) - (define (read-headers in) - (let read-header () - (let ([l (read-bytes-line in 'any)]) - (cond - [(eof-object? l) null] - [(zero? (bytes-length l)) null] - [(match-colon l) => - (lambda (match) - ; (cadr match) exists because COLON:REGEXP contains two (.) - ; (caddr match) exists because COLON:REGEXP contains two (.) - (cons (cons (lowercase-symbol! (cadr match)) - (read-one-head in (caddr match))) - (read-header)))] - [else (network-error 'read-headers "malformed header")])))) - - - ; read-one-head : iport bytes -> bytes - (define (read-one-head in rhs) - (let ([c (peek-byte in)]) - (cond - [(or (= c 32) (= c 9)) ;(or (eq? c #\space) (eq? c #\tab)) - - ; (read-bytes-line in 'any) can't return eof - ; because we just checked with peek-char - ; Spidey: FLOW - (read-one-head in (bytes-append rhs (read-bytes-line in 'any)))] - [else rhs]))) - - ;; ************************************************** - ;; read-bindings - - (define INPUT-BUFFER-SIZE 4096) - - ;; read-bindings: connection symboll url (listof header?) -> (or/c (listof binding?) string?) - (define (read-bindings conn meth uri headers) - (case meth - [(get) (url-query uri)] - [(post) - (call-with-semaphore - (connection-mutex conn) - (lambda () - (let ([content-type (assq 'content-type headers)]) - (cond - [(and content-type (regexp-match FILE-FORM-REGEXP (cdr content-type))) - => (lambda (content-boundary) - (map (lambda (part) - ;; more here - better checks, avoid string-append - (cons (get-field-name (cdr (assq 'content-disposition (car part)))) - (apply bytes-append (cdr part)))) - (read-mime-multipart (cadr content-boundary) (connection-i-port conn))))] - [else - (let ([len-str (assq 'content-length headers)] - [in (connection-i-port conn)]) - (if len-str - (cond - [(string->number (bytes->string/utf-8 (cdr len-str))) - => (lambda (len) (read-string len in))] - [else (network-error 'read-bindings "Post request contained a non-numeric content-length")]) - (apply string-append - (let read-to-eof () - (let ([s (read-string INPUT-BUFFER-SIZE in)]) - (if (eof-object? s) - null - (cons s (read-to-eof))))))))]))))] - [else (network-error 'read-bindings "unsupported method" meth)])) - - (define FILE-FORM-REGEXP (regexp "multipart/form-data; *boundary=(.*)")) - - ;; GregP: this is where I would get the filename out. - ; get-field-name : str -> symbol - (define (get-field-name rhs) - (let ([x (regexp-match "name=(\"([^\"]*)\"|([^ ;]*))" rhs)]) - (unless x - (network-error 'get-field-name "Couldn't extract form field name for file upload from ~a" x)) - (lowercase-symbol! (or (caddr x) (cadddr x))))) - - ;; ************************************************** - ;; read-mime-multipart - - ; read-mime-multipart : bytes iport -> (listof part) - (define (read-mime-multipart boundary in) - (let* ([boundary-len (bytes-length boundary)] - [start-boundary (bytes-append #"--" boundary)] - [end-boundary (bytes-append start-boundary #"--")]) - (let skip-preamble () - (let ([line (read-bytes-line in 'return-linefeed)]) - (cond - [(bytes=? line start-boundary) - (let read-parts () - (let ([headers (read-headers in)]) - (let read-mime-part-body ([more-k (lambda (contents) - (cons (construct-mime-part - headers contents) - (read-parts)))] - [end-k (lambda (contents) - (list (construct-mime-part - headers contents)))]) - (let ([line (read-bytes-line in 'return-linefeed)]) - (cond - [(bytes=? line start-boundary) - (more-k null)] - [(bytes=? line end-boundary) - (end-k null)] - [else (read-mime-part-body - (lambda (x) (more-k (cons line x))) - (lambda (x) (end-k (cons line x))))])))))] - [(bytes=? line end-boundary) null] - [else (skip-preamble)]))))) - - ; more here - use structure, perhaps - ; construct-mime-part : (listof header) (listof bytes) -> part - (define (construct-mime-part headers body) - (cons headers - (cond - [(null? body) null] - [else (cons (car body) - (foldr (lambda (byt acc) - (list* (string->bytes/utf-8 CR-NL) byt acc)) - null - (cdr body)))]))) - - (define CR-NL (format "~a~a" #\return #\newline))) diff --git a/collects/web-server/request-structs.ss b/collects/web-server/request-structs.ss index a017f0e4fb..df33536cad 100644 --- a/collects/web-server/request-structs.ss +++ b/collects/web-server/request-structs.ss @@ -1,26 +1,47 @@ (module request-structs mzscheme (require (lib "contract.ss") + (lib "plt-match.ss") (lib "url.ss" "net")) + + (define-struct header (field value)) + (define (headers-assq f hs) + (match hs + [(list) + #f] + [(list-rest (and h (struct header (af av))) hs) + (if (equal? af f) + h + (headers-assq f hs))])) + (provide/contract + [headers-assq (bytes? (listof header?) . -> . (or/c false/c header?))] + [struct header ([field bytes?] + [value bytes?])]) + + (define-struct binding (id)) + (define-struct (binding:form binding) (value)) + (define-struct (binding:file binding) (filename content)) + (define (bindings-assq ti bs) + (match bs + [(list) + #f] + [(list-rest (and b (struct binding (i))) bs) + (if (equal? ti i) + b + (bindings-assq ti bs))])) + (provide/contract + [bindings-assq (bytes? (listof binding?) . -> . (or/c false/c binding?))] + [struct binding ([id bytes?])] + [struct (binding:form binding) ([id bytes?] + [value bytes?])] + [struct (binding:file binding) ([id bytes?] + [filename bytes?] + [content bytes?])]) - ;; the request struct as currently doc'd (define-struct request (method uri headers bindings/raw host-ip host-port client-ip)) - - ;; header?: anyd/c -> boolean - ;; is this a header? - (define header? - (cons/c symbol? bytes?)) - - ;; bindings? any/c -> boolean - ;; is this a binding - (define binding? - (cons/c symbol? - (or/c string? - bytes?))) - - (provide header? binding?) (provide/contract - [struct request ([method symbol?] [uri url?] [headers (listof header?)] - [bindings/raw (or/c (listof binding?) string?)] - [host-ip string?] [host-port number?] - [client-ip string?])])) \ No newline at end of file + [struct request ([method symbol?] [uri url?] + [headers/raw (listof header?)] + [bindings/raw (listof binding?)] + [host-ip string?] [host-port number?] + [client-ip string?])])) \ No newline at end of file diff --git a/collects/web-server/response.ss b/collects/web-server/response.ss index 903d492e7b..2c43f0227a 100644 --- a/collects/web-server/response.ss +++ b/collects/web-server/response.ss @@ -51,7 +51,7 @@ ;; Notes: ;; 1. close? is a boolean which corresponds roughly to the protocol version. ;; #t |-> 1.0 and #f |-> 1.1. See function close-connection? in - ;; #request-parsing.ss + ;; private/request.ss ;; ;; 2. In the case of a chunked response when close? = #f, then the response ;; must be compliant with http 1.0. In this case the chunked response is diff --git a/collects/web-server/servlet-helpers.ss b/collects/web-server/servlet-helpers.ss index d66537dfa6..8364925e0b 100644 --- a/collects/web-server/servlet-helpers.ss +++ b/collects/web-server/servlet-helpers.ss @@ -1,12 +1,13 @@ (module servlet-helpers mzscheme (require (lib "list.ss") (lib "etc.ss") + (lib "plt-match.ss") (lib "xml.ss" "xml") (lib "base64.ss" "net") (lib "url.ss" "net")) (require "util.ss" "response.ss" - "request-parsing.ss") + "request-structs.ss") (provide get-host extract-binding/single extract-bindings @@ -19,47 +20,39 @@ permanently temporarily see-other - (all-from "request-parsing.ss") - (rename get-parsed-bindings request-bindings) + (all-from "request-structs.ss") + request-bindings + request-headers translate-escapes) + (define (request-headers request) + (map (match-lambda + [(struct header (field value)) + (cons (lowercase-symbol! (bytes->string/utf-8 field)) + (bytes->string/utf-8 value))]) + (request-headers/raw request))) + (define (request-bindings request) + (map (match-lambda + [(struct binding:form (id value)) + (cons (lowercase-symbol! (bytes->string/utf-8 id)) + (bytes->string/utf-8 value))] + [(struct binding:file (id fname value)) + (cons (lowercase-symbol! (bytes->string/utf-8 id)) + value)]) + (request-bindings/raw request))) + ;; get-host : Url (listof (cons Symbol String)) -> Symbol ;; host names are case insesitive---Internet RFC 1034 (define DEFAULT-HOST-NAME ') (define (get-host uri headers) (cond [(url-host uri) => string->symbol] - [(assq 'host headers) - => - (lambda (h) (string->symbol (bytes->string/utf-8 (cdr h))))] + [(headers-assq #"Host" headers) + => (match-lambda + [(struct header (_ v)) + (string->symbol (bytes->string/utf-8 v))])] [else DEFAULT-HOST-NAME])) - - ;; get-parsed-bindings : request -> (listof (cons sym str)) - (define (get-parsed-bindings r) - (let ([x (request-bindings/raw r)]) - (if (list? x) - x - (parse-bindings x)))) - - ;; parse-bindings : (U #f String) -> (listof (cons Symbol String)) - (define (parse-bindings raw) - (if (string? raw) - (let ([len (string-length raw)]) - (let loop ([start 0]) - (let find= ([key-end start]) - (if (>= key-end len) - null - (if (eq? (string-ref raw key-end) #\=) - (let find-amp ([amp-end (add1 key-end)]) - (if (or (= amp-end len) (eq? (string-ref raw amp-end) #\&)) - (cons (cons (string->symbol (substring raw start key-end)) - (translate-escapes - (substring raw (add1 key-end) amp-end))) - (loop (add1 amp-end))) - (find-amp (add1 amp-end)))) - (find= (add1 key-end))))))) - null)) - + ; extract-binding/single : sym (listof (cons str str)) -> str (define (extract-binding/single name bindings) (let ([lst (extract-bindings name bindings)]) @@ -146,21 +139,20 @@ ;; 2. Headers should be read as bytes and then translated to unicode as appropriate. ;; 3. The Authorization header should have bytes (i.e. (cdr pass-pair) is bytes (define (extract-user-pass headers) - (let ([pass-pair (assq 'authorization headers)]) - (and pass-pair - (let ([basic-credentials (cdr pass-pair)]) - (cond - [(and (basic? basic-credentials) - (match-authentication - (base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials)))) - ) - => (lambda (user-pass) - (cons (cadr user-pass) (caddr user-pass)))] - [else #f]))))) + (match (headers-assq #"Authorization" headers) + [#f #f] + [(struct header (_ basic-credentials)) + (cond + [(and (basic? basic-credentials) + (match-authentication + (base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials)))) + ) + => (lambda (user-pass) + (cons (cadr user-pass) (caddr user-pass)))] + [else #f])])) ;; basic?: bytes -> (or/c (listof bytes) #f) ;; does the second part of the authorization header start with #"Basic " (define basic? - (let ([basic-regexp (byte-regexp #"^Basic .*")]) - (lambda (some-bytes) - (regexp-match basic-regexp some-bytes))))) \ No newline at end of file + (let ([rx (byte-regexp #"^Basic .*")]) + (lambda (a) (regexp-match rx a))))) \ No newline at end of file diff --git a/collects/web-server/url.ss b/collects/web-server/url.ss index eecefa3d26..b7e27b6c1d 100644 --- a/collects/web-server/url.ss +++ b/collects/web-server/url.ss @@ -4,7 +4,7 @@ (lib "url.ss" "net") (lib "struct.ss")) (require "private/url.ss" - "request-parsing.ss") + "request-structs.ss") ;; URL parsing (provide (struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path)) diff --git a/collects/web-server/util.ss b/collects/web-server/util.ss index 7c3f0f4159..19ca24028d 100644 --- a/collects/web-server/util.ss +++ b/collects/web-server/util.ss @@ -2,6 +2,7 @@ (require (lib "contract.ss") (lib "string.ss") (lib "list.ss") + (lib "plt-match.ss") (lib "url.ss" "net") (lib "errortrace-lib.ss" "errortrace") (lib "uri-codec.ss" "net")) @@ -207,16 +208,16 @@ (define-struct servlet-error ()) (define-struct (invalid-%-suffix servlet-error) (chars)) (define-struct (incomplete-%-suffix invalid-%-suffix) ()) - (define (translate-escapes raw) - (let ([raw (uri-decode raw)]) - (list->string - (let loop ((chars (string->list raw))) - (if (null? chars) null - (let ((first (car chars)) - (rest (cdr chars))) - (let-values (((this rest) - (cond - ((char=? first #\+) - (values #\space rest)) - (else (values first rest))))) - (cons this (loop rest)))))))))) + (define (translate-escapes init) + (define raw (uri-decode init)) + (list->string + (let loop ([chars (string->list raw)]) + (match chars + [(list) + (list)] + [(list-rest ic cs) + (define c + (cond + [(char=? ic #\+) #\space] + [else ic])) + (list* c (loop cs))]))))) \ No newline at end of file diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 9e07c83f1b..4e391854d9 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -5,7 +5,7 @@ "configuration-structures.ss" "servlet.ss" "private/cache-table.ss" - (rename "request-parsing.ss" + (rename "private/request.ss" the-read-request read-request)) (require (prefix sequencer: "dispatch-sequencer.ss") (prefix passwords: "dispatch-passwords.ss")