diff --git a/Application.hs b/Application.hs new file mode 100644 --- /dev/null +++ b/Application.hs @@ -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 + } diff --git a/Foundation.hs b/Foundation.hs new file mode 100644 --- /dev/null +++ b/Foundation.hs @@ -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 + + + #{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 diff --git a/Handler/Handlers.hs b/Handler/Handlers.hs new file mode 100644 --- /dev/null +++ b/Handler/Handlers.hs @@ -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) diff --git a/Hledger/Web.hs b/Hledger/Web.hs --- a/Hledger/Web.hs +++ b/Hledger/Web.hs @@ -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 ] diff --git a/Hledger/Web/Application.hs b/Hledger/Web/Application.hs deleted file mode 100644 --- a/Hledger/Web/Application.hs +++ /dev/null @@ -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 - } diff --git a/Hledger/Web/Foundation.hs b/Hledger/Web/Foundation.hs deleted file mode 100644 --- a/Hledger/Web/Foundation.hs +++ /dev/null @@ -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 diff --git a/Hledger/Web/Handlers.hs b/Hledger/Web/Handlers.hs deleted file mode 100644 --- a/Hledger/Web/Handlers.hs +++ /dev/null @@ -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) diff --git a/Hledger/Web/Import.hs b/Hledger/Web/Import.hs deleted file mode 100644 --- a/Hledger/Web/Import.hs +++ /dev/null @@ -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 diff --git a/Hledger/Web/Main.hs b/Hledger/Web/Main.hs new file mode 100644 --- /dev/null +++ b/Hledger/Web/Main.hs @@ -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 diff --git a/Hledger/Web/Options.hs b/Hledger/Web/Options.hs --- a/Hledger/Web/Options.hs +++ b/Hledger/Web/Options.hs @@ -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 diff --git a/Hledger/Web/Settings.hs b/Hledger/Web/Settings.hs deleted file mode 100644 --- a/Hledger/Web/Settings.hs +++ /dev/null @@ -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} diff --git a/Hledger/Web/Settings/StaticFiles.hs b/Hledger/Web/Settings/StaticFiles.hs deleted file mode 100644 --- a/Hledger/Web/Settings/StaticFiles.hs +++ /dev/null @@ -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) diff --git a/Import.hs b/Import.hs new file mode 100644 --- /dev/null +++ b/Import.hs @@ -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 diff --git a/Settings.hs b/Settings.hs new file mode 100644 --- /dev/null +++ b/Settings.hs @@ -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" diff --git a/Settings/Development.hs b/Settings/Development.hs new file mode 100644 --- /dev/null +++ b/Settings/Development.hs @@ -0,0 +1,14 @@ +module Settings.Development where + +import Prelude + +development :: Bool +development = +#if DEVELOPMENT + True +#else + False +#endif + +production :: Bool +production = not development diff --git a/Settings/StaticFiles.hs b/Settings/StaticFiles.hs new file mode 100644 --- /dev/null +++ b/Settings/StaticFiles.hs @@ -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) diff --git a/app/main.hs b/app/main.hs new file mode 100644 --- /dev/null +++ b/app/main.hs @@ -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 diff --git a/config/routes b/config/routes new file mode 100644 --- /dev/null +++ b/config/routes @@ -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 diff --git a/hledger-web.cabal b/hledger-web.cabal --- a/hledger-web.cabal +++ b/hledger-web.cabal @@ -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 diff --git a/hledger-web.hs b/hledger-web.hs deleted file mode 100644 --- a/hledger-web.hs +++ /dev/null @@ -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 diff --git a/messages/en.msg b/messages/en.msg new file mode 100644 --- /dev/null +++ b/messages/en.msg @@ -0,0 +1,1 @@ +Hello: Hello diff --git a/models b/models deleted file mode 100644 --- a/models +++ /dev/null diff --git a/routes b/routes deleted file mode 100644 --- a/routes +++ /dev/null @@ -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 diff --git a/tests/main.hs b/tests/main.hs new file mode 100644 --- /dev/null +++ b/tests/main.hs @@ -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