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))))) (uri-decode (url-path->string (url-path uri)))))
(cond (cond
[(file-exists? path) [(file-exists? path)
(match (headers-assq #"Range" (request-headers/raw req)) (match (headers-assq* #"Range" (request-headers/raw req))
[#f [#f
(output-file conn path method (get-mime-type path))] (output-file conn path method (get-mime-type path))]
[range [range

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

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

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

@ -45,7 +45,7 @@
(lambda (headers major minor client-ip host-ip) (lambda (headers major minor client-ip host-ip)
(or (< major 1) (or (< major 1)
(and (= major 1) (= minor 0)) (and (= major 1) (= minor 0))
(match (headers-assq #"Connection" headers) (match (headers-assq* #"Connection" headers)
[(struct header (f v)) [(struct header (f v))
(and (regexp-match rx v) (and (regexp-match rx v)
#t)] #t)]
@ -62,8 +62,8 @@
(lambda (headers client-ip host-ip) (lambda (headers client-ip host-ip)
(and (string=? host-ip client-ip) (and (string=? host-ip client-ip)
(match (match
(or (headers-assq #"HTTP_USER_AGENT" headers) (or (headers-assq* #"HTTP_USER_AGENT" headers)
(headers-assq #"User-Agent" headers)) (headers-assq* #"User-Agent" headers))
[(struct header (f v)) [(struct header (f v))
(and (regexp-match rx v) (and (regexp-match rx v)
#t)] #t)]
@ -144,7 +144,7 @@
(string->bytes/utf-8 v))]) (string->bytes/utf-8 v))])
(url-query uri))] (url-query uri))]
['post ['post
(define content-type (headers-assq #"Content-Type" headers)) (define content-type (headers-assq* #"Content-Type" headers))
(define in (connection-i-port conn)) (define in (connection-i-port conn))
(cond (cond
[(and content-type (regexp-match FILE-FORM-REGEXP (header-value content-type))) [(and content-type (regexp-match FILE-FORM-REGEXP (header-value content-type)))
@ -152,7 +152,7 @@
[(list _ content-boundary) [(list _ content-boundary)
(map (match-lambda (map (match-lambda
[(struct mime-part (headers contents)) [(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) (match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs)
(regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs)) (regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs))
[(list #f #f) [(list #f #f)
@ -163,7 +163,7 @@
(make-binding:file (or f10 f11) (or f00 f01) (apply bytes-append contents))])]) (make-binding:file (or f10 f11) (or f00 f01) (apply bytes-append contents))])])
(read-mime-multipart content-boundary in))])] (read-mime-multipart content-boundary in))])]
[else [else
(match (headers-assq #"Content-Length" headers) (match (headers-assq* #"Content-Length" headers)
[(struct header (_ value)) [(struct header (_ value))
(cond (cond
[(string->number (bytes->string/utf-8 value)) [(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) (define (get-host uri headers)
(cond (cond
[(url-host uri) => string->symbol] [(url-host uri) => string->symbol]
[(headers-assq #"Host" headers) [(headers-assq* #"Host" headers)
=> (match-lambda => (match-lambda
[(struct header (_ v)) [(struct header (_ v))
(string->symbol (bytes->string/utf-8 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. ;; 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 ;; 3. The Authorization header should have bytes (i.e. (cdr pass-pair) is bytes
(define (extract-user-pass headers) (define (extract-user-pass headers)
(match (headers-assq #"Authorization" headers) (match (headers-assq* #"Authorization" headers)
[#f #f] [#f #f]
[(struct header (_ basic-credentials)) [(struct header (_ basic-credentials))
(cond (cond

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

@ -3,17 +3,30 @@
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "url.ss" "net")) (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-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) (define (headers-assq f hs)
(match hs (match hs
[(list) [(list)
#f] #f]
[(list-rest (and h (struct header (af av))) hs) [(list-rest (and h (struct header (af av))) hs)
(if (equal? af f) (if (bytes=? af f)
h h
(headers-assq f hs))])) (headers-assq f hs))]))
(provide/contract (provide/contract
[headers-assq (bytes? (listof header?) . -> . (or/c false/c header?))] [headers-assq (bytes? (listof header?) . -> . (or/c false/c header?))]
[headers-assq* (bytes? (listof header?) . -> . (or/c false/c header?))]
[struct header ([field bytes?] [struct header ([field bytes?]
[value bytes?])]) [value bytes?])])