diff --git a/collects/web-server/prototype-web-server/dispatch-servlets2.ss b/collects/web-server/prototype-web-server/dispatch-servlets2.ss index 4974668701..a687787425 100644 --- a/collects/web-server/prototype-web-server/dispatch-servlets2.ss +++ b/collects/web-server/prototype-web-server/dispatch-servlets2.ss @@ -21,29 +21,7 @@ (define myprint #;printf (lambda _ (void))) (define top-cust (current-custodian)) - - ;; Parameter Parsing - - ;; encodes a simple number: - (define (match-url-params x) (regexp-match #rx"([0-9]+)" x)) - - ;; resume-session? url -> (union number #f) - ;; Determine if the url encodes a session-id and extract it - (define (resume-session? a-url) - (myprint "resume-session?: url-string = ~s~n" (url->string a-url)) - (let ([k-params (filter match-url-params - (apply append - (map path/param-param (url-path a-url))))]) - (myprint "resume-session?: ~S~n" k-params) - (if (empty? k-params) - #f - (match (match-url-params (first k-params)) - [(list _ n) - (myprint "resume-session?: Found ~a~n" n) - (string->number n)] - [_ - #f])))) - + (define make-servlet-namespace (make-make-servlet-namespace #:to-be-copied-module-specs @@ -84,7 +62,7 @@ (responders-servlet-loading uri the-exn) (request-method req)))]) (cond - [(resume-session? uri) + [(extract-session uri) => (lambda (session-id) (resume-session session-id conn req))] [else diff --git a/collects/web-server/prototype-web-server/private/session.ss b/collects/web-server/prototype-web-server/private/session.ss index 5f6ad1fa13..8207901b03 100644 --- a/collects/web-server/prototype-web-server/private/session.ss +++ b/collects/web-server/prototype-web-server/private/session.ss @@ -1,5 +1,7 @@ (module session mzscheme (require (lib "contract.ss") + (lib "list.ss") + (lib "plt-match.ss") (lib "url.ss" "net") (lib "request-structs.ss" "web-server") (lib "response.ss" "web-server")) @@ -13,6 +15,7 @@ [namespace namespace?] [servlet (request? . -> . response?)] [url url?])] + [extract-session (url? . -> . (or/c number? false/c))] [lookup-session (number? . -> . (or/c session? false/c))] [new-session (custodian? namespace? url? . -> . session?)]) @@ -46,6 +49,21 @@ ;; encode-session: url number -> url (define (encode-session a-url ses-id) (insert-param a-url (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 (match-url-params x) (regexp-match #rx"([0-9]+)" x)) + (let ([k-params (filter match-url-params + (apply append + (map path/param-param (url-path a-url))))]) + (if (empty? k-params) + #f + (match (match-url-params (first k-params)) + [(list _ n) + (string->number n)] + [_ + #f])))) ;; insert-param: url string -> string ;; add a path/param to the path in a url 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 8b04de9b4a..e178fdb9c4 100644 --- a/collects/web-server/prototype-web-server/private/stuff-url.ss +++ b/collects/web-server/prototype-web-server/private/stuff-url.ss @@ -12,7 +12,6 @@ (provide/contract [stuff-url (serializable? url? . -> . url?)] [stuffed-url? (url? . -> . boolean?)] - [extend-url-query (url? symbol? string? . -> . url?)] [unstuff-url (url? . -> . serializable?)]) ; XXX Abstract this @@ -44,19 +43,7 @@ (let* ([qry (url-query uri)] [l-code (find-binding 'c qry)]) (and l-code - #t))) - - (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))) + #t))) ;; unstuff-url: url -> serial ;; decode from the url and reconstruct the serial diff --git a/collects/web-server/prototype-web-server/private/utils.ss b/collects/web-server/prototype-web-server/private/utils.ss index 5f7a112837..00d243233d 100644 --- a/collects/web-server/prototype-web-server/private/utils.ss +++ b/collects/web-server/prototype-web-server/private/utils.ss @@ -7,6 +7,7 @@ (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)))] @@ -22,6 +23,18 @@ (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 77aa0d4c24..2236340f36 100644 --- a/collects/web-server/prototype-web-server/private/web.ss +++ b/collects/web-server/prototype-web-server/private/web.ss @@ -6,7 +6,8 @@ (rename "abort-resume.ss" send/suspend0 send/suspend) (all-except "abort-resume.ss" send/suspend) "session.ss" - "stuff-url.ss") + "stuff-url.ss" + "utils.ss") (provide ;; Server Interface