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

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

@ -32,34 +32,50 @@
servlet-url->servlet-url/no-extra-path servlet-url->servlet-url/no-extra-path
request->servlet-url request->servlet-url
uri->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) (define (servlet-url->url-string/no-continuation su)
(url->string (url->string
(make-url (servlet-url-protocol su) (make-url (servlet-url-protocol su)
#f #f
#f ;(servlet-url-host su) #f ;(servlet-url-host su)
#f ;(servlet-url-port 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-servlet-path su)
(servlet-url-extra-path su)) (servlet-url-extra-path su))
empty empty
#f))) #f)))
(define (servlet-url->url-string su) (define (servlet-url->url-string su)
(url->string (let ([the-url
(make-url (servlet-url-protocol su) (make-url (servlet-url-protocol su)
#f #f
#f ;(servlet-url-host su) #f ;(servlet-url-host su)
#f ;(servlet-url-port su) #f ;(servlet-url-port su)
(append (reverse (rest (reverse (servlet-url-servlets-root su)))) #t
(list (make-path/param (first (reverse (servlet-url-servlets-root su))) (append (reverse (rest (reverse (servlet-url-servlets-root su))))
(format "~a*~a*~a" (list (make-path/param (path/param-path (first (reverse (servlet-url-servlets-root su))))
(servlet-url-instance-id su) empty))
(servlet-url-k-id su) (servlet-url-servlet-path su)
(servlet-url-nonce su)))) (servlet-url-extra-path su))
(servlet-url-servlet-path su) empty
(servlet-url-extra-path su)) #f)])
empty (if (and (servlet-url-instance-id su)
#f))) (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) (define (servlet-url->servlet-url/no-extra-path su)
(copy-struct servlet-url su (copy-struct servlet-url su
[servlet-url-extra-path empty])) [servlet-url-extra-path empty]))
@ -68,6 +84,31 @@
(request-host-ip req) (request-host-ip req)
(request-host-port req))) (request-host-port req)))
(define uri->servlet-url (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]) (opt-lambda (uri [default-host #f] [default-port #f])
(let-values ([(k-instance k-id k-salt) (let-values ([(k-instance k-id k-salt)
(let ([k-parts (continuation-url? uri)]) (let ([k-parts (continuation-url? uri)])
@ -80,10 +121,11 @@
[servlet-path empty] [servlet-path empty]
[found-servlet-path? #f] [found-servlet-path? #f]
[extra-path empty]) [extra-path empty])
#;(printf "~S~n" (list path (printf "~S~n" (list uri (list k-instance k-id k-salt)
servlets-root found-servlets-root? path
servlet-path found-servlet-path? servlets-root found-servlets-root?
extra-path)) servlet-path found-servlet-path?
extra-path))
(let ([top (if (empty? path) (let ([top (if (empty? path)
#f #f
(first path))]) (first path))])
@ -149,7 +191,8 @@
servlet-path servlet-path
path)] path)]
[(empty? 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 (list path
servlets-root found-servlets-root? servlets-root found-servlets-root?
servlet-path found-servlet-path? servlet-path found-servlet-path?

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

@ -2,6 +2,7 @@
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "list.ss") (lib "list.ss")
(lib "plt-match.ss")
"timer.ss") "timer.ss")
(provide (struct exn:servlet:instance ()) (provide (struct exn:servlet:instance ())
(struct exn:servlet:no-current-instance ()) (struct exn:servlet:no-current-instance ())
@ -34,9 +35,11 @@
;; * The servlet-instance-mutex is used to guarentee mutual-exclusion in the ;; * The servlet-instance-mutex is used to guarentee mutual-exclusion in the
;; case when it is attempted to invoke multiple continuations ;; case when it is attempted to invoke multiple continuations
;; simultaneously. ;; simultaneously.
(provide
match-url-params)
(provide/contract (provide/contract
[continuation-url? (url? . -> . (union boolean? (list/c symbol? number? number?)))] [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?)] [store-continuation! (procedure? procedure? url? servlet-instance? . -> . string?)]
[create-new-instance! (hash-table? custodian? execution-context? semaphore? timer? [create-new-instance! (hash-table? custodian? execution-context? semaphore? timer?
. -> . servlet-instance?)] . -> . servlet-instance?)]
@ -122,7 +125,6 @@
(define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x)) (define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x))
;; embed-ids: number number number url -> string ;; embed-ids: number number number url -> string
;; embedd the two numbers in a url
(define (embed-ids inst-id k-id salt in-url) (define (embed-ids inst-id k-id salt in-url)
(insert-param (insert-param
in-url in-url
@ -132,19 +134,15 @@
;; determine if this url encodes a continuation and extract the instance id and ;; determine if this url encodes a continuation and extract the instance id and
;; continuation id. ;; continuation id.
(define (continuation-url? a-url) (define (continuation-url? a-url)
(let ([str (url->param a-url)]) (let ([k-params (filter match-url-params
(and str (apply append (map path/param-param (url-path a-url))))])
(let ([param-match (cdr (match-url-params str))]) (if (empty? k-params)
(list (string->symbol (car param-match)) #f
(string->number (cadr param-match)) (match (match-url-params (first k-params))
(string->number (caddr param-match))))))) [(list s instance k-id salt)
(list (string->symbol instance)
;; url->param: url -> (union string #f) (string->number k-id)
(define (url->param a-url) (string->number salt))]))))
(let ([l (filter (λ (x) (not (null? (path/param-param x))))
(url-path a-url))])
(and (not (null? l))
(car (path/param-param (car l))))))
;; insert-param: url string -> string ;; insert-param: url string -> string
;; add a path/param to the path in a url ;; add a path/param to the path in a url
@ -153,14 +151,11 @@
(url->string (url->string
(replace-path (replace-path
(lambda (old-path) (lambda (old-path)
(if (null? old-path) (if (empty? old-path)
(list (make-path/param "" new-param-str)) (list (make-path/param "" (list new-param-str)))
(let* ([car-old-path (car old-path)]) (list* (make-path/param (path/param-path (first old-path))
(cons (make-path/param (if (path/param? car-old-path) (list new-param-str))
(path/param-path car-old-path) (rest old-path))))
car-old-path)
new-param-str)
(cdr old-path)))))
in-url))) in-url)))
;; replace-path: (url-path -> url-path) url -> url ;; replace-path: (url-path -> url-path) url -> url
@ -174,6 +169,7 @@
(url-user in-url) (url-user in-url)
(url-host in-url) (url-host in-url)
(url-port in-url) (url-port in-url)
(url-path-absolute? in-url)
new-path new-path
'() empty
(url-fragment in-url))))) (url-fragment in-url)))))