From 27cae4bf2e7f96813ec8267de3fc1aeeb16acee1 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 18 Oct 2006 16:51:56 +0000 Subject: [PATCH] up svn: r4629 --- .../web-server/dispatchers/dispatch-files.ss | 2 +- .../web-server/dispatchers/dispatch-log.ss | 28 +++++++++++++------ collects/web-server/private/request.ss | 12 ++++---- .../web-server/private/servlet-helpers.ss | 4 +-- collects/web-server/request-structs.ss | 15 +++++++++- 5 files changed, 42 insertions(+), 19 deletions(-) diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index df888cb99d..d39eeb6ec4 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -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 diff --git a/collects/web-server/dispatchers/dispatch-log.ss b/collects/web-server/dispatchers/dispatch-log.ss index e0f2ebbe72..89e015ad14 100644 --- a/collects/web-server/dispatchers/dispatch-log.ss +++ b/collects/web-server/dispatchers/dispatch-log.ss @@ -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 diff --git a/collects/web-server/private/request.ss b/collects/web-server/private/request.ss index cbbdb6d6ca..12d3b101fc 100644 --- a/collects/web-server/private/request.ss +++ b/collects/web-server/private/request.ss @@ -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)) diff --git a/collects/web-server/private/servlet-helpers.ss b/collects/web-server/private/servlet-helpers.ss index 295c966ee0..4730000021 100644 --- a/collects/web-server/private/servlet-helpers.ss +++ b/collects/web-server/private/servlet-helpers.ss @@ -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 diff --git a/collects/web-server/request-structs.ss b/collects/web-server/request-structs.ss index ad246076d4..2e5054b83a 100644 --- a/collects/web-server/request-structs.ss +++ b/collects/web-server/request-structs.ss @@ -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?])])