suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

url bugs

Browse Source 
svn: r1805
This commit is contained in:
Jay McCarthy 2006-01-11 16:10:43 +00:00
parent 38c86f0638
commit efdc8a6486
2 changed files with 88 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/web-server/servlet-helpers.ss
View File

@ -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
(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 (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))))
(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)))
#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,7 +121,8 @@
[servlet-path empty]
[found-servlet-path? #f]
[extra-path empty])
#;(printf "~S~n" (list 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))
@ -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?

44
collects/web-server/servlet-tables.ss
View File

@ -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)))))