diff --git a/hledger-web/Hledger/Web/App.hs b/hledger-web/Hledger/Web/App.hs index 11e5fb36f..3b95ed6b7 100644 --- a/hledger-web/Hledger/Web/App.hs +++ b/hledger-web/Hledger/Web/App.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} module Hledger.Web.App ( App (..) , AppRoute (..) @@ -6,46 +7,44 @@ module Hledger.Web.App , Handler , Widget , module Yesod.Core + -- , module Settings , StaticRoute (..) , lift , liftIO ) where -import Control.Monad -import Control.Monad.Trans.Class (lift) +import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) -import qualified Data.ByteString.Lazy as L -import qualified Data.Text as T +import Control.Monad.Trans.Class (lift) import System.Directory import Text.Hamlet hiding (hamletFile) +import Web.ClientSession (getKey) import Yesod.Core -import Yesod.Helpers.Static +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.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 + { settings :: Hledger.Web.Settings.AppConfig + , getLogger :: Logger + , getStatic :: Static -- ^ Settings for static file serving. + ,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/ @@ -57,7 +56,7 @@ type Widget = GWidget App App -- * 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 +-- 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 @@ -70,13 +69,17 @@ 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 + 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 $(Settings.cassiusFile "default-layout") + -- addCassius $(cassiusFile "default-layout") + -- hamletToRepHtml $(hamletFile "default-layout") hamletToRepHtml [$hamlet| !!! >= 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/" + 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] [], []) - diff --git a/hledger-web/Hledger/Web/AppRun.hs b/hledger-web/Hledger/Web/AppRun.hs index 08a232abe..cbc27e753 100644 --- a/hledger-web/Hledger/Web/AppRun.hs +++ b/hledger-web/Hledger/Web/AppRun.hs @@ -1,18 +1,20 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hledger.Web.AppRun ( withApp - ,withDevelApp - ,withWaiHandlerDevelApp + ,withDevelAppPort ) where import Data.Dynamic (Dynamic, toDyn) import Network.Wai (Application) +import Network.Wai.Middleware.Debug (debugHandle) import System.IO.Storage (withStore, putValue) -import Yesod.Helpers.Static +import Yesod.Logger (makeLogger, flushLogger, Logger, logLazyText, logString) +import Yesod.Static import Hledger import Hledger.Cli @@ -26,38 +28,71 @@ import Hledger.Web.Settings -- the comments there for more details. mkYesodDispatch "App" resourcesApp +-- withApp :: App -> (Application -> IO a) -> IO a +-- withApp a f = toWaiApp a >>= f + -- 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 +withApp :: AppConfig -> Logger -> (Application -> IO a) -> IO a +withApp conf logger f = do +#ifdef PRODUCTION + s <- static Hledger.Web.Settings.staticDir +#else + s <- staticDevel Hledger.Web.Settings.staticDir +#endif + let h = App {settings=conf + ,getLogger=logger + ,getStatic=s + ,appOpts=defwebopts + ,appArgs=[] + ,appJournal=nulljournal + } + toWaiApp h >>= 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 - } +-- withDevelApp :: Dynamic +-- withDevelApp = do +-- s <- static Hledger.Web.Settings.staticdir +-- let a = App{ +-- getStatic=s +-- ,appRoot=Hledger.Web.Settings.defapproot +-- ,appOpts=defwebopts +-- ,appArgs=[] +-- ,appJournal=nulljournal +-- } +-- return $ toDyn (withApp a :: (Application -> IO ()) -> IO ()) --- 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://localhost:5002" - ,appOpts=defwebopts{cliopts_=defcliopts{file_=Just f}} - ,appArgs=[] - ,appJournal=j - } - withStore "hledger" $ do - putValue "hledger" "journal" j - withApp a func +-- 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, listening on port " ++ show port + withApp conf logger $ \app -> f (port, debugHandle (logHandle logger) app) + flushLogger logger + where + logHandle logger msg = logLazyText logger msg >> flushLogger logger + +-- -- 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://localhost:5002" +-- ,appOpts=defwebopts{cliopts_=defcliopts{file_=Just f}} +-- ,appArgs=[] +-- ,appJournal=j +-- } +-- withStore "hledger" $ do +-- putValue "hledger" "journal" j +-- withApp a func diff --git a/hledger-web/Hledger/Web/Handlers.hs b/hledger-web/Hledger/Web/Handlers.hs index 1a088315b..f07e91775 100644 --- a/hledger-web/Hledger/Web/Handlers.hs +++ b/hledger-web/Hledger/Web/Handlers.hs @@ -17,10 +17,10 @@ import Data.Text(Text,pack,unpack) 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 @@ -34,7 +34,7 @@ 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) @@ -187,11 +187,11 @@ getAccountsJsonR = do -- 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| filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher - itemAsHtml :: ViewData -> AccountsReportItem -> Hamlet AppRoute + itemAsHtml :: ViewData -> AccountsReportItem -> HtmlUrl AppRoute itemAsHtml _ (acct, adisplay, aindent, abal) = [$hamlet| ViewData -> EntriesReport -> Hamlet AppRoute +entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> HtmlUrl AppRoute entriesReportAsHtml _ vd items = [$hamlet| $forall i <- numbered items ^{itemAsHtml vd i} |] where - itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> Hamlet AppRoute + itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute itemAsHtml _ (n, t) = [$hamlet| @@ -290,7 +290,7 @@ entriesReportAsHtml _ vd items = [$hamlet| 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| (Int, Bool, Bool, Bool, TransactionsReportItem) -> Hamlet AppRoute + itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [$hamlet| #{date} @@ -328,14 +328,14 @@ $forall p <- tpostings t 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| (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| #{date} @@ -451,7 +451,7 @@ postRegisterR = handlePost -- | 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 +462,13 @@ handleAdd :: Handler RepPlain 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 +504,7 @@ handleAdd = do Left errs -> do -- save current form values in session -- setMessage $ toHtml $ intercalate "; " errs - setMessage [$hamlet| + setMessage [$shamlet| Errors:
$forall e<-errs #{e}
@@ -518,7 +516,7 @@ handleAdd = do liftIO $ do ensureJournalFile journalpath appendToJournalFileOrStdout journalpath $ showTransaction t' -- setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String) - setMessage [$hamlet|Added transaction:
#{chomp $ show t'}
|] + setMessage [$shamlet|Added transaction:
#{chomp $ show t'}
|] redirectParams RedirectTemporary RegisterR [("add","1")] chomp :: String -> String @@ -530,10 +528,8 @@ handleEdit = do 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 @@ -578,7 +574,7 @@ handleImport = do 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 @@ -594,7 +590,7 @@ handleImport = do -- | Other view components. -- | Global toolbar/heading area. -topbar :: ViewData -> Hamlet AppRoute +topbar :: ViewData -> HtmlUrl AppRoute topbar VD{..} = [$hamlet| String -> AppRoute -> String -> Hamlet AppRoute +navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute navlink VD{..} s dest title = [$hamlet| #{s} |] @@ -619,7 +615,7 @@ navlink VD{..} s dest title = [$hamlet| | otherwise = "navlink" :: Text -- | Links to the various journal editing forms. -editlinks :: Hamlet AppRoute +editlinks :: HtmlUrl AppRoute editlinks = [$hamlet| edit \ | # @@ -628,14 +624,14 @@ editlinks = [$hamlet| |] -- | Link to a topic in the manual. -helplink :: String -> String -> Hamlet AppRoute +helplink :: String -> String -> HtmlUrl AppRoute helplink topic label = [$hamlet| #{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| Hamlet AppRoute +addform :: ViewData -> HtmlUrl AppRoute addform vd@VD{..} = [$hamlet|