More uniform treatment of resource-path functions
This commit is contained in:
parent
4af472f7ff
commit
0a585d7842
|
@ -6,6 +6,10 @@
|
||||||
url->resource
|
url->resource
|
||||||
resource->url
|
resource->url
|
||||||
|
|
||||||
|
string->resource-path
|
||||||
|
resource-path->string
|
||||||
|
append-resource-path
|
||||||
|
|
||||||
(struct-out web-request)
|
(struct-out web-request)
|
||||||
(struct-out web-request-header)
|
(struct-out web-request-header)
|
||||||
(struct-out web-request-cookie)
|
(struct-out web-request-cookie)
|
||||||
|
@ -33,8 +37,6 @@
|
||||||
web-respond/xexpr!
|
web-respond/xexpr!
|
||||||
web-redirect!
|
web-redirect!
|
||||||
|
|
||||||
append-url-path
|
|
||||||
|
|
||||||
spawn-web-driver)
|
spawn-web-driver)
|
||||||
|
|
||||||
(define-logger syndicate/drivers/web)
|
(define-logger syndicate/drivers/web)
|
||||||
|
@ -202,14 +204,55 @@
|
||||||
host
|
host
|
||||||
port
|
port
|
||||||
#t
|
#t
|
||||||
(let loop ((p path))
|
(resource-path->string path)
|
||||||
(match p
|
|
||||||
['() '()]
|
|
||||||
[(list d par ... rest)
|
|
||||||
(cons (path/param d par) (loop rest))]))
|
|
||||||
query
|
query
|
||||||
#f))
|
#f))
|
||||||
|
|
||||||
|
(define (string->resource-path str)
|
||||||
|
(define-values (_absolute? rp) (string->resource-path* str))
|
||||||
|
rp)
|
||||||
|
|
||||||
|
(define (string->resource-path* str)
|
||||||
|
(define u (string->url str))
|
||||||
|
(values (url-path-absolute? u)
|
||||||
|
(url-path->resource-path (url-path u))))
|
||||||
|
|
||||||
|
(define (resource-path->string rp #:absolute? [absolute? #t])
|
||||||
|
(url->string
|
||||||
|
(url #f #f #f #f absolute? (resource-path->url-path rp) '() #f)))
|
||||||
|
|
||||||
|
(define (url-path->resource-path up)
|
||||||
|
(define elements (for/list [(p (in-list up))]
|
||||||
|
(match-define (path/param path-element params) p)
|
||||||
|
(list* path-element params)))
|
||||||
|
(foldr (lambda (e acc) (append e (list acc))) '() elements))
|
||||||
|
|
||||||
|
(define (resource-path->url-path p)
|
||||||
|
(match p
|
||||||
|
['() '()]
|
||||||
|
[(list d par ... rest)
|
||||||
|
(cons (path/param d par) (resource-path->url-path rest))]))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(check-equal? (string->resource-path "/foo;p/bar") '("foo" "p" ("bar" ())))
|
||||||
|
(check-equal? (string->resource-path "foo;p/bar") '("foo" "p" ("bar" ())))
|
||||||
|
(check-equal? (resource-path->string #:absolute? #t '("foo" "p" ("bar" ()))) "/foo;p/bar")
|
||||||
|
(check-equal? (resource-path->string #:absolute? #f '("foo" "p" ("bar" ()))) "foo;p/bar"))
|
||||||
|
|
||||||
|
(define (append-resource-path p1 p2)
|
||||||
|
(match p1
|
||||||
|
['() p2]
|
||||||
|
[(list "" '()) p2]
|
||||||
|
[(list pieces ... next) (append pieces (list (append-resource-path next p2)))]))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(check-equal? (append-resource-path '() '("c" ("d" ()))) '("c" ("d" ())))
|
||||||
|
(check-equal? (append-resource-path '("" ()) '("c" ("d" ()))) '("c" ("d" ())))
|
||||||
|
(check-equal? (append-resource-path '("a" "x" ("b" ())) '("c" ("d" ())))
|
||||||
|
'("a" "x" ("b" ("c" ("d" ())))))
|
||||||
|
(check-equal? (append-resource-path '("a" "x" ("b" ("" ()))) '("c" ("d" ())))
|
||||||
|
'("a" "x" ("b" ("c" ("d" ()))))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (spawn-web-driver)
|
(define (spawn-web-driver)
|
||||||
|
@ -339,24 +382,7 @@
|
||||||
(web-virtual-host scheme #f port)]))
|
(web-virtual-host scheme #f port)]))
|
||||||
|
|
||||||
(define (format-url-path u)
|
(define (format-url-path u)
|
||||||
(define elements (for/list [(p (in-list (url-path u)))]
|
(string->resource-path (url-path u)))
|
||||||
(match-define (path/param path-element params) p)
|
|
||||||
(list* path-element params)))
|
|
||||||
(foldr (lambda (e acc) (append e (list acc))) '() elements))
|
|
||||||
|
|
||||||
(define (append-url-path p1 p2)
|
|
||||||
(match p1
|
|
||||||
['() p2]
|
|
||||||
[(list "" '()) p2]
|
|
||||||
[(list pieces ... next) (append pieces (list (append-url-path next p2)))]))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(check-equal? (append-url-path '() '("c" ("d" ()))) '("c" ("d" ())))
|
|
||||||
(check-equal? (append-url-path '("" ()) '("c" ("d" ()))) '("c" ("d" ())))
|
|
||||||
(check-equal? (append-url-path '("a" "x" ("b" ())) '("c" ("d" ())))
|
|
||||||
'("a" "x" ("b" ("c" ("d" ())))))
|
|
||||||
(check-equal? (append-url-path '("a" "x" ("b" ("" ()))) '("c" ("d" ())))
|
|
||||||
'("a" "x" ("b" ("c" ("d" ()))))))
|
|
||||||
|
|
||||||
(define (build-headers hs)
|
(define (build-headers hs)
|
||||||
(for/list ((h (in-list hs)))
|
(for/list ((h (in-list hs)))
|
||||||
|
|
Loading…
Reference in New Issue