Shedding bad interfaces
svn: r6424
This commit is contained in:
Jay McCarthy
parent
1b02edd3d9
commit
44a49ff272
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
@ -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?)]))
|
||||
default))))
|
||||
|
|
@ -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)))))
|
||||
in-url)))
|
||||
|
|
@ -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?)]))
|
||||
[request->servlet-url (request? . -> . servlet-url?)]))
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user