-- | Web utilities and rendering helpers. module Handler.Utils where import Prelude import Control.Applicative ((<$>)) import Control.Monad.IO.Class (liftIO) import Data.List import Data.Maybe import Data.Text(Text,pack,unpack) import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format 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 ---------------------------------------------------------------------- -- 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) chomp :: String -> String chomp = reverse . dropWhile (`elem` "\r\n") . reverse ---------------------------------------------------------------------- -- Rendering helpers -- | Link to a topic in the manual. helplink :: String -> String -> HtmlUrl AppRoute helplink topic label = [hamlet| #{label} |] where u = manualurl ++ if null topic then "" else '#':topic -- | Render an "AccountsReport" as html. accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> HtmlUrl AppRoute accountsReportAsHtml _ vd@VD{..} (items',total) = [hamlet| [+]
Add a transaction..
Journal   entries   edit
Accounts $forall i <- items ^{itemAsHtml vd i} #{mixedAmountAsHtml total} |] 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| #{indent} #{adisplay} $if hassubs   only #{mixedAmountAsHtml abal} |] where hassubs = not $ maybe False (null.asubs) $ ledgerAccount l acct -- (#{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| $forall i <- numbered items ^{itemAsHtml vd i} |] where itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute itemAsHtml _ (n, t) = [hamlet| 
#{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|

 
  Date
  Description
  Accounts
  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|

 #{date}
 #{elideRight 60 desc}
 
  $if showamt
   #{mixedAmountAsHtml amt}
$forall p' <- tpostings t
  
   
   
    #{elideRight 40 $ paccount p'}
   #{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|

 
  Date
  Description
  To/From Account
    
  Amount
  #{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|

 #{date}
 #{elideRight 30 desc}
 
  
   #{elideRight 40 acct}
   
  
   [+]
 
  $if showamt
   #{mixedAmountAsHtml amt}
 #{mixedAmountAsHtml bal}
$forall p' <- tpostings t
 
   
   
    #{elideRight 40 $ paccount p'}
   #{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)
       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|