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

dyoo url-path->path

Browse Source 
svn: r5563
This commit is contained in:
Jay McCarthy 2007-02-06 15:02:43 +00:00
parent a32a36453a
commit 5b987feeb4
3 changed files with 44 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/web-server/dispatchers/dispatch-files.ss
View File

@ -3,6 +3,7 @@
(lib "xml.ss" "xml")
(lib "kw.ss")
(lib "list.ss")
(lib "string.ss")
(lib "plt-match.ss")
(lib "contract.ss")
(lib "uri-codec.ss" "net"))
@ -20,6 +21,20 @@
(provide ; XXX contract kw
make)
; more here - ".." should probably raise an error instead of disappearing.
(define (url-path->path base p)
(path->complete-path
(apply build-path base
(reverse!
(foldl (lambda (x acc)
(cond
[(string=? x "") acc]
[(string=? x ".") acc]
[(string=? x "..") (if (pair? acc) (cdr acc) acc)]
[else (cons x acc)]))
null
(regexp-split #rx"/" p))))))
(define interface-version 'v1)
(define/kw (make #:key
[htdocs-path "htdocs"]

29
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -3,6 +3,7 @@
(lib "kw.ss")
(lib "plt-match.ss")
(lib "unit.ss")
(lib "string.ss")
(lib "contract.ss"))
(require "dispatch.ss"
"../private/web-server-structs.ss"
@ -26,6 +27,34 @@
; XXX contract kw
make)
(define (url-path->path base p)
(path->complete-path
(let ([path-elems (regexp-split #rx"/" p)])
;; Servlets can have extra stuff after them
(let ([build-path
(lambda (b p)
(if (string=? p "")
b
(build-path b p)))])
(let loop
([p-e (if (string=? (car path-elems) "")
(cddr path-elems)
(cdr path-elems))]
[f (build-path base
(if (string=? (car path-elems) "")
(cadr path-elems)
(car path-elems)))])
(cond
[(null? p-e)
f]
[(directory-exists? f)
(loop (cdr p-e) (build-path f (car p-e)))]
[(file-exists? f)
f]
[else
;; Don't worry about e.g. links for now
f]))))))
(define interface-version 'v1)
(define/kw (make config:instances config:scripts config:make-servlet-namespace
#:key

42
collects/web-server/private/util.ss
View File

@ -94,47 +94,6 @@
[(not base) (error 'directory-part "~a is a top-level directory" path)]
[(path? base) base])))
; more here - ".." should probably raise an error instead of disappearing.
; XXX: This is terrible. should re-write.
(define (url-path->path base p)
(let ([path-elems (regexp-split #rx"/" p)])
;;; Hardcoded, bad, and wrong
(if (or (string=? (car path-elems) "servlets")
(and (string=? (car path-elems) "")
(string=? (cadr path-elems) "servlets")))
;; Servlets can have extra stuff after them
(let ([build-path
(lambda (b p)
(if (string=? p "")
b
(build-path b p)))])
(let loop ([p-e (if (string=? (car path-elems) "")
(cddr path-elems)
(cdr path-elems))]
[f (build-path base
(if (string=? (car path-elems) "")
(cadr path-elems)
(car path-elems)))])
(cond
[(null? p-e)
f]
[(directory-exists? f)
(loop (cdr p-e) (build-path f (car p-e)))]
[(file-exists? f)
f]
[else
f]))) ;; Don't worry about e.g. links for now
(apply build-path base
(reverse!
(foldl (lambda (x acc)
(cond
[(string=? x "") acc]
[(string=? x ".") acc]
[(string=? x "..") (if (pair? acc) (cdr acc) acc)]
[else (cons x acc)]))
null
(regexp-split #rx"/" p)))))))
; to convert a platform dependent path into a listof path parts such that
; (forall x (equal? (path->list x) (path->list (apply build-path (path->list x)))))
(define (path->list p)
@ -168,7 +127,6 @@
[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)))))]
[url-path->path ((or/c (symbols 'up 'same) path?) string? . -> . path?)]
[directory-part (path? . -> . path?)]
[lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)]
[exn->string ((or/c exn? any/c) . -> . string?)]