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

web: Split long functions, remove unused parameters

Browse Source
This commit is contained in:
Jakub Zárybnický 2018-06-09 11:56:42 +02:00
parent 7404813239
commit 1d2b3521f6
6 changed files with 101 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
hledger-web/Foundation.hs
View File

@ -1,5 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, QuasiQuotes, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE CPP, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RecordWildCards, QuasiQuotes, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
-- | Define the web application's foundation, in the usual Yesod style.
-- See a default Yesod app's comments for more details of each part.
@ -21,7 +21,7 @@ import Yesod.Static
import Yesod.Default.Config
import Settings.StaticFiles
import Settings (staticRoot, widgetFile, Extra (..))
import Settings (widgetFile, Extra (..))
#ifndef DEVELOPMENT
import Settings (staticDir)
import Text.Jasmine (minifym)
@ -115,7 +115,6 @@ instance Yesod App where
addScript $ StaticR hledger_js
$(widgetFile "default-layout")
staticRootUrl <- (staticRoot . settings) <$> getYesod
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
#ifndef DEVELOPMENT
@ -180,25 +179,18 @@ viewdataWithDateAndParams d q a =
-- | Gather data used by handlers and templates in the current request.
getViewData :: Handler ViewData
getViewData = do
mhere <- getCurrentRoute
case mhere of
getViewData = getCurrentRoute >>= \case
Nothing -> return nullviewdata
Just here -> do
app <- getYesod
let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app
App {appOpts, appJournal} <- getYesod
let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts
today <- liftIO getCurrentDay
(j, merr) <- getCurrentJournal app copts{reportopts_=ropts{no_elide_=True}} today
(j, merr) <- getCurrentJournal appJournal copts{reportopts_=ropts{no_elide_=True}} today
lastmsg <- getLastMessage
let msg = maybe lastmsg (Just . toHtml) merr
q <- fromMaybe "" <$> lookupGetParam "q"
a <- fromMaybe "" <$> lookupGetParam "a"
-- sidebar visibility: show it, unless there is a showsidebar cookie
-- set to "0", or a ?sidebar=0 query parameter.
msidebarparam <- lookupGetParam "sidebar"
msidebarcookie <- reqCookies <$> getRequest >>= return . lookup "showsidebar"
let showsidebar = maybe (msidebarcookie /= Just "0") (/="0") msidebarparam
showsidebar <- shouldShowSidebar
return (viewdataWithDateAndParams today q a){
opts=opts
,msg=msg
@ -207,25 +199,35 @@ getViewData = do
,j=j
,showsidebar=showsidebar
}
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 :: App -> CliOpts -> Day -> Handler (Journal, Maybe String)
getCurrentJournal app opts d = do
-- XXX put this inside atomicModifyIORef' for thread safety
j <- liftIO $ readIORef $ appJournal app
(ej, changed) <- liftIO $ journalReloadIfChanged opts d j
-- re-apply any initial filter specified at startup
let initq = queryFromOpts d $ reportopts_ opts
ej' = filterJournalTransactions initq <$> ej
if not changed
then return (j,Nothing)
else case ej' of
Right j' -> do liftIO $ writeIORef (appJournal app) j'
return (j',Nothing)
Left e -> do setMessage "error while reading"
return (j, Just e)
-- | Find out if the sidebar should be visible. Show it, unless there is a
-- showsidebar cookie set to "0", or a ?sidebar=0 query parameter.
shouldShowSidebar :: Handler Bool
shouldShowSidebar = do
msidebarparam <- lookupGetParam "sidebar"
msidebarcookie <- lookup "showsidebar" . reqCookies <$> getRequest
return $ maybe (msidebarcookie /= Just "0") (/="0") msidebarparam
-- | 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 :: IORef Journal -> CliOpts -> Day -> Handler (Journal, Maybe String)
getCurrentJournal jref opts d = do
-- XXX put this inside atomicModifyIORef' for thread safety
j <- liftIO (readIORef jref)
(ej, changed) <- liftIO $ journalReloadIfChanged opts d j
-- re-apply any initial filter specified at startup
let initq = queryFromOpts d $ reportopts_ opts
ej' = filterJournalTransactions initq <$> ej
if not changed
then return (j,Nothing)
else case ej' of
Right j' -> do
liftIO $ writeIORef jref j'
return (j',Nothing)
Left e -> do
setMessage "error while reading journal"
return (j, Just e)
-- | Get the message that was set by the last request, in a
-- referentially transparent manner (allowing multiple reads).
@ -235,8 +237,8 @@ getLastMessage = cached getMessage
-- add form dialog, part of the default template
-- | Add transaction form.
addform :: Text -> ViewData -> HtmlUrl AppRoute
addform _ vd@VD{..} = [hamlet|
addform :: ViewData -> HtmlUrl AppRoute
addform VD{..} = [hamlet|
<script>
jQuery(document).ready(function() {
@ -281,7 +283,7 @@ addform _ vd@VD{..} = [hamlet|
<input #description required .typeahead .form-control .input-lg type=text size=40 name=description placeholder="Description">
<div .account-postings>
$forall n <- postingnums
^{postingfields vd n}
^{postingfields n}
<div .col-md-8 .col-xs-8 .col-sm-8>
<div .col-md-4 .col-xs-4 .col-sm-4>
<button type=submit .btn .btn-default .btn-lg name=submit>add
@ -303,8 +305,8 @@ addform _ vd@VD{..} = [hamlet|
numpostings = 4
postingnums = [1..numpostings]
filepaths = map fst $ jfiles j
postingfields :: ViewData -> Int -> HtmlUrl AppRoute
postingfields _ n = [hamlet|
postingfields :: Int -> HtmlUrl AppRoute
postingfields n = [hamlet|
<div .form-group .row .account-group ##{grpvar}>
<div .col-md-8 .col-xs-8 .col-sm-8>
<input ##{acctvar} .account-input .typeahead .form-control .input-lg type=text name=#{acctvar} placeholder="#{acctph}">

88
hledger-web/Handler/AddForm.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards, TypeFamilies #-}
{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards, ScopedTypeVariables, TypeFamilies #-}
-- | Add form data & handler. (The layout and js are defined in
-- Foundation so that the add form can be in the default layout for
-- all views.)
@ -8,13 +8,12 @@ module Handler.AddForm where
import Import
import Control.Monad.State.Strict (evalStateT)
import Data.Either (lefts, rights)
import Data.List (sort)
import Data.Maybe (fromMaybe, maybeToList)
import Data.List (sortBy)
import qualified Data.Text as T
import Data.Time.Calendar
import Data.Void (Void)
import Safe (headMay)
import Text.Blaze (ToMarkup)
import Text.Megaparsec
import Text.Megaparsec.Char
@ -30,31 +29,26 @@ data AddForm = AddForm
, addFormJournalFile :: Maybe Text
} deriving Show
postAddForm :: Handler Html
postAddForm = do
let showErrors errs = do
setMessage [shamlet|
Errors:<br>
$forall e<-errs
\#{e}<br>
|]
-- 1. process the fixed fields with yesod-form
VD{..} <- getViewData
let validateJournalFile :: Text -> Either FormMessage Text
validateJournalFile f
| T.unpack f `elem` journalFilePaths j = Right f
| otherwise = Left $ MsgInvalidEntry $ "the selected journal file \"" <> f <> "\"is unknown"
validateDate :: Text -> Either FormMessage Day
validateDate s = case fixSmartDateStrEither' today (T.strip s) of
Right d -> Right d
Left _ -> Left $ MsgInvalidEntry $ "could not parse date \"" <> s <> "\":"
formresult <- runInputPostResult $ AddForm
addForm :: Day -> Journal -> FormInput Handler AddForm
addForm today j = AddForm
<$> ireq (checkMMap (pure . validateDate) (T.pack . show) textField) "date"
<*> iopt textField "description"
<*> iopt (check validateJournalFile textField) "journal"
where
validateJournalFile :: Text -> Either FormMessage Text
validateJournalFile f
| T.unpack f `elem` journalFilePaths j = Right f
| otherwise = Left $ MsgInvalidEntry $ "the selected journal file \"" <> f <> "\"is unknown"
validateDate :: Text -> Either FormMessage Day
validateDate s = case fixSmartDateStrEither' today (T.strip s) of
Right d -> Right d
Left _ -> Left $ MsgInvalidEntry $ "could not parse date \"" <> s <> "\":"
postAddForm :: Handler Html
postAddForm = do
-- 1. process the fixed fields with yesod-form
VD{..} <- getViewData
formresult <- runInputPostResult (addForm today j)
ok <- case formresult of
FormMissing -> showErrors ["there is no form data" :: Text] >> return False
@ -72,16 +66,8 @@ postAddForm = do
-- getting either errors or a balanced transaction
(params,_) <- runRequestBody
let numberedParams s =
reverse $ dropWhile (T.null . snd) $ reverse $ sort
[ (n,v) | (k,v) <- params
, let en = parsewith (paramnamep s) k :: Either (ParseError Char Void) Int
, isRight en
, let Right n = en
]
where paramnamep s = do {string s; n <- some digitChar; eof; return (read n :: Int)}
acctparams = numberedParams "account"
amtparams = numberedParams "amount"
let acctparams = parseNumberedParameters "account" params
amtparams = parseNumberedParameters "amount" params
num = length acctparams
paramErrs | num == 0 = ["at least one posting must be entered"]
| map fst acctparams == [1..num] &&
@ -105,12 +91,32 @@ postAddForm = do
Left errs -> showErrors errs >> return False
Right t -> do
-- 3. all fields look good and form a balanced transaction; append it to the file
liftIO $ do ensureJournalFileExists journalfile
appendToJournalFileOrStdout journalfile $
showTransaction $
txnTieKnot -- XXX move into balanceTransaction
t
liftIO (appendTransaction journalfile t)
setMessage [shamlet|<span>Transaction added.|]
return True
if ok then redirect JournalR else redirect (JournalR, [("add","1")])
parseNumberedParameters :: Text -> [(Text, Text)] -> [(Int, Text)]
parseNumberedParameters s =
reverse . dropWhile (T.null . snd) . sortBy (flip compare) . mapMaybe parseNum
where
parseNum :: (Text, Text) -> Maybe (Int, Text)
parseNum (k, v) = case parsewith paramnamep k of
Left (_ :: ParseError Char Void) -> Nothing
Right k' -> Just (k', v)
paramnamep = string s *> (read <$> some digitChar) <* eof
-- XXX move into balanceTransaction
appendTransaction :: FilePath -> Transaction -> IO ()
appendTransaction journalfile t = do
ensureJournalFileExists journalfile
appendToJournalFileOrStdout journalfile $
showTransaction (txnTieKnot t)
showErrors :: ToMarkup a => [a] -> Handler ()
showErrors errs = setMessage [shamlet|
Errors:<br>
$forall e<-errs
\#{e}<br>
|]

6
hledger-web/Handler/JournalR.hs
View File

@ -26,7 +26,7 @@ getJournalR = do
where s1 = if inclsubs then "" else " (excluding subaccounts)"
where
s2 = if m /= Any then ", filtered" else ""
maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
maincontent = journalTransactionsReportAsHtml vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
hledgerLayout vd "journal" [hamlet|
<div .row>
<h2 #contenttitle>#{title}
@ -40,8 +40,8 @@ postJournalR :: Handler Html
postJournalR = postAddForm
-- | Render a "TransactionsReport" as html for the formatted journal view.
journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
journalTransactionsReportAsHtml _ vd (_,items) = [hamlet|
journalTransactionsReportAsHtml :: ViewData -> TransactionsReport -> HtmlUrl AppRoute
journalTransactionsReportAsHtml vd (_,items) = [hamlet|
<table .transactionsreport .table .table-condensed>
<thead>
<th .date style="text-align:left;">

13
hledger-web/Handler/RegisterR.hs
View File

@ -7,7 +7,6 @@ import Import
import Data.Time
import Data.List (intersperse)
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T
import Safe (headMay)
@ -32,22 +31,22 @@ getRegisterR = do
s2 = if m /= Any then ", filtered" else ""
hledgerLayout vd "register" $ do
_ <- [hamlet|<h2 #contenttitle>#{title}|]
registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts
registerReportHtml vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts
postRegisterR :: Handler Html
postRegisterR = postAddForm
-- | Generate html for an account register, including a balance chart and transaction list.
registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
registerReportHtml opts vd r = [hamlet|
registerReportHtml :: ViewData -> TransactionsReport -> HtmlUrl AppRoute
registerReportHtml vd r = [hamlet|
<div .hidden-xs>
^{registerChartHtml $ transactionsReportByCommodity r}
^{registerItemsHtml opts vd r}
^{registerItemsHtml vd r}
|]
-- | Generate html for a transaction list from an "TransactionsReport".
registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
registerItemsHtml _ vd (balancelabel,items) = [hamlet|
registerItemsHtml :: ViewData -> TransactionsReport -> HtmlUrl AppRoute
registerItemsHtml vd (balancelabel,items) = [hamlet|
<div .table-responsive>
<table.registerreport .table .table-striped .table-condensed>
<thead>

3
hledger-web/Import.hs
View File

@ -7,6 +7,9 @@ import Prelude as Import hiding (head, init, last,
readFile, tail, writeFile)
import Yesod as Import hiding (Route (..))
import Data.Bifunctor as Import (first, second, bimap)
import Data.Either as Import (lefts, rights)
import Data.Maybe as Import (fromMaybe, maybeToList, mapMaybe, isJust)
import Data.Text as Import (Text)
import Foundation as Import

2
hledger-web/templates/default-layout-wrapper.hamlet
View File

@ -104,4 +104,4 @@ $newline never
$maybe m <- lastmsg
$if isPrefixOf "Errors" (renderHtml m)
<div #message>#{m}
^{addform staticRootUrl vd}
^{addform vd}