slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

web: update for yesod 0.9

Browse Source
This commit is contained in:
Simon Michael 2011-09-12 18:41:43 +00:00
parent 2f313663af
commit 7bc67a7f00
7 changed files with 340 additions and 199 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
hledger-web/Hledger/Web/App.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Web.App module Hledger.Web.App
( App (..) ( App (..)
, AppRoute (..) , AppRoute (..)
@ -6,46 +7,44 @@ module Hledger.Web.App
, Handler , Handler
, Widget , Widget
, module Yesod.Core , module Yesod.Core
-- , module Settings
, StaticRoute (..) , StaticRoute (..)
, lift , lift
, liftIO , liftIO
) where ) where
import Control.Monad import Control.Monad (unless)
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Lazy as L import Control.Monad.Trans.Class (lift)
import qualified Data.Text as T
import System.Directory import System.Directory
import Text.Hamlet hiding (hamletFile) import Text.Hamlet hiding (hamletFile)
import Web.ClientSession (getKey)
import Yesod.Core 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.Data
import Hledger.Web.Options import Hledger.Web.Options
import Hledger.Web.Settings import Hledger.Web.Settings
import Hledger.Web.StaticFiles import Hledger.Web.StaticFiles
-- | The site argument for your application. This can be a good place to -- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
-- access to the data present here. -- access to the data present here.
data App = App data App = App
{getStatic :: Static -- ^ Settings for static file serving. { settings :: Hledger.Web.Settings.AppConfig
,appRoot :: T.Text , getLogger :: Logger
, getStatic :: Static -- ^ Settings for static file serving.
,appOpts :: WebOpts ,appOpts :: WebOpts
,appArgs :: [String] ,appArgs :: [String]
,appJournal :: Journal ,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 -- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see: -- explanation of the syntax, please see:
-- http://docs.yesodweb.com/book/web-routes-quasi/ -- http://docs.yesodweb.com/book/web-routes-quasi/
@ -57,7 +56,7 @@ type Widget = GWidget App App
-- * Creates the associated type: -- * Creates the associated type:
-- type instance Route App = AppRoute -- type instance Route App = AppRoute
-- * Creates the value resourcesApp which contains information on the -- * 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 -- mkYesodDispatch
-- --
-- What this function does *not* do is create a YesodSite instance for -- 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 -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- of settings which can be configured by overriding methods here.
instance Yesod App where 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 defaultLayout widget = do
-- mmsg <- getMessage -- mmsg <- getMessage
pc <- widgetToPageContent $ do pc <- widgetToPageContent $ do
widget widget
-- addCassius $(Settings.cassiusFile "default-layout") -- addCassius $(cassiusFile "default-layout")
-- hamletToRepHtml $(hamletFile "default-layout")
hamletToRepHtml [$hamlet| hamletToRepHtml [$hamlet|
!!! !!!
<html <html
@ -96,22 +99,24 @@ instance Yesod App where
^{pageBody pc} ^{pageBody pc}
|] |]
-- -- This is done to provide an optimization for serving static files from -- This is done to provide an optimization for serving static files from
-- -- a separate domain. Please see the staticroot setting in Settings.hs -- a separate domain. Please see the staticroot setting in Settings.hs
-- urlRenderOverride a (StaticR s) = -- urlRenderOverride y (StaticR s) =
-- Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s -- Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
-- urlRenderOverride _ _ = Nothing -- urlRenderOverride _ _ = Nothing
messageLogger y loc level msg =
formatLogMessage loc level msg >>= logLazyText (getLogger y)
-- This function creates static content files in the static folder -- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows -- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of -- expiration dates to be set far in the future without worry of
-- users receiving stale content. -- users receiving stale content.
addStaticContent ext' _ content = do addStaticContent ext' _ content = do
let fn = base64md5 content ++ '.' : T.unpack ext' 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 liftIO $ createDirectoryIfMissing True statictmp
let fn' = statictmp ++ fn let fn' = statictmp ++ fn
exists <- liftIO $ doesFileExist fn' exists <- liftIO $ doesFileExist fn'
unless exists $ liftIO $ L.writeFile fn' content unless exists $ liftIO $ L.writeFile fn' content
return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], []) return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])

