hledger-web 0.15.3 → 0.16
raw patch · 13 files changed
+493/−451 lines, 13 filesdep +aeson-nativedep +blaze-htmldep +clientsessiondep −aesondep ~hamletdep ~hledgerdep ~hledger-lib
Dependencies added: aeson-native, blaze-html, clientsession, data-object, data-object-yaml, shakespeare-css, shakespeare-js, shakespeare-text, yesod
Dependencies removed: aeson
Dependency ranges changed: hamlet, hledger, hledger-lib, wai, wai-extra, warp, yesod-core, yesod-form, yesod-json, yesod-static
Files
- Hledger/Web.hs +9/−11
- Hledger/Web/App.hs +0/−117
- Hledger/Web/AppRun.hs +0/−63
- Hledger/Web/Application.hs +62/−0
- Hledger/Web/EmbeddedFiles.hs +0/−46
- Hledger/Web/Foundation.hs +120/−0
- Hledger/Web/Handlers.hs +54/−56
- Hledger/Web/Options.hs +8/−7
- Hledger/Web/Settings.hs +121/−70
- Hledger/Web/Settings/StaticFiles.hs +18/−0
- Hledger/Web/StaticFiles.hs +0/−18
- hledger-web.cabal +30/−36
- hledger-web.hs +71/−27
Hledger/Web.hs view
@@ -3,33 +3,31 @@ -} module Hledger.Web (- module Hledger.Web.App,- module Hledger.Web.AppRun,- module Hledger.Web.EmbeddedFiles,+ module Hledger.Web.Foundation,+ module Hledger.Web.Application, module Hledger.Web.Handlers, module Hledger.Web.Options, module Hledger.Web.Settings,- module Hledger.Web.StaticFiles,+ module Hledger.Web.Settings.StaticFiles, tests_Hledger_Web ) where import Test.HUnit -import Hledger.Web.App-import Hledger.Web.AppRun-import Hledger.Web.EmbeddedFiles+import Hledger.Web.Foundation+import Hledger.Web.Application import Hledger.Web.Handlers import Hledger.Web.Options import Hledger.Web.Settings-import Hledger.Web.StaticFiles+import Hledger.Web.Settings.StaticFiles tests_Hledger_Web :: Test tests_Hledger_Web = TestList [- -- tests_Hledger_Web_App- -- ,tests_Hledger_Web_AppRun+ -- tests_Hledger_Web_Foundation+ -- ,tests_Hledger_Web_Application -- ,tests_Hledger_Web_EmbeddedFiles -- ,tests_Hledger_Web_Handlers -- ,tests_Hledger_Web_Settings- -- ,tests_Hledger_Web_StaticFiles+ -- ,tests_Hledger_Web_Settings_StaticFiles ]
− Hledger/Web/App.hs
@@ -1,117 +0,0 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}-module Hledger.Web.App- ( App (..)- , AppRoute (..)- , resourcesApp- , Handler- , Widget- , module Yesod.Core- , StaticRoute (..)- , lift- , liftIO- ) where--import Control.Monad-import Control.Monad.Trans.Class (lift)-import Control.Monad.IO.Class (liftIO)-import qualified Data.ByteString.Lazy as L-import qualified Data.Text as T-import System.Directory-import Text.Hamlet hiding (hamletFile)-import Yesod.Core-import Yesod.Helpers.Static--import Hledger.Data-import Hledger.Web.Options-import Hledger.Web.Settings-import Hledger.Web.StaticFiles---- | The site argument for your application. This can be a good place to--- keep settings and values requiring initialization before your application--- starts running, such as database connections. Every handler will have--- access to the data present here.-data App = App- {getStatic :: Static -- ^ Settings for static file serving.- ,appRoot :: T.Text- ,appOpts :: WebOpts- ,appArgs :: [String]- ,appJournal :: Journal- }---- | A useful synonym; most of the handler functions in your application--- will need to be of this type.-type Handler = GHandler App App---- | A useful synonym; most of the widgets functions in your application--- will need to be of this type.-type Widget = GWidget App App---- This is where we define all of the routes in our application. For a full--- explanation of the syntax, please see:--- http://docs.yesodweb.com/book/web-routes-quasi/------ This function does three things:------ * Creates the route datatype AppRoute. Every valid URL in your--- application can be represented as a value of this type.--- * Creates the associated type:--- type instance Route App = AppRoute--- * Creates the value resourcesApp which contains information on the--- resources declared below. This is used in Controller.hs by the call to--- mkYesodDispatch------ What this function does *not* do is create a YesodSite instance for--- App. Creating that instance requires all of the handler functions--- for our application to be in scope. However, the handler functions--- usually require access to the AppRoute datatype. Therefore, we--- split these actions into two functions and place them in separate files.-mkYesodData "App" $(parseRoutesFile "routes")---- Please see the documentation for the Yesod typeclass. There are a number--- of settings which can be configured by overriding methods here.-instance Yesod App where- approot = appRoot-- defaultLayout widget = do- -- mmsg <- getMessage- pc <- widgetToPageContent $ do- widget- -- addCassius $(Settings.cassiusFile "default-layout")- hamletToRepHtml [$hamlet|-!!!-<html- <head- <title>#{pageTitle pc}- ^{pageHead pc}- <meta http-equiv=Content-Type content="text/html; charset=utf-8"- <script type=text/javascript src=@{StaticR jquery_js}- <script type=text/javascript src=@{StaticR jquery_url_js}- <script type=text/javascript src=@{StaticR jquery_flot_js}- <!--[if lte IE 8]><script language="javascript" type="text/javascript" src="excanvas.min.js"></script><![endif]-->- <script type=text/javascript src=@{StaticR dhtmlxcommon_js}- <script type=text/javascript src=@{StaticR dhtmlxcombo_js}- <script type=text/javascript src=@{StaticR hledger_js}- <link rel=stylesheet type=text/css media=all href=@{StaticR style_css}- <body- ^{pageBody pc}-|]-- -- -- This is done to provide an optimization for serving static files from- -- -- a separate domain. Please see the staticroot setting in Settings.hs- -- urlRenderOverride a (StaticR s) =- -- Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s- -- urlRenderOverride _ _ = Nothing-- -- This function creates static content files in the static folder- -- and names them based on a hash of their content. This allows- -- expiration dates to be set far in the future without worry of- -- users receiving stale content.- addStaticContent ext' _ content = do- let fn = base64md5 content ++ '.' : T.unpack ext'- let statictmp = Hledger.Web.Settings.staticdir ++ "/tmp/"- liftIO $ createDirectoryIfMissing True statictmp- let fn' = statictmp ++ fn- exists <- liftIO $ doesFileExist fn'- unless exists $ liftIO $ L.writeFile fn' content- return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])-
− Hledger/Web/AppRun.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Hledger.Web.AppRun (- withApp- ,withDevelApp- ,withWaiHandlerDevelApp- )-where--import Data.Dynamic (Dynamic, toDyn)-import Network.Wai (Application)-import System.IO.Storage (withStore, putValue)-import Yesod.Helpers.Static--import Hledger-import Hledger.Cli-import Hledger.Web.App-import Hledger.Web.Handlers-import Hledger.Web.Options-import Hledger.Web.Settings---- This line actually creates our YesodSite instance. It is the second half--- of the call to mkYesodData which occurs in App.hs. Please see--- the comments there for more details.-mkYesodDispatch "App" resourcesApp---- This function allocates resources (such as a database connection pool),--- performs initialization and creates a WAI application. This is also the--- place to put your migrate statements to have automatic database--- migrations handled by Yesod.-withApp :: App -> (Application -> IO a) -> IO a-withApp a f = toWaiApp a >>= f---- Called by yesod devel.-withDevelApp :: Dynamic-withDevelApp = toDyn (withApp a :: (Application -> IO ()) -> IO ())- where a = App{- getStatic=static Hledger.Web.Settings.staticdir- ,appRoot=Hledger.Web.Settings.defapproot- ,appOpts=defwebopts- ,appArgs=[]- ,appJournal=nulljournal- }---- Called by wai-handler-devel.--- Eg: cabal-dev/bin/wai-handler-devel 5001 AppRun withWaiHandlerDevelApp-withWaiHandlerDevelApp :: (Application -> IO ()) -> IO ()-withWaiHandlerDevelApp func = do- let f = "./test.journal"- ej <- readJournalFile Nothing f- let Right j = ej- let a = App{- getStatic=static Hledger.Web.Settings.staticdir- ,appRoot="http://demo.hledger.org:5001"- ,appOpts=defwebopts{cliopts_=defcliopts{file_=Just f}}- ,appArgs=[]- ,appJournal=j- }- withStore "hledger" $ do- putValue "hledger" "journal" j- withApp a func
+ Hledger/Web/Application.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Hledger.Web.Application (+ withApp+ ,withDevelAppPort+ )+where++import Data.Dynamic (Dynamic, toDyn)+import Network.Wai (Application)+import Network.Wai.Middleware.Debug (debugHandle)+import Yesod.Logger (makeLogger, flushLogger, Logger, logLazyText, logString)+import Yesod.Static++import Hledger.Web.Foundation+import Hledger.Web.Handlers+import Hledger.Web.Options+import Hledger.Web.Settings++-- This line actually creates our YesodSite instance. It is the second half+-- of the call to mkYesodData which occurs in App.hs. Please see+-- the comments there for more details.+mkYesodDispatch "App" resourcesApp++-- This function allocates resources (such as a database connection pool),+-- performs initialization and creates a WAI application. This is also the+-- place to put your migrate statements to have automatic database+-- migrations handled by Yesod.+withApp :: AppConfig -> Logger -> WebOpts -> (Application -> IO a) -> IO a+withApp conf logger opts f = do+#ifdef PRODUCTION+ putStrLn $ "Production mode, using embedded web files"+ let s = $(embed Hledger.Web.Settings.staticDir)+#else+ putStrLn $ "Not in production mode, using web files from " ++ Hledger.Web.Settings.staticDir ++ "/"+ s <- staticDevel Hledger.Web.Settings.staticDir+#endif+ let a = App {settings=conf+ ,getLogger=logger+ ,getStatic=s+ ,appOpts=opts+ }+ toWaiApp a >>= f++-- for yesod devel+withDevelAppPort :: Dynamic+withDevelAppPort =+ toDyn go+ where+ go :: ((Int, Application) -> IO ()) -> IO ()+ go f = do+ conf <- Hledger.Web.Settings.loadConfig Hledger.Web.Settings.Development+ let port = appPort conf+ logger <- makeLogger+ logString logger $ "Devel application launched with default options, listening on port " ++ show port+ withApp conf logger defwebopts $ \app -> f (port, debugHandle (logHandle logger) app)+ flushLogger logger+ where+ logHandle logger msg = logLazyText logger msg >> flushLogger logger
− Hledger/Web/EmbeddedFiles.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-| --Support files (static files and templates) used by the web app are-embedded in this module at compile time. Since hamlet can not easily use-these directly, we provide a way to write them out to the filesystem at-startup, when needed. This simplifies installation for end-users, and-customisation too.---}-module Hledger.Web.EmbeddedFiles- (- files- ,createFilesIfMissing- )-where-import Control.Monad-import qualified Data.ByteString as B-import Data.FileEmbed (embedDir)-import System.Directory-import System.FilePath--import Hledger.Web.Settings (datadir)---- | An embedded copy of all files below the the hledger-web data--- directory (@.hledger\/web\/@) at compile time, as (FilePath,ByteString)--- pairs.-files :: [(FilePath, B.ByteString)]-files = $(embedDir datadir)---- | If the hledger-web data directory (@.hledger\/web\/@) does not exist in--- the current directory, create and fill it with the web app support--- files (templates, stylesheets, images etc.) Returns True if the--- directory was missing.-createFilesIfMissing :: IO Bool-createFilesIfMissing = do- exists <- doesDirectoryExist datadir- if exists- then return False- else do- createDirectoryIfMissing True datadir - setCurrentDirectory datadir- forM_ files $ \(f,d) -> do- createDirectoryIfMissing True $ takeDirectory f- B.writeFile f d- return True
+ Hledger/Web/Foundation.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+module Hledger.Web.Foundation+ ( App (..)+ , AppRoute (..)+ , resourcesApp+ , Handler+ , Widget+ , module Yesod.Core+ -- , module Settings+ , StaticRoute (..)+ , lift+ , liftIO+ ) where++import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import System.Directory+import Text.Hamlet hiding (hamletFile)+import Web.ClientSession (getKey)+import Yesod.Core+import Yesod.Logger (Logger, logLazyText)+import Yesod.Static (Static, base64md5, StaticRoute(..))+import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T++import Hledger.Web.Options+import Hledger.Web.Settings+import Hledger.Web.Settings.StaticFiles+++-- | The site argument for your application. This can be a good place to+-- keep settings and values requiring initialization before your application+-- starts running, such as database connections. Every handler will have+-- access to the data present here.+data App = App+ { settings :: Hledger.Web.Settings.AppConfig+ , getLogger :: Logger+ , getStatic :: Static -- ^ Settings for static file serving.++ ,appOpts :: WebOpts+ -- ,appJournal :: Journal+ }++-- This is where we define all of the routes in our application. For a full+-- explanation of the syntax, please see:+-- http://docs.yesodweb.com/book/web-routes-quasi/+--+-- This function does three things:+--+-- * Creates the route datatype AppRoute. Every valid URL in your+-- application can be represented as a value of this type.+-- * Creates the associated type:+-- type instance Route App = AppRoute+-- * Creates the value resourcesApp which contains information on the+-- resources declared below. This is used in Handler.hs by the call to+-- mkYesodDispatch+--+-- What this function does *not* do is create a YesodSite instance for+-- App. Creating that instance requires all of the handler functions+-- for our application to be in scope. However, the handler functions+-- usually require access to the AppRoute datatype. Therefore, we+-- split these actions into two functions and place them in separate files.+mkYesodData "App" $(parseRoutesFile "routes")++-- Please see the documentation for the Yesod typeclass. There are a number+-- of settings which can be configured by overriding methods here.+instance Yesod App where+ approot = Hledger.Web.Settings.appRoot . settings++ -- Place the session key file in the config folder+ encryptKey _ = fmap Just $ getKey "client_session_key.aes"++ defaultLayout widget = do+ -- mmsg <- getMessage+ pc <- widgetToPageContent $ do+ widget+ -- addCassius $(cassiusFile "default-layout")+ -- hamletToRepHtml $(hamletFile "default-layout")+ hamletToRepHtml [$hamlet|+!!!+<html+ <head+ <title>#{pageTitle pc}+ ^{pageHead pc}+ <meta http-equiv=Content-Type content="text/html; charset=utf-8"+ <script type=text/javascript src=@{StaticR jquery_js}+ <script type=text/javascript src=@{StaticR jquery_url_js}+ <script type=text/javascript src=@{StaticR jquery_flot_js}+ <!--[if lte IE 8]><script language="javascript" type="text/javascript" src="excanvas.min.js"></script><![endif]-->+ <script type=text/javascript src=@{StaticR dhtmlxcommon_js}+ <script type=text/javascript src=@{StaticR dhtmlxcombo_js}+ <script type=text/javascript src=@{StaticR hledger_js}+ <link rel=stylesheet type=text/css media=all href=@{StaticR style_css}+ <body+ ^{pageBody pc}+|]++ -- 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++ messageLogger y loc level msg =+ formatLogMessage loc level msg >>= logLazyText (getLogger y)++ -- This function creates static content files in the static folder+ -- and names them based on a hash of their content. This allows+ -- expiration dates to be set far in the future without worry of+ -- users receiving stale content.+ addStaticContent ext' _ content = do+ let fn = base64md5 content ++ '.' : T.unpack ext'+ let statictmp = Hledger.Web.Settings.staticDir ++ "/tmp/"+ liftIO $ createDirectoryIfMissing True statictmp+ let fn' = statictmp ++ fn+ exists <- liftIO $ doesFileExist fn'+ unless exists $ liftIO $ L.writeFile fn' content+ return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])
Hledger/Web/Handlers.hs view
@@ -7,7 +7,7 @@ module Hledger.Web.Handlers where -import Control.Applicative ((<$>), (<*>))+import Control.Applicative ((<$>)) import Data.Aeson import Data.ByteString (ByteString) import Data.Either (lefts,rights)@@ -17,24 +17,23 @@ import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format--- import Safe import System.FilePath (takeFileName, (</>)) import System.IO.Storage (putValue, getValue) import System.Locale (defaultTimeLocale)+import Text.Blaze (preEscapedString, toHtml) import Text.Hamlet hiding (hamletFile) import Text.Printf-import Yesod.Form import Yesod.Json import Hledger hiding (today) import Hledger.Cli-import Hledger.Web.App+import Hledger.Web.Foundation import Hledger.Web.Options import Hledger.Web.Settings getFaviconR :: Handler ()-getFaviconR = sendFile "image/x-icon" $ Hledger.Web.Settings.staticdir </> "favicon.ico"+getFaviconR = sendFile "image/x-icon" $ Hledger.Web.Settings.staticDir </> "favicon.ico" getRobotsR :: Handler RepPlain getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)@@ -70,9 +69,9 @@ <div#sidebar ^{sidecontent} <div#main.register- <h2#contenttitle>#{title}- ^{searchform vd} <div#maincontent+ <h2#contenttitle>#{title}+ ^{searchform vd} ^{maincontent} ^{addform vd} ^{editform vd}@@ -103,9 +102,9 @@ <div#sidebar ^{sidecontent} <div#main.journal- <h2#contenttitle>#{title}- ^{searchform vd} <div#maincontent+ <h2#contenttitle>#{title}+ ^{searchform vd} ^{maincontent} ^{addform vd} ^{editform vd}@@ -143,9 +142,9 @@ <div#sidebar ^{sidecontent} <div#main.register- <h2#contenttitle>#{title}- ^{searchform vd} <div#maincontent+ <h2#contenttitle>#{title}+ ^{searchform vd} ^{maincontent} ^{addform vd} ^{editform vd}@@ -187,11 +186,11 @@ -- view helpers -- | Render the sidebar used on most views.-sidebar :: ViewData -> Hamlet AppRoute+sidebar :: ViewData -> HtmlUrl AppRoute sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport2 (reportopts_ $ cliopts_ opts) am j -- | Render a "AccountsReport" as HTML.-accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> Hamlet AppRoute+accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> HtmlUrl AppRoute accountsReportAsHtml _ vd@VD{..} (items',total) = [$hamlet| <div#accountsheading@@ -234,7 +233,7 @@ inacctmatcher = inAccountMatcher qopts allaccts = isNothing inacctmatcher items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher- itemAsHtml :: ViewData -> AccountsReportItem -> Hamlet AppRoute+ itemAsHtml :: ViewData -> AccountsReportItem -> HtmlUrl AppRoute itemAsHtml _ (acct, adisplay, aindent, abal) = [$hamlet| <tr.item.#{inacctclass} <td.account.#{depthclass}@@ -272,14 +271,14 @@ accountUrl r a = (r, [("q",pack $ accountQuery a)]) -- | Render a "EntriesReport" as HTML for the journal entries view.-entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> Hamlet AppRoute+entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> HtmlUrl AppRoute entriesReportAsHtml _ vd items = [$hamlet| <table.journalreport> $forall i <- numbered items ^{itemAsHtml vd i} |] where- itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> Hamlet AppRoute+ itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute itemAsHtml _ (n, t) = [$hamlet| <tr.item.#{evenodd}> <td.transaction>@@ -290,7 +289,7 @@ txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse -- | Render an "TransactionsReport" as HTML for the formatted journal view.-journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> Hamlet AppRoute+journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet| <table.journalreport <tr.headings@@ -303,7 +302,7 @@ |] where -- .#{datetransition}- itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> Hamlet AppRoute+ itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [$hamlet| <tr.item.#{evenodd}.#{firstposting} <td.date>#{date}@@ -328,14 +327,14 @@ showamt = not split || not (isZeroMixedAmount amt) -- Generate html for an account register, including a balance chart and transaction list.-registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> Hamlet AppRoute+registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute registerReportHtml opts vd r@(_,items) = [$hamlet| ^{registerChartHtml items} ^{registerItemsHtml opts vd r} |] -- Generate html for a transaction list from an "TransactionsReport".-registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> Hamlet AppRoute+registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute registerItemsHtml _ vd (balancelabel,items) = [$hamlet| <table.registerreport <tr.headings@@ -353,7 +352,7 @@ where -- inacct = inAccount qopts -- filtering = m /= MatchAny- itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> Hamlet AppRoute+ itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute itemAsHtml VD{..} (n, newd, newm, _, (t, _, split, acct, amt, bal)) = [$hamlet| <tr.item.#{evenodd}.#{firstposting}.#{datetransition} <td.date>#{date}@@ -451,7 +450,7 @@ -- | Handle a post from any of the edit forms. handlePost :: Handler RepPlain handlePost = do- action <- runFormPost' $ maybeStringInput "action"+ action <- lookupPostParam "action" case action of Just "add" -> handleAdd Just "edit" -> handleEdit Just "import" -> handleImport@@ -462,15 +461,13 @@ handleAdd = do VD{..} <- getViewData -- get form input values. M means a Maybe value.- (dateM, descM, acct1M, amt1M, acct2M, amt2M, journalM) <- runFormPost'- $ (,,,,,,)- <$> maybeStringInput "date"- <*> maybeStringInput "description"- <*> maybeStringInput "account1"- <*> maybeStringInput "amount1"- <*> maybeStringInput "account2"- <*> maybeStringInput "amount2"- <*> maybeStringInput "journal"+ dateM <- lookupPostParam "date"+ descM <- lookupPostParam "description"+ acct1M <- lookupPostParam "account1"+ amt1M <- lookupPostParam "amount1"+ acct2M <- lookupPostParam "account2"+ amt2M <- lookupPostParam "amount2"+ journalM <- lookupPostParam "journal" -- supply defaults and parse date and amounts, or get errors. let dateE = maybe (Left "date required") (either (\e -> Left $ showDateParseError e) Right . fixSmartDateStrEither today . unpack) dateM descE = Right $ maybe "" unpack descM@@ -506,7 +503,7 @@ Left errs -> do -- save current form values in session -- setMessage $ toHtml $ intercalate "; " errs- setMessage [$hamlet|+ setMessage [$shamlet| Errors:<br> $forall e<-errs #{e}<br>@@ -515,9 +512,10 @@ Right t -> do let t' = txnTieKnot t -- XXX move into balanceTransaction- liftIO $ appendToJournalFile journalpath $ showTransaction t'+ liftIO $ do ensureJournalFile journalpath+ appendToJournalFileOrStdout journalpath $ showTransaction t' -- setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String)- setMessage [$hamlet|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|]+ setMessage [$shamlet|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|] redirectParams RedirectTemporary RegisterR [("add","1")] chomp :: String -> String@@ -529,10 +527,8 @@ VD{..} <- getViewData -- get form input values, or validation errors. -- getRequest >>= liftIO (reqRequestBody req) >>= mtrace- (textM, journalM) <- runFormPost'- $ (,)- <$> maybeStringInput "text"- <*> maybeStringInput "journal"+ textM <- lookupPostParam "text"+ journalM <- lookupPostParam "journal" let textE = maybe (Left "No value provided") (Right . unpack) textM journalE = maybe (Right $ journalFilePath j) (\f -> let f' = unpack f in@@ -577,7 +573,7 @@ setMessage "can't handle file upload yet" redirect RedirectTemporary JournalR -- -- get form input values, or basic validation errors. E means an Either value.- -- fileM <- runFormPost' $ maybeFileInput "file"+ -- fileM <- runFormPost $ maybeFileInput "file" -- let fileE = maybe (Left "No file provided") Right fileM -- -- display errors or import transactions -- case fileE of@@ -593,7 +589,7 @@ -- | Other view components. -- | Global toolbar/heading area.-topbar :: ViewData -> Hamlet AppRoute+topbar :: ViewData -> HtmlUrl AppRoute topbar VD{..} = [$hamlet| <div#topbar <a.topleftlink href=#{hledgerorgurl} title="More about hledger"@@ -609,7 +605,7 @@ title = takeFileName $ journalFilePath j -- | Navigation link, preserving parameters and possibly highlighted.-navlink :: ViewData -> String -> AppRoute -> String -> Hamlet AppRoute+navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute navlink VD{..} s dest title = [$hamlet| <a##{s}link.#{style} href=@?{u} title="#{title}">#{s} |]@@ -618,7 +614,7 @@ | otherwise = "navlink" :: Text -- | Links to the various journal editing forms.-editlinks :: Hamlet AppRoute+editlinks :: HtmlUrl AppRoute editlinks = [$hamlet| <a#editformlink href="#" onclick="return editformToggle(event)" title="Toggle journal edit form">edit \ | #@@ -627,14 +623,14 @@ |] -- | Link to a topic in the manual.-helplink :: String -> String -> Hamlet AppRoute+helplink :: String -> String -> HtmlUrl AppRoute helplink topic label = [$hamlet| <a href=#{u} target=hledgerhelp>#{label} |] where u = manualurl ++ if null topic then "" else '#':topic -- | Search form for entering custom queries to filter journal data.-searchform :: ViewData -> Hamlet AppRoute+searchform :: ViewData -> HtmlUrl AppRoute searchform VD{..} = [$hamlet| <div#searchformdiv <form#searchform.form method=GET@@ -675,7 +671,7 @@ filtering = not $ null q -- | Add transaction form.-addform :: ViewData -> Hamlet AppRoute+addform :: ViewData -> HtmlUrl AppRoute addform vd@VD{..} = [$hamlet| <script type=text/javascript> $(document).ready(function() {@@ -778,9 +774,10 @@ ) -- | Edit journal form.-editform :: ViewData -> Hamlet AppRoute+editform :: ViewData -> HtmlUrl AppRoute editform VD{..} = [$hamlet| <form#editform method=POST style=display:none;+ <h2#contenttitle>#{title} <table.form $if manyfiles <tr@@ -804,11 +801,12 @@ <a href="#" onclick="return editformToggle(event)">cancel |] where+ title = "Edit journal" :: String manyfiles = (length $ files j) > 1 formathelp = helplink "file-format" "file format help" -- | Import journal form.-importform :: Hamlet AppRoute+importform :: HtmlUrl AppRoute importform = [$hamlet| <form#importform method=POST style=display:none; <table.form@@ -821,14 +819,14 @@ <a href="#" onclick="return importformToggle(event)" cancel |] -journalselect :: [(FilePath,String)] -> Hamlet AppRoute+journalselect :: [(FilePath,String)] -> HtmlUrl AppRoute journalselect journalfiles = [$hamlet| <select id=journalselect name=journal onchange="editformJournalSelect(event)" $forall f <- journalfiles <option value=#{fst f}>#{fst f} |] -nulltemplate :: Hamlet AppRoute+nulltemplate :: HtmlUrl AppRoute nulltemplate = [$hamlet||] ----------------------------------------------------------------------@@ -859,7 +857,7 @@ let (querymatcher,queryopts) = parseQuery d q (acctsmatcher,acctsopts) = parseQuery d a in VD {- opts = defwebopts{cliopts_=defcliopts{reportopts_=defreportopts{no_elide_=True}}}+ opts = defwebopts ,j = nulljournal ,here = RootR ,msg = Nothing@@ -881,9 +879,9 @@ msg <- getMessageOr err Just here <- getCurrentRoute today <- liftIO getCurrentDay- q <- getParameter "q"- a <- getParameter "a"- p <- getParameter "p"+ q <- getParameterOrNull "q"+ a <- getParameterOrNull "a"+ p <- getParameterOrNull "p" return (viewdataWithDateAndParams today q a p){ opts=opts ,msg=msg@@ -907,9 +905,9 @@ Left e -> do setMessage $ "error while reading" {- ++ ": " ++ e-} return (j, Just e) - -- | Get the named request parameter.- getParameter :: String -> Handler String- getParameter p = unpack `fmap` fromMaybe "" <$> lookupGetParam (pack p)+ -- | Get the named request parameter, or the empty string if not present.+ getParameterOrNull :: String -> Handler String+ getParameterOrNull p = unpack `fmap` fromMaybe "" <$> lookupGetParam (pack p) -- | Get the message set by the last request, or the newer message provided, if any. getMessageOr :: Maybe String -> Handler (Maybe Html)
Hledger/Web/Options.hs view
@@ -5,7 +5,6 @@ module Hledger.Web.Options where import Data.Maybe-import Data.Text (unpack) import System.Console.CmdArgs import System.Console.CmdArgs.Explicit @@ -17,17 +16,16 @@ progname = Hledger.Cli.progname ++ "-web" progversion = progversionstr progname -defbaseurl = unpack defapproot-defbaseurl' = (reverse $ drop 4 $ reverse defbaseurl) ++ "PORT"+defbaseurlexample = (reverse $ drop 4 $ reverse $ defbaseurl defport) ++ "PORT" webflags = [- flagReq ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) "URL" ("set the base url (default: "++defbaseurl'++")")+ 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++")") ] webmode = (mode "hledger-web" [("command","web")] "start serving the hledger web interface"- commandargsflag []){+ mainargsflag []){ modeGroupFlags = Group { groupUnnamed = webflags ,groupHidden = []@@ -55,11 +53,14 @@ toWebOpts :: RawOpts -> IO WebOpts toWebOpts rawopts = do cliopts <- toCliOpts rawopts+ let p = fromMaybe defport $ maybeintopt "port" rawopts return defwebopts {- base_url_ = fromMaybe defbaseurl $ maybestringopt "base-url" rawopts- ,port_ = fromMaybe defport $ maybeintopt "port" rawopts+ port_ = p+ ,base_url_ = maybe (defbaseurl p) stripTrailingSlash $ maybestringopt "base-url" rawopts ,cliopts_ = cliopts }+ where+ stripTrailingSlash = reverse . dropWhile (=='/') . reverse -- yesod don't like it checkWebOpts :: WebOpts -> IO WebOpts checkWebOpts opts = do
Hledger/Web/Settings.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod@@ -14,31 +12,37 @@ , juliusFile , luciusFile , widgetFile- , datadir- , staticdir- -- , staticroot- , defhost+ , staticRoot+ , staticDir+ , loadConfig+ , AppEnvironment(..)+ , AppConfig(..)+ , defport- , defapproot- -- , browserstartdelay+ , defbaseurl , hledgerorgurl , manualurl+ -- , datadir+ ) where -import Data.Monoid (mempty) --, mappend)-import Data.Text (Text,pack)+import qualified Text.Hamlet as S+import qualified Text.Cassius as S+import qualified Text.Julius as S+import qualified Text.Lucius as S+import Text.Printf+import qualified Text.Shakespeare.Text as S+import Text.Shakespeare.Text (st) import Language.Haskell.TH.Syntax+import Yesod.Widget (addWidget, addCassius, addJulius, addLucius, whamletFile)+import Data.Monoid (mempty) import System.Directory (doesFileExist)-import Text.Printf (printf)-import qualified Text.Hamlet as H-import qualified Text.Cassius as H-import qualified Text.Julius as H-import qualified Text.Lucius as H-import Yesod.Widget (addWidget, addCassius, addJulius, addLucius)+import Data.Text (Text, pack)+import Data.Object+import qualified Data.Object.Yaml as YAML+import Control.Monad (join) --- browserstartdelay = 100000 -- microseconds- hledgerorgurl, manualurl :: String hledgerorgurl = "http://hledger.org" manualurl = hledgerorgurl++"/MANUAL.html"@@ -47,52 +51,89 @@ defport :: Int defport = 5000 -defhost :: String-defhost = "localhost"+defbaseurl :: Int -> String+defbaseurl port = printf "http://localhost:%d" port --- | The default base URL for your application. This will usually be different for--- development and production. Yesod automatically constructs URLs for you,--- so this value must be accurate to create valid links.--- For hledger-web this is usually overridden with --base-url.-defapproot :: Text-defapproot = pack $ printf "http://%s:%d" defhost defport--- #ifdef PRODUCTION--- #else--- #endif --- | Hard-coded data directory path. This must be in your current dir when--- you compile. At run time it's also required but we'll auto-create it.-datadir :: FilePath-datadir = "./.hledger/web/"+data AppEnvironment = Test+ | Development+ | Staging+ | Production+ deriving (Eq, Show, Read, Enum, Bounded) --- -- | The base URL for your static files. As you can see by the default--- -- value, this can simply be "static" appended to your application root.--- -- A powerful optimization can be serving static files from a separate--- -- domain name. This allows you to use a web server optimized for static--- -- files, more easily set expires and cache values, and avoid possibly--- -- costly transference of cookies on static files. For more information,--- -- please see:--- -- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain--- ----- -- If you change the resource pattern for StaticR in hledger-web.hs, you will--- -- have to make a corresponding change here.--- ----- -- To see how this value is used, see urlRenderOverride in hledger-web.hs--- staticroot :: Text--- staticroot = defapproot `mappend` "/static"+-- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml.+-- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments).+--+-- By convention these settings should be overwritten by any command line arguments.+-- See config/App.hs for command line arguments+-- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku).+--+data AppConfig = AppConfig {+ appEnv :: AppEnvironment + , appPort :: Int++ -- The base URL for your application. This will usually be different for+ -- development and production. Yesod automatically constructs URLs for you,+ -- so this value must be accurate to create valid links.+ -- Please note that there is no trailing slash.+ --+ -- You probably want to change this! If your domain name was "yesod.com",+ -- you would probably want it to be:+ -- > "http://yesod.com"+ , appRoot :: Text+} deriving (Show)++loadConfig :: AppEnvironment -> IO AppConfig+loadConfig env = do+ allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping+ settings <- lookupMapping (show env) allSettings+ hostS <- lookupScalar "host" settings+ port <- fmap read $ lookupScalar "port" settings+ return $ AppConfig {+ appEnv = env+ , appPort = port+ , appRoot = pack $ hostS ++ addPort port+ }+ where+ addPort :: Int -> String+#ifdef PRODUCTION+ addPort _ = ""+#else+ addPort p = ":" ++ (show p)+#endif+ -- | The location of static files on your system. This is a file system -- path. The default value works properly with your scaffolded site.-staticdir :: FilePath-staticdir = datadir++"static"+staticDir :: FilePath+--staticDir = "static"+staticDir = datadir++"static" +datadir :: FilePath+datadir = "./"+-- datadir = "./.hledger/web/" +-- | The base URL for your static files. As you can see by the default+-- value, this can simply be "static" appended to your application root.+-- A powerful optimization can be serving static files from a separate+-- domain name. This allows you to use a web server optimized for static+-- files, more easily set expires and cache values, and avoid possibly+-- costly transference of cookies on static files. For more information,+-- please see:+-- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain+--+-- If you change the resource pattern for StaticR in hledger-web.hs, you will+-- have to make a corresponding change here.+--+-- To see how this value is used, see urlRenderOverride in hledger-web.hs+staticRoot :: AppConfig -> Text+staticRoot conf = [st|#{appRoot conf}/static|] -- The rest of this file contains settings which rarely need changing by a -- user. --- The following three functions are used for calling HTML, CSS and--- Javascript templates from your Haskell code. During development,+-- The following functions are used for calling HTML, CSS,+-- Javascript, and plain text templates from your Haskell code. During development, -- the "Debug" versions of these functions are used so that changes to -- the templates are immediately reflected in an already running -- application. When making a production compile, the non-debug version@@ -104,44 +145,54 @@ -- used; to get the same auto-loading effect, it is recommended that you -- use the devel server. -toHamletFile, toCassiusFile, toJuliusFile, toLuciusFile :: String -> FilePath-toHamletFile x = datadir++"templates/" ++ x ++ ".hamlet"-toCassiusFile x = datadir++"templates/" ++ x ++ ".cassius"-toJuliusFile x = datadir++"templates/" ++ x ++ ".julius"-toLuciusFile x = datadir++"templates/" ++ x ++ ".lucius"+-- | expects a root folder for each type, e.g: hamlet/ lucius/ julius/+globFile :: String -> String -> FilePath+-- globFile kind x = kind ++ "/" ++ x ++ "." ++ kind+globFile kind x = datadir ++ "templates/" ++ x ++ "." ++ kind hamletFile :: FilePath -> Q Exp-hamletFile = H.hamletFile . toHamletFile+hamletFile = S.hamletFile . globFile "hamlet" cassiusFile :: FilePath -> Q Exp+cassiusFile = #ifdef PRODUCTION-cassiusFile = H.cassiusFile . toCassiusFile+ S.cassiusFile . globFile "cassius" #else-cassiusFile = H.cassiusFileDebug . toCassiusFile+ S.cassiusFileDebug . globFile "cassius" #endif luciusFile :: FilePath -> Q Exp+luciusFile = #ifdef PRODUCTION-luciusFile = H.luciusFile . toLuciusFile+ S.luciusFile . globFile "lucius" #else-luciusFile = H.luciusFileDebug . toLuciusFile+ S.luciusFileDebug . globFile "lucius" #endif juliusFile :: FilePath -> Q Exp+juliusFile = #ifdef PRODUCTION-juliusFile = H.juliusFile . toJuliusFile+ S.juliusFile . globFile "julius" #else-juliusFile = H.juliusFileDebug . toJuliusFile+ S.juliusFileDebug . globFile "julius" #endif +textFile :: FilePath -> Q Exp+textFile =+#ifdef PRODUCTION+ S.textFile . globFile "text"+#else+ S.textFileDebug . globFile "text"+#endif+ widgetFile :: FilePath -> Q Exp widgetFile x = do- let h = unlessExists toHamletFile hamletFile- let c = unlessExists toCassiusFile cassiusFile- let j = unlessExists toJuliusFile juliusFile- let l = unlessExists toLuciusFile luciusFile+ let h = whenExists (globFile "hamlet") (whamletFile . globFile "hamlet")+ let c = whenExists (globFile "cassius") cassiusFile+ let j = whenExists (globFile "julius") juliusFile+ let l = whenExists (globFile "lucius") luciusFile [|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|] where- unlessExists tofn f = do+ whenExists tofn f = do e <- qRunIO $ doesFileExist $ tofn x if e then f x else [|mempty|]
+ Hledger/Web/Settings/StaticFiles.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}+{-| ++This module exports routes for all the files in the static directory at+compile time, allowing compile-time verification that referenced files+exist. However, any files added during run-time can't be accessed this+way; use their FilePath or URL to access them.++This is a separate module to satisfy template haskell requirements.++-}+module Hledger.Web.Settings.StaticFiles where++import Yesod.Static++import Hledger.Web.Settings (staticDir)++$(staticFiles staticDir)
− Hledger/Web/StaticFiles.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}-{-| --This module exports routes for all the files in the static directory at-compile time, allowing compile-time verification that referenced files-exist. However, any files added during run-time can't be accessed this-way; use their FilePath or URL to access them.--This is a separate module to satisfy template haskell requirements.---}-module Hledger.Web.StaticFiles where--import Yesod.Helpers.Static--import Hledger.Web.Settings (staticdir)--$(staticFiles staticdir)
hledger-web.cabal view
@@ -1,5 +1,5 @@ name: hledger-web-version: 0.15.3+version: 0.16 category: Finance synopsis: A web interface for the hledger accounting tool. description: @@ -22,7 +22,6 @@ build-type: Simple extra-tmp-files: extra-source-files:--- included via hamletFile/EmbeddedFiles.hs since yesod needs the paths at compile-time -- data-dir: -- data-files: @@ -31,11 +30,11 @@ location: http://joyful.com/repos/hledger Flag production- Description: Build in production mode, which reads template files only once at startup.- Default: False+ Description: Build in production mode, with web files embedded. Otherwise, they will be loaded from ./static/.+ Default: True Flag devel- Description: Build for use with "yesod devel"+ Description: Build for use with "yesod devel". Default: False executable hledger-web@@ -49,54 +48,50 @@ ghc-options: -W -threaded other-modules: Hledger.Web- Hledger.Web.App- Hledger.Web.AppRun- Hledger.Web.EmbeddedFiles+ Hledger.Web.Foundation+ Hledger.Web.Application Hledger.Web.Options Hledger.Web.Settings- Hledger.Web.StaticFiles+ Hledger.Web.Settings.StaticFiles Hledger.Web.Handlers build-depends:- hledger == 0.15.2- ,hledger-lib == 0.15.2+ hledger == 0.16+ ,hledger-lib == 0.16 ,HUnit ,base >= 4 && < 5 ,bytestring ,cmdargs >= 0.8 && < 0.9- -- ,containers- -- ,csv ,directory ,filepath- -- ,mtl ,old-locale- -- ,old-time ,parsec- -- ,process ,regexpr >= 0.5.1 ,safe >= 0.2- -- ,split == 0.1.* ,text ,time- -- ,utf8-string >= 0.3.5 && < 0.4 ,io-storage >= 0.3 && < 0.4- -- ,convertible-text >= 0.3.0.1 && < 0.4- -- ,data-object >= 0.3.1.2 && < 0.4 ,failure >= 0.1 && < 0.2 ,file-embed == 0.0.* ,template-haskell >= 2.4 && < 2.6- -- ,yesod >= 0.8 && < 0.9- ,yesod-core >= 0.8 && < 0.9- ,yesod-form == 0.1.*- ,yesod-json == 0.1.*- ,yesod-static == 0.1.*- ,aeson == 0.3.*- ,hamlet == 0.8.*++ ,yesod >= 0.9.2.1 && < 0.10+ ,yesod-core+ ,yesod-form+ ,yesod-json+ ,yesod-static >= 0.3+ ,aeson-native >= 0.3.3.1+ ,blaze-html+ ,clientsession+ ,data-object+ ,data-object-yaml+ ,hamlet+ ,shakespeare-css+ ,shakespeare-js+ ,shakespeare-text ,transformers- ,wai < 0.5- ,wai-extra < 0.5- ,warp < 0.5- -- , blaze-builder- -- , web-routes+ ,wai+ ,wai-extra+ ,warp library if flag(devel)@@ -104,12 +99,11 @@ else Buildable: False exposed-modules: - Hledger.Web.AppRun+ Hledger.Web.Application other-modules: Hledger.Web- Hledger.Web.App- Hledger.Web.EmbeddedFiles+ Hledger.Web.Foundation Hledger.Web.Options Hledger.Web.Settings- Hledger.Web.StaticFiles+ Hledger.Web.Settings.StaticFiles Hledger.Web.Handlers
hledger-web.hs view
@@ -13,18 +13,18 @@ import Data.Maybe import Data.Text(pack) import Network.Wai.Handler.Warp (run)-#if PRODUCTION-#else-import Network.Wai.Middleware.Debug (debug)-#endif import System.Exit import System.IO.Storage (withStore, putValue) import Text.Printf-import Yesod.Helpers.Static+#ifndef PRODUCTION+import Network.Wai.Middleware.Debug (debugHandle)+import Yesod.Logger (logString, logLazyText, flushLogger, makeLogger)+#else+import Yesod.Logger (makeLogger)+#endif import Hledger import Hledger.Cli hiding (progname,progversion)-import Hledger.Cli.Tests import Prelude hiding (putStrLn) import Hledger.Utils.UTF8 (putStrLn) import Hledger.Web@@ -43,7 +43,7 @@ | "help" `in_` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp webmode) >> exitSuccess | "version" `in_` (rawopts_ $ cliopts_ opts) = putStrLn progversion >> exitSuccess | "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)- | otherwise = withJournalDo' opts web+ | otherwise = journalFilePathFromOpts (cliopts_ opts) >>= ensureJournalFile >> withJournalDo' opts web withJournalDo' :: WebOpts -> (WebOpts -> Journal -> IO ()) -> IO () withJournalDo' opts cmd = do@@ -53,17 +53,8 @@ -- | The web command. web :: WebOpts -> Journal -> IO () web opts j = do- created <- createFilesIfMissing- if created- then do- putStrLn $ "Installing support files in "++datadir++" - done, please run again."- exitFailure- else do- putStrLn $ "Running self-tests..."- runTestsOrExit $ cliopts_ opts- putStrLn $ "Using support files in "++datadir- -- unless (debug_ $ cliopts_ opts) $ forkIO (browser baseurl) >> return ()- server (base_url_ opts) (port_ opts) opts j+ -- unless (debug_ $ cliopts_ opts) $ forkIO (browser baseurl) >> return ()+ server (base_url_ opts) (port_ opts) opts j -- browser :: String -> IO () -- browser baseurl = do@@ -74,17 +65,70 @@ server :: String -> Int -> WebOpts -> Journal -> IO () server baseurl port opts j = do printf "Starting http server on port %d with base url %s\n" port baseurl- let a = App{getStatic=static staticdir- ,appRoot=pack baseurl- ,appOpts=opts- ,appArgs=patterns_ $ reportopts_ $ cliopts_ opts- ,appJournal=j- }+ -- let a = App{getStatic=static staticdir+ -- ,appRoot=pack baseurl+ -- ,appOpts=opts+ -- ,appArgs=patterns_ $ reportopts_ $ cliopts_ opts+ -- ,appJournal=j+ -- } withStore "hledger" $ do putValue "hledger" "journal" j- return ()++ -- yesod main+ logger <- makeLogger+ -- args <- cmdArgs argConfig+ -- env <- getAppEnv args+ let env = Development+ -- c <- loadConfig env+ -- let c' = if port_ opts /= 0+ -- then c{ appPort = port args }+ -- else c+ let c = AppConfig {+ appEnv = env+ , appPort = port_ opts+ , appRoot = pack baseurl+ } #if PRODUCTION- withApp a (run port)+ withApp c logger opts $ run (appPort c) #else- withApp a (run port . debug)+ logString logger $ (show env) ++ " application launched, listening on port " ++ show (appPort c)+ withApp c logger opts $ run (appPort c) . debugHandle (logHandle logger)+ flushLogger logger++ where+ logHandle logger msg = logLazyText logger msg >> flushLogger logger #endif++-- data ArgConfig = ArgConfig+-- { environment :: String+-- , port :: Int+-- } deriving (Show, Data, Typeable)++-- argConfig :: ArgConfig+-- argConfig = ArgConfig+-- { environment = def +-- &= help ("application environment, one of: " ++ (foldl1 (\a b -> a ++ ", " ++ b) environments))+-- &= typ "ENVIRONMENT"+-- , port = def+-- &= typ "PORT"+-- }++-- environments :: [String]+-- environments = map ((map toLower) . show) ([minBound..maxBound] :: [AppEnvironment])++-- | retrieve the -e environment option+-- getAppEnv :: ArgConfig -> IO AppEnvironment+-- getAppEnv cfg = do+-- let e = if environment cfg /= ""+-- then environment cfg+-- else+-- #if PRODUCTION+-- "production"+-- #else+-- "development"+-- #endif+-- return $ read $ capitalize e++-- where+-- capitalize [] = []+-- capitalize (x:xs) = toUpper x : map toLower xs