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

up

Browse Source 
svn: r4629
This commit is contained in:
Jay McCarthy 2006-10-18 16:51:56 +00:00
parent 004f36864a
commit 27cae4bf2e
5 changed files with 42 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/web-server/dispatchers/dispatch-files.ss
View File

@ -41,7 +41,7 @@
(uri-decode (url-path->string (url-path uri)))))
(cond
[(file-exists? path)
(match (headers-assq #"Range" (request-headers/raw req))
(match (headers-assq* #"Range" (request-headers/raw req))
[#f
(output-file conn path method (get-mime-type path))]
[range

28
collects/web-server/dispatchers/dispatch-log.ss
View File

@ -6,6 +6,7 @@
(lib "plt-match.ss")
(lib "contract.ss"))
(require "dispatch.ss"
"../request-structs.ss"
"../private/servlet-helpers.ss")
(provide/contract
[interface-version dispatcher-interface-version?])
@ -18,14 +19,10 @@
[log-path #f])
(if log-path
(case log-format
[(parenthesized-default)
[(parenthesized-default extended)
(let ([log-message (gen-log-message log-format log-path)])
(lambda (conn req)
(log-message (request-host-ip req)
(request-client-ip req)
(request-method req)
(request-uri req)
(get-host (request-uri req) (request-headers/raw req)))
(log-message req)
(next-dispatcher)))]
[else
(lambda (conn req)
@ -49,7 +46,7 @@
(handle-evt
log-ch
(match-lambda
[(list host-ip client-ip method uri host)
[(list req)
(with-handlers ([exn? (lambda (e)
((error-display-handler) "dispatch-log.ss: Error writing log entry" e)
(loop #f))])
@ -64,8 +61,21 @@
log-p))
(display
(format "~s~n"
(list 'from client-ip 'to host-ip 'for (url->string uri) 'at
(date->string (seconds->date (current-seconds)) #t)))
(case log-format
[(parenthesized-default)
(list 'from (request-client-ip req)
'to (request-host-ip req)
'for (url->string (request-uri req)) 'at
(date->string (seconds->date (current-seconds)) #t))]
[(extended)
`((client-ip ,(request-client-ip req))
(host-ip ,(request-host-ip req))
(referer ,(let ([R (headers-assq* #"Referer" (request-headers/raw req))])
(if R
(header-value R)
#f)))
(uri ,(url->string (request-uri req)))
(time ,(current-seconds)))]))
the-log-p)
(loop the-log-p))])))))))
(lambda args

12
collects/web-server/private/request.ss
View File

@ -45,7 +45,7 @@
(lambda (headers major minor client-ip host-ip)
(or (< major 1)
(and (= major 1) (= minor 0))
(match (headers-assq #"Connection" headers)
(match (headers-assq* #"Connection" headers)
[(struct header (f v))
(and (regexp-match rx v)
#t)]
@ -62,8 +62,8 @@
(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))
(or (headers-assq* #"HTTP_USER_AGENT" headers)
(headers-assq* #"User-Agent" headers))
[(struct header (f v))
(and (regexp-match rx v)
#t)]
@ -144,7 +144,7 @@
(string->bytes/utf-8 v))])
(url-query uri))]
['post
(define content-type (headers-assq #"Content-Type" headers))
(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)))
@ -152,7 +152,7 @@
[(list _ content-boundary)
(map (match-lambda
[(struct mime-part (headers contents))
(define rhs (header-value (headers-assq #"Content-Disposition" headers)))
(define rhs (header-value (headers-assq* #"Content-Disposition" headers)))
(match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs)
(regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs))
[(list #f #f)
@ -163,7 +163,7 @@
(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)
(match (headers-assq* #"Content-Length" headers)
[(struct header (_ value))
(cond
[(string->number (bytes->string/utf-8 value))

4
collects/web-server/private/servlet-helpers.ss
View File

@ -36,7 +36,7 @@
(define (get-host uri headers)
(cond
[(url-host uri) => string->symbol]
[(headers-assq #"Host" headers)
[(headers-assq* #"Host" headers)
=> (match-lambda
[(struct header (_ v))
(string->symbol (bytes->string/utf-8 v))])]
@ -108,7 +108,7 @@
;; 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)
(match (headers-assq #"Authorization" headers)
(match (headers-assq* #"Authorization" headers)
[#f #f]
[(struct header (_ basic-credentials))
(cond

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

@ -2,18 +2,31 @@
(require (lib "contract.ss")
(lib "plt-match.ss")
(lib "url.ss" "net"))
(define (bytes-ci=? b0 b1)
(string-ci=? (bytes->string/utf-8 b0)
(bytes->string/utf-8 b1)))
(define-struct header (field value))
(define (headers-assq* f hs)
(match hs
[(list)
#f]
[(list-rest (and h (struct header (af aw))) hs)
(if (bytes-ci=? af f)
h
(headers-assq f hs))]))
(define (headers-assq f hs)
(match hs
[(list)
#f]
[(list-rest (and h (struct header (af av))) hs)
(if (equal? af f)
(if (bytes=? af f)
h
(headers-assq f hs))]))
(provide/contract
[headers-assq (bytes? (listof header?) . -> . (or/c false/c header?))]
[headers-assq* (bytes? (listof header?) . -> . (or/c false/c header?))]
[struct header ([field bytes?]
[value bytes?])])