93
hledger-web/Hledger/Web/AppRun.hs
View File

@ -1,18 +1,20 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Hledger.Web.AppRun ( module Hledger.Web.AppRun (
withApp withApp
,withDevelApp ,withDevelAppPort
,withWaiHandlerDevelApp
) )
where where
import Data.Dynamic (Dynamic, toDyn) import Data.Dynamic (Dynamic, toDyn)
import Network.Wai (Application) import Network.Wai (Application)
import Network.Wai.Middleware.Debug (debugHandle)
import System.IO.Storage (withStore, putValue) 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
import Hledger.Cli import Hledger.Cli
@ -26,38 +28,71 @@ import Hledger.Web.Settings
-- the comments there for more details. -- the comments there for more details.
mkYesodDispatch "App" resourcesApp 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), -- This function allocates resources (such as a database connection pool),
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database -- place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
withApp :: App -> (Application -> IO a) -> IO a withApp :: AppConfig -> Logger -> (Application -> IO a) -> IO a
withApp a f = toWaiApp a >>= f withApp conf logger f = do
#ifdef PRODUCTION
-- Called by yesod devel. s <- static Hledger.Web.Settings.staticDir
withDevelApp :: Dynamic #else
withDevelApp = toDyn (withApp a :: (Application -> IO ()) -> IO ()) s <- staticDevel Hledger.Web.Settings.staticDir
where a = App{ #endif
getStatic=static Hledger.Web.Settings.staticdir let h = App {settings=conf
,appRoot=Hledger.Web.Settings.defapproot ,getLogger=logger
,getStatic=s
,appOpts=defwebopts ,appOpts=defwebopts
,appArgs=[] ,appArgs=[]
,appJournal=nulljournal ,appJournal=nulljournal
} }
toWaiApp h >>= f
-- Called by wai-handler-devel. -- withDevelApp :: Dynamic
-- Eg: cabal-dev/bin/wai-handler-devel 5001 AppRun withWaiHandlerDevelApp -- withDevelApp = do
withWaiHandlerDevelApp :: (Application -> IO ()) -> IO () -- s <- static Hledger.Web.Settings.staticdir
withWaiHandlerDevelApp func = do -- let a = App{
let f = "./test.journal" -- getStatic=s
ej <- readJournalFile Nothing f -- ,appRoot=Hledger.Web.Settings.defapproot
let Right j = ej -- ,appOpts=defwebopts
let a = App{ -- ,appArgs=[]
getStatic=static Hledger.Web.Settings.staticdir -- ,appJournal=nulljournal
,appRoot="http://localhost:5002" -- }
,appOpts=defwebopts{cliopts_=defcliopts{file_=Just f}} -- return $ toDyn (withApp a :: (Application -> IO ()) -> IO ())
,appArgs=[]
,appJournal=j -- for yesod devel
} withDevelAppPort :: Dynamic
withStore "hledger" $ do withDevelAppPort =
putValue "hledger" "journal" j toDyn go
withApp a func 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

74
hledger-web/Hledger/Web/Handlers.hs
View File

