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,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
+      (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