hledger-web 0.18.2 → 0.19
raw patch · 24 files changed
+1637/−1457 lines, 24 filesdep +bytestringdep +data-defaultdep +hjsmindep −cabal-file-thdep ~basedep ~blaze-htmldep ~clientsession
Dependencies added: bytestring, data-default, hjsmin, hledger-web, http-conduit, monad-control, shakespeare-css, shakespeare-js, yesod-form, yesod-test
Dependencies removed: cabal-file-th
Dependency ranges changed: base, blaze-html, clientsession, cmdargs, directory, hamlet, hledger, hledger-lib, shakespeare-text, text, transformers, wai-extra, warp, yaml, yesod, yesod-core, yesod-default, yesod-static
Files
- Application.hs +54/−0
- Foundation.hs +159/−0
- Handler/Handlers.hs +976/−0
- Hledger/Web.hs +4/−18
- Hledger/Web/Application.hs +0/−58
- Hledger/Web/Foundation.hs +0/−109
- Hledger/Web/Handlers.hs +0/−974
- Hledger/Web/Import.hs +0/−16
- Hledger/Web/Main.hs +90/−0
- Hledger/Web/Options.hs +6/−8
- Hledger/Web/Settings.hs +0/−89
- Hledger/Web/Settings/StaticFiles.hs +0/−37
- Import.hs +28/−0
- Settings.hs +85/−0
- Settings/Development.hs +14/−0
- Settings/StaticFiles.hs +32/−0
- app/main.hs +11/−0
- config/routes +10/−0
- hledger-web.cabal +148/−45
- hledger-web.hs +0/−93
- messages/en.msg +1/−0
- models +0/−0
- routes +0/−10
- tests/main.hs +19/−0
+ Application.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Application+ ( makeApplication+ , getApplicationDev+ , makeFoundation+ ) where++import Import+import Yesod.Default.Config+import Yesod.Default.Main+import Yesod.Default.Handlers+import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)+import Network.HTTP.Conduit (newManager, def)++-- Import all relevant handler modules here.+-- Don't forget to add new modules to your cabal file!+-- import Handler.Home+import Handler.Handlers++import Hledger.Web.Options++-- This line actually creates our YesodDispatch instance. It is the second half+-- of the call to mkYesodData which occurs in Foundation.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.+makeApplication :: AppConfig DefaultEnv Extra -> IO Application+makeApplication conf = do+ foundation <- makeFoundation conf+ app <- toWaiAppPlain foundation+ return $ logWare app+ where+ logWare = if development then logStdoutDev+ else logStdout++makeFoundation :: AppConfig DefaultEnv Extra -> IO App+makeFoundation conf = do+ manager <- newManager def+ s <- staticSite+ return $ App conf s manager+ defwebopts++-- for yesod devel+getApplicationDev :: IO (Int, Application)+getApplicationDev =+ defaultDevelApp loader makeApplication+ where+ loader = loadConfig (configSettings Development)+ { csParseExtra = parseExtra+ }
+ Foundation.hs view
@@ -0,0 +1,159 @@+{-++Define the web application's foundation, in the usual Yesod style.+See a default Yesod app's comments for more details of each part.++-}+module Foundation where++import Prelude+import Yesod+import Yesod.Static+import Yesod.Default.Config+#ifndef DEVELOPMENT+import Yesod.Default.Util (addStaticContentExternal)+#endif+import Network.HTTP.Conduit (Manager)+-- import qualified Settings+import Settings.Development (development)+import Settings.StaticFiles+import Settings ({-widgetFile,-} Extra (..))+#ifndef DEVELOPMENT+import Settings (staticDir)+import Text.Jasmine (minifym)+#endif+import Web.ClientSession (getKey)+-- import Text.Hamlet (hamletFile)++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 :: AppConfig DefaultEnv Extra+ , getStatic :: Static -- ^ Settings for static file serving.+ , httpManager :: Manager+ --+ , appOpts :: WebOpts+ }++-- Set up i18n messages. See the message folder.+mkMessage "App" "messages" "en"++-- This is where we define all of the routes in our application. For a full+-- explanation of the syntax, please see:+-- http://www.yesodweb.com/book/handler+--+-- 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 "config/routes")++-- | A convenience alias.+type AppRoute = Route App++type Form x = Html -> MForm App App (FormResult x, Widget)++-- 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 = ApprootMaster $ appRoot . settings++ -- Store session data on the client in encrypted cookies,+ -- default session idle timeout is 120 minutes+ makeSessionBackend _ = do+ key <- getKey ".hledger-web_client_session_key.aes"+ return . Just $ clientSessionBackend key 120++ -- defaultLayout widget = do+ -- master <- getYesod+ -- mmsg <- getMessage++ -- -- We break up the default layout into two components:+ -- -- default-layout is the contents of the body tag, and+ -- -- default-layout-wrapper is the entire page. Since the final+ -- -- value passed to hamletToRepHtml cannot be a widget, this allows+ -- -- you to use normal widget features in default-layout.++ -- pc <- widgetToPageContent $ do+ -- $(widgetFile "normalize")+ -- addStylesheet $ StaticR css_bootstrap_css+ -- $(widgetFile "default-layout")+ -- hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")++ defaultLayout widget = do + pc <- widgetToPageContent $ do+ widget+ hamletToRepHtml [hamlet|+$doctype 5+<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++#ifndef DEVELOPMENT+ -- 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 = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute [])+#endif++ -- Place Javascript at bottom of the body tag so the rest of the page loads first+ jsLoader _ = BottomOfBody++ -- What messages should be logged. The following includes all messages when+ -- in development, and warnings and errors in production.+ shouldLog _ _source level =+ development || level == LevelWarn || level == LevelError++-- This instance is required to use forms. You can modify renderMessage to+-- achieve customized and internationalized form validation messages.+instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++-- | Get the 'Extra' value, used to hold data from the settings.yml file.+getExtra :: Handler Extra+getExtra = fmap (appExtra . settings) getYesod++-- Note: previous versions of the scaffolding included a deliver function to+-- send emails. Unfortunately, there are too many different options for us to+-- give a reasonable default. Instead, the information is available on the+-- wiki:+--+-- https://github.com/yesodweb/yesod/wiki/Sending-email
+ Handler/Handlers.hs view
@@ -0,0 +1,976 @@+{-# LANGUAGE RecordWildCards #-}+{-++hledger-web's request handlers, and helpers.++-}++module Handler.Handlers+(+ -- * GET handlers+ getRootR,+ getJournalR,+ getJournalEntriesR,+ getJournalEditR,+ getRegisterR,+ -- ** helpers+ -- sidebar,+ -- accountsReportAsHtml,+ -- accountQuery,+ -- accountOnlyQuery,+ -- accountUrl,+ -- entriesReportAsHtml,+ -- journalTransactionsReportAsHtml,+ -- registerReportHtml,+ -- registerItemsHtml,+ -- registerChartHtml,+ -- stringIfLongerThan,+ -- numberTransactionsReportItems,+ -- mixedAmountAsHtml,+ -- * POST handlers+ postJournalR,+ postJournalEntriesR,+ postJournalEditR,+ postRegisterR,+ -- * Common page components+ -- * Utilities+ ViewData(..),+ nullviewdata,+)+where++import Prelude+import Control.Applicative ((<$>))+import Control.Monad.IO.Class (liftIO)+import Data.Either (lefts,rights)+import Data.List+import Data.Maybe+import Data.Text(Text,pack,unpack)+import qualified Data.Text (null)+import Data.Time.Calendar+import Data.Time.Clock+import Data.Time.Format+import System.FilePath (takeFileName)+import System.IO.Storage (putValue, getValue)+import System.Locale (defaultTimeLocale)+#if BLAZE_HTML_0_5+import Text.Blaze.Internal (preEscapedString)+import Text.Blaze.Html (toHtml)+#else+import Text.Blaze (preEscapedString, toHtml)+#endif+import Text.Hamlet -- hiding (hamlet)+import Text.Printf+import Yesod.Core+-- import Yesod.Json++import Foundation+import Settings++import Hledger hiding (is)+import Hledger.Cli hiding (version)+import Hledger.Web.Options++-- routes:+-- /static StaticR Static getStatic+-- -- /favicon.ico FaviconR GET+-- /robots.txt RobotsR GET+-- / RootR GET+-- /journal JournalR GET POST+-- /journal/entries JournalEntriesR GET POST+-- /journal/edit JournalEditR GET POST+-- /register RegisterR GET POST+-- -- /accounts AccountsR GET+-- -- /api/accounts AccountsJsonR GET++----------------------------------------------------------------------+-- GET handlers++getRootR :: Handler RepHtml+getRootR = redirect defaultroute where defaultroute = RegisterR++-- | The formatted journal view, with sidebar.+getJournalR :: Handler RepHtml+getJournalR = do+ vd@VD{..} <- getViewData+ let sidecontent = sidebar vd+ -- XXX like registerReportAsHtml+ inacct = inAccount qopts+ -- injournal = isNothing inacct+ filtering = m /= Any+ -- showlastcolumn = if injournal && not filtering then False else True+ title = case inacct of+ Nothing -> "Journal"++s2+ Just (a,inclsubs) -> "Transactions in "++a++s1++s2+ where s1 = if inclsubs then " (and subaccounts)" else ""+ where+ s2 = if filtering then ", filtered" else ""+ maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m+ defaultLayout $ do+ setTitle "hledger-web journal"+ toWidget [hamlet|+^{topbar vd}+<div#content>+ <div#sidebar>+ ^{sidecontent}+ <div#main.register>+ <div#maincontent>+ <h2#contenttitle>#{title}+ ^{searchform vd}+ ^{maincontent}+ ^{addform vd}+ ^{editform vd}+ ^{importform}+|]++-- | The journal entries view, with sidebar.+getJournalEntriesR :: Handler RepHtml+getJournalEntriesR = do+ vd@VD{..} <- getViewData+ let+ sidecontent = sidebar vd+ title = "Journal entries" ++ if m /= Any then ", filtered" else "" :: String+ maincontent = entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) Any $ filterJournalTransactions m j+ defaultLayout $ do+ setTitle "hledger-web journal"+ toWidget [hamlet|+^{topbar vd}+<div#content>+ <div#sidebar>+ ^{sidecontent}+ <div#main.journal>+ <div#maincontent>+ <h2#contenttitle>#{title}+ ^{searchform vd}+ ^{maincontent}+ ^{addform vd}+ ^{editform vd}+ ^{importform}+|]++-- | The journal editform, no sidebar.+getJournalEditR :: Handler RepHtml+getJournalEditR = do+ vd <- getViewData+ defaultLayout $ do+ setTitle "hledger-web journal edit form"+ toWidget $ editform vd++-- -- | The journal entries view, no sidebar.+-- getJournalOnlyR :: Handler RepHtml+-- getJournalOnlyR = do+-- vd@VD{..} <- getViewData+-- defaultLayout $ do+-- setTitle "hledger-web journal only"+-- toWidget $ entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) nullfilterspec $ filterJournalTransactions2 m j++-- | The main journal/account register view, with accounts sidebar.+getRegisterR :: Handler RepHtml+getRegisterR = do+ vd@VD{..} <- getViewData+ let sidecontent = sidebar vd+ -- injournal = isNothing inacct+ filtering = m /= Any+ title = "Transactions in "++a++s1++s2+ where+ (a,inclsubs) = fromMaybe ("all accounts",False) $ inAccount qopts+ s1 = if inclsubs then " (and subaccounts)" else ""+ s2 = if filtering then ", filtered" else ""+ maincontent = registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts+ defaultLayout $ do+ setTitle "hledger-web register"+ toWidget [hamlet|+^{topbar vd}+<div#content>+ <div#sidebar>+ ^{sidecontent}+ <div#main.register>+ <div#maincontent>+ <h2#contenttitle>#{title}+ ^{searchform vd}+ ^{maincontent}+ ^{addform vd}+ ^{editform vd}+ ^{importform}+|]++-- -- | The register view, no sidebar.+-- getRegisterOnlyR :: Handler RepHtml+-- getRegisterOnlyR = do+-- vd@VD{..} <- getViewData+-- defaultLayout $ do+-- setTitle "hledger-web register only"+-- toWidget $+-- case inAccountQuery qopts of Just m' -> registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m m'+-- Nothing -> registerReportHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m++{-+-- | A simple accounts view. This one is json-capable, returning the chart+-- of accounts as json if the Accept header specifies json.+getAccountsR :: Handler RepHtmlJson+getAccountsR = do+ vd@VD{..} <- getViewData+ let j' = filterJournalPostings2 m j+ html = do+ setTitle "hledger-web accounts"+ toWidget $ accountsReportAsHtml opts vd $ accountsReport2 (reportopts_ $ cliopts_ opts) am j'+ json = jsonMap [("accounts", toJSON $ journalAccountNames j')]+ defaultLayoutJson html json++-- | A json-only version of "getAccountsR", does not require the special Accept header.+getAccountsJsonR :: Handler RepJson+getAccountsJsonR = do+ VD{..} <- getViewData+ let j' = filterJournalPostings2 m j+ jsonToRepJson $ jsonMap [("accounts", toJSON $ journalAccountNames j')]+-}++-- helpers++-- | Render the sidebar used on most views.+sidebar :: ViewData -> HtmlUrl AppRoute+sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport (reportopts_ $ cliopts_ opts) am j++-- | Render an "AccountsReport" as html.+accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> HtmlUrl AppRoute+accountsReportAsHtml _ vd@VD{..} (items',total) =+ [hamlet|+<div#accountsheading>+ <a#accounts-toggle-link.togglelink href="#" title="Toggle sidebar">[+]+<div#accounts>+ <table.balancereport>+ <tr>+ <td.add colspan=3>+ <br>+ <a#addformlink href="#" onclick="return addformToggle(event)" title="Add a new transaction to the journal">Add a transaction..++ <tr.item :allaccts:.inacct>+ <td.journal colspan=3>+ <br>+ <a href=@{JournalR} title="Show all transactions in journal format">Journal+ <span.hoverlinks>+ + <a href=@{JournalEntriesR} title="Show journal entries">entries+ + <a#editformlink href="#" onclick="return editformToggle(event)" title="Edit the journal">+ edit++ <tr>+ <td colspan=3>+ <br>+ Accounts++ $forall i <- items+ ^{itemAsHtml vd i}++ <tr.totalrule>+ <td colspan=3>+ <tr>+ <td>+ <td.balance align=right>#{mixedAmountAsHtml total}+ <td>+|]+ where+ l = ledgerFromJournal Any j+ inacctmatcher = inAccountQuery qopts+ allaccts = isNothing inacctmatcher+ items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher+ itemAsHtml :: ViewData -> AccountsReportItem -> HtmlUrl AppRoute+ itemAsHtml _ (acct, adisplay, aindent, abal) = [hamlet|+<tr.item.#{inacctclass}>+ <td.account.#{depthclass}>+ #{indent}+ <a href="@?{acctquery}" title="Show transactions in this account, including subaccounts">#{adisplay}+ <span.hoverlinks>+ $if hassubs+ + <a href="@?{acctonlyquery}" title="Show transactions in this account only">only+ <!--+ + <a href="@?{acctsonlyquery}" title="Focus on this account and sub-accounts and hide others">-others -->++ <td.balance align=right>#{mixedAmountAsHtml abal}+|]+ where+ hassubs = not $ maybe False (null.asubs) $ ledgerAccount l acct+ -- <td.numpostings align=right title="#{numpostings} transactions in this account">(#{numpostings})+ -- numpostings = maybe 0 (length.apostings) $ ledgerAccount l acct+ depthclass = "depth"++show aindent+ inacctclass = case inacctmatcher of+ Just m' -> if m' `matchesAccount` acct then "inacct" else "notinacct"+ Nothing -> "" :: String+ indent = preEscapedString $ concat $ replicate (2 * (1+aindent)) " "+ acctquery = (RegisterR, [("q", pack $ accountQuery acct)])+ acctonlyquery = (RegisterR, [("q", pack $ accountOnlyQuery acct)])++accountQuery :: AccountName -> String+accountQuery a = "inacct:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a)++accountOnlyQuery :: AccountName -> String+accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a)++accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])+accountUrl r a = (r, [("q", pack $ accountQuery a)])++-- | Render an "EntriesReport" as html for the journal entries view.+entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> HtmlUrl AppRoute+entriesReportAsHtml _ vd items = [hamlet|+<table.journalreport>+ $forall i <- numbered items+ ^{itemAsHtml vd i}+ |]+ where+ itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute+ itemAsHtml _ (n, t) = [hamlet|+<tr.item.#{evenodd}>+ <td.transaction>+ <pre>#{txn}+ |]+ where+ evenodd = if even n then "even" else "odd" :: String+ txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse++-- | Render a "TransactionsReport" as html for the formatted journal view.+journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute+journalTransactionsReportAsHtml _ vd (_,items) = [hamlet|+<table.journalreport>+ <tr.headings>+ <th.date align=left>Date+ <th.description align=left>Description+ <th.account align=left>Accounts+ <th.amount align=right>Amount+ $forall i <- numberTransactionsReportItems items+ ^{itemAsHtml vd i}+ |]+ where+-- .#{datetransition}+ itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute+ itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [hamlet|+<tr.item.#{evenodd}.#{firstposting}>+ <td.date>#{date}+ <td.description colspan=2 title="#{show t}">#{elideRight 60 desc}+ <td.amount align=right>+ $if showamt+ #{mixedAmountAsHtml amt}+$forall p' <- tpostings t+ <tr.item.#{evenodd}.posting>+ <td.date>+ <td.description>+ <td.account> <a href="@?{accountUrl here $ paccount p'}" title="Show transactions in #{paccount p'}">#{elideRight 40 $ paccount p'}+ <td.amount align=right>#{mixedAmountAsHtml $ pamount p'}+|]+ where+ evenodd = if even n then "even" else "odd" :: String+ -- datetransition | newm = "newmonth"+ -- | newd = "newday"+ -- | otherwise = "" :: String+ (firstposting, date, desc) = (False, show $ tdate t, tdescription t)+ -- acctquery = (here, [("q", pack $ accountQuery acct)])+ showamt = not split || not (isZeroMixedAmount amt)++-- Generate html for an account register, including a balance chart and transaction list.+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 -> HtmlUrl AppRoute+registerItemsHtml _ vd (balancelabel,items) = [hamlet|+<table.registerreport>+ <tr.headings>+ <th.date align=left>Date+ <th.description align=left>Description+ <th.account align=left>To/From Account+ <!-- \ #+ <a#all-postings-toggle-link.togglelink href="#" title="Toggle all split postings">[+] -->+ <th.amount align=right>Amount+ <th.balance align=right>#{balancelabel}++ $forall i <- numberTransactionsReportItems items+ ^{itemAsHtml vd i}+ |]+ where+ -- inacct = inAccount qopts+ -- filtering = m /= Any+ 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}+ <td.description title="#{show t}">#{elideRight 30 desc}+ <td.account title="#{show t}">+ <a>+ #{elideRight 40 acct}+ + <a.postings-toggle-link.togglelink href="#" title="Toggle all postings">+ [+]+ <td.amount align=right>+ $if showamt+ #{mixedAmountAsHtml amt}+ <td.balance align=right>#{mixedAmountAsHtml bal}+$forall p' <- tpostings t+ <tr.item.#{evenodd}.posting style=#{postingsdisplaystyle}>+ <td.date>+ <td.description>+ <td.account> <a href="@?{accountUrl here $ paccount p'}" title="Show transactions in #{paccount p'}">#{elideRight 40 $ paccount p'}+ <td.amount align=right>#{mixedAmountAsHtml $ pamount p'}+ <td.balance align=right>+|]+ where+ evenodd = if even n then "even" else "odd" :: String+ datetransition | newm = "newmonth"+ | newd = "newday"+ | otherwise = "" :: String+ (firstposting, date, desc) = (False, show $ tdate t, tdescription t)+ -- acctquery = (here, [("q", pack $ accountQuery acct)])+ showamt = not split || not (isZeroMixedAmount amt)+ postingsdisplaystyle = if showpostings then "" else "display:none;" :: String++-- | Generate javascript/html for a register balance line chart based on+-- the provided "TransactionsReportItem"s.+ -- registerChartHtml :: forall t (t1 :: * -> *) t2 t3 t4 t5.+ -- Data.Foldable.Foldable t1 =>+ -- t1 (Transaction, t2, t3, t4, t5, MixedAmount)+ -- -> t -> Text.Blaze.Internal.HtmlM ()+registerChartHtml :: [TransactionsReportItem] -> HtmlUrl AppRoute+registerChartHtml items =+ -- have to make sure plot is not called when our container (maincontent)+ -- is hidden, eg with add form toggled+ [hamlet|+<div#register-chart style="width:600px;height:100px; margin-bottom:1em;">+<script type=text/javascript>+ \$(document).ready(function() {+ /* render chart with flot, if visible */+ var chartdiv = $('#register-chart');+ if (chartdiv.is(':visible'))+ \$.plot(chartdiv,+ [+ [+ $forall i <- items+ [#{dayToJsTimestamp $ triDate i}, #{triBalance i}],+ ]+ ],+ {+ xaxis: {+ mode: "time",+ timeformat: "%y/%m/%d"+ }+ }+ );+ });+|]++-- stringIfLongerThan :: Int -> String -> String+-- stringIfLongerThan n s = if length s > n then s else ""++numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]+numberTransactionsReportItems [] = []+numberTransactionsReportItems items = number 0 nulldate items+ where+ number :: Int -> Day -> [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]+ number _ _ [] = []+ number n prevd (i@(Transaction{tdate=d},_,_,_,_,_):is) = (n+1,newday,newmonth,newyear,i):(number (n+1) d is)+ where+ newday = d/=prevd+ newmonth = dm/=prevdm || dy/=prevdy+ newyear = dy/=prevdy+ (dy,dm,_) = toGregorian d+ (prevdy,prevdm,_) = toGregorian prevd++mixedAmountAsHtml :: MixedAmount -> Html+mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "<br>" $ lines $ showMixedAmount b+ where addclass = printf "<span class=\"%s\">%s</span>" (c :: String)+ c = case isNegativeMixedAmount b of Just True -> "negative amount"+ _ -> "positive amount"++-------------------------------------------------------------------------------+-- POST handlers++postJournalR :: Handler RepHtml+postJournalR = handlePost++postJournalEntriesR :: Handler RepHtml+postJournalEntriesR = handlePost++postJournalEditR :: Handler RepHtml+postJournalEditR = handlePost++postRegisterR :: Handler RepHtml+postRegisterR = handlePost++-- | Handle a post from any of the edit forms.+handlePost :: Handler RepHtml+handlePost = do+ action <- lookupPostParam "action"+ case action of Just "add" -> handleAdd+ Just "edit" -> handleEdit+ Just "import" -> handleImport+ _ -> invalidArgs [pack "invalid action"]++-- | Handle a post from the transaction add form.+handleAdd :: Handler RepHtml+handleAdd = do+ VD{..} <- getViewData+ -- get form input values. M means a Maybe value.+ 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+ maybeNonNull = maybe Nothing (\t -> if Data.Text.null t then Nothing else Just t)+ acct1E = maybe (Left "to account required") (Right . unpack) $ maybeNonNull acct1M+ acct2E = maybe (Left "from account required") (Right . unpack) $ maybeNonNull acct2M+ amt1E = maybe (Left "amount required") (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx amount . unpack) amt1M+ amt2E = maybe (Right missingmixedamt) (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx amount . unpack) amt2M+ journalE = maybe (Right $ journalFilePath j)+ (\f -> let f' = unpack f in+ if f' `elem` journalFilePaths j+ then Right f'+ else Left $ "unrecognised journal file path: " ++ f'+ )+ journalM+ strEs = [dateE, descE, acct1E, acct2E, journalE]+ amtEs = [amt1E, amt2E]+ errs = lefts strEs ++ lefts amtEs+ [date,desc,acct1,acct2,journalpath] = rights strEs+ [amt1,amt2] = rights amtEs+ -- if no errors so far, generate a transaction and balance it or get the error.+ tE | not $ null errs = Left errs+ | otherwise = either (\e -> Left ["unbalanced postings: " ++ (head $ lines e)]) Right+ (balanceTransaction Nothing $ nulltransaction { -- imprecise balancing+ tdate=parsedate date+ ,tdescription=desc+ ,tpostings=[+ Posting False acct1 amt1 "" RegularPosting [] Nothing+ ,Posting False acct2 amt2 "" RegularPosting [] Nothing+ ]+ })+ -- display errors or add transaction+ case tE of+ Left errs' -> do+ -- save current form values in session+ -- setMessage $ toHtml $ intercalate "; " errs+ setMessage [shamlet|+ Errors:<br>+ $forall e<-errs'+ #{e}<br>+ |]+ Right t -> do+ let t' = txnTieKnot t -- XXX move into balanceTransaction+ liftIO $ do ensureJournalFileExists journalpath+ appendToJournalFileOrStdout journalpath $ showTransaction t'+ -- setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String)+ setMessage [shamlet|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|]++ redirect (RegisterR, [("add","1")])++chomp :: String -> String+chomp = reverse . dropWhile (`elem` "\r\n") . reverse++-- | Handle a post from the journal edit form.+handleEdit :: Handler RepHtml+handleEdit = do+ VD{..} <- getViewData+ -- get form input values, or validation errors.+ -- getRequest >>= liftIO (reqRequestBody req) >>= mtrace+ 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+ if f' `elem` journalFilePaths j+ then Right f'+ else Left "unrecognised journal file path")+ journalM+ strEs = [textE, journalE]+ errs = lefts strEs+ [text,journalpath] = rights strEs+ -- display errors or perform edit+ if not $ null errs+ then do+ setMessage $ toHtml (intercalate "; " errs :: String)+ redirect JournalR++ else do+ -- try to avoid unnecessary backups or saving invalid data+ filechanged' <- liftIO $ journalSpecifiedFileIsNewer j journalpath+ told <- liftIO $ readFileStrictly journalpath+ let tnew = filter (/= '\r') text+ changed = tnew /= told || filechanged'+ if not changed+ then do+ setMessage "No change"+ redirect JournalR+ else do+ jE <- liftIO $ readJournal Nothing Nothing (Just journalpath) tnew+ either+ (\e -> do+ setMessage $ toHtml e+ redirect JournalR)+ (const $ do+ liftIO $ writeFileWithBackup journalpath tnew+ setMessage $ toHtml (printf "Saved journal %s\n" (show journalpath) :: String)+ redirect JournalR)+ jE++-- | Handle a post from the journal import form.+handleImport :: Handler RepHtml+handleImport = do+ setMessage "can't handle file upload yet"+ redirect JournalR+ -- -- get form input values, or basic validation errors. E means an Either value.+ -- fileM <- runFormPost $ maybeFileInput "file"+ -- let fileE = maybe (Left "No file provided") Right fileM+ -- -- display errors or import transactions+ -- case fileE of+ -- Left errs -> do+ -- setMessage errs+ -- redirect JournalR++ -- Right s -> do+ -- setMessage s+ -- redirect JournalR++----------------------------------------------------------------------+-- Common page components.++-- | Global toolbar/heading area.+topbar :: ViewData -> HtmlUrl AppRoute+topbar VD{..} = [hamlet|+<div#topbar>+ <a.topleftlink href=#{hledgerorgurl} title="More about hledger">+ hledger-web+ <br />+ #{version}+ <a.toprightlink href=#{manualurl} target=hledgerhelp title="User manual">manual+ <h1>#{title}+$maybe m' <- msg+ <div#message>#{m'}+|]+ where+ title = takeFileName $ journalFilePath j++-- -- | Navigation link, preserving parameters and possibly highlighted.+-- navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute+-- navlink VD{..} s dest title = [hamlet|+-- <a##{s}link.#{style} href=@?{u'} title="#{title}">#{s}+-- |]+-- where u' = (dest, if null q then [] else [("q", pack q)])+-- style | dest == here = "navlinkcurrent"+-- | otherwise = "navlink" :: Text++-- -- | Links to the various journal editing forms.+-- editlinks :: HtmlUrl AppRoute+-- editlinks = [hamlet|+-- <a#editformlink href="#" onclick="return editformToggle(event)" title="Toggle journal edit form">edit+-- \ | #+-- <a#addformlink href="#" onclick="return addformToggle(event)" title="Toggle transaction add form">add+-- <a#importformlink href="#" onclick="return importformToggle(event)" style="display:none;">import transactions+-- |]++-- | Link to a topic in the manual.+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 -> HtmlUrl AppRoute+searchform VD{..} = [hamlet|+<div#searchformdiv>+ <form#searchform.form method=GET>+ <table>+ <tr>+ <td>+ Search:+ \ #+ <td>+ <input name=q size=70 value=#{q}>+ <input type=submit value="Search">+ $if filtering+ \ #+ <span.showall>+ <a href=@{here}>clear search+ \ #+ <a#search-help-link href="#" title="Toggle search help">help+ <tr>+ <td>+ <td>+ <div#search-help.help style="display:none;">+ Leave blank to see journal (all transactions), or click account links to see transactions under that account.+ <br>+ Transactions/postings may additionally be filtered by:+ <br>+ acct:REGEXP (target account), #+ desc:REGEXP (description), #+ date:PERIODEXP (date), #+ edate:PERIODEXP (effective date), #+ <br>+ status:BOOL (cleared status), #+ real:BOOL (real/virtual-ness), #+ empty:BOOL (posting amount = 0).+ <br>+ not: to negate, enclose space-containing patterns in quotes, multiple filters are AND'ed.+|]+ where+ filtering = not $ null q++-- | Add transaction form.+addform :: ViewData -> HtmlUrl AppRoute+addform vd@VD{..} = [hamlet|+<script type=text/javascript>+ \$(document).ready(function() {+ /* dhtmlxcombo setup */+ window.dhx_globalImgPath="../static/";+ var desccombo = new dhtmlXCombo("description");+ var acct1combo = new dhtmlXCombo("account1");+ var acct2combo = new dhtmlXCombo("account2");+ desccombo.enableFilteringMode(true);+ acct1combo.enableFilteringMode(true);+ acct2combo.enableFilteringMode(true);+ desccombo.setSize(300);+ acct1combo.setSize(300);+ acct2combo.setSize(300);+ /* desccombo.enableOptionAutoHeight(true, 20); */+ /* desccombo.setOptionHeight(200); */+ });++<form#addform method=POST style=display:none;>+ <h2#contenttitle>#{title}+ <table.form>+ <tr>+ <td colspan=4>+ <table>+ <tr#descriptionrow>+ <td>+ Date:+ <td>+ <input.textinput size=15 name=date value=#{date}>+ <td style=padding-left:1em;>+ Description:+ <td>+ <select id=description name=description>+ <option>+ $forall d <- descriptions+ <option value=#{d}>#{d}+ <tr.helprow>+ <td>+ <td>+ <span.help>#{datehelp} #+ <td>+ <td>+ <span.help>#{deschelp}+ ^{postingfields vd 1}+ ^{postingfields vd 2}+ <tr#addbuttonrow>+ <td colspan=4>+ <input type=hidden name=action value=add>+ <input type=submit name=submit value="add transaction">+ $if manyfiles+ \ to: ^{journalselect $ files j}+ \ or #+ <a href="#" onclick="return addformToggle(event)">cancel+|]+ where+ title = "Add transaction" :: String+ datehelp = "eg: 2010/7/20" :: String+ deschelp = "eg: supermarket (optional)" :: String+ date = "today" :: String+ descriptions = sort $ nub $ map tdescription $ jtxns j+ manyfiles = (length $ files j) > 1+ postingfields :: ViewData -> Int -> HtmlUrl AppRoute+ postingfields _ n = [hamlet|+<tr#postingrow>+ <td align=right>#{acctlabel}:+ <td>+ <select id=#{acctvar} name=#{acctvar}>+ <option>+ $forall a <- acctnames+ <option value=#{a} :shouldselect a:selected>#{a}+ ^{amtfield}+<tr.helprow>+ <td>+ <td>+ <span.help>#{accthelp}+ <td>+ <td>+ <span.help>#{amthelp}+|]+ where+ shouldselect a = n == 2 && maybe False ((a==).fst) (inAccount qopts)+ withnumber = (++ show n)+ acctvar = withnumber "account"+ amtvar = withnumber "amount"+ acctnames = sort $ journalAccountNamesUsed j+ (acctlabel, accthelp, amtfield, amthelp)+ | n == 1 = ("To account"+ ,"eg: expenses:food"+ ,[hamlet|+<td style=padding-left:1em;>+ Amount:+<td>+ <input.textinput size=15 name=#{amtvar} value="">+|]+ ,"eg: $6"+ )+ | otherwise = ("From account" :: String+ ,"eg: assets:bank:checking" :: String+ ,nulltemplate+ ,"" :: String+ )++-- | Edit journal form.+editform :: ViewData -> HtmlUrl AppRoute+editform VD{..} = [hamlet|+<form#editform method=POST style=display:none;>+ <h2#contenttitle>#{title}>+ <table.form>+ $if manyfiles+ <tr>+ <td colspan=2>+ Editing ^{journalselect $ files j}+ <tr>+ <td colspan=2>+ <!-- XXX textarea ids are unquoted journal file paths here, not valid html -->+ $forall f <- files j+ <textarea id=#{fst f}_textarea name=text rows=25 cols=80 style=display:none; disabled=disabled>+ #{snd f}+ <tr#addbuttonrow>+ <td>+ <span.help>^{formathelp}+ <td align=right>+ <span.help>+ Are you sure ? This will overwrite the journal. #+ <input type=hidden name=action value=edit>+ <input type=submit name=submit value="save journal">+ \ or #+ <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 :: HtmlUrl AppRoute+importform = [hamlet|+<form#importform method=POST style=display:none;>+ <table.form>+ <tr>+ <td>+ <input type=file name=file>+ <input type=hidden name=action value=import>+ <input type=submit name=submit value="import from file">+ \ or #+ <a href="#" onclick="return importformToggle(event)">cancel+|]++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 :: HtmlUrl AppRoute+nulltemplate = [hamlet||]++----------------------------------------------------------------------+-- Utilities++-- | A bundle of data useful for hledger-web request handlers and templates.+data ViewData = VD {+ opts :: WebOpts -- ^ the command-line options at startup+ ,here :: AppRoute -- ^ the current route+ ,msg :: Maybe Html -- ^ the current UI message if any, possibly from the current request+ ,today :: Day -- ^ today's date (for queries containing relative dates)+ ,j :: Journal -- ^ the up-to-date parsed unfiltered journal+ ,q :: String -- ^ the current q parameter, the main query expression+ ,m :: Query -- ^ a query parsed from the q parameter+ ,qopts :: [QueryOpt] -- ^ query options parsed from the q parameter+ ,am :: Query -- ^ a query parsed from the accounts sidebar query expr ("a" parameter)+ ,aopts :: [QueryOpt] -- ^ query options parsed from the accounts sidebar query expr+ ,showpostings :: Bool -- ^ current p parameter, 1 or 0 shows/hides all postings where applicable+ }++-- | Make a default ViewData, using day 0 as today's date.+nullviewdata :: ViewData+nullviewdata = viewdataWithDateAndParams nulldate "" "" ""++-- | Make a ViewData using the given date and request parameters, and defaults elsewhere.+viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData+viewdataWithDateAndParams d q a p =+ let (querymatcher,queryopts) = parseQuery d q+ (acctsmatcher,acctsopts) = parseQuery d a+ in VD {+ opts = defwebopts+ ,j = nulljournal+ ,here = RootR+ ,msg = Nothing+ ,today = d+ ,q = q+ ,m = querymatcher+ ,qopts = queryopts+ ,am = acctsmatcher+ ,aopts = acctsopts+ ,showpostings = p == "1"+ }++-- | Gather data used by handlers and templates in the current request.+getViewData :: Handler ViewData+getViewData = do+ app <- getYesod+ let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app+ (j, err) <- getCurrentJournal $ copts{reportopts_=ropts{no_elide_=True}}+ msg <- getMessageOr err+ Just here <- getCurrentRoute+ today <- liftIO getCurrentDay+ q <- getParameterOrNull "q"+ a <- getParameterOrNull "a"+ p <- getParameterOrNull "p"+ return (viewdataWithDateAndParams today q a p){+ opts=opts+ ,msg=msg+ ,here=here+ ,today=today+ ,j=j+ }+ where+ -- | Update our copy of the journal if the file changed. If there is an+ -- error while reloading, keep the old one and return the error, and set a+ -- ui message.+ getCurrentJournal :: CliOpts -> Handler (Journal, Maybe String)+ getCurrentJournal opts = do+ j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"+ (jE, changed) <- liftIO $ journalReloadIfChanged opts j+ if not changed+ then return (j,Nothing)+ else case jE of+ Right j' -> do liftIO $ putValue "hledger" "journal" j'+ return (j',Nothing)+ Left e -> do setMessage $ "error while reading" {- ++ ": " ++ e-}+ return (j, Just e)++ -- | 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)+getMessageOr mnewmsg = do+ oldmsg <- getMessage+ return $ maybe oldmsg (Just . toHtml) mnewmsg++numbered :: [a] -> [(Int,a)]+numbered = zip [1..]++dayToJsTimestamp :: Day -> Integer+dayToJsTimestamp d = read (formatTime defaultTimeLocale "%s" t) * 1000+ where t = UTCTime d (secondsToDiffTime 0)
Hledger/Web.hs view
@@ -3,33 +3,19 @@ -} module Hledger.Web (- module Hledger.Web.Foundation,- module Hledger.Web.Application,- module Hledger.Web.Handlers,- module Hledger.Web.Import, module Hledger.Web.Options,- module Hledger.Web.Settings,- module Hledger.Web.Settings.StaticFiles,+ module Hledger.Web.Main, tests_Hledger_Web ) where import Test.HUnit -import Hledger.Web.Foundation-import Hledger.Web.Application-import Hledger.Web.Handlers-import Hledger.Web.Import import Hledger.Web.Options-import Hledger.Web.Settings-import Hledger.Web.Settings.StaticFiles+import Hledger.Web.Main tests_Hledger_Web :: Test tests_Hledger_Web = TestList [- -- tests_Hledger_Web_Foundation- -- ,tests_Hledger_Web_Application- -- ,tests_Hledger_Web_EmbeddedFiles- -- ,tests_Hledger_Web_Handlers- -- ,tests_Hledger_Web_Settings- -- ,tests_Hledger_Web_Settings_StaticFiles+ -- tests_Hledger_Web_Options+ -- ,tests_Hledger_Web_Main ]
− Hledger/Web/Application.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Hledger.Web.Application- ( getApplication- , getApplicationDev- )-where--import Prelude-import Yesod.Default.Config-import Yesod.Default.Main (defaultDevelApp)-import Yesod.Default.Handlers (getRobotsR)-#if DEVELOPMENT-import Yesod.Logger (Logger, logBS)-import Network.Wai.Middleware.RequestLogger (logCallbackDev)-#else-import Yesod.Logger (Logger, logBS, toProduction)-import Network.Wai.Middleware.RequestLogger (logCallback)-#endif-import Network.Wai (Application)--import Hledger.Web.Foundation-import Hledger.Web.Handlers-import Hledger.Web.Options-import Hledger.Web.Settings (Extra(..), parseExtra)-import Hledger.Web.Settings.StaticFiles (staticSite)---- 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--getApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application-getApplication conf logger = do- s <- staticSite- let foundation = App conf setLogger s defwebopts -- XXX- app <- toWaiAppPlain foundation- return $ logWare app- where-#ifdef DEVELOPMENT- logWare = logCallbackDev (logBS setLogger)- setLogger = logger-#else- setLogger = toProduction logger -- by default the logger is set for development- logWare = logCallback (logBS setLogger)-#endif---- for yesod devel-getApplicationDev :: IO (Int, Application)-getApplicationDev =- defaultDevelApp loader getApplication- where- loader = loadConfig (configSettings Development)- { csParseExtra = parseExtra- }
− Hledger/Web/Foundation.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, CPP #-}-{---Define the web application's foundation, in the usual Yesod style.-See a default Yesod app's comments for more details of each part.---}--module Hledger.Web.Foundation- ( App (..)- , Route (..)- , AppRoute- -- , AppMessage (..)- , resourcesApp- , Handler- , Widget- , module Yesod.Core- , liftIO- ) where--import Prelude-import Yesod.Core hiding (Route)-import Yesod.Default.Config-#ifndef DEVELOPMENT-import Yesod.Default.Util (addStaticContentExternal)-#endif-import Yesod.Static-import Yesod.Logger (Logger, logMsg, formatLogText)-import Control.Monad.IO.Class (liftIO)--import Hledger.Web.Options-import Hledger.Web.Settings-import Hledger.Web.Settings.StaticFiles---- | The web application's configuration and data, available to all request handlers.-data App = App- { settings :: AppConfig DefaultEnv Extra- , getLogger :: Logger- , getStatic :: Static -- ^ Settings for static file serving.- , appOpts :: WebOpts- -- , appJournal :: Journal- }---- Set up i18n messages.--- mkMessage "App" "messages" "en"---- The web application's routes (urls).-mkYesodData "App" $(parseRoutesFile "routes")---- | A convenience alias.-type AppRoute = Route App---- More configuration, including the default page layout.-instance Yesod App where- -- approot = Hledger.Web.Settings.appRoot . settings- approot = ApprootMaster $ appRoot . settings-- defaultLayout widget = do- -- master <- getYesod- -- mmsg <- getMessage- -- We break up the default layout into two components:- -- default-layout is the contents of the body tag, and- -- default-layout-wrapper is the entire page. Since the final- -- value passed to hamletToRepHtml cannot be a widget, this allows- -- you to use normal widget features in default-layout.- -- pc <- widgetToPageContent $ do- -- $(widgetFile "normalize")- -- $(widgetFile "default-layout")- -- hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")- pc <- widgetToPageContent $ do- widget- hamletToRepHtml [hamlet|-$doctype 5-<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 =- formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y)--#ifndef DEVELOPMENT- -- 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 = addStaticContentExternal (const $ Left ()) base64md5 Hledger.Web.Settings.staticDir (StaticR . flip StaticRoute [])-#endif-- -- Place Javascript at bottom of the body tag so the rest of the page loads first- jsLoader _ = BottomOfBody
− Hledger/Web/Handlers.hs
@@ -1,974 +0,0 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, RecordWildCards #-}-{---hledger-web's request handlers, and helpers.---}--module Hledger.Web.Handlers-(- -- * GET handlers- getRootR,- getJournalR,- getJournalEntriesR,- getJournalEditR,- getRegisterR,- -- ** helpers- -- sidebar,- -- accountsReportAsHtml,- -- accountQuery,- -- accountOnlyQuery,- -- accountUrl,- -- entriesReportAsHtml,- -- journalTransactionsReportAsHtml,- -- registerReportHtml,- -- registerItemsHtml,- -- registerChartHtml,- -- stringIfLongerThan,- -- numberTransactionsReportItems,- -- mixedAmountAsHtml,- -- * POST handlers- postJournalR,- postJournalEntriesR,- postJournalEditR,- postRegisterR,- -- * Common page components- -- * Utilities- ViewData(..),- nullviewdata,-)-where--import Prelude-import Control.Applicative ((<$>))-import Data.Either (lefts,rights)-import Data.List-import Data.Maybe-import Data.Text(Text,pack,unpack)-import qualified Data.Text (null)-import Data.Time.Calendar-import Data.Time.Clock-import Data.Time.Format-import System.FilePath (takeFileName)-import System.IO.Storage (putValue, getValue)-import System.Locale (defaultTimeLocale)-#if BLAZE_HTML_0_5-import Text.Blaze.Internal (preEscapedString)-import Text.Blaze.Html (toHtml)-#else-import Text.Blaze (preEscapedString, toHtml)-#endif-import Text.Hamlet hiding (hamlet)-import Text.Printf-import Yesod.Core--- import Yesod.Json--import Hledger hiding (is)-import Hledger.Cli hiding (version)-import Hledger.Web.Foundation-import Hledger.Web.Options-import Hledger.Web.Settings---- routes:--- /static StaticR Static getStatic--- -- /favicon.ico FaviconR GET--- /robots.txt RobotsR GET--- / RootR GET--- /journal JournalR GET POST--- /journal/entries JournalEntriesR GET POST--- /journal/edit JournalEditR GET POST--- /register RegisterR GET POST--- -- /accounts AccountsR GET--- -- /api/accounts AccountsJsonR GET--------------------------------------------------------------------------- GET handlers--getRootR :: Handler RepHtml-getRootR = redirect defaultroute where defaultroute = RegisterR---- | The formatted journal view, with sidebar.-getJournalR :: Handler RepHtml-getJournalR = do- vd@VD{..} <- getViewData- let sidecontent = sidebar vd- -- XXX like registerReportAsHtml- inacct = inAccount qopts- -- injournal = isNothing inacct- filtering = m /= Any- -- showlastcolumn = if injournal && not filtering then False else True- title = case inacct of- Nothing -> "Journal"++s2- Just (a,inclsubs) -> "Transactions in "++a++s1++s2- where s1 = if inclsubs then " (and subaccounts)" else ""- where- s2 = if filtering then ", filtered" else ""- maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m- defaultLayout $ do- setTitle "hledger-web journal"- addWidget $ toWidget [hamlet|-^{topbar vd}-<div#content>- <div#sidebar>- ^{sidecontent}- <div#main.register>- <div#maincontent>- <h2#contenttitle>#{title}- ^{searchform vd}- ^{maincontent}- ^{addform vd}- ^{editform vd}- ^{importform}-|]---- | The journal entries view, with sidebar.-getJournalEntriesR :: Handler RepHtml-getJournalEntriesR = do- vd@VD{..} <- getViewData- let- sidecontent = sidebar vd- title = "Journal entries" ++ if m /= Any then ", filtered" else "" :: String- maincontent = entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) Any $ filterJournalTransactions m j- defaultLayout $ do- setTitle "hledger-web journal"- addWidget $ toWidget [hamlet|-^{topbar vd}-<div#content>- <div#sidebar>- ^{sidecontent}- <div#main.journal>- <div#maincontent>- <h2#contenttitle>#{title}- ^{searchform vd}- ^{maincontent}- ^{addform vd}- ^{editform vd}- ^{importform}-|]---- | The journal editform, no sidebar.-getJournalEditR :: Handler RepHtml-getJournalEditR = do- vd <- getViewData- defaultLayout $ do- setTitle "hledger-web journal edit form"- addWidget $ toWidget $ editform vd---- -- | The journal entries view, no sidebar.--- getJournalOnlyR :: Handler RepHtml--- getJournalOnlyR = do--- vd@VD{..} <- getViewData--- defaultLayout $ do--- setTitle "hledger-web journal only"--- addWidget $ toWidget $ entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) nullfilterspec $ filterJournalTransactions2 m j---- | The main journal/account register view, with accounts sidebar.-getRegisterR :: Handler RepHtml-getRegisterR = do- vd@VD{..} <- getViewData- let sidecontent = sidebar vd- -- injournal = isNothing inacct- filtering = m /= Any- title = "Transactions in "++a++s1++s2- where- (a,inclsubs) = fromMaybe ("all accounts",False) $ inAccount qopts- s1 = if inclsubs then " (and subaccounts)" else ""- s2 = if filtering then ", filtered" else ""- maincontent = registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts- defaultLayout $ do- setTitle "hledger-web register"- addWidget $ toWidget [hamlet|-^{topbar vd}-<div#content>- <div#sidebar>- ^{sidecontent}- <div#main.register>- <div#maincontent>- <h2#contenttitle>#{title}- ^{searchform vd}- ^{maincontent}- ^{addform vd}- ^{editform vd}- ^{importform}-|]---- -- | The register view, no sidebar.--- getRegisterOnlyR :: Handler RepHtml--- getRegisterOnlyR = do--- vd@VD{..} <- getViewData--- defaultLayout $ do--- setTitle "hledger-web register only"--- addWidget $ toWidget $--- case inAccountQuery qopts of Just m' -> registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m m'--- Nothing -> registerReportHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m--{---- | A simple accounts view. This one is json-capable, returning the chart--- of accounts as json if the Accept header specifies json.-getAccountsR :: Handler RepHtmlJson-getAccountsR = do- vd@VD{..} <- getViewData- let j' = filterJournalPostings2 m j- html = do- setTitle "hledger-web accounts"- addWidget $ toWidget $ accountsReportAsHtml opts vd $ accountsReport2 (reportopts_ $ cliopts_ opts) am j'- json = jsonMap [("accounts", toJSON $ journalAccountNames j')]- defaultLayoutJson html json---- | A json-only version of "getAccountsR", does not require the special Accept header.-getAccountsJsonR :: Handler RepJson-getAccountsJsonR = do- VD{..} <- getViewData- let j' = filterJournalPostings2 m j- jsonToRepJson $ jsonMap [("accounts", toJSON $ journalAccountNames j')]--}---- helpers---- | Render the sidebar used on most views.-sidebar :: ViewData -> HtmlUrl AppRoute-sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport (reportopts_ $ cliopts_ opts) am j---- | Render an "AccountsReport" as html.-accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> HtmlUrl AppRoute-accountsReportAsHtml _ vd@VD{..} (items',total) =- [hamlet|-<div#accountsheading>- <a#accounts-toggle-link.togglelink href="#" title="Toggle sidebar">[+]-<div#accounts>- <table.balancereport>- <tr>- <td.add colspan=3>- <br>- <a#addformlink href="#" onclick="return addformToggle(event)" title="Add a new transaction to the journal">Add a transaction..-- <tr.item :allaccts:.inacct>- <td.journal colspan=3>- <br>- <a href=@{JournalR} title="Show all transactions in journal format">Journal- <span.hoverlinks>- - <a href=@{JournalEntriesR} title="Show journal entries">entries- - <a#editformlink href="#" onclick="return editformToggle(event)" title="Edit the journal">- edit-- <tr>- <td colspan=3>- <br>- Accounts-- $forall i <- items- ^{itemAsHtml vd i}-- <tr.totalrule>- <td colspan=3>- <tr>- <td>- <td.balance align=right>#{mixedAmountAsHtml total}- <td>-|]- where- l = journalToLedger Any j- inacctmatcher = inAccountQuery qopts- allaccts = isNothing inacctmatcher- items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher- itemAsHtml :: ViewData -> AccountsReportItem -> HtmlUrl AppRoute- itemAsHtml _ (acct, adisplay, aindent, abal) = [hamlet|-<tr.item.#{inacctclass}>- <td.account.#{depthclass}>- #{indent}- <a href="@?{acctquery}" title="Show transactions in this account, including subaccounts">#{adisplay}- <span.hoverlinks>- $if hassubs- - <a href="@?{acctonlyquery}" title="Show transactions in this account only">only- <!--- - <a href="@?{acctsonlyquery}" title="Focus on this account and sub-accounts and hide others">-others -->-- <td.balance align=right>#{mixedAmountAsHtml abal}- <td.numpostings align=right title="#{numpostings} transactions in this account">(#{numpostings})-|]- where- hassubs = not $ null $ ledgerSubAccounts l $ ledgerAccount l acct- numpostings = length $ apostings $ ledgerAccount l acct- depthclass = "depth"++show aindent- inacctclass = case inacctmatcher of- Just m' -> if m' `matchesAccount` acct then "inacct" else "notinacct"- Nothing -> "" :: String- indent = preEscapedString $ concat $ replicate (2 * (1+aindent)) " "- acctquery = (RegisterR, [("q", pack $ accountQuery acct)])- acctonlyquery = (RegisterR, [("q", pack $ accountOnlyQuery acct)])--accountQuery :: AccountName -> String-accountQuery a = "inacct:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a)--accountOnlyQuery :: AccountName -> String-accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a)--accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])-accountUrl r a = (r, [("q", pack $ accountQuery a)])---- | Render an "EntriesReport" as html for the journal entries view.-entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> HtmlUrl AppRoute-entriesReportAsHtml _ vd items = [hamlet|-<table.journalreport>- $forall i <- numbered items- ^{itemAsHtml vd i}- |]- where- itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute- itemAsHtml _ (n, t) = [hamlet|-<tr.item.#{evenodd}>- <td.transaction>- <pre>#{txn}- |]- where- evenodd = if even n then "even" else "odd" :: String- txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse---- | Render a "TransactionsReport" as html for the formatted journal view.-journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute-journalTransactionsReportAsHtml _ vd (_,items) = [hamlet|-<table.journalreport>- <tr.headings>- <th.date align=left>Date- <th.description align=left>Description- <th.account align=left>Accounts- <th.amount align=right>Amount- $forall i <- numberTransactionsReportItems items- ^{itemAsHtml vd i}- |]- where--- .#{datetransition}- itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute- itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [hamlet|-<tr.item.#{evenodd}.#{firstposting}>- <td.date>#{date}- <td.description colspan=2 title="#{show t}">#{elideRight 60 desc}- <td.amount align=right>- $if showamt- #{mixedAmountAsHtml amt}-$forall p' <- tpostings t- <tr.item.#{evenodd}.posting>- <td.date>- <td.description>- <td.account> <a href="@?{accountUrl here $ paccount p'}" title="Show transactions in #{paccount p'}">#{elideRight 40 $ paccount p'}- <td.amount align=right>#{mixedAmountAsHtml $ pamount p'}-|]- where- evenodd = if even n then "even" else "odd" :: String- -- datetransition | newm = "newmonth"- -- | newd = "newday"- -- | otherwise = "" :: String- (firstposting, date, desc) = (False, show $ tdate t, tdescription t)- -- acctquery = (here, [("q", pack $ accountQuery acct)])- showamt = not split || not (isZeroMixedAmount amt)---- Generate html for an account register, including a balance chart and transaction list.-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 -> HtmlUrl AppRoute-registerItemsHtml _ vd (balancelabel,items) = [hamlet|-<table.registerreport>- <tr.headings>- <th.date align=left>Date- <th.description align=left>Description- <th.account align=left>To/From Account- <!-- \ #- <a#all-postings-toggle-link.togglelink href="#" title="Toggle all split postings">[+] -->- <th.amount align=right>Amount- <th.balance align=right>#{balancelabel}-- $forall i <- numberTransactionsReportItems items- ^{itemAsHtml vd i}- |]- where- -- inacct = inAccount qopts- -- filtering = m /= Any- 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}- <td.description title="#{show t}">#{elideRight 30 desc}- <td.account title="#{show t}">- <a>- #{elideRight 40 acct}- - <a.postings-toggle-link.togglelink href="#" title="Toggle all postings">- [+]- <td.amount align=right>- $if showamt- #{mixedAmountAsHtml amt}- <td.balance align=right>#{mixedAmountAsHtml bal}-$forall p' <- tpostings t- <tr.item.#{evenodd}.posting style=#{postingsdisplaystyle}>- <td.date>- <td.description>- <td.account> <a href="@?{accountUrl here $ paccount p'}" title="Show transactions in #{paccount p'}">#{elideRight 40 $ paccount p'}- <td.amount align=right>#{mixedAmountAsHtml $ pamount p'}- <td.balance align=right>-|]- where- evenodd = if even n then "even" else "odd" :: String- datetransition | newm = "newmonth"- | newd = "newday"- | otherwise = "" :: String- (firstposting, date, desc) = (False, show $ tdate t, tdescription t)- -- acctquery = (here, [("q", pack $ accountQuery acct)])- showamt = not split || not (isZeroMixedAmount amt)- postingsdisplaystyle = if showpostings then "" else "display:none;" :: String---- | Generate javascript/html for a register balance line chart based on--- the provided "TransactionsReportItem"s.- -- registerChartHtml :: forall t (t1 :: * -> *) t2 t3 t4 t5.- -- Data.Foldable.Foldable t1 =>- -- t1 (Transaction, t2, t3, t4, t5, MixedAmount)- -- -> t -> Text.Blaze.Internal.HtmlM ()-registerChartHtml :: [TransactionsReportItem] -> HtmlUrl AppRoute-registerChartHtml items =- -- have to make sure plot is not called when our container (maincontent)- -- is hidden, eg with add form toggled- [hamlet|-<div#register-chart style="width:600px;height:100px; margin-bottom:1em;">-<script type=text/javascript>- \$(document).ready(function() {- /* render chart with flot, if visible */- var chartdiv = $('#register-chart');- if (chartdiv.is(':visible'))- \$.plot(chartdiv,- [- [- $forall i <- items- [#{dayToJsTimestamp $ triDate i}, #{triBalance i}],- ]- ],- {- xaxis: {- mode: "time",- timeformat: "%y/%m/%d"- }- }- );- });-|]---- stringIfLongerThan :: Int -> String -> String--- stringIfLongerThan n s = if length s > n then s else ""--numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]-numberTransactionsReportItems [] = []-numberTransactionsReportItems items = number 0 nulldate items- where- number :: Int -> Day -> [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]- number _ _ [] = []- number n prevd (i@(Transaction{tdate=d},_,_,_,_,_):is) = (n+1,newday,newmonth,newyear,i):(number (n+1) d is)- where- newday = d/=prevd- newmonth = dm/=prevdm || dy/=prevdy- newyear = dy/=prevdy- (dy,dm,_) = toGregorian d- (prevdy,prevdm,_) = toGregorian prevd--mixedAmountAsHtml :: MixedAmount -> Html-mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "<br>" $ lines $ showMixedAmount b- where addclass = printf "<span class=\"%s\">%s</span>" (c :: String)- c = case isNegativeMixedAmount b of Just True -> "negative amount"- _ -> "positive amount"------------------------------------------------------------------------------------ POST handlers--postJournalR :: Handler RepHtml-postJournalR = handlePost--postJournalEntriesR :: Handler RepHtml-postJournalEntriesR = handlePost--postJournalEditR :: Handler RepHtml-postJournalEditR = handlePost--postRegisterR :: Handler RepHtml-postRegisterR = handlePost---- | Handle a post from any of the edit forms.-handlePost :: Handler RepHtml-handlePost = do- action <- lookupPostParam "action"- case action of Just "add" -> handleAdd- Just "edit" -> handleEdit- Just "import" -> handleImport- _ -> invalidArgs [pack "invalid action"]---- | Handle a post from the transaction add form.-handleAdd :: Handler RepHtml-handleAdd = do- VD{..} <- getViewData- -- get form input values. M means a Maybe value.- 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- maybeNonNull = maybe Nothing (\t -> if Data.Text.null t then Nothing else Just t)- acct1E = maybe (Left "to account required") (Right . unpack) $ maybeNonNull acct1M- acct2E = maybe (Left "from account required") (Right . unpack) $ maybeNonNull acct2M- amt1E = maybe (Left "amount required") (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx amount . unpack) amt1M- amt2E = maybe (Right missingmixedamt) (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx amount . unpack) amt2M- journalE = maybe (Right $ journalFilePath j)- (\f -> let f' = unpack f in- if f' `elem` journalFilePaths j- then Right f'- else Left $ "unrecognised journal file path: " ++ f'- )- journalM- strEs = [dateE, descE, acct1E, acct2E, journalE]- amtEs = [amt1E, amt2E]- errs = lefts strEs ++ lefts amtEs- [date,desc,acct1,acct2,journalpath] = rights strEs- [amt1,amt2] = rights amtEs- -- if no errors so far, generate a transaction and balance it or get the error.- tE | not $ null errs = Left errs- | otherwise = either (\e -> Left ["unbalanced postings: " ++ (head $ lines e)]) Right- (balanceTransaction Nothing $ nulltransaction { -- imprecise balancing- tdate=parsedate date- ,tdescription=desc- ,tpostings=[- Posting False acct1 amt1 "" RegularPosting [] Nothing- ,Posting False acct2 amt2 "" RegularPosting [] Nothing- ]- })- -- display errors or add transaction- case tE of- Left errs' -> do- -- save current form values in session- -- setMessage $ toHtml $ intercalate "; " errs- setMessage [shamlet|- Errors:<br>- $forall e<-errs'- #{e}<br>- |]- Right t -> do- let t' = txnTieKnot t -- XXX move into balanceTransaction- liftIO $ do ensureJournalFileExists journalpath- appendToJournalFileOrStdout journalpath $ showTransaction t'- -- setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String)- setMessage [shamlet|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|]-- redirect (RegisterR, [("add","1")])--chomp :: String -> String-chomp = reverse . dropWhile (`elem` "\r\n") . reverse---- | Handle a post from the journal edit form.-handleEdit :: Handler RepHtml-handleEdit = do- VD{..} <- getViewData- -- get form input values, or validation errors.- -- getRequest >>= liftIO (reqRequestBody req) >>= mtrace- 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- if f' `elem` journalFilePaths j- then Right f'- else Left "unrecognised journal file path")- journalM- strEs = [textE, journalE]- errs = lefts strEs- [text,journalpath] = rights strEs- -- display errors or perform edit- if not $ null errs- then do- setMessage $ toHtml (intercalate "; " errs :: String)- redirect JournalR-- else do- -- try to avoid unnecessary backups or saving invalid data- filechanged' <- liftIO $ journalSpecifiedFileIsNewer j journalpath- told <- liftIO $ readFileStrictly journalpath- let tnew = filter (/= '\r') text- changed = tnew /= told || filechanged'- if not changed- then do- setMessage "No change"- redirect JournalR- else do- jE <- liftIO $ readJournal Nothing Nothing (Just journalpath) tnew- either- (\e -> do- setMessage $ toHtml e- redirect JournalR)- (const $ do- liftIO $ writeFileWithBackup journalpath tnew- setMessage $ toHtml (printf "Saved journal %s\n" (show journalpath) :: String)- redirect JournalR)- jE---- | Handle a post from the journal import form.-handleImport :: Handler RepHtml-handleImport = do- setMessage "can't handle file upload yet"- redirect JournalR- -- -- get form input values, or basic validation errors. E means an Either value.- -- fileM <- runFormPost $ maybeFileInput "file"- -- let fileE = maybe (Left "No file provided") Right fileM- -- -- display errors or import transactions- -- case fileE of- -- Left errs -> do- -- setMessage errs- -- redirect JournalR-- -- Right s -> do- -- setMessage s- -- redirect JournalR--------------------------------------------------------------------------- Common page components.---- | Global toolbar/heading area.-topbar :: ViewData -> HtmlUrl AppRoute-topbar VD{..} = [hamlet|-<div#topbar>- <a.topleftlink href=#{hledgerorgurl} title="More about hledger">- hledger-web- <br />- #{version}- <a.toprightlink href=#{manualurl} target=hledgerhelp title="User manual">manual- <h1>#{title}-$maybe m' <- msg- <div#message>#{m'}-|]- where- title = takeFileName $ journalFilePath j---- -- | Navigation link, preserving parameters and possibly highlighted.--- navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute--- navlink VD{..} s dest title = [hamlet|--- <a##{s}link.#{style} href=@?{u'} title="#{title}">#{s}--- |]--- where u' = (dest, if null q then [] else [("q", pack q)])--- style | dest == here = "navlinkcurrent"--- | otherwise = "navlink" :: Text---- -- | Links to the various journal editing forms.--- editlinks :: HtmlUrl AppRoute--- editlinks = [hamlet|--- <a#editformlink href="#" onclick="return editformToggle(event)" title="Toggle journal edit form">edit--- \ | #--- <a#addformlink href="#" onclick="return addformToggle(event)" title="Toggle transaction add form">add--- <a#importformlink href="#" onclick="return importformToggle(event)" style="display:none;">import transactions--- |]---- | Link to a topic in the manual.-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 -> HtmlUrl AppRoute-searchform VD{..} = [hamlet|-<div#searchformdiv>- <form#searchform.form method=GET>- <table>- <tr>- <td>- Search:- \ #- <td>- <input name=q size=70 value=#{q}>- <input type=submit value="Search">- $if filtering- \ #- <span.showall>- <a href=@{here}>clear search- \ #- <a#search-help-link href="#" title="Toggle search help">help- <tr>- <td>- <td>- <div#search-help.help style="display:none;">- Leave blank to see journal (all transactions), or click account links to see transactions under that account.- <br>- Transactions/postings may additionally be filtered by:- <br>- acct:REGEXP (target account), #- desc:REGEXP (description), #- date:PERIODEXP (date), #- edate:PERIODEXP (effective date), #- <br>- status:BOOL (cleared status), #- real:BOOL (real/virtual-ness), #- empty:BOOL (posting amount = 0).- <br>- not: to negate, enclose space-containing patterns in quotes, multiple filters are AND'ed.-|]- where- filtering = not $ null q---- | Add transaction form.-addform :: ViewData -> HtmlUrl AppRoute-addform vd@VD{..} = [hamlet|-<script type=text/javascript>- \$(document).ready(function() {- /* dhtmlxcombo setup */- window.dhx_globalImgPath="../static/";- var desccombo = new dhtmlXCombo("description");- var acct1combo = new dhtmlXCombo("account1");- var acct2combo = new dhtmlXCombo("account2");- desccombo.enableFilteringMode(true);- acct1combo.enableFilteringMode(true);- acct2combo.enableFilteringMode(true);- desccombo.setSize(300);- acct1combo.setSize(300);- acct2combo.setSize(300);- /* desccombo.enableOptionAutoHeight(true, 20); */- /* desccombo.setOptionHeight(200); */- });--<form#addform method=POST style=display:none;>- <h2#contenttitle>#{title}- <table.form>- <tr>- <td colspan=4>- <table>- <tr#descriptionrow>- <td>- Date:- <td>- <input.textinput size=15 name=date value=#{date}>- <td style=padding-left:1em;>- Description:- <td>- <select id=description name=description>- <option>- $forall d <- descriptions- <option value=#{d}>#{d}- <tr.helprow>- <td>- <td>- <span.help>#{datehelp} #- <td>- <td>- <span.help>#{deschelp}- ^{postingfields vd 1}- ^{postingfields vd 2}- <tr#addbuttonrow>- <td colspan=4>- <input type=hidden name=action value=add>- <input type=submit name=submit value="add transaction">- $if manyfiles- \ to: ^{journalselect $ files j}- \ or #- <a href="#" onclick="return addformToggle(event)">cancel-|]- where- title = "Add transaction" :: String- datehelp = "eg: 2010/7/20" :: String- deschelp = "eg: supermarket (optional)" :: String- date = "today" :: String- descriptions = sort $ nub $ map tdescription $ jtxns j- manyfiles = (length $ files j) > 1- postingfields :: ViewData -> Int -> HtmlUrl AppRoute- postingfields _ n = [hamlet|-<tr#postingrow>- <td align=right>#{acctlabel}:- <td>- <select id=#{acctvar} name=#{acctvar}>- <option>- $forall a <- acctnames- <option value=#{a} :shouldselect a:selected>#{a}- ^{amtfield}-<tr.helprow>- <td>- <td>- <span.help>#{accthelp}- <td>- <td>- <span.help>#{amthelp}-|]- where- shouldselect a = n == 2 && maybe False ((a==).fst) (inAccount qopts)- withnumber = (++ show n)- acctvar = withnumber "account"- amtvar = withnumber "amount"- acctnames = sort $ journalAccountNamesUsed j- (acctlabel, accthelp, amtfield, amthelp)- | n == 1 = ("To account"- ,"eg: expenses:food"- ,[hamlet|-<td style=padding-left:1em;>- Amount:-<td>- <input.textinput size=15 name=#{amtvar} value="">-|]- ,"eg: $6"- )- | otherwise = ("From account" :: String- ,"eg: assets:bank:checking" :: String- ,nulltemplate- ,"" :: String- )---- | Edit journal form.-editform :: ViewData -> HtmlUrl AppRoute-editform VD{..} = [hamlet|-<form#editform method=POST style=display:none;>- <h2#contenttitle>#{title}>- <table.form>- $if manyfiles- <tr>- <td colspan=2>- Editing ^{journalselect $ files j}- <tr>- <td colspan=2>- <!-- XXX textarea ids are unquoted journal file paths here, not valid html -->- $forall f <- files j- <textarea id=#{fst f}_textarea name=text rows=25 cols=80 style=display:none; disabled=disabled>- #{snd f}- <tr#addbuttonrow>- <td>- <span.help>^{formathelp}- <td align=right>- <span.help>- Are you sure ? This will overwrite the journal. #- <input type=hidden name=action value=edit>- <input type=submit name=submit value="save journal">- \ or #- <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 :: HtmlUrl AppRoute-importform = [hamlet|-<form#importform method=POST style=display:none;>- <table.form>- <tr>- <td>- <input type=file name=file>- <input type=hidden name=action value=import>- <input type=submit name=submit value="import from file">- \ or #- <a href="#" onclick="return importformToggle(event)">cancel-|]--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 :: HtmlUrl AppRoute-nulltemplate = [hamlet||]--------------------------------------------------------------------------- Utilities---- | A bundle of data useful for hledger-web request handlers and templates.-data ViewData = VD {- opts :: WebOpts -- ^ the command-line options at startup- ,here :: AppRoute -- ^ the current route- ,msg :: Maybe Html -- ^ the current UI message if any, possibly from the current request- ,today :: Day -- ^ today's date (for queries containing relative dates)- ,j :: Journal -- ^ the up-to-date parsed unfiltered journal- ,q :: String -- ^ the current q parameter, the main query expression- ,m :: Query -- ^ a query parsed from the q parameter- ,qopts :: [QueryOpt] -- ^ query options parsed from the q parameter- ,am :: Query -- ^ a query parsed from the accounts sidebar query expr ("a" parameter)- ,aopts :: [QueryOpt] -- ^ query options parsed from the accounts sidebar query expr- ,showpostings :: Bool -- ^ current p parameter, 1 or 0 shows/hides all postings where applicable- }---- | Make a default ViewData, using day 0 as today's date.-nullviewdata :: ViewData-nullviewdata = viewdataWithDateAndParams nulldate "" "" ""---- | Make a ViewData using the given date and request parameters, and defaults elsewhere.-viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData-viewdataWithDateAndParams d q a p =- let (querymatcher,queryopts) = parseQuery d q- (acctsmatcher,acctsopts) = parseQuery d a- in VD {- opts = defwebopts- ,j = nulljournal- ,here = RootR- ,msg = Nothing- ,today = d- ,q = q- ,m = querymatcher- ,qopts = queryopts- ,am = acctsmatcher- ,aopts = acctsopts- ,showpostings = p == "1"- }---- | Gather data used by handlers and templates in the current request.-getViewData :: Handler ViewData-getViewData = do- app <- getYesod- let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app- (j, err) <- getCurrentJournal $ copts{reportopts_=ropts{no_elide_=True}}- msg <- getMessageOr err- Just here <- getCurrentRoute- today <- liftIO getCurrentDay- q <- getParameterOrNull "q"- a <- getParameterOrNull "a"- p <- getParameterOrNull "p"- return (viewdataWithDateAndParams today q a p){- opts=opts- ,msg=msg- ,here=here- ,today=today- ,j=j- }- where- -- | Update our copy of the journal if the file changed. If there is an- -- error while reloading, keep the old one and return the error, and set a- -- ui message.- getCurrentJournal :: CliOpts -> Handler (Journal, Maybe String)- getCurrentJournal opts = do- j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"- (jE, changed) <- liftIO $ journalReloadIfChanged opts j- if not changed- then return (j,Nothing)- else case jE of- Right j' -> do liftIO $ putValue "hledger" "journal" j'- return (j',Nothing)- Left e -> do setMessage $ "error while reading" {- ++ ": " ++ e-}- return (j, Just e)-- -- | 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)-getMessageOr mnewmsg = do- oldmsg <- getMessage- return $ maybe oldmsg (Just . toHtml) mnewmsg--numbered :: [a] -> [(Int,a)]-numbered = zip [1..]--dayToJsTimestamp :: Day -> Integer-dayToJsTimestamp d = read (formatTime defaultTimeLocale "%s" t) * 1000- where t = UTCTime d (secondsToDiffTime 0)
− Hledger/Web/Import.hs
@@ -1,16 +0,0 @@-module Hledger.Web.Import- ( module Prelude- , (<>)- , Text- , module Data.Monoid- , module Control.Applicative- ) where--import Prelude hiding (writeFile, readFile, putStrLn)-import Data.Monoid (Monoid (mappend, mempty, mconcat))-import Control.Applicative ((<$>), (<*>), pure)-import Data.Text (Text)--infixr 5 <>-(<>) :: Monoid m => m -> m -> m-(<>) = mappend
+ Hledger/Web/Main.hs view
@@ -0,0 +1,90 @@+{-|++hledger-web - a hledger add-on providing a web interface.+Copyright (c) 2007-2012 Simon Michael <simon@joyful.com>+Released under GPL version 3 or later.++-}++module Hledger.Web.Main+where++-- yesod scaffold imports+import Prelude (IO)+import Yesod.Default.Config --(fromArgs)+-- import Yesod.Default.Main (defaultMain)+import Settings -- (parseExtra)+import Application (makeApplication)+import Data.Conduit.Network (HostPreference(HostIPv4))+import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort)+--+import Prelude hiding (putStrLn)+import Control.Monad (when)+import Data.Text (pack)+import System.Exit (exitSuccess)+import System.IO.Storage (withStore, putValue)+import Text.Printf++import Hledger+import Hledger.Utils.UTF8IOCompat (putStrLn)+import Hledger.Cli hiding (progname,prognameandversion)+import Hledger.Web.Options+++main :: IO ()+main = do+ opts <- getHledgerWebOpts+ when (debug_ $ cliopts_ opts) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts)+ runWith opts++runWith :: WebOpts -> IO ()+runWith opts+ | "help" `in_` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp webmode) >> exitSuccess+ | "version" `in_` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess+ | "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)+ | otherwise = do+ requireJournalFileExists =<< journalFilePathFromOpts (cliopts_ opts)+ withJournalDo' opts web++withJournalDo' :: WebOpts -> (WebOpts -> Journal -> IO ()) -> IO ()+withJournalDo' opts cmd = do+ journalFilePathFromOpts (cliopts_ opts) >>= readJournalFile Nothing Nothing >>=+ either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts))++-- | The web command.+web :: WebOpts -> Journal -> IO ()+web opts j = do+ -- unless (debug_ $ cliopts_ opts) $ forkIO (browser baseurl) >> return ()+ d <- getCurrentDay+ let j' = filterJournalTransactions (queryFromOpts d $ reportopts_ $ cliopts_ opts) j+ server (base_url_ opts) (port_ opts) opts j'++-- browser :: String -> IO ()+-- browser baseurl = do+-- threadDelay $ fromIntegral browserstartdelay+-- putStrLn "Attempting to start a web browser"+-- openBrowserOn baseurl >> return ()++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+ -- }+ withStore "hledger" $ do+ putValue "hledger" "journal" j++-- defaultMain (fromArgs parseExtra) makeApplication+ app <- makeApplication (AppConfig {+ appEnv = Development+ , appPort = port_ opts+ , appRoot = pack baseurl+ , appHost = HostIPv4+ , appExtra = Extra "" Nothing+ })+ runSettings defaultSettings+ { settingsPort = port_ opts+ } app
Hledger/Web/Options.hs view
@@ -7,20 +7,18 @@ where import Prelude import Data.Maybe-import Distribution.PackageDescription.TH (packageVariable, package, pkgName, pkgVersion) import System.Console.CmdArgs import System.Console.CmdArgs.Explicit import Hledger.Cli hiding (progname,version,prognameandversion)-import Hledger.Web.Settings+import Settings progname, version :: String-#if HADDOCK-progname = ""-version = ""+progname = "hledger-web"+#ifdef VERSION+version = VERSION #else-progname = $(packageVariable (pkgName . package))-version = $(packageVariable (pkgVersion . package))+version = "" #endif prognameandversion :: String prognameandversion = progname ++ " " ++ version :: String@@ -77,7 +75,7 @@ checkWebOpts :: WebOpts -> IO WebOpts checkWebOpts opts = do- checkCliOpts $ cliopts_ opts+ _ <- checkCliOpts $ cliopts_ opts return opts getHledgerWebOpts :: IO WebOpts
− Hledger/Web/Settings.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE CPP, TemplateHaskell, QuasiQuotes, OverloadedStrings #-}--- | 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--- by overriding methods in the Yesod typeclass. That instance is--- declared in the hledger-web.hs file.-module Hledger.Web.Settings- ( widgetFile- , staticRoot- , staticDir- , Extra (..)- , parseExtra- , hamlet- , defport- , defbaseurl- , hledgerorgurl- , manualurl- ) where--import Control.Applicative-import Data.Text (Text)-import Data.Yaml-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote-import Prelude-import Text.Printf-import Text.Shakespeare.Text (st)-import Yesod.Default.Config-import qualified Yesod.Default.Util-import qualified Text.Hamlet (hamlet)--- when available:--- import Text.Hamlet (HamletSettings(..), hamletWithSettings, defaultHamletSettings, hamletRules)---hledgerorgurl, manualurl :: String-hledgerorgurl = "http://hledger.org"-manualurl = hledgerorgurl++"/MANUAL.html"---- | The default TCP port to listen on. May be overridden with --port.-defport :: Int-defport = 5000--defbaseurl :: Int -> String-defbaseurl port = printf "http://localhost:%d" port----- | 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).--- | 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 = "static"---- | 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 DefaultEnv a -> Text-staticRoot conf = [st|#{appRoot conf}/static|]--widgetFile :: String -> Q Exp-#if DEVELOPMENT-widgetFile = Yesod.Default.Util.widgetFileReload-#else-widgetFile = Yesod.Default.Util.widgetFileNoReload-#endif--data Extra = Extra- { extraCopyright :: Text- , extraAnalytics :: Maybe Text -- ^ Google Analytics- }--parseExtra :: DefaultEnv -> Object -> Parser Extra-parseExtra _ o = Extra- <$> o .: "copyright"- <*> o .:? "analytics"--hamlet :: QuasiQuoter-hamlet = Text.Hamlet.hamlet--- hamlet = hamletWithSettings hamletRules defaultHamletSettings{hamletNewlines=True}
− Hledger/Web/Settings/StaticFiles.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, CPP, OverloadedStrings #-}-{-| --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 System.IO-import Yesod.Static-import qualified Yesod.Static as Static--import Prelude-import Hledger.Web.Settings (staticDir)---- | use this to create your static file serving site-staticSite :: IO Static.Static-staticSite = do-#ifdef DEVELOPMENT- putStrLn ("using web files from: " ++ staticDir ++ "/") >> hFlush stdout- Static.staticDevel staticDir-#else- putStrLn "using embedded web files" >> hFlush stdout- return $(Static.embed staticDir)-#endif----- | This generates easy references to files in the static directory at compile time,--- giving you compile-time verification that referenced files exist.--- Warning: any files added to your static directory during run-time can't be--- accessed this way. You'll have to use their FilePath or URL to access them.-$(publicFiles staticDir)
+ Import.hs view
@@ -0,0 +1,28 @@+module Import+ ( module Import+ ) where++import Prelude as Import hiding (head, init, last,+ readFile, tail, writeFile)+import Yesod as Import hiding (Route (..))++import Control.Applicative as Import (pure, (<$>), (<*>))+import Data.Text as Import (Text)++import Foundation as Import+import Settings as Import+import Settings.Development as Import+import Settings.StaticFiles as Import++#if __GLASGOW_HASKELL__ >= 704+import Data.Monoid as Import+ (Monoid (mappend, mempty, mconcat),+ (<>))+#else+import Data.Monoid as Import+ (Monoid (mappend, mempty, mconcat))++infixr 5 <>+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+#endif
+ Settings.hs view
@@ -0,0 +1,85 @@+-- | 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+-- by overriding methods in the Yesod typeclass. That instance is+-- declared in the Foundation.hs file.+module Settings where++import Prelude+import Text.Shakespeare.Text (st)+import Language.Haskell.TH.Syntax+import Yesod.Default.Config+import Yesod.Default.Util+import Data.Text (Text)+import Data.Yaml+import Control.Applicative+import Settings.Development+import Data.Default (def)+import Text.Hamlet++import Text.Printf (printf)+++hledgerorgurl, manualurl :: String+hledgerorgurl = "http://hledger.org"+manualurl = hledgerorgurl++"/MANUAL.html"++-- | The default TCP port to listen on. May be overridden with --port.+defport :: Int+defport = 5000++defbaseurl :: Int -> String+defbaseurl port = printf "http://localhost:%d" port+++++-- Static setting below. Changing these requires a recompile++-- | 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 = "static"++-- | 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 Foundation.hs, you will+-- have to make a corresponding change here.+--+-- To see how this value is used, see urlRenderOverride in Foundation.hs+staticRoot :: AppConfig DefaultEnv x -> Text+staticRoot conf = [st|#{appRoot conf}/static|]++-- | Settings for 'widgetFile', such as which template languages to support and+-- default Hamlet settings.+widgetFileSettings :: WidgetFileSettings+widgetFileSettings = def+ { wfsHamletSettings = defaultHamletSettings+ { hamletNewlines = AlwaysNewlines+ }+ }++-- The rest of this file contains settings which rarely need changing by a+-- user.++widgetFile :: String -> Q Exp+widgetFile = (if development then widgetFileReload+ else widgetFileNoReload)+ widgetFileSettings++data Extra = Extra+ { extraCopyright :: Text+ , extraAnalytics :: Maybe Text -- ^ Google Analytics+ } deriving Show++parseExtra :: DefaultEnv -> Object -> Parser Extra+parseExtra _ o = Extra+ <$> o .: "copyright"+ <*> o .:? "analytics"
+ Settings/Development.hs view
@@ -0,0 +1,14 @@+module Settings.Development where++import Prelude++development :: Bool+development =+#if DEVELOPMENT+ True+#else+ False+#endif++production :: Bool+production = not development
+ Settings/StaticFiles.hs view
@@ -0,0 +1,32 @@+module Settings.StaticFiles where++import Prelude (IO, putStrLn, (++), (>>), return)+import System.IO (stdout, hFlush)+import Yesod.Static+import qualified Yesod.Static as Static+import Settings (staticDir)+import Settings.Development++-- | use this to create your static file serving site+-- staticSite :: IO Static.Static+-- staticSite = if development then Static.staticDevel staticDir+-- else Static.static staticDir+--+-- | This generates easy references to files in the static directory at compile time,+-- giving you compile-time verification that referenced files exist.+-- Warning: any files added to your static directory during run-time can't be+-- accessed this way. You'll have to use their FilePath or URL to access them.+-- $(staticFiles Settings.staticDir)+++staticSite :: IO Static.Static+staticSite =+ if development+ then (do+ putStrLn ("using web files from: " ++ staticDir ++ "/") >> hFlush stdout+ Static.staticDevel staticDir)+ else (do+ putStrLn "using built-in web files" >> hFlush stdout+ return $(Static.embed staticDir))++$(publicFiles staticDir)
+ app/main.hs view
@@ -0,0 +1,11 @@+import Prelude (IO)+-- import Yesod.Default.Config (fromArgs)+-- import Yesod.Default.Main (defaultMain)+-- import Settings (parseExtra)+-- import Application (makeApplication)++import qualified Hledger.Web.Main++main :: IO ()+-- main = defaultMain (fromArgs parseExtra) makeApplication+main = Hledger.Web.Main.main
+ config/routes view
@@ -0,0 +1,10 @@+/static StaticR Static getStatic+-- /favicon.ico FaviconR GET+/robots.txt RobotsR GET+/ RootR GET+/journal JournalR GET POST+/journal/entries JournalEntriesR GET POST+/journal/edit JournalEditR GET POST+/register RegisterR GET POST+-- /accounts AccountsR GET+-- /api/accounts AccountsJsonR GET
hledger-web.cabal view
@@ -1,5 +1,6 @@ name: hledger-web-version: 0.18.2+-- also in cpp-options below+version: 0.19 category: Finance synopsis: A web interface for the hledger accounting tool. description: @@ -17,13 +18,13 @@ homepage: http://hledger.org bug-reports: http://code.google.com/p/hledger/issues stability: beta-tested-with: GHC==7.0, GHC==7.2, GHC==7.4.1-cabal-version: >= 1.6+tested-with: GHC==7.4.2+cabal-version: >= 1.8 build-type: Simple extra-tmp-files: extra-source-files:- models- routes+ messages/en.msg+ config/routes static/style.css static/hledger.js static/jquery.js@@ -49,8 +50,9 @@ flag blaze_html_0_5 description: Use the newer 0.5 version of blaze-html and blaze-markup.- default: False+ default: True + flag dev Description: Turn on development settings, like auto-reload templates. Default: False@@ -59,44 +61,109 @@ Description: Build for use with "yesod devel" Default: False + library- if flag(library-only)- Buildable: True- else- Buildable: False+ hs-source-dirs: . app - exposed-modules: - Hledger.Web.Application+ exposed-modules: Application+ Foundation+ Import+ Settings+ Settings.StaticFiles+ Settings.Development+ Handler.Handlers other-modules:- Hledger.Web- Hledger.Web.Foundation- Hledger.Web.Import- Hledger.Web.Options- Hledger.Web.Settings- Hledger.Web.Settings.StaticFiles- Hledger.Web.Handlers+ Hledger.Web+ Hledger.Web.Main+ Hledger.Web.Options - ghc-options: -Wall -O0 -fno-warn-unused-do-bind- cpp-options: -DDEVELOPMENT+ -- if flag(library-only)+ -- Buildable: True+ -- else+ -- Buildable: False + ghc-options: -Wall -fno-warn-unused-do-bind+ cpp-options: -DVERSION="0.19"+ if flag(dev) || flag(library-only)+ cpp-options: -DDEVELOPMENT+ extensions: TemplateHaskell QuasiQuotes OverloadedStrings NoImplicitPrelude CPP- OverloadedStrings MultiParamTypeClasses TypeFamilies+ GADTs+ GeneralizedNewtypeDeriving+ FlexibleContexts+ EmptyDataDecls+ NoMonomorphismRestriction + build-depends: base >= 4 && < 5+ -- , yesod-platform >= 1.1 && < 1.2+ , yesod >= 1.1 && < 1.2+ , yesod-core >= 1.1.2 && < 1.2+ , yesod-static >= 1.1 && < 1.2+ , yesod-default >= 1.1 && < 1.2+ , yesod-form >= 1.1 && < 1.2+ , clientsession >= 0.8 && < 0.9+ , bytestring >= 0.9 && < 0.11+ , text >= 0.11 && < 0.12+ , template-haskell+ , hamlet >= 1.1 && < 1.2+ , shakespeare-css >= 1.0 && < 1.1+ , shakespeare-js >= 1.0 && < 1.1+ , shakespeare-text >= 1.0 && < 1.1+ , hjsmin >= 0.1 && < 0.2+ , monad-control >= 0.3 && < 0.4+ , wai-extra >= 1.3 && < 1.4+ , yaml >= 0.8 && < 0.9+ , http-conduit >= 1.8 && < 1.9+ , directory >= 1.1 && < 1.3+ , warp >= 1.3 && < 1.4+ , data-default++ , hledger == 0.19.1+ , hledger-lib == 0.19.1+ , cmdargs >= 0.10 && < 0.11+ , directory+ , filepath+ , HUnit+ , io-storage >= 0.3 && < 0.4+ , network-conduit+ , old-locale+ , parsec+ , regexpr >= 0.5.1+ , safe >= 0.2+ , time+ , transformers+ , wai+ , wai-extra+ , warp+ , yaml++ if flag(blaze_html_0_5)+ cpp-options: -DBLAZE_HTML_0_5+ build-depends:+ blaze-html >= 0.5 && < 0.6+ , blaze-markup >= 0.5.1 && < 0.6+ else+ build-depends:+ blaze-html >= 0.4 && < 0.5++ executable hledger-web+ cpp-options: -DVERSION="0.19"+ if flag(library-only) Buildable: False if flag(dev) cpp-options: -DDEVELOPMENT- ghc-options: -Wall -O0 -fno-warn-unused-do-bind+ ghc-options: -O0 -Wall -fno-warn-unused-do-bind else- ghc-options: -Wall -O2 -fno-warn-unused-do-bind+ ghc-options: -O2 -Wall -fno-warn-unused-do-bind if flag(threaded) ghc-options: -threaded@@ -110,24 +177,27 @@ MultiParamTypeClasses TypeFamilies - main-is: hledger-web.hs+ hs-source-dirs: . app + main-is: main.hs other-modules:+ Application+ Foundation+ Import+ Settings+ Settings.StaticFiles+ Settings.Development+ Handler.Handlers Hledger.Web- Hledger.Web.Foundation- Hledger.Web.Application- Hledger.Web.Import+ Hledger.Web.Main Hledger.Web.Options- Hledger.Web.Settings- Hledger.Web.Settings.StaticFiles- Hledger.Web.Handlers build-depends:- hledger == 0.18.2- , hledger-lib == 0.18.2+ hledger-web+ , hledger == 0.19.1+ , hledger-lib == 0.19.1 , base >= 4.3 && < 5- , cabal-file-th- , cmdargs >= 0.9.1 && < 0.10+ , cmdargs >= 0.10 && < 0.11 , directory , filepath , HUnit@@ -138,7 +208,8 @@ , safe >= 0.2 , time - , yesod == 1.0.*+ -- , yesod-platform == 1.1.*+ , yesod >= 1.1.3 && < 1.2 , yesod-core , yesod-default , yesod-static@@ -147,12 +218,15 @@ , network-conduit , shakespeare-text , template-haskell- , text >= 0.11 && < 0.12- , transformers >= 0.2 && < 0.4+ , text+ , transformers , wai , wai-extra , warp , yaml+ , hjsmin >= 0.1 && < 0.2+ , http-conduit >= 1.8 && < 1.9+ if flag(blaze_html_0_5) cpp-options: -DBLAZE_HTML_0_5 build-depends:@@ -162,11 +236,40 @@ build-depends: blaze-html >= 0.4 && < 0.5 + build-depends:+ -- base >= 4 && < 5+ -- -- , yesod-platform >= 1.1 && < 1.2+ -- , yesod >= 1.1 && < 1.2+ -- , yesod-core >= 1.1.2 && < 1.2+ -- , yesod-static >= 1.1 && < 1.2+ -- , yesod-default >= 1.1 && < 1.2+ -- , yesod-form >= 1.1 && < 1.2+ -- , clientsession >= 0.8 && < 0.9+ -- , bytestring >= 0.9 && < 0.11+ -- , text >= 0.11 && < 0.12+ -- , template-haskell+ -- , hamlet >= 1.1 && < 1.2+ -- , shakespeare-css >= 1.0 && < 1.1+ -- , shakespeare-js >= 1.0 && < 1.1+ -- , shakespeare-text >= 1.0 && < 1.1+ -- , hjsmin >= 0.1 && < 0.2+ -- , monad-control >= 0.3 && < 0.4+ -- , wai-extra >= 1.3 && < 1.4+ -- , yaml >= 0.8 && < 0.9+ -- , http-conduit >= 1.8 && < 1.9+ -- , directory >= 1.1 && < 1.3+ -- , warp >= 1.3 && < 1.4+ data-default - -- if flag(production)- -- cpp-options: -DPRODUCTION- -- ghc-options: -O2- -- else- -- ghc-options: -Wall- -- if flag(threaded)- -- ghc-options: -threaded+test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: tests+ ghc-options: -Wall++ build-depends: + base+ , hledger-web+ , yesod-test >= 0.3 && < 0.4+ , yesod-default+ , yesod-core
− hledger-web.hs
@@ -1,93 +0,0 @@-{-# LANGUAGE CPP, OverloadedStrings #-}-{-|--hledger-web - a hledger add-on providing a web interface.-Copyright (c) 2007-2012 Simon Michael <simon@joyful.com>-Released under GPL version 3 or later.---}--module Main-where--import Data.Conduit.Network (HostPreference(..))-import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort)-import Yesod.Default.Config--- import Yesod.Default.Main (defaultMain)-import Yesod.Logger ({- Logger,-} defaultDevelopmentLogger) --, logString)--import Prelude hiding (putStrLn)--- -- import Control.Concurrent (forkIO, threadDelay)-import Control.Monad--- import Data.Maybe-import Data.Text(pack)-import System.Exit-import System.IO.Storage (withStore, putValue)-import Text.Printf--import Hledger-import Hledger.Cli hiding (progname,prognameandversion)-import Hledger.Utils.UTF8IOCompat (putStrLn)-import Hledger.Web hiding (opts,j)---main :: IO ()-main = do- opts <- getHledgerWebOpts- when (debug_ $ cliopts_ opts) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts)- runWith opts--runWith :: WebOpts -> IO ()-runWith opts- | "help" `in_` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp webmode) >> exitSuccess- | "version" `in_` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess- | "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)- | otherwise = journalFilePathFromOpts (cliopts_ opts) >>= requireJournalFileExists >> withJournalDo' opts web--withJournalDo' :: WebOpts -> (WebOpts -> Journal -> IO ()) -> IO ()-withJournalDo' opts cmd = do- journalFilePathFromOpts (cliopts_ opts) >>= readJournalFile Nothing Nothing >>=- either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts))---- | The web command.-web :: WebOpts -> Journal -> IO ()-web opts j = do- -- unless (debug_ $ cliopts_ opts) $ forkIO (browser baseurl) >> return ()- server (base_url_ opts) (port_ opts) opts j---- browser :: String -> IO ()--- browser baseurl = do--- threadDelay $ fromIntegral browserstartdelay--- putStrLn "Attempting to start a web browser"--- openBrowserOn baseurl >> return ()--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- -- }- withStore "hledger" $ do- putValue "hledger" "journal" j---- defaultMain :: (Show env, Read env)--- => IO (AppConfig env extra)--- -> (AppConfig env extra -> Logger -> IO Application)--- -> IO ()--- defaultMain load getApp = do- -- config <- fromArgs parseExtra- let config = AppConfig {- appEnv = Development- , appPort = port_ opts- , appRoot = pack baseurl- , appHost = HostIPv4- , appExtra = Extra "" Nothing- }- logger <- defaultDevelopmentLogger- app <- getApplication config logger- runSettings defaultSettings- { settingsPort = appPort config- } app
+ messages/en.msg view
@@ -0,0 +1,1 @@+Hello: Hello
− models
− routes
@@ -1,10 +0,0 @@-/static StaticR Static getStatic--- /favicon.ico FaviconR GET-/robots.txt RobotsR GET-/ RootR GET-/journal JournalR GET POST-/journal/entries JournalEntriesR GET POST-/journal/edit JournalEditR GET POST-/register RegisterR GET POST--- /accounts AccountsR GET--- /api/accounts AccountsJsonR GET
+ tests/main.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Import+import Yesod.Default.Config+import Yesod.Test+import Application (makeFoundation)++import HomeTest++main :: IO ()+main = do+ conf <- loadConfig $ (configSettings Testing) { csParseExtra = parseExtra }+ foundation <- makeFoundation conf+ app <- toWaiAppPlain foundation+ runTests app (error "No database available") homeSpecs