101 lines
4.7 KiB
Scheme
101 lines
4.7 KiB
Scheme
(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")
|
|
|
|
(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)
|
|
#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]))
|
|
(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))))
|
|
|
|
(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?)])) |