suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

revamping request parsing for filenames

Browse Source 
svn: r3217
This commit is contained in:
Jay McCarthy 2006-06-04 22:04:29 +00:00
parent b28e19eba3
commit d489e3e0b3
12 changed files with 346 additions and 331 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/web-server/dispatch-host.ss
View File

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

2
collects/web-server/dispatch-log.ss
View File

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

2
collects/web-server/dispatch-passwords.ss
View File

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

11
collects/web-server/dispatch-servlets.ss
View File

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

246
collects/web-server/private/request.ss Normal file
View 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)]))))

234
collects/web-server/request-parsing.ss
View File

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

55
collects/web-server/request-structs.ss
View File

@ -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?)]
[bindings/raw (or/c (listof binding?) string?)]
[struct request ([method symbol?] [uri url?]
[headers/raw (listof header?)]
[bindings/raw (listof binding?)]
[host-ip string?] [host-port number?]
[client-ip string?])]))

2
collects/web-server/response.ss
View File

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

70
collects/web-server/servlet-helpers.ss
View File

@ -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,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)])
(and pass-pair
(let ([basic-credentials (cdr pass-pair)])
(match (headers-assq #"Authorization" headers)
[#f #f]
[(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 .*")])
(lambda (some-bytes)
(regexp-match basic-regexp some-bytes)))))
(let ([rx (byte-regexp #"^Basic .*")])
(lambda (a) (regexp-match rx a)))))

2
collects/web-server/url.ss
View File

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

23
collects/web-server/util.ss
View File

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

2
collects/web-server/web-server-unit.ss
View File

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