revamping request parsing for filenames

svn: r3217

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)))))

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)

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

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
@@ -51,14 +48,6 @@
            [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

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)]))))

collects/web-server/request-parsing.ss

@@ -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)))

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"))
     
-  ;; the request struct as currently doc'd
+  (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?])])
+  
   (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?)]
+   [struct request ([method symbol?] [uri url?] 
-                    [bindings/raw (or/c (listof binding?) string?)]
+                                     [headers/raw (listof header?)]
+                                     [bindings/raw (listof binding?)]
                                      [host-ip string?] [host-port number?]
                                      [client-ip string?])]))

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

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")
+           (all-from "request-structs.ss")
-           (rename get-parsed-bindings request-bindings)
+           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 '<none>)
   (define (get-host uri headers)
     (cond
       [(url-host uri) => string->symbol]
-      [(assq 'host headers)
+      [(headers-assq #"Host" headers)
-       =>
+       => (match-lambda
-       (lambda (h) (string->symbol (bytes->string/utf-8 (cdr h))))]
+            [(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,9 +139,9 @@
   ;; 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)])
+    (match (headers-assq #"Authorization" headers)
-      (and pass-pair
+      [#f #f]
-           (let ([basic-credentials (cdr pass-pair)])
+      [(struct header (_ basic-credentials))
        (cond
          [(and (basic? basic-credentials)
                (match-authentication
@@ -156,11 +149,10 @@
                )
           => (lambda (user-pass)
                (cons (cadr user-pass) (caddr user-pass)))]
-               [else #f])))))
+         [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 .*")])
+    (let ([rx (byte-regexp #"^Basic .*")])
-      (lambda (some-bytes)
+      (lambda (a) (regexp-match rx a)))))
-        (regexp-match basic-regexp some-bytes)))))

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))

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)
+  (define (translate-escapes init)
-    (let ([raw (uri-decode raw)])
+    (define raw (uri-decode init))
     (list->string
-       (let loop ((chars (string->list raw)))
+     (let loop ([chars (string->list raw)])
-         (if (null? chars) null
+       (match chars
-             (let ((first (car chars))
+         [(list)
-                   (rest (cdr chars)))
+          (list)]
-               (let-values (((this rest)
+         [(list-rest ic cs)
+          (define c
             (cond
-                               ((char=? first #\+)
+              [(char=? ic #\+) #\space]
-                                (values #\space rest))                             
+              [else ic]))
-                               (else (values first rest)))))
+          (list* c (loop cs))])))))
-                 (cons this (loop rest))))))))))

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")