diff --git a/collects/web-server/prototype-web-server/dispatch-servlets2.ss b/collects/web-server/prototype-web-server/dispatch-servlets2.ss index 6a79c310ed..5a25575d7b 100644 --- a/collects/web-server/prototype-web-server/dispatch-servlets2.ss +++ b/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)) diff --git a/collects/web-server/prototype-web-server/private/session.ss b/collects/web-server/prototype-web-server/private/session.ss index 7ca9c05b52..48d671dad1 100644 --- a/collects/web-server/prototype-web-server/private/session.ss +++ b/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))))) \ No newline at end of file + (string->number id)))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/private/stuff-url.ss b/collects/web-server/prototype-web-server/private/stuff-url.ss index e178fdb9c4..ec08ed910a 100644 --- a/collects/web-server/prototype-web-server/private/stuff-url.ss +++ b/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))))))) \ No newline at end of file + (decompress-serial (read/string (md5-lookup (extract-param req-url "c")))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/private/url-param.ss b/collects/web-server/prototype-web-server/private/url-param.ss new file mode 100644 index 0000000000..3b0024bb19 --- /dev/null +++ b/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))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/private/utils.ss b/collects/web-server/prototype-web-server/private/utils.ss index 00d243233d..e936777c72 100644 --- a/collects/web-server/prototype-web-server/private/utils.ss +++ b/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) diff --git a/collects/web-server/prototype-web-server/private/web.ss b/collects/web-server/prototype-web-server/private/web.ss index 2236340f36..0fd2db97e2 100644 --- a/collects/web-server/prototype-web-server/private/web.ss +++ b/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 diff --git a/collects/web-server/prototype-web-server/servlets/add02.ss b/collects/web-server/prototype-web-server/servlets/add02.ss index c5a7b5a2a4..7dd6cba64d 100644 --- a/collects/web-server/prototype-web-server/servlets/add02.ss +++ b/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)