87 lines
3.3 KiB
Haskell
87 lines
3.3 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Handler.AddR
|
|
( postAddR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Control.Monad.State.Strict (evalStateT)
|
|
import Data.List (sortBy)
|
|
import qualified Data.Text as T
|
|
import Data.Void (Void)
|
|
import Safe (headMay)
|
|
import Text.Megaparsec
|
|
import Text.Megaparsec.Char
|
|
|
|
import Handler.AddForm (AddForm(..), addForm)
|
|
import Handler.Common (showErrors)
|
|
|
|
import Hledger
|
|
import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout)
|
|
|
|
postAddR :: Handler ()
|
|
postAddR = do
|
|
VD{today, j} <- getViewData
|
|
-- 1. process the fixed fields with yesod-form
|
|
runInputPostResult (addForm today j) >>= \case
|
|
FormMissing -> bail ["there is no form data"]
|
|
FormFailure errs -> bail errs
|
|
FormSuccess form -> do
|
|
let journalfile = maybe (journalFilePath j) T.unpack $ addFormJournalFile form
|
|
-- 2. the fixed fields look good; now process the posting fields adhocly,
|
|
-- getting either errors or a balanced transaction
|
|
(params,_) <- runRequestBody
|
|
let acctparams = parseNumberedParameters "account" params
|
|
amtparams = parseNumberedParameters "amount" params
|
|
pnum = length acctparams
|
|
when (pnum == 0) (bail ["at least one posting must be entered"])
|
|
when (map fst acctparams /= [1..pnum] || map fst amtparams `elem` [[1..pnum], [1..pnum-1]])
|
|
(bail ["the posting parameters are malformed"])
|
|
|
|
let eaccts = runParser (accountnamep <* eof) "" . textstrip . snd <$> acctparams
|
|
eamts = runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd <$> amtparams
|
|
(acctErrs, accts) = partitionEithers eaccts
|
|
(amtErrs, amts') = partitionEithers eamts
|
|
amts | length amts' == pnum = amts'
|
|
| otherwise = amts' ++ [missingamt]
|
|
errs = T.pack . parseErrorPretty <$> acctErrs ++ amtErrs
|
|
unless (null errs) (bail errs)
|
|
|
|
let etxn = balanceTransaction Nothing $ nulltransaction
|
|
{ tdate = addFormDate form
|
|
, tdescription = fromMaybe "" $ addFormDescription form
|
|
, tpostings = (\(ac, am) -> nullposting {paccount = ac, pamount = Mixed [am]}) <$> zip accts amts
|
|
}
|
|
case etxn of
|
|
Left errs' -> bail (fmap T.pack . maybeToList . headMay $ lines errs')
|
|
Right t -> do
|
|
-- 3. all fields look good and form a balanced transaction; append it to the file
|
|
liftIO (appendTransaction journalfile t)
|
|
setMessage [shamlet|<span>Transaction added.|]
|
|
redirect JournalR
|
|
where
|
|
bail :: [Text] -> Handler ()
|
|
bail xs = showErrors xs >> 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)
|