From 0275485bf977426d06043803d6ce50efe223a36b Mon Sep 17 00:00:00 2001
From: Xinruo Sun <xiaoruoruo@gmail.com>
Date: Sun, 15 Dec 2013 12:20:07 +0800
Subject: [PATCH] web: add a --static-root option to customize static files
 root

---
 hledger-web/Foundation.hs          | 12 ++++++------
 hledger-web/Hledger/Web/Main.hs    |  4 +++-
 hledger-web/Hledger/Web/Options.hs |  5 +++++
 hledger-web/Settings.hs            | 12 ++++++++----
 4 files changed, 22 insertions(+), 11 deletions(-)

diff --git a/hledger-web/Foundation.hs b/hledger-web/Foundation.hs
index 0e29b6b09..dce2dd46b 100644
--- a/hledger-web/Foundation.hs
+++ b/hledger-web/Foundation.hs
@@ -19,7 +19,7 @@ import Network.HTTP.Conduit (Manager)
 -- import qualified Settings
 import Settings.Development (development)
 import Settings.StaticFiles
-import Settings (widgetFile, Extra (..))
+import Settings (staticRoot, widgetFile, Extra (..))
 #ifndef DEVELOPMENT
 import Settings (staticDir)
 import Text.Jasmine (minifym)
@@ -117,11 +117,11 @@ instance Yesod App where
 
         hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
 
-    -- -- This is done to provide an optimization for serving static files from
-    -- -- a separate domain. Please see the staticRoot setting in Settings.hs
-    -- urlRenderOverride y (StaticR s) =
-    --     Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
-    -- urlRenderOverride _ _ = Nothing
+    -- This is done to provide an optimization for serving static files from
+    -- a separate domain. Please see the staticRoot setting in Settings.hs
+    urlRenderOverride y (StaticR s) =
+        Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
+    urlRenderOverride _ _ = Nothing
 
 #ifndef DEVELOPMENT
     -- This function creates static content files in the static folder
diff --git a/hledger-web/Hledger/Web/Main.hs b/hledger-web/Hledger/Web/Main.hs
index 27eac3d9b..56fa27d1b 100644
--- a/hledger-web/Hledger/Web/Main.hs
+++ b/hledger-web/Hledger/Web/Main.hs
@@ -20,6 +20,7 @@ import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort)
 import Network.Wai.Handler.Launch (runUrlPort)
 --
 import Prelude hiding (putStrLn)
+import Control.Applicative ((<$>))
 import Control.Monad (when)
 import Data.Text (pack)
 import System.Exit (exitSuccess)
@@ -59,12 +60,13 @@ web opts j = do
   let j' = filterJournalTransactions (queryFromOpts d $ reportopts_ $ cliopts_ opts) j
       p = port_ opts
       u = base_url_ opts
+      staticRoot = pack <$> static_root_ opts
   _ <- printf "Starting web app on port %d with base url %s\n" p u
   app <- makeApplication opts j' AppConfig{appEnv = Development
                                           ,appPort = p
                                           ,appRoot = pack u
                                           ,appHost = HostIPv4
-                                          ,appExtra = Extra "" Nothing
+                                          ,appExtra = Extra "" Nothing staticRoot
                                           }
   if server_ opts
    then do
diff --git a/hledger-web/Hledger/Web/Options.hs b/hledger-web/Hledger/Web/Options.hs
index 43b0e2735..23c74457b 100644
--- a/hledger-web/Hledger/Web/Options.hs
+++ b/hledger-web/Hledger/Web/Options.hs
@@ -1,6 +1,7 @@
 module Hledger.Web.Options
 where
 import Prelude
+import Control.Applicative ((<$>))
 import Data.Maybe
 import System.Console.CmdArgs
 import System.Console.CmdArgs.Explicit
@@ -26,6 +27,7 @@ webflags = [
   flagNone ["server"]  (setboolopt "server") ("log requests, don't auto-exit")
  ,flagReq ["base-url"]  (\s opts -> Right $ setopt "base-url" s opts) "URL" ("set the base url (default: "++defbaseurlexample++")")
  ,flagReq ["port"]  (\s opts -> Right $ setopt "port" s opts) "PORT" ("listen on this tcp port (default: "++show defport++")")
+ ,flagReq ["static-root"]  (\s opts -> Right $ setopt "static-root" s opts) "Static Root" ("The root url from which the static files will be loaded (default: BASE_URL/static)")
  ]
  
 webmode :: Mode [([Char], [Char])]
@@ -47,6 +49,7 @@ data WebOpts = WebOpts {
      server_   :: Bool
     ,base_url_ :: String
     ,port_     :: Int
+    ,static_root_ :: Maybe String
     ,cliopts_  :: CliOpts
  } deriving (Show)
 
@@ -56,6 +59,7 @@ defwebopts = WebOpts
     def
     def
     def
+    def
 
 -- instance Default WebOpts where def = defwebopts
 
@@ -67,6 +71,7 @@ toWebOpts rawopts = do
               port_ = p
              ,server_ = boolopt "server" rawopts
              ,base_url_ = maybe (defbaseurl p) stripTrailingSlash $ maybestringopt "base-url" rawopts
+             ,static_root_ = stripTrailingSlash <$> maybestringopt "static-root" rawopts
              ,cliopts_   = cliopts
              }
   where
diff --git a/hledger-web/Settings.hs b/hledger-web/Settings.hs
index 5db500dfe..887959637 100644
--- a/hledger-web/Settings.hs
+++ b/hledger-web/Settings.hs
@@ -54,8 +54,10 @@ staticDir = "static"
 -- have to make a corresponding change here.
 --
 -- To see how this value is used, see urlRenderOverride in Foundation.hs
-staticRoot :: AppConfig DefaultEnv x -> Text
-staticRoot conf = [st|#{appRoot conf}/static|]
+staticRoot :: AppConfig DefaultEnv Extra -> Text
+staticRoot conf = case extraStaticRoot $ appExtra conf of
+                    Just root -> root
+                    Nothing -> [st|#{appRoot conf}/static|]
 
 -- | Settings for 'widgetFile', such as which template languages to support and
 -- default Hamlet settings.
@@ -75,11 +77,13 @@ widgetFile = (if development then widgetFileReload
               widgetFileSettings
 
 data Extra = Extra
-    { extraCopyright :: Text
-    , extraAnalytics :: Maybe Text -- ^ Google Analytics
+    { extraCopyright  :: Text
+    , extraAnalytics  :: Maybe Text -- ^ Google Analytics
+    , extraStaticRoot :: Maybe Text
     } deriving Show
 
 parseExtra :: DefaultEnv -> Object -> Parser Extra
 parseExtra _ o = Extra
     <$> o .:  "copyright"
     <*> o .:? "analytics"
+    <*> o .:? "staticRoot"