From 0ed9334cc1c09f20c1656794865cba0730b0383d Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Tue, 19 Oct 2010 21:06:32 -0400
Subject: [PATCH] Fix rendering in local build mode -- make it create file://
 urls when insisting on an absolute url (currently happens only in the tr
 pages). (cherry picked from commit 1e2d4b816946b9ab94c572ac5bae53d688bc4ed8)

---
 collects/meta/web/html/resource.rkt | 18 ++++++++++++------
 1 file changed, 12 insertions(+), 6 deletions(-)

diff --git a/collects/meta/web/html/resource.rkt b/collects/meta/web/html/resource.rkt
index 0a95328d43..54632f4eaa 100644
--- a/collects/meta/web/html/resource.rkt
+++ b/collects/meta/web/html/resource.rkt
@@ -47,10 +47,10 @@
 
 (define cached-roots '(#f . #f))
 (define (current-url-roots)
-  ;; 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).
+  ;; takes `url-roots', 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).
   (let ([roots (url-roots)])
     (unless (eq? roots (car cached-roots))
       (set! cached-roots
@@ -86,7 +86,7 @@
         ;; find shared prefix
         [(and (pair? t) (pair? c) (equal? (car t) (car c)))
          (loop (cdr t) (cdr c) (cons (car t) pfx))]
-        ;; done
+        ;; done with the shared prefix, deal with the root now
         ;; 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
@@ -197,7 +197,13 @@
                    (printf "  ~a\n" path)
                    (renderer filename))))))
     (define (url) (relativize filename dirpathlist (rendered-dirpath)))
-    (define absolute-url (delay (relativize filename dirpathlist "")))
+    (define absolute-url
+      (delay (let ([url (relativize filename dirpathlist '())])
+               (if (url-roots)
+                 url
+                 ;; we're in local build mode, and insist on an absolute url,
+                 ;; so construct a `file://' result
+                 (list* "file://" (current-directory) url)))))
     (add-renderer path render)
     (make-keyword-procedure
      (lambda (kws kvs . args) (keyword-apply referrer kws kvs (url) args))