Uniformly use parameter embedding, see add02.ss for why

svn: r6386

collects/web-server/prototype-web-server/dispatch-servlets2.ss

@@ -20,7 +20,7 @@
    [interface-version dispatcher-interface-version?])
   (provide make)
   
-  (define myprint #;printf (lambda _ (void)))
+  (define myprint printf #;(lambda _ (void)))
   
   (define top-cust (current-custodian))
   

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

@@ -4,7 +4,8 @@
            (lib "plt-match.ss")
            (lib "url.ss" "net")
            (lib "request-structs.ss" "web-server")
-           (lib "response.ss" "web-server"))
+           (lib "response.ss" "web-server")
+           "url-param.ss")
   (provide current-session)
   
   (define-struct session (id cust namespace servlet url))
@@ -48,57 +49,11 @@
   
   ;; encode-session : url number -> url
   (define (encode-session a-url ses-id)
-    (insert-param a-url 's (number->string ses-id)))
+    (insert-param a-url "s" (number->string ses-id)))
     
   ;; extract-session : url -> (union number #f)
   ;; Determine if the url encodes a session-id and extract it
   (define (extract-session a-url)
     (define id (extract-param a-url "s"))
     (with-handlers ([exn? (lambda _ #f)])
-      (string->number id)))
-  
-  ;; extract-param : url string -> string
-  (define (extract-param url key)
-    (define (match-url-params x) (regexp-match (format "^~a=(.+)$" key) x))
-    (let ([k-params (filter match-url-params
-                            (apply append
-                                   (map path/param-param (url-path url))))])
-      (if (empty? k-params)
-          #f
-          (match (match-url-params (first k-params))
-            [(list _ val)
-             val]
-            [_
-             #f]))))
-  
-  ;; insert-param : url string string -> url
-  ;; add a path/param to the path in a url
-  ;; (assumes that there is only one path/param)
-  (define (insert-param in-url key new-param-str)
-    (replace-path
-     (lambda (old-path)
-       (if (null? old-path)
-           (list (make-path/param "" (list (format "~a=~a" key new-param-str))))
-           (let* ([car-old-path (car old-path)])
-             (cons (make-path/param (if (path/param? car-old-path)
-                                        (path/param-path car-old-path)
-                                        car-old-path)
-                                    (list (format "~a=~a" key new-param-str)))
-                   (cdr old-path)))))
-     in-url))
-  
-  ;; replace-path : (url-path -> url-path) url -> url
-  ;; make a new url by replacing the path part of a url with a function
-  ;; of the url's old path
-  ;; also remove the query
-  (define (replace-path proc in-url)
-    (let ([new-path (proc (url-path in-url))])
-      (make-url
-       (url-scheme in-url)
-       (url-user in-url)
-       (url-host in-url)
-       (url-port in-url)
-       #t
-       new-path
-       (url-query in-url)
-       (url-fragment in-url)))))
+      (string->number id))))

collects/web-server/prototype-web-server/private/stuff-url.ss

@@ -3,6 +3,7 @@
            (lib "url.ss" "net")
            (lib "serialize.ss")
            "utils.ss"
+           "url-param.ss"
            "mod-map.ss")
   
   ; XXX url: first try continuation, then turn into hash
@@ -33,19 +34,17 @@
   ;; encode in the url
   (define (stuff-url svl uri)
     (define result-uri
-      (extend-url-query uri 'c (md5-store (write/string (compress-serial svl)))))
+      (insert-param uri "c" (md5-store (write/string (compress-serial svl)))))
     (when (> (string-length (url->string result-uri))
              1024)
       (error "the url is too big: " (url->string result-uri)))
     result-uri)
   
   (define (stuffed-url? uri)
-    (let* ([qry (url-query uri)]
-           [l-code (find-binding 'c qry)])
-      (and l-code
-           #t)))  
+    (and (extract-param uri "c")
+         #t))
   
   ;; unstuff-url: url -> serial
   ;; decode from the url and reconstruct the serial
   (define (unstuff-url req-url)
-    (decompress-serial (read/string (md5-lookup (find-binding 'c (url-query req-url)))))))
+    (decompress-serial (read/string (md5-lookup (extract-param req-url "c"))))))

collects/web-server/prototype-web-server/private/url-param.ss

@@ -0,0 +1,63 @@
+(module url-param mzscheme
+  (require (lib "contract.ss")
+           (lib "url.ss" "net")
+           (lib "plt-match.ss")
+           (lib "list.ss")
+           (lib "serialize.ss")
+           "utils.ss")
+  
+  (provide/contract
+   [extract-param (url? string? . -> . (or/c string? false/c))]
+   [insert-param (url? string? string? . -> . url?)])
+  
+  ;; extract-param : url string -> string
+  (define (extract-param url key)
+    (define ps
+      (apply append
+             (map path/param-param (url-path url))))
+    (let/ec esc
+      (for-each (lambda (p)
+                  (with-handlers ([exn? void])
+                    (define l (read/string p))
+                    (esc (cdr (assoc key l)))))
+                ps)
+      #f))
+  
+  ;; insert-param : url string string -> url
+  ;; add a path/param to the path in a url
+  ;; (assumes that there is only one path/param)
+  (define (insert-param in-url key val)
+    (replace-path
+     (match-lambda
+       [(list)
+        (list (make-path/param 
+               ""
+               (list (write/string (list (cons key val))))))]
+       [old
+        (match (reverse old)
+          [(list-rest f r)
+           (reverse (list* (make-path/param 
+                            (path/param-path f)
+                            (list (write/string
+                                   (list* (cons key val)
+                                          (with-handlers ([exn? (lambda _ empty)])
+                                            (filter (lambda (k*v) (not (equal? key (car k*v))))
+                                                    (read/string (first (path/param-param f)))))))))
+                           r))])])
+     in-url))
+  
+  ;; replace-path : (url-path -> url-path) url -> url
+  ;; make a new url by replacing the path part of a url with a function
+  ;; of the url's old path
+  ;; also remove the query
+  (define (replace-path proc in-url)
+    (let ([new-path (proc (url-path in-url))])
+      (make-url
+       (url-scheme in-url)
+       (url-user in-url)
+       (url-host in-url)
+       (url-port in-url)
+       #t
+       new-path
+       (url-query in-url)
+       (url-fragment in-url)))))

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

@@ -6,35 +6,12 @@
            (lib "serialize.ss"))
   
   (provide/contract
-   [find-binding (symbol? (listof (cons/c symbol? string?)) . -> . (or/c serializable? false/c))]
-   [extend-url-query (url? symbol? string? . -> . url?)]
    [read/string (string? . -> . serializable?)]
    [write/string (serializable? . -> . string?)]
    [url->servlet-path ((path? url?) . ->* . ((or/c path? false/c) (or/c (listof string?) false/c) (or/c (listof string?) false/c)))]
    [make-session-url (url? (listof string?) . -> . url?)]
    [split-url-path (url? url? . -> . (or/c (listof string?) false/c))])
-  
-  ;; find-binding: symbol (list (cons symbol string)) -> (union string #f)
-  ;; find the binding in the query or return false
-  (define (find-binding key qry)
-    (cond
-      [(null? qry) #f]
-      [(eqv? key (caar qry))
-       (read/string (cdar qry))]
-      [else (find-binding key (cdr qry))]))
-  
-  (define (extend-url-query uri key val)
-    (make-url
-     (url-scheme uri)
-     (url-user uri)
-     (url-host uri)
-     (url-port uri)
-     #t
-     (url-path uri)
-     (list* (cons key val)
-            (url-query uri))
-     (url-fragment uri)))
-  
+    
   (define (read/string str)
     (read (open-input-string str)))
   (define (write/string v)

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

@@ -7,7 +7,7 @@
            (all-except "abort-resume.ss" send/suspend)
            "session.ss"
            "stuff-url.ss"
-           "utils.ss")
+           "url-param.ss")
   
   (provide 
    ;; Server Interface
@@ -53,29 +53,27 @@
         (stuff-url (serialize k)
                    (session-url (current-session)))))))
   
-  ; XXX Changing embedding to be a param
-  (define embed-label 'superkont)  
+  (define embed-label "superkont")  
   (define (embed-proc/url k-url proc)
     (define superkont-url
       (stuff-url (serialize proc)                                              
                  (session-url (current-session))))
     (define result-uri
-      (extend-url-query k-url embed-label 
-                        (url->string superkont-url)))
+      (insert-param k-url embed-label 
+                    (url->string superkont-url)))
     (begin0 result-uri
             (when (> (string-length (url->string result-uri))
                      1024)
               (error "the url is too big: " (url->string result-uri)))))
   (define (extract-proc/url request)
     (define req-url (request-uri request))
-    (define binds (url-query req-url))
-    (define maybe-embedding (assq embed-label binds))
+    (define maybe-embedding (extract-param req-url embed-label))
     (if maybe-embedding
         (let ([proc (deserialize 
                      (unstuff-url
-                      (string->url (cdr maybe-embedding))))])
+                      (string->url maybe-embedding)))])
           (proc request))
-        (error 'send/suspend/dispatch "No ~a: ~S!" embed-label binds)))
+        (error 'send/suspend/dispatch "No ~a: ~S!" embed-label)))
   
   ;; request->continuation: req -> continuation
   ;; decode the continuation from the hidden field of a request

collects/web-server/prototype-web-server/servlets/add02.ss

@@ -2,9 +2,7 @@
   (require (lib "url.ss" "net")
            (lib "request-structs.ss" "web-server"))
   (provide start)
-  
-  ;; XXX This demonstrates that if we hide the K in a query, it will be overridden.
-  
+
   ;; get-number-from-user: string -> number
   ;; ask the user for a number
   (define (gn msg)