Fixing same-servlet to support arbitrary junk after servlet file

svn: r6360

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
+        (map path/param-path
-         (apply build-path
+             (url-path u)))
-                (map path/param-path
+      (define ans
-                     (url-path u)))))
+      (let loop ([rp (abstract-url req)]
-      (string=? (abstract-url u)
+                 [sp (abstract-url ses)])
-                (abstract-url v)))
+        (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)
+              (if (same-servlet? (request-uri req) (session-url ses))
-                                 (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)))]

collects/web-server/prototype-web-server/private/utils.ss

@@ -1,5 +1,6 @@
 (module utils mzscheme
   (require (lib "url.ss" "net")
+           (lib "plt-match.ss")
            (lib "list.ss"))
   (provide url->servlet-path
            make-session-url
@@ -82,20 +83,20 @@
                [servlet-path '()]
                [path-list (simplify-url-path uri)])
       #;(printf "~S~n" `(loop ,base-path ,servlet-path ,path-list))
-      (if
+      (match path-list
-       (null? path-list)
+        [(list)
-       (values #f #f #f)
+         (values #f #f #f)]
-       (let* ([next-path-segment (car path-list)]
+        [(list-rest next-path-segment rest-of-path)
-              [new-base (build-path base-path next-path-segment)])
+         (let ([new-base (build-path base-path next-path-segment)])
-         #;(printf "   new-base = ~s~n" new-base)
+           #;(printf "   new-base = ~s~n" new-base)
-         (cond
+           (cond
-           [(file-exists? new-base)
+             [(file-exists? new-base)
-            (values new-base
+              (values new-base
-                    (reverse (cons next-path-segment servlet-path))
+                      (reverse (list* next-path-segment servlet-path))
-                    (cdr path-list))]
+                      rest-of-path)]
-           [else (loop new-base
+             [else (loop new-base
-                       (cons next-path-segment servlet-path)
+                         (list* next-path-segment servlet-path)
-                       (cdr path-list))])))))
+                         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

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