@ -17,10 +17,10 @@ import Data.Text(Text,pack,unpack)
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Format import Data.Time.Format
-- import Safe
import System.FilePath (takeFileName, (</>)) import System.FilePath (takeFileName, (</>))
import System.IO.Storage (putValue, getValue) import System.IO.Storage (putValue, getValue)
import System.Locale (defaultTimeLocale) import System.Locale (defaultTimeLocale)
import Text.Blaze (preEscapedString, toHtml)
import Text.Hamlet hiding (hamletFile) import Text.Hamlet hiding (hamletFile)
import Text.Printf import Text.Printf
import Yesod.Form import Yesod.Form
@ -34,7 +34,7 @@ import Hledger.Web.Settings
getFaviconR :: Handler () 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 :: Handler RepPlain
getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)
@ -187,11 +187,11 @@ getAccountsJsonR = do
-- view helpers -- view helpers
-- | Render the sidebar used on most views. -- | 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 sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport2 (reportopts_ $ cliopts_ opts) am j
-- | Render a "AccountsReport" as HTML. -- | Render a "AccountsReport" as HTML.
accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> Hamlet AppRoute accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> HtmlUrl AppRoute
accountsReportAsHtml _ vd@VD{..} (items',total) = accountsReportAsHtml _ vd@VD{..} (items',total) =
[$hamlet| [$hamlet|
<div#accountsheading <div#accountsheading
@ -234,7 +234,7 @@ accountsReportAsHtml _ vd@VD{..} (items',total) =
inacctmatcher = inAccountMatcher qopts inacctmatcher = inAccountMatcher qopts
allaccts = isNothing inacctmatcher allaccts = isNothing inacctmatcher
items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher 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| itemAsHtml _ (acct, adisplay, aindent, abal) = [$hamlet|
<tr.item.#{inacctclass} <tr.item.#{inacctclass}
<td.account.#{depthclass} <td.account.#{depthclass}
@ -272,14 +272,14 @@ accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced a -- (accountNameToAccountRe
accountUrl r a = (r, [("q",pack $ accountQuery a)]) accountUrl r a = (r, [("q",pack $ accountQuery a)])
-- | Render a "EntriesReport" as HTML for the journal entries view. -- | 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| entriesReportAsHtml _ vd items = [$hamlet|
<table.journalreport> <table.journalreport>
$forall i <- numbered items $forall i <- numbered items
^{itemAsHtml vd i} ^{itemAsHtml vd i}
|] |]
where where
itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> Hamlet AppRoute itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute
itemAsHtml _ (n, t) = [$hamlet| itemAsHtml _ (n, t) = [$hamlet|
<tr.item.#{evenodd}> <tr.item.#{evenodd}>
<td.transaction> <td.transaction>
@ -290,7 +290,7 @@ entriesReportAsHtml _ vd items = [$hamlet|
txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse
-- | Render an "TransactionsReport" as HTML for the formatted journal view. -- | 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| journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet|
<table.journalreport <table.journalreport
<tr.headings <tr.headings
@ -303,7 +303,7 @@ journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet|
|] |]
where where
-- .#{datetransition} -- .#{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| itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [$hamlet|
<tr.item.#{evenodd}.#{firstposting} <tr.item.#{evenodd}.#{firstposting}
<td.date>#{date} <td.date>#{date}
@ -328,14 +328,14 @@ $forall p <- tpostings t
showamt = not split || not (isZeroMixedAmount amt) showamt = not split || not (isZeroMixedAmount amt)
-- Generate html for an account register, including a balance chart and transaction list. -- 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| registerReportHtml opts vd r@(_,items) = [$hamlet|
^{registerChartHtml items} ^{registerChartHtml items}
^{registerItemsHtml opts vd r} ^{registerItemsHtml opts vd r}
|] |]
-- Generate html for a transaction list from an "TransactionsReport". -- 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| registerItemsHtml _ vd (balancelabel,items) = [$hamlet|
<table.registerreport <table.registerreport
<tr.headings <tr.headings
@ -353,7 +353,7 @@ registerItemsHtml _ vd (balancelabel,items) = [$hamlet|
where where
-- inacct = inAccount qopts -- inacct = inAccount qopts
-- filtering = m /= MatchAny -- 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| itemAsHtml VD{..} (n, newd, newm, _, (t, _, split, acct, amt, bal)) = [$hamlet|
<tr.item.#{evenodd}.#{firstposting}.#{datetransition} <tr.item.#{evenodd}.#{firstposting}.#{datetransition}
<td.date>#{date} <td.date>#{date}
@ -451,7 +451,7 @@ postRegisterR = handlePost
-- | Handle a post from any of the edit forms. -- | Handle a post from any of the edit forms.
handlePost :: Handler RepPlain handlePost :: Handler RepPlain
handlePost = do handlePost = do
action <- runFormPost' $ maybeStringInput "action" action <- lookupPostParam "action"
case action of Just "add" -> handleAdd case action of Just "add" -> handleAdd
Just "edit" -> handleEdit Just "edit" -> handleEdit
Just "import" -> handleImport Just "import" -> handleImport
@ -462,15 +462,13 @@ handleAdd :: Handler RepPlain
handleAdd = do handleAdd = do
VD{..} <- getViewData VD{..} <- getViewData
-- get form input values. M means a Maybe value. -- get form input values. M means a Maybe value.
(dateM, descM, acct1M, amt1M, acct2M, amt2M, journalM) <- runFormPost' dateM <- lookupPostParam "date"
$ (,,,,,,) descM <- lookupPostParam "description"
<$> maybeStringInput "date" acct1M <- lookupPostParam "account1"
<*> maybeStringInput "description" amt1M <- lookupPostParam "amount1"
<*> maybeStringInput "account1" acct2M <- lookupPostParam "account2"
<*> maybeStringInput "amount1" amt2M <- lookupPostParam "amount2"
<*> maybeStringInput "account2" journalM <- lookupPostParam "journal"
<*> maybeStringInput "amount2"
<*> maybeStringInput "journal"
-- supply defaults and parse date and amounts, or get errors. -- 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 let dateE = maybe (Left "date required") (either (\e -> Left $ showDateParseError e) Right . fixSmartDateStrEither today . unpack) dateM
descE = Right $ maybe "" unpack descM descE = Right $ maybe "" unpack descM
@ -506,7 +504,7 @@ handleAdd = do
Left errs -> do Left errs -> do
-- save current form values in session -- save current form values in session
-- setMessage $ toHtml $ intercalate "; " errs -- setMessage $ toHtml $ intercalate "; " errs
setMessage [$hamlet| setMessage [$shamlet|
Errors:<br> Errors:<br>
$forall e<-errs $forall e<-errs
#{e}<br> #{e}<br>
@ -518,7 +516,7 @@ handleAdd = do
liftIO $ do ensureJournalFile journalpath liftIO $ do ensureJournalFile journalpath
appendToJournalFileOrStdout journalpath $ showTransaction t' appendToJournalFileOrStdout journalpath $ showTransaction t'
-- setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String) -- 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")] redirectParams RedirectTemporary RegisterR [("add","1")]
chomp :: String -> String chomp :: String -> String
@ -530,10 +528,8 @@ handleEdit = do
VD{..} <- getViewData VD{..} <- getViewData
-- get form input values, or validation errors. -- get form input values, or validation errors.
-- getRequest >>= liftIO (reqRequestBody req) >>= mtrace -- getRequest >>= liftIO (reqRequestBody req) >>= mtrace
(textM, journalM) <- runFormPost' textM <- lookupPostParam "text"
$ (,) journalM <- lookupPostParam "journal"
<$> maybeStringInput "text"
<*> maybeStringInput "journal"
let textE = maybe (Left "No value provided") (Right . unpack) textM let textE = maybe (Left "No value provided") (Right . unpack) textM
journalE = maybe (Right $ journalFilePath j) journalE = maybe (Right $ journalFilePath j)
(\f -> let f' = unpack f in (\f -> let f' = unpack f in
@ -578,7 +574,7 @@ handleImport = do
setMessage "can't handle file upload yet" setMessage "can't handle file upload yet"
redirect RedirectTemporary JournalR redirect RedirectTemporary JournalR
-- -- get form input values, or basic validation errors. E means an Either value. -- -- 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 -- let fileE = maybe (Left "No file provided") Right fileM
-- -- display errors or import transactions -- -- display errors or import transactions
-- case fileE of -- case fileE of
@ -594,7 +590,7 @@ handleImport = do
-- | Other view components. -- | Other view components.
-- | Global toolbar/heading area. -- | Global toolbar/heading area.
topbar :: ViewData -> Hamlet AppRoute topbar :: ViewData -> HtmlUrl AppRoute
topbar VD{..} = [$hamlet| topbar VD{..} = [$hamlet|
<div#topbar <div#topbar
<a.topleftlink href=#{hledgerorgurl} title="More about hledger" <a.topleftlink href=#{hledgerorgurl} title="More about hledger"
@ -610,7 +606,7 @@ $maybe m <- msg
title = takeFileName $ journalFilePath j title = takeFileName $ journalFilePath j
-- | Navigation link, preserving parameters and possibly highlighted. -- | 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| navlink VD{..} s dest title = [$hamlet|
<a##{s}link.#{style} href=@?{u} title="#{title}">#{s} <a##{s}link.#{style} href=@?{u} title="#{title}">#{s}
|] |]
@ -619,7 +615,7 @@ navlink VD{..} s dest title = [$hamlet|
| otherwise = "navlink" :: Text | otherwise = "navlink" :: Text
-- | Links to the various journal editing forms. -- | Links to the various journal editing forms.
editlinks :: Hamlet AppRoute editlinks :: HtmlUrl AppRoute
editlinks = [$hamlet| editlinks = [$hamlet|
<a#editformlink href="#" onclick="return editformToggle(event)" title="Toggle journal edit form">edit <a#editformlink href="#" onclick="return editformToggle(event)" title="Toggle journal edit form">edit
\ | # \ | #
@ -628,14 +624,14 @@ editlinks = [$hamlet|
|] |]
-- | Link to a topic in the manual. -- | Link to a topic in the manual.
helplink :: String -> String -> Hamlet AppRoute helplink :: String -> String -> HtmlUrl AppRoute
helplink topic label = [$hamlet| helplink topic label = [$hamlet|
<a href=#{u} target=hledgerhelp>#{label} <a href=#{u} target=hledgerhelp>#{label}
|] |]
where u = manualurl ++ if null topic then "" else '#':topic where u = manualurl ++ if null topic then "" else '#':topic
-- | Search form for entering custom queries to filter journal data. -- | Search form for entering custom queries to filter journal data.
searchform :: ViewData -> Hamlet AppRoute searchform :: ViewData -> HtmlUrl AppRoute
searchform VD{..} = [$hamlet| searchform VD{..} = [$hamlet|
<div#searchformdiv <div#searchformdiv
<form#searchform.form method=GET <form#searchform.form method=GET
@ -676,7 +672,7 @@ searchform VD{..} = [$hamlet|
filtering = not $ null q filtering = not $ null q
-- | Add transaction form. -- | Add transaction form.
addform :: ViewData -> Hamlet AppRoute addform :: ViewData -> HtmlUrl AppRoute
addform vd@VD{..} = [$hamlet| addform vd@VD{..} = [$hamlet|
<script type=text/javascript> <script type=text/javascript>
$(document).ready(function() { $(document).ready(function() {
@ -779,7 +775,7 @@ addform vd@VD{..} = [$hamlet|
) )
-- | Edit journal form. -- | Edit journal form.
editform :: ViewData -> Hamlet AppRoute editform :: ViewData -> HtmlUrl AppRoute
editform VD{..} = [$hamlet| editform VD{..} = [$hamlet|
<form#editform method=POST style=display:none; <form#editform method=POST style=display:none;
<table.form <table.form
@ -809,7 +805,7 @@ editform VD{..} = [$hamlet|
formathelp = helplink "file-format" "file format help" formathelp = helplink "file-format" "file format help"
-- | Import journal form. -- | Import journal form.
importform :: Hamlet AppRoute importform :: HtmlUrl AppRoute
importform = [$hamlet| importform = [$hamlet|
<form#importform method=POST style=display:none; <form#importform method=POST style=display:none;
<table.form <table.form
@ -822,14 +818,14 @@ importform = [$hamlet|
<a href="#" onclick="return importformToggle(event)" cancel <a href="#" onclick="return importformToggle(event)" cancel
|] |]
journalselect :: [(FilePath,String)] -> Hamlet AppRoute journalselect :: [(FilePath,String)] -> HtmlUrl AppRoute
journalselect journalfiles = [$hamlet| journalselect journalfiles = [$hamlet|
<select id=journalselect name=journal onchange="editformJournalSelect(event)" <select id=journalselect name=journal onchange="editformJournalSelect(event)"
$forall f <- journalfiles $forall f <- journalfiles
<option value=#{fst f}>#{fst f} <option value=#{fst f}>#{fst f}
|] |]
nulltemplate :: Hamlet AppRoute nulltemplate :: HtmlUrl AppRoute
nulltemplate = [$hamlet||] nulltemplate = [$hamlet||]
---------------------------------------------------------------------- ----------------------------------------------------------------------

183
hledger-web/Hledger/Web/Settings.hs
View File

@ -1,8 +1,6 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
-- | Settings are centralized, as much as possible, into this file. This -- | Settings are centralized, as much as possible, into this file. This
-- includes database connection settings, static file locations, etc. -- includes database connection settings, static file locations, etc.
-- In addition, you can configure a number of different aspects of Yesod -- In addition, you can configure a number of different aspects of Yesod
@ -14,30 +12,36 @@ module Hledger.Web.Settings
, juliusFile , juliusFile
, luciusFile , luciusFile
, widgetFile , widgetFile
, datadir , staticRoot
, staticdir , staticDir
-- , staticroot , loadConfig
, AppEnvironment(..)
, AppConfig(..)
, defhost , defhost
, defport , defport
, defapproot , defapproot
-- , browserstartdelay
, hledgerorgurl , hledgerorgurl
, manualurl , manualurl
, datadir
) where ) where
import Data.Monoid (mempty) --, mappend) import qualified Text.Hamlet as S
import Data.Text (Text,pack) 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 Language.Haskell.TH.Syntax
import Yesod.Widget (addWidget, addCassius, addJulius, addLucius, whamletFile)
import Data.Monoid (mempty)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import Text.Printf (printf) import Data.Text (Text, pack)
import qualified Text.Hamlet as H import Data.Object
import qualified Text.Cassius as H import qualified Data.Object.Yaml as YAML
import qualified Text.Julius as H import Control.Monad (join)
import qualified Text.Lucius as H
import Yesod.Widget (addWidget, addCassius, addJulius, addLucius)
-- browserstartdelay = 100000 -- microseconds
hledgerorgurl, manualurl :: String hledgerorgurl, manualurl :: String
hledgerorgurl = "http://hledger.org" hledgerorgurl = "http://hledger.org"
@ -50,49 +54,88 @@ defport = 5000
defhost :: String defhost :: String
defhost = "localhost" defhost = "localhost"
-- | 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 :: Text
defapproot = pack $ printf "http://%s:%d" defhost defport 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/"
-- -- | The base URL for your static files. As you can see by the default data AppEnvironment = Test
-- -- value, this can simply be "static" appended to your application root. | Development
-- -- A powerful optimization can be serving static files from a separate | Staging
-- -- domain name. This allows you to use a web server optimized for static | Production
-- -- files, more easily set expires and cache values, and avoid possibly deriving (Eq, Show, Read, Enum, Bounded)
-- -- costly transference of cookies on static files. For more information,
-- -- please see: -- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml.
-- -- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain -- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments).
-- -- --
-- -- If you change the resource pattern for StaticR in hledger-web.hs, you will -- By convention these settings should be overwritten by any command line arguments.
-- -- have to make a corresponding change here. -- 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).
-- -- To see how this value is used, see urlRenderOverride in hledger-web.hs --
-- staticroot :: Text data AppConfig = AppConfig {
-- staticroot = defapproot `mappend` "/static" 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 -- | The location of static files on your system. This is a file system
-- path. The default value works properly with your scaffolded site. -- path. The default value works properly with your scaffolded site.
staticdir :: FilePath staticDir :: FilePath
staticdir = datadir++"static" --staticDir = "static"
staticDir = datadir++"static"
datadir :: FilePath
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 -- The rest of this file contains settings which rarely need changing by a
-- user. -- user.
-- The following three functions are used for calling HTML, CSS and -- The following functions are used for calling HTML, CSS,
-- Javascript templates from your Haskell code. During development, -- Javascript, and plain text templates from your Haskell code. During development,
-- the "Debug" versions of these functions are used so that changes to -- the "Debug" versions of these functions are used so that changes to
-- the templates are immediately reflected in an already running -- the templates are immediately reflected in an already running
-- application. When making a production compile, the non-debug version -- application. When making a production compile, the non-debug version
@ -104,44 +147,54 @@ staticdir = datadir++"static"
-- used; to get the same auto-loading effect, it is recommended that you -- used; to get the same auto-loading effect, it is recommended that you
-- use the devel server. -- use the devel server.
toHamletFile, toCassiusFile, toJuliusFile, toLuciusFile :: String -> FilePath -- | expects a root folder for each type, e.g: hamlet/ lucius/ julius/
toHamletFile x = datadir++"templates/" ++ x ++ ".hamlet" globFile :: String -> String -> FilePath
toCassiusFile x = datadir++"templates/" ++ x ++ ".cassius" -- globFile kind x = kind ++ "/" ++ x ++ "." ++ kind
toJuliusFile x = datadir++"templates/" ++ x ++ ".julius" globFile kind x = datadir ++ "templates/" ++ x ++ "." ++ kind
toLuciusFile x = datadir++"templates/" ++ x ++ ".lucius"
hamletFile :: FilePath -> Q Exp hamletFile :: FilePath -> Q Exp
hamletFile = H.hamletFile . toHamletFile hamletFile = S.hamletFile . globFile "hamlet"
cassiusFile :: FilePath -> Q Exp cassiusFile :: FilePath -> Q Exp
cassiusFile =
#ifdef PRODUCTION #ifdef PRODUCTION
cassiusFile = H.cassiusFile . toCassiusFile S.cassiusFile . globFile "cassius"
#else #else
cassiusFile = H.cassiusFileDebug . toCassiusFile S.cassiusFileDebug . globFile "cassius"
#endif #endif
luciusFile :: FilePath -> Q Exp luciusFile :: FilePath -> Q Exp
luciusFile =
#ifdef PRODUCTION #ifdef PRODUCTION
luciusFile = H.luciusFile . toLuciusFile S.luciusFile . globFile "lucius"
#else #else
luciusFile = H.luciusFileDebug . toLuciusFile S.luciusFileDebug . globFile "lucius"
#endif #endif
juliusFile :: FilePath -> Q Exp juliusFile :: FilePath -> Q Exp
juliusFile =
#ifdef PRODUCTION #ifdef PRODUCTION
juliusFile = H.juliusFile . toJuliusFile S.juliusFile . globFile "julius"
#else #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 #endif
widgetFile :: FilePath -> Q Exp widgetFile :: FilePath -> Q Exp
widgetFile x = do widgetFile x = do
let h = unlessExists toHamletFile hamletFile let h = whenExists (globFile "hamlet") (whamletFile . globFile "hamlet")
let c = unlessExists toCassiusFile cassiusFile let c = whenExists (globFile "cassius") cassiusFile
let j = unlessExists toJuliusFile juliusFile let j = whenExists (globFile "julius") juliusFile
let l = unlessExists toLuciusFile luciusFile let l = whenExists (globFile "lucius") luciusFile
[|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|] [|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|]
where where
unlessExists tofn f = do whenExists tofn f = do
e <- qRunIO $ doesFileExist $ tofn x e <- qRunIO $ doesFileExist $ tofn x
if e then f x else [|mempty|] if e then f x else [|mempty|]

6
hledger-web/Hledger/Web/StaticFiles.hs
View File

@ -11,8 +11,8 @@ This is a separate module to satisfy template haskell requirements.
-} -}
module Hledger.Web.StaticFiles where module Hledger.Web.StaticFiles where
import Yesod.Helpers.Static import Yesod.Static
import Hledger.Web.Settings (staticdir) import Hledger.Web.Settings (staticDir)
$(staticFiles staticdir) $(staticFiles staticDir)

39
hledger-web/hledger-web.cabal
View File

@ -63,40 +63,37 @@ executable hledger-web
,base >= 4 && < 5 ,base >= 4 && < 5
,bytestring ,bytestring
,cmdargs >= 0.8 && < 0.9 ,cmdargs >= 0.8 && < 0.9
-- ,containers
-- ,csv
,directory ,directory
,filepath ,filepath
-- ,mtl
,old-locale ,old-locale
-- ,old-time
,parsec ,parsec
-- ,process
,regexpr >= 0.5.1 ,regexpr >= 0.5.1
,safe >= 0.2 ,safe >= 0.2
-- ,split == 0.1.*
,text ,text
,time ,time
-- ,utf8-string >= 0.3.5 && < 0.4
,io-storage >= 0.3 && < 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 ,failure >= 0.1 && < 0.2
,file-embed == 0.0.* ,file-embed == 0.0.*
,template-haskell >= 2.4 && < 2.6 ,template-haskell >= 2.4 && < 2.6
-- ,yesod >= 0.8 && < 0.9
,yesod-core >= 0.8 && < 0.9 ,yesod >= 0.9.2.1 && < 0.10
,yesod-form == 0.1.* ,yesod-core
,yesod-json == 0.1.* ,yesod-form
,yesod-static == 0.1.* ,yesod-json
,aeson == 0.3.* ,yesod-static >= 0.3
,hamlet == 0.8.* ,aeson-native
,blaze-html
,clientsession
,data-object
,data-object-yaml
,hamlet
,shakespeare-css
,shakespeare-js
,shakespeare-text
,transformers ,transformers
,wai < 0.5 ,wai
,wai-extra < 0.5 ,wai-extra
,warp < 0.5 ,warp
-- , blaze-builder
-- , web-routes
library library
if flag(devel) if flag(devel)

83
hledger-web/hledger-web.hs
View File

@ -13,14 +13,15 @@ import Control.Monad
import Data.Maybe import Data.Maybe
import Data.Text(pack) import Data.Text(pack)
import Network.Wai.Handler.Warp (run) import Network.Wai.Handler.Warp (run)
#if PRODUCTION
#else
import Network.Wai.Middleware.Debug (debug)
#endif
import System.Exit import System.Exit
import System.IO.Storage (withStore, putValue) import System.IO.Storage (withStore, putValue)
import Text.Printf 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
import Hledger.Cli hiding (progname,progversion) import Hledger.Cli hiding (progname,progversion)
@ -74,17 +75,71 @@ web opts j = do
server :: String -> Int -> WebOpts -> Journal -> IO () server :: String -> Int -> WebOpts -> Journal -> IO ()
server baseurl port opts j = do server baseurl port opts j = do
printf "Starting http server on port %d with base url %s\n" port baseurl printf "Starting http server on port %d with base url %s\n" port baseurl
let a = App{getStatic=static staticdir -- let a = App{getStatic=static staticdir
,appRoot=pack baseurl -- ,appRoot=pack baseurl
,appOpts=opts -- ,appOpts=opts
,appArgs=patterns_ $ reportopts_ $ cliopts_ opts -- ,appArgs=patterns_ $ reportopts_ $ cliopts_ opts
,appJournal=j -- ,appJournal=j
} -- }
withStore "hledger" $ do withStore "hledger" $ do
putValue "hledger" "journal" j 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 #if PRODUCTION
withApp a (run port) withApp c logger $ run (appPort c)
#else #else
withApp a (run port . debug) logString logger $ (show env) ++ " application launched, listening on port " ++ show (appPort c)
withApp c logger $ run (appPort c) . debugHandle (logHandle logger)
flushLogger logger
where
logHandle logger msg = logLazyText logger msg >> flushLogger logger
#endif #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