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

Make it possible to have toplevel sites with absolute urls, needed for some stubs

Browse Source
This commit is contained in:
Eli Barzilay 2010-06-09 18:28:54 -04:00
parent 5aaf3811cf
commit e24d11a03c
2 changed files with 43 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/meta/web/config.rkt
View File

@ -5,11 +5,13 @@
'(("www" "http://racket-lang.org/")
("download" "http://download.racket-lang.org/")
("lists" "http://lists.racket-lang.org/")
("stubs/planet" "http://planet.racket-lang.org/")
("stubs/pre" "http://pre.racket-lang.org/")
("stubs/git" "http://git.racket-lang.org/")
("stubs/blog" "http://blog.racket-lang.org/")
("stubs/mailman" "http://lists.racket-lang.org/")))
;; stubs usually use absolute paths for resources, since they're
;; templates that often get used in sub-dir pages too
("stubs/planet" "http://planet.racket-lang.org/" abs)
("stubs/pre" "http://pre.racket-lang.org/" abs)
("stubs/git" "http://git.racket-lang.org/" abs)
("stubs/blog" "http://blog.racket-lang.org/" abs)
("stubs/mailman" "http://lists.racket-lang.org/" abs)))
(provide distributions)
(define distributions

57
collects/meta/web/html/resource.rkt
View File

@ -35,22 +35,26 @@
;; the currently rendered directory, as a list
(define rendered-dirpath (make-parameter '()))
;; a mapping from path prefixes to urls (actually, any string) -- when two
;; A mapping from path prefixes to urls (actually, any string) -- when two
;; paths are in the same prefix, links from one to the other are relative, but
;; if they're in different prefixes, the url will be used instead; the roots
;; are expected to be disjoint (= no "/foo" and "/foo/bar" roots)
;; are expected to be disjoint (= no "/foo" and "/foo/bar" roots).
;; Additionally, optional symbol flags can appear in each entry, currently only
;; 'abs is used below for roots that should always use absolute links (needed
;; for some skeleton pages that are used in nested subdirectories).
(provide url-roots)
(define url-roots
;; takes in a (listof (list prefix-string url-string)), and produces an alist
;; with lists of strings for the keys; the prefix-strings are split on "/"s,
;; and the url-strings can be anything at all actually (they are put as-is
;; before the path with a "/" between them)
;; takes in a (listof (list prefix-string url-string . flags)), and produces
;; an alist with lists of strings for the keys; the prefix-strings are split
;; on "/"s, and the url-strings can be anything at all actually (they are put
;; as-is before the path with a "/" between them).
(make-parameter #f
(lambda (x)
(and (list? x) (pair? x)
(map (lambda (x)
(cons (regexp-match* #rx"[^/]+" (car x))
(regexp-replace #rx"/$" (cadr x) "")))
(list* (regexp-match* #rx"[^/]+" (car x))
(regexp-replace #rx"/$" (cadr x) "")
(cddr x)))
x)))))
;; a utility for relative paths, taking the above `default-file' and
@ -58,13 +62,17 @@
(define (relativize file tgtdir curdir)
(define file* (if (equal? file default-file) "" file))
(define roots (url-roots))
(define (make-rooted path)
(ormap (lambda (root+url)
(let loop ([r (car root+url)] [p path])
(if (null? r)
`(,(cdr root+url) ,@p ,file*)
(define (find-root path mode)
(ormap (lambda (root+url+flags)
(let loop ([r (car root+url+flags)] [p path])
(if (pair? r)
(and (pair? p) (equal? (car p) (car r))
(loop (cdr r) (cdr p))))))
(loop (cdr r) (cdr p)))
(case mode
[(get-path) `(,(cadr root+url+flags) ,@p ,file*)]
[(get-abs-or-true)
(if (memq 'abs (cddr root+url+flags)) `("" ,@p) #t)]
[else (error 'relativize "internal error: ~e" mode)]))))
roots))
(define result
(let loop ([t tgtdir] [c curdir] [pfx '()])
@ -73,13 +81,17 @@
[(and (pair? t) (pair? c) (equal? (car t) (car c)))
(loop (cdr t) (cdr c) (cons (car t) pfx))]
;; done
[(or (not roots) ; if there are no roots
(make-rooted (reverse pfx))) ; or if they share a root
;; then make them relative
`(,@(map (lambda (_) "..") c) ,@t ,file*)]
;; no roots => always use a relative path (useful for debugging)
[(not roots) `(,@(map (lambda (_) "..") c) ,@t ,file*)]
;; share a root => use a relative path unless its an absolute root
[(find-root (reverse pfx) 'get-abs-or-true)
=> (lambda (abs/true)
`(;; rel. => as above
,@(if (list? abs/true) abs/true (map (lambda (_) "..") c))
,@t ,file*))]
;; different roots => use the one for the target
[(make-rooted tgtdir)]
;; otherwise throw an error
[(find-root tgtdir 'get-path)]
;; if there isn't any, throw an error
[else (error 'relativize "target url is not in any known root: ~a"
(string-join `(,@tgtdir ,file*) "/"))])))
(if (equal? '("") result) "." (string-join result "/")))
@ -127,7 +139,10 @@
(R "index.html" '() '("x" "y")) =error> "not in any"
(R "index.html" '("x") '("x" "y")) => "../"
(R "index.html" '("x" "y") '("x" "y")) => "."
(R "index.html" '("x" "y") '("y" "x")) => "/X/y/"))))
(R "index.html" '("x" "y") '("y" "x")) => "/X/y/"))
do (parameterize ([url-roots '(["/x" "/X/"] ["/y" "/Y/" abs])])
(test (R "foo.txt" '("x" "1") '("x" "2")) => "../1/foo.txt"
(R "foo.txt" '("y" "1") '("y" "2")) => "/1/foo.txt"))))
|#
;; utility for keeping a list of renderer thunks