url bugs
svn: r1805
This commit is contained in:
Jay McCarthy
parent
38c86f0638
commit
efdc8a6486
|
|
@ -32,34 +32,50 @@
|
|||
servlet-url->servlet-url/no-extra-path
|
||||
request->servlet-url
|
||||
uri->servlet-url)
|
||||
(define-struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path))
|
||||
(define-struct servlet-url (protocol host port
|
||||
servlets-root
|
||||
instance-id k-id nonce
|
||||
servlet-path extra-path))
|
||||
(define (servlet-url->url-string/no-continuation su)
|
||||
(url->string
|
||||
(make-url (servlet-url-protocol su)
|
||||
#f
|
||||
#f ;(servlet-url-host su)
|
||||
#f ;(servlet-url-port su)
|
||||
(append (servlet-url-servlets-root 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)
|
||||
(url->string
|
||||
(make-url (servlet-url-protocol su)
|
||||
#f
|
||||
#f ;(servlet-url-host su)
|
||||
#f ;(servlet-url-port su)
|
||||
(append (reverse (rest (reverse (servlet-url-servlets-root su))))
|
||||
(list (make-path/param (first (reverse (servlet-url-servlets-root su)))
|
||||
(format "~a*~a*~a"
|
||||
(servlet-url-instance-id su)
|
||||
(servlet-url-k-id su)
|
||||
(servlet-url-nonce su))))
|
||||
(servlet-url-servlet-path su)
|
||||
(servlet-url-extra-path su))
|
||||
empty
|
||||
#f)))
|
||||
(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 (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]))
|
||||
|
|
@ -68,6 +84,31 @@
|
|||
(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))))
|
||||
(define uri->servlet-url2
|
||||
(opt-lambda (uri [default-host #f] [default-port #f])
|
||||
(let-values ([(k-instance k-id k-salt)
|
||||
(let ([k-parts (continuation-url? uri)])
|
||||
|
|
@ -80,10 +121,11 @@
|
|||
[servlet-path empty]
|
||||
[found-servlet-path? #f]
|
||||
[extra-path empty])
|
||||
#;(printf "~S~n" (list path
|
||||
servlets-root found-servlets-root?
|
||||
servlet-path found-servlet-path?
|
||||
extra-path))
|
||||
(printf "~S~n" (list uri (list k-instance k-id k-salt)
|
||||
path
|
||||
servlets-root found-servlets-root?
|
||||
servlet-path found-servlet-path?
|
||||
extra-path))
|
||||
(let ([top (if (empty? path)
|
||||
#f
|
||||
(first path))])
|
||||
|
|
@ -149,7 +191,8 @@
|
|||
servlet-path
|
||||
path)]
|
||||
[(empty? path)
|
||||
(error 'request->servlet-url "Not servlet-url: ~S; parsed: ~S" (url->string uri)
|
||||
(error 'request->servlet-url "Not servlet-url: ~S; parsed: ~S"
|
||||
(url->string uri)
|
||||
(list path
|
||||
servlets-root found-servlets-root?
|
||||
servlet-path found-servlet-path?
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require (lib "contract.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
"timer.ss")
|
||||
(provide (struct exn:servlet:instance ())
|
||||
(struct exn:servlet:no-current-instance ())
|
||||
|
|
@ -34,9 +35,11 @@
|
|||
;; * The servlet-instance-mutex is used to guarentee mutual-exclusion in the
|
||||
;; case when it is attempted to invoke multiple continuations
|
||||
;; simultaneously.
|
||||
|
||||
(provide
|
||||
match-url-params)
|
||||
(provide/contract
|
||||
[continuation-url? (url? . -> . (union boolean? (list/c symbol? number? number?)))]
|
||||
[embed-ids (symbol? number? number? url? . -> . string?)]
|
||||
[store-continuation! (procedure? procedure? url? servlet-instance? . -> . string?)]
|
||||
[create-new-instance! (hash-table? custodian? execution-context? semaphore? timer?
|
||||
. -> . servlet-instance?)]
|
||||
|
|
@ -122,7 +125,6 @@
|
|||
(define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x))
|
||||
|
||||
;; embed-ids: number number number url -> string
|
||||
;; embedd the two numbers in a url
|
||||
(define (embed-ids inst-id k-id salt in-url)
|
||||
(insert-param
|
||||
in-url
|
||||
|
|
@ -132,19 +134,15 @@
|
|||
;; determine if this url encodes a continuation and extract the instance id and
|
||||
;; continuation id.
|
||||
(define (continuation-url? a-url)
|
||||
(let ([str (url->param a-url)])
|
||||
(and str
|
||||
(let ([param-match (cdr (match-url-params str))])
|
||||
(list (string->symbol (car param-match))
|
||||
(string->number (cadr param-match))
|
||||
(string->number (caddr param-match)))))))
|
||||
|
||||
;; url->param: url -> (union string #f)
|
||||
(define (url->param a-url)
|
||||
(let ([l (filter (λ (x) (not (null? (path/param-param x))))
|
||||
(url-path a-url))])
|
||||
(and (not (null? l))
|
||||
(car (path/param-param (car l))))))
|
||||
(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)
|
||||
(list (string->symbol instance)
|
||||
(string->number k-id)
|
||||
(string->number salt))]))))
|
||||
|
||||
;; insert-param: url string -> string
|
||||
;; add a path/param to the path in a url
|
||||
|
|
@ -153,14 +151,11 @@
|
|||
(url->string
|
||||
(replace-path
|
||||
(lambda (old-path)
|
||||
(if (null? old-path)
|
||||
(list (make-path/param "" 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)
|
||||
new-param-str)
|
||||
(cdr 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
|
||||
|
|
@ -174,6 +169,7 @@
|
|||
(url-user in-url)
|
||||
(url-host in-url)
|
||||
(url-port in-url)
|
||||
(url-path-absolute? in-url)
|
||||
new-path
|
||||
'()
|
||||
empty
|
||||
(url-fragment in-url)))))
|
||||
Loading…
Reference in New Issue
Block a user