diff --git a/collects/web-server/prototype-web-server/dispatch-servlets2.ss b/collects/web-server/prototype-web-server/dispatch-servlets2.ss index 59866fcd00..63ab120e1a 100644 --- a/collects/web-server/prototype-web-server/dispatch-servlets2.ss +++ b/collects/web-server/prototype-web-server/dispatch-servlets2.ss @@ -122,14 +122,26 @@ (request-method req)))))) ; same-servlet? : url? url? -> boolean? - (define (same-servlet? u v) + (define (same-servlet? req ses) (define (abstract-url u) - (path->string - (apply build-path - (map path/param-path - (url-path u))))) - (string=? (abstract-url u) - (abstract-url v))) + (map path/param-path + (url-path u))) + (define ans + (let loop ([rp (abstract-url req)] + [sp (abstract-url ses)]) + (match sp + [(list) + #t] + [(list-rest s sp) + (match rp + [(list) + #f] + [(list-rest r rp) + (if (string=? s r) + (loop rp sp) + #f)])]))) + (myprint "~S => ~S~n" `(same-servlet? ,(url->string req) ,(url->string ses)) ans) + ans) ;; resume-session: number connection request (define (resume-session ses-id conn req) @@ -137,8 +149,7 @@ (cond [(lookup-session ses-id) => (lambda (ses) - (if (same-servlet? (request-uri req) - (session-url ses)) + (if (same-servlet? (request-uri req) (session-url ses)) (parameterize ([current-custodian (session-cust ses)] [current-session ses]) (with-handlers ([void @@ -147,7 +158,7 @@ conn (responders-servlet (request-uri req) the-exn) (request-method req)))]) - #;(printf "session-handler ~S~n" (session-handler ses)) + (myprint "session-handler ~S~n" (session-handler ses)) (output-response conn ((session-handler ses) req)))) (begin-session conn req)))] diff --git a/collects/web-server/prototype-web-server/private/utils.ss b/collects/web-server/prototype-web-server/private/utils.ss index 39dad04b5d..e03775f35b 100644 --- a/collects/web-server/prototype-web-server/private/utils.ss +++ b/collects/web-server/prototype-web-server/private/utils.ss @@ -1,10 +1,11 @@ (module utils mzscheme (require (lib "url.ss" "net") + (lib "plt-match.ss") (lib "list.ss")) (provide url->servlet-path make-session-url split-url-path) - + ;; make-session-url: url (listof string) -> url ;; produce a new url for this session: ;; Minimal path to the servlet. @@ -22,7 +23,7 @@ '() #f )) - + ;; build-root-path: -> path ;; build the root path for whatever this OS is (define (build-root-path) @@ -32,9 +33,9 @@ prev (loop next (simplify-path (build-path next 'up)))))) - + (define the-root-path (build-root-path)) - + ;; simplify-url-path: url -> (listof string) ;; take the dots out of the url-path ;; Note: we simplify the url path relative to a hypothetical root, @@ -56,7 +57,7 @@ (path/param-path path-elt) path-elt)) (url-path uri)))))))) - + ;; path->list pth ;; convert an absolute path to a list of strings (define (path->list pth) @@ -66,8 +67,8 @@ (if base (cons (path->string name) (path->list base)) '()))))) - - + + ;; url->servlet-path: path url -> (values (union path #f) ;; (union (listof url->string) #f) ;; (union (listof string) #f)) @@ -82,20 +83,20 @@ [servlet-path '()] [path-list (simplify-url-path uri)]) #;(printf "~S~n" `(loop ,base-path ,servlet-path ,path-list)) - (if - (null? path-list) - (values #f #f #f) - (let* ([next-path-segment (car path-list)] - [new-base (build-path base-path next-path-segment)]) - #;(printf " new-base = ~s~n" new-base) - (cond - [(file-exists? new-base) - (values new-base - (reverse (cons next-path-segment servlet-path)) - (cdr path-list))] - [else (loop new-base - (cons next-path-segment servlet-path) - (cdr path-list))]))))) + (match path-list + [(list) + (values #f #f #f)] + [(list-rest next-path-segment rest-of-path) + (let ([new-base (build-path base-path next-path-segment)]) + #;(printf " new-base = ~s~n" new-base) + (cond + [(file-exists? new-base) + (values new-base + (reverse (list* next-path-segment servlet-path)) + rest-of-path)] + [else (loop new-base + (list* next-path-segment servlet-path) + rest-of-path)]))]))) ;; split-url-path: url url -> (union (listof string) #f) ;; the first url's path is a prefix of the path of the second diff --git a/collects/web-server/prototype-web-server/run.ss b/collects/web-server/prototype-web-server/run.ss index e009e63d2a..cf2986262c 100644 --- a/collects/web-server/prototype-web-server/run.ss +++ b/collects/web-server/prototype-web-server/run.ss @@ -59,7 +59,7 @@ (define dispatch (sequencer:make (filter:make - #rx"\\.ss$" + #rx"\\.ss" (servlets2:make #:htdocs-path htdocs-path #:timeouts-servlet-connection 86400 #:responders-servlet-loading responders-servlet-loading