revamping request parsing for filenames
svn: r3217
This commit is contained in:
Jay McCarthy
parent
b28e19eba3
commit
d489e3e0b3
|
|
@ -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)))))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
246
collects/web-server/private/request.ss
Normal file
246
collects/web-server/private/request.ss
Normal file
|
|
@ -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)]))))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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?])]))
|
||||
[struct request ([method symbol?] [uri url?]
|
||||
[headers/raw (listof header?)]
|
||||
[bindings/raw (listof binding?)]
|
||||
[host-ip string?] [host-port number?]
|
||||
[client-ip string?])]))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 '<none>)
|
||||
(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)))))
|
||||
(let ([rx (byte-regexp #"^Basic .*")])
|
||||
(lambda (a) (regexp-match rx a)))))
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))])))))
|
||||
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user