[Fencommits] fenserve: use relative path names to work behind a reverse proxy

[Tuukka Hastrup]

Sat Aug 11 15:13:23 EEST 2007  Tuukka Hastrup <Tuukka.Hastrup at iki.fi>
  * use relative path names to work behind a reverse proxy
diff -rN -u old-fenserve/notetaker/Main.hs new-fenserve/notetaker/Main.hs
--- old-fenserve/notetaker/Main.hs	2007-08-11 15:15:25.000000000 +0300
+++ new-fenserve/notetaker/Main.hs	2007-08-11 15:15:25.000000000 +0300
@@ -32,11 +32,12 @@
 
 views n item nick = "\n<p>Views: "++concat (intersperse " | " [view i|i<-[0..length links-1]])
     where links = (if null item then []
-                      else if length item == 1 then [("up", "/")]
-                      else [("up", "/item/" ++ renderPath (init item))]) ++
-                  [("main", "/"), ("log", "/log"), ("lastlog", "/lastlog")]
+                      else if length item == 1 then [("up", "")]
+                      else [("up", "item/" ++ renderPath (init item))]) ++
+                  [("main", ""), ("log", "log"), ("lastlog", "lastlog")]
           view i | i == n    = printf "<b>%s</b>" name
-                 | otherwise = printf "<a href=%s?nick=%s>%s</a>" uri nick name
+                 | otherwise = printf "<a href=%s?nick=%s>%s</a>" 
+                                   (?root++uri) nick name
               where (name,uri) = links !! i
 
 page path nick = do 
@@ -64,14 +65,14 @@
     
     link [] _ = ""
     link [Line t n _] _ = " <span class='loglink'>(" ++ n
-                       ++ "; <a href='/log#"++show t++"'>log</a>)</span>"
+                       ++ "; <a href='"++ ?root++"log#"++show t++"'>log</a>)</span>"
     link ls p = " <span class='loglink'>("
              ++ (concat $ intersperse ", " $ nub $ map lineNick ls)
-             ++ "; <a href='/log/"++renderPath p++"'>log</a>)</span>"
+             ++ "; <a href='"++ ?root++"log/"++renderPath p++"'>log</a>)</span>"
     
     renderNote p (Note title False ls cs) = "\n<li>" ++ title ++ link ls p ++ renderNotes p nick cs
     renderNote p (Note title True ls cs) =
-         "\n<li>" ++ title ++ " <span class='children'>(<a href='/item/"
+         "\n<li>" ++ title ++ " <span class='children'>(<a href='"++ ?root++"item/"
       ++ renderPath p ++ "?nick=" ++ nick ++ "'>"
       ++ countable (length cs) "child" "ren" ++ "</a>, "
       ++ countable (gather ((+1) . sum) 1 cs - 1) "descendant" "s" ++ ", "
@@ -163,7 +164,7 @@
             header title' ++ "<h2>" ++ title' ++ "</h2>" ++ views (-1) [] nick
          ++ concatMap renderLine' ls ++ views (-1) [] (nick :: String) ++ footer
     where renderLine' l@(Line t _ _) =
-              renderLine l ++ " (<a href='/log#"++show t++"'>context</a>)"
+              renderLine l ++ " (<a href='"++ ?root++"log#"++show t++"'>context</a>)"
            
 renderLine (Line time nick body) =
     "\n<p class='logline' id='"++show time++"'>"
@@ -189,7 +190,7 @@
 renderTime t0 = printf "%02u:%02u" (ctHour t) (ctMin t)
     where t = toUTCTime (TOD (fromIntegral t0) 0)
     
-viewURI (Body _) nick = ("/lastlog?nick=" ++ nick, "lastlog" )
+viewURI (Body _) nick = ("lastlog?nick=" ++ nick, "lastlog" )
 viewURI (Add p _) nick = pageURI p nick
 viewURI (Edit p _) nick = pageURI p nick
 viewURI (Move _ q) nick = pageURI q nick
@@ -199,7 +200,7 @@
 viewURI (Unpage p) nick = pageURI p nick
 viewURI (Revert n) nick = pageURI [] nick
 
-pageURI p nick = ("/item/" ++ renderPath p ++ "?nick=" ++ nick, 
+pageURI p nick = ("item/" ++ renderPath p ++ "?nick=" ++ nick, 
                   "item " ++ renderPath p)
 
 export path notes = concatMap f [0..length notes-1] where
@@ -211,7 +212,13 @@
 plain s = setHeader "Content-Type" "text/plain" (toMessage s)
     
 main = stdHTTP [ debugFilter
-               , h ["log"] GET  $ ok $ \() nick -> renderLog nick False
+               , h (Prefix ()) () $ \(_:path'::[String]) req -> do
+                   let ?root = concatMap (const "../") path'
+                   runServerParts [app] req
+               ]                 
+
+app :: (?root :: String, Monad im) => ServerPart (Ev [Line] ev) Request im Result
+app = multi    [ h ["log"] GET  $ ok $ \() nick -> renderLog nick False
                , h (Prefix ["log"]) GET $ ok $ \[p] nick -> itemLog nick (readPath p)
                , h ["lastlog"] GET $ ok $ \() nick -> renderLog nick True
                , h (Prefix ["export"]) GET $ ok $ \[p] () -> do
@@ -221,9 +228,10 @@
                , h [""]    GET  $ ok $ \() nick -> page [] nick
                , h ()      POST $ seeOther $ \() (nick,line) -> do
                      let respondRedirect uri anchor = respond
-                             (uri, "<a href='"++uri++"'>"++anchor++"</a>")
+                             (?root++uri, 
+                              "<a href='"++ ?root++uri++"'>"++anchor++"</a>")
                      if line == ":ll" then
-                         respondRedirect ("/lastlog?nick="++nick) "lastlog"
+                         respondRedirect ("lastlog?nick="++nick) "lastlog"
                        else if line == ":m" || ":m " `isPrefixOf` line then
                          uncurry respondRedirect $
                              pageURI (readPath (drop 2 line)) nick