From 44a49ff2726f175fcd8a0e4d4ffca9959e3b8a67 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 30 May 2007 23:16:58 +0000 Subject: [PATCH] Shedding bad interfaces svn: r6424 --- .../dispatchers/dispatch-servlets.ss | 1 - collects/web-server/private/url.ss | 77 ------------- collects/web-server/private/util.ss | 50 ++++++--- .../prototype-web-server/private/url-param.ss | 24 +--- collects/web-server/servlet/servlet-url.ss | 106 +++--------------- collects/web-server/servlet/web.ss | 60 +++++++++- 6 files changed, 109 insertions(+), 209 deletions(-) delete mode 100644 collects/web-server/private/url.ss diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 7823f78b18..9e4582f7eb 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -20,7 +20,6 @@ "../managers/timeouts.ss" "../managers/lru.ss" "../managers/none.ss" - "../private/url.ss" "../private/servlet.ss" "../private/cache-table.ss") (provide/contract diff --git a/collects/web-server/private/url.ss b/collects/web-server/private/url.ss deleted file mode 100644 index b2fdba9064..0000000000 --- a/collects/web-server/private/url.ss +++ /dev/null @@ -1,77 +0,0 @@ -(module url mzscheme - (require (lib "contract.ss") - (lib "url.ss" "net") - (lib "list.ss") - (lib "plt-match.ss")) - - (provide/contract - [match-url-params (string? . -> . (or/c false/c (list/c string? string? string? string?)))] - [continuation-url? (url? . -> . (or/c boolean? (list/c number? number? number?)))] - [embed-ids ((list/c number? number? number?) url? . -> . string?)]) - - ;; ******************************************************************************** - ;; Parameter Embedding - - (define URL-PARAMS:REGEXP (regexp "([^\\*]*)\\*([^\\*]*)\\*([^\\*]*)")) - - (define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x)) - - ;; embed-ids: (list number number number) url -> string - (define embed-ids - (match-lambda* - [(list (list inst-id k-id salt) in-url) - (insert-param - in-url - (format "~a*~a*~a" inst-id k-id salt))])) - - ;; continuation-url?: url -> (or/c (list number number number) #f) - ;; determine if this url encodes a continuation and extract the instance id and - ;; continuation id. - (define (continuation-url? a-url) - (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 s instance k-id salt) - (let ([instance/n (string->number instance)] - [k-id/n (string->number k-id)] - [salt/n (string->number salt)]) - (if (and (number? instance/n) - (number? k-id/n) - (number? salt/n)) - (list instance/n - k-id/n - salt/n) - ; XXX: Maybe log this in some way? - #f))])))) - - ;; insert-param: url string -> string - ;; add a path/param to the path in a url - ;; (assumes that there is only one path/param) - (define (insert-param in-url new-param-str) - (url->string - (replace-path - (lambda (old-path) - (if (empty? old-path) - (list (make-path/param "" (list new-param-str))) - (list* (make-path/param (path/param-path (first old-path)) - (list new-param-str)) - (rest 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) - (url-path-absolute? in-url) - new-path - empty - (url-fragment in-url))))) \ No newline at end of file diff --git a/collects/web-server/private/util.ss b/collects/web-server/private/util.ss index 8454221d27..ba7a4bcc2c 100644 --- a/collects/web-server/private/util.ss +++ b/collects/web-server/private/util.ss @@ -1,9 +1,36 @@ (module util mzscheme - (require (lib "contract.ss") + (require (lib "list.ss") + (lib "contract.ss") (lib "string.ss") - (lib "url.ss" "net") - (lib "uri-codec.ss" "net")) - (require "../request-structs.ss") + (lib "url.ss" "net")) + (provide + url-replace-path) + (provide/contract + [url-path->string ((listof (or/c string? path/param?)) . -> . string?)] + [extract-flag (symbol? (listof (cons/c symbol? any/c)) any/c . -> . any/c)] + [network-error ((symbol? string?) (listof any/c) . ->* . (void))] + [path->list (path? . -> . (cons/c (or/c path? (symbols 'up 'same)) + (listof (or/c path? (symbols 'up 'same)))))] + [directory-part (path? . -> . path?)] + [lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)] + [exn->string ((or/c exn? any/c) . -> . string?)] + [build-path-unless-absolute (path-string? path-string? . -> . path?)]) + + ;; 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 (url-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) + (url-path-absolute? in-url) + new-path + empty + (url-fragment in-url)))) ;; ripped this off from url-unit.ss (define (url-path->string strs) @@ -52,7 +79,7 @@ s)]) (string-lowercase! s) (string->symbol s))) - + (define (directory-part path) (let-values ([(base name must-be-dir) (split-path path)]) (cond @@ -78,15 +105,4 @@ (let ([x (assq name flags)]) (if x (cdr x) - default))) - - (provide/contract - [url-path->string ((listof (or/c string? path/param?)) . -> . string?)] - [extract-flag (symbol? (listof (cons/c symbol? any/c)) any/c . -> . any/c)] - [network-error ((symbol? string?) (listof any/c) . ->* . (void))] - [path->list (path? . -> . (cons/c (or/c path? (symbols 'up 'same)) - (listof (or/c path? (symbols 'up 'same)))))] - [directory-part (path? . -> . path?)] - [lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)] - [exn->string ((or/c exn? any/c) . -> . string?)] - [build-path-unless-absolute (path-string? path-string? . -> . path?)])) \ No newline at end of file + default)))) \ 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 index 3b0024bb19..99c341b4a9 100644 --- a/collects/web-server/prototype-web-server/private/url-param.ss +++ b/collects/web-server/prototype-web-server/private/url-param.ss @@ -3,8 +3,8 @@ (lib "url.ss" "net") (lib "plt-match.ss") (lib "list.ss") - (lib "serialize.ss") - "utils.ss") + "utils.ss" + "../../private/util.ss") (provide/contract [extract-param (url? string? . -> . (or/c string? false/c))] @@ -27,7 +27,7 @@ ;; 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 + (url-replace-path (match-lambda [(list) (list (make-path/param @@ -44,20 +44,4 @@ (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 + in-url))) \ No newline at end of file diff --git a/collects/web-server/servlet/servlet-url.ss b/collects/web-server/servlet/servlet-url.ss index 667ca144bb..7b22662df6 100644 --- a/collects/web-server/servlet/servlet-url.ss +++ b/collects/web-server/servlet/servlet-url.ss @@ -1,101 +1,25 @@ (module servlet-url mzscheme (require (lib "list.ss") - (lib "etc.ss") (lib "contract.ss") - (lib "url.ss" "net") - (lib "struct.ss")) - (require "../private/url.ss" - "../request-structs.ss") + (lib "url.ss" "net")) + (require "../request-structs.ss" + "../private/util.ss") - (define-struct servlet-url (protocol host port - servlets-root - instance-id k-id nonce - servlet-path extra-path)) + (define-struct servlet-url (url)) (define (servlet-url->url-string/no-continuation su) + (define in-url (servlet-url-url su)) + (define first? (box #t)) (url->string - (make-url (servlet-url-protocol su) - #f - #f ;(servlet-url-host su) - #f ;(servlet-url-port su) - #t - (append (map (lambda (p/p) - (if (and (not (empty? (path/param-param p/p))) - ; XXX: not robust - (match-url-params (first (path/param-param p/p)))) - (make-path/param (path/param-path p/p) empty) - p/p)) - (servlet-url-servlets-root su)) - (servlet-url-servlet-path su) - (servlet-url-extra-path su)) - empty - #f))) - (define (servlet-url->url-string su) - (let ([the-url - (make-url (servlet-url-protocol su) - #f - #f ;(servlet-url-host su) - #f ;(servlet-url-port su) - #t - (append (reverse (rest (reverse (servlet-url-servlets-root su)))) - (list (make-path/param (path/param-path (first (reverse (servlet-url-servlets-root su)))) - empty)) - (servlet-url-servlet-path su) - (servlet-url-extra-path su)) - empty - #f)]) - (if (and (servlet-url-instance-id su) - (servlet-url-k-id su) - (servlet-url-nonce su)) - (embed-ids (list (servlet-url-instance-id su) - (servlet-url-k-id su) - (servlet-url-nonce su)) - the-url) - (url->string the-url)))) - (define (servlet-url->servlet-url/no-extra-path su) - (copy-struct servlet-url su - [servlet-url-extra-path empty])) + (url-replace-path + (lambda (ps) + (map (lambda (p/p) + (if (unbox first?) + (make-path/param (path/param-path p/p) empty) + p/p)) + ps))))) (define (request->servlet-url req) - (uri->servlet-url (request-uri req) - (request-host-ip req) - (request-host-port req))) - (define uri->servlet-url - (opt-lambda (uri [default-host #f] [default-port #f]) - (let-values ([(k-instance k-id k-salt) - (let ([k-parts (continuation-url? uri)]) - (if k-parts - (apply values k-parts) - (values #f #f #f)))] - [(servlet-path path) - (let loop ([servlet-path empty] - [path (rest (url-path uri))]) - (if (empty? path) - (values servlet-path path) - (let ([cur (first path)]) - (if (regexp-match "\\.ss$" (path/param-path cur)) - (values (append servlet-path (list cur)) - (rest path)) - (loop (append servlet-path (list cur)) - (rest path))))))]) - (make-servlet-url (url-scheme uri) - (or (url-host uri) default-host) - (or (url-port uri) default-port) - (list (first (url-path uri))) - k-instance k-id k-salt - servlet-path - path)))) + (make-servlet-url (request-uri req))) (provide/contract - [struct servlet-url ([protocol (or/c false/c string?)] - [host (or/c false/c string?)] - [port (or/c false/c natural-number/c)] - [servlets-root (listof path/param?)] - [instance-id number?] - [k-id number?] - [nonce number?] - [servlet-path (listof path/param?)] - [extra-path (listof path/param?)])] - [servlet-url->url-string (servlet-url? . -> . string?)] [servlet-url->url-string/no-continuation (servlet-url? . -> . string?)] - [servlet-url->servlet-url/no-extra-path (servlet-url? . -> . servlet-url?)] - [request->servlet-url (request? . -> . servlet-url?)] - [uri->servlet-url ((url?) ((or/c false/c string?) (or/c false/c natural-number/c)) . opt-> . servlet-url?)])) \ No newline at end of file + [request->servlet-url (request? . -> . servlet-url?)])) \ No newline at end of file diff --git a/collects/web-server/servlet/web.ss b/collects/web-server/servlet/web.ss index 46adc970d4..5a018d6594 100644 --- a/collects/web-server/servlet/web.ss +++ b/collects/web-server/servlet/web.ss @@ -1,10 +1,13 @@ (module web mzscheme - (require (lib "contract.ss") + (require (lib "url.ss" "net") + (lib "list.ss") + (lib "plt-match.ss") + (lib "contract.ss") (lib "etc.ss") (lib "xml.ss" "xml")) (require "../managers/manager.ss" + "../private/util.ss" "../private/servlet.ss" - "../private/url.ss" "../servlet/helpers.ss" "../servlet/web-cells.ss" "../request-structs.ss" @@ -12,6 +15,57 @@ ;; ************************************************************ ;; HELPERS + (provide/contract + [continuation-url? (url? . -> . (or/c boolean? (list/c number? number? number?)))] + [embed-ids ((list/c number? number? number?) url? . -> . string?)]) + + ;; ******************************************************************************** + ;; Parameter Embedding + + ;; embed-ids: (list number number number) url -> string + (define embed-ids + (match-lambda* + [(list (list inst-id k-id salt) in-url) + (insert-param + in-url + (format "~a*~a*~a" inst-id k-id salt))])) + + ;; continuation-url?: url -> (or/c (list number number number) #f) + ;; determine if this url encodes a continuation and extract the instance id and + ;; continuation id. + (define (continuation-url? a-url) + (define (match-url-params x) (regexp-match #rx"([^\\*]*)\\*([^\\*]*)\\*([^\\*]*)" 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 s instance k-id salt) + (let ([instance/n (string->number instance)] + [k-id/n (string->number k-id)] + [salt/n (string->number salt)]) + (if (and (number? instance/n) + (number? k-id/n) + (number? salt/n)) + (list instance/n + k-id/n + salt/n) + ; XXX: Maybe log this in some way? + #f))])))) + + ;; insert-param: url string -> string + ;; add a path/param to the path in a url + ;; (assumes that there is only one path/param) + (define (insert-param in-url new-param-str) + (url->string + (url-replace-path + (lambda (old-path) + (if (empty? old-path) + (list (make-path/param "" (list new-param-str))) + (list* (make-path/param (path/param-path (first old-path)) + (list new-param-str)) + (rest old-path)))) + in-url))) ;; replace-procedures : (proc -> url) xexpr/callbacks? -> xexpr? ;; Change procedures to the send/suspend of a k-url @@ -38,7 +92,7 @@ [send/forward ((response-generator?) (expiration-handler?) . opt-> . request?)] [send/suspend/dispatch ((embed/url? . -> . servlet-response?) . -> . any/c)] [send/suspend/callback (xexpr/callback? . -> . any/c)]) - + ;; ************************************************************ ;; EXPORTS