From e24d11a03c4bf08bfa2b3bc45ed79c4820195456 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 9 Jun 2010 18:28:54 -0400 Subject: [PATCH] Make it possible to have toplevel sites with absolute urls, needed for some stubs --- collects/meta/web/config.rkt | 12 +++--- collects/meta/web/html/resource.rkt | 57 ++++++++++++++++++----------- 2 files changed, 43 insertions(+), 26 deletions(-) diff --git a/collects/meta/web/config.rkt b/collects/meta/web/config.rkt index 611d408bc5..05e8311230 100644 --- a/collects/meta/web/config.rkt +++ b/collects/meta/web/config.rkt @@ -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 diff --git a/collects/meta/web/html/resource.rkt b/collects/meta/web/html/resource.rkt index 1e0cdf5b02..0047f9ab6d 100644 --- a/collects/meta/web/html/resource.rkt +++ b/collects/meta/web/html/resource.rkt @@ -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