{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Hledger.Web.Widget.AddForm
( addForm
, addModal
) where
import Control.Monad.State.Strict (evalStateT)
import Data.Bifunctor (first)
import Data.Foldable (toList)
import Data.List (dropWhileEnd, unfoldr)
import Data.Maybe (isJust, fromMaybe)
import qualified Data.Set as S
import Data.Text (Text)
import Data.Text.Encoding.Base64 (encodeBase64)
import qualified Data.Text as T
import Data.Time (Day)
import Text.Blaze.Internal (Markup, preEscapedText)
import Text.Megaparsec (bundleErrors, eof, parseErrorTextPretty, runParser)
import Yesod
import Hledger
import Hledger.Web.App (App, Handler, Widget)
import Hledger.Web.Settings (widgetFile)
import Data.Function ((&))
import Control.Arrow (right)
addModal :: Route App -> Journal -> Day -> Widget
addModal :: Route App -> Journal -> Day -> WidgetFor App ()
addModal Route App
addR Journal
j Day
today = do
(WidgetFor App ()
addView, Enctype
addEnctype) <- HandlerFor App (WidgetFor App (), Enctype)
-> WidgetFor App (WidgetFor App (), Enctype)
forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget (HandlerFor App (WidgetFor App (), Enctype)
-> WidgetFor App (WidgetFor App (), Enctype))
-> HandlerFor App (WidgetFor App (), Enctype)
-> WidgetFor App (WidgetFor App (), Enctype)
forall a b. (a -> b) -> a -> b
$ (Markup
-> MForm
(HandlerFor App)
(FormResult (Transaction, FilePath), WidgetFor App ()))
-> HandlerFor App (WidgetFor App (), Enctype)
forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadHandler m) =>
(Markup -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormPost (Journal
-> Day
-> Markup
-> MForm
(HandlerFor App)
(FormResult (Transaction, FilePath), WidgetFor App ())
addForm Journal
j Day
today)
WidgetFor App ()
[whamlet|
<div .modal #addmodal tabindex="-1" role="dialog" aria-labelledby="addLabel" aria-hidden="true">
<div .modal-dialog .modal-lg>
<div .modal-content>
<div .modal-header>
<button type="button" .close data-dismiss="modal" aria-hidden="true">×
<h3 .modal-title #addLabel>Add a transaction
<div .modal-body>
<form#addform.form action=@{addR} method=POST enctype=#{addEnctype}>
^{addView}
|]
addForm :: Journal -> Day -> Markup -> MForm Handler (FormResult (Transaction,FilePath), Widget)
addForm :: Journal
-> Day
-> Markup
-> MForm
(HandlerFor App)
(FormResult (Transaction, FilePath), WidgetFor App ())
addForm Journal
j Day
today = Text
-> (Markup
-> RWST
(Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
Enctype
Ints
(HandlerFor App)
(FormResult (Transaction, FilePath),
WidgetFor (HandlerSite (HandlerFor App)) ()))
-> Markup
-> RWST
(Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
Enctype
Ints
(HandlerFor App)
(FormResult (Transaction, FilePath),
WidgetFor (HandlerSite (HandlerFor App)) ())
forall (m :: * -> *) a.
Monad m =>
Text
-> (Markup -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
-> Markup
-> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
identifyForm Text
"add" ((Markup
-> RWST
(Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
Enctype
Ints
(HandlerFor App)
(FormResult (Transaction, FilePath),
WidgetFor (HandlerSite (HandlerFor App)) ()))
-> Markup
-> RWST
(Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
Enctype
Ints
(HandlerFor App)
(FormResult (Transaction, FilePath),
WidgetFor (HandlerSite (HandlerFor App)) ()))
-> (Markup
-> RWST
(Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
Enctype
Ints
(HandlerFor App)
(FormResult (Transaction, FilePath),
WidgetFor (HandlerSite (HandlerFor App)) ()))
-> Markup
-> RWST
(Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
Enctype
Ints
(HandlerFor App)
(FormResult (Transaction, FilePath),
WidgetFor (HandlerSite (HandlerFor App)) ())
forall a b. (a -> b) -> a -> b
$ \Markup
extra -> do
let
descriptions :: Set Text
descriptions = ([Text] -> Set Text) -> [[Text]] -> Set Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Journal -> [Text]
journalPayeesDeclaredOrUsed Journal
j, Journal -> [Text]
journalDescriptions Journal
j]
files :: [FilePath]
files = (FilePath, Text) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, Text) -> FilePath) -> [(FilePath, Text)] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Journal -> [(FilePath, Text)]
jfiles Journal
j
deffile :: FilePath
deffile = Journal -> FilePath
journalFilePath Journal
j
(FormResult Day
dateRes, FieldView (HandlerSite (HandlerFor App))
dateView) <- Field (HandlerFor App) Day
-> FieldSettings (HandlerSite (HandlerFor App))
-> Maybe Day
-> MForm
(HandlerFor App)
(FormResult Day, FieldView (HandlerSite (HandlerFor App)))
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field (HandlerFor App) Day
dateField FieldSettings (HandlerSite (HandlerFor App))
forall {master}. FieldSettings master
dateSettings Maybe Day
forall a. Maybe a
Nothing
(FormResult (Maybe Text)
descRes, FieldView (HandlerSite (HandlerFor App))
descView) <- Field (HandlerFor App) Text
-> FieldSettings (HandlerSite (HandlerFor App))
-> Maybe (Maybe Text)
-> MForm
(HandlerFor App)
(FormResult (Maybe Text), FieldView (HandlerSite (HandlerFor App)))
forall site (m :: * -> *) a.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> MForm m (FormResult (Maybe a), FieldView site)
mopt Field (HandlerFor App) Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField FieldSettings (HandlerSite (HandlerFor App))
forall {master}. FieldSettings master
descSettings Maybe (Maybe Text)
forall a. Maybe a
Nothing
(FormResult [Text]
acctsRes, FieldView (HandlerSite (HandlerFor App))
_) <- Field (HandlerFor App) [Text]
-> FieldSettings (HandlerSite (HandlerFor App))
-> Maybe [Text]
-> MForm
(HandlerFor App)
(FormResult [Text], FieldView (HandlerSite (HandlerFor App)))
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field (HandlerFor App) [Text]
listField FieldSettings (HandlerSite (HandlerFor App))
forall {master}. FieldSettings master
acctSettings Maybe [Text]
forall a. Maybe a
Nothing
(FormResult [Text]
amtsRes, FieldView App
_) <- Field (HandlerFor App) [Text]
-> FieldSettings App
-> Maybe [Text]
-> MForm (HandlerFor App) (FormResult [Text], FieldView App)
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field (HandlerFor App) [Text]
listField FieldSettings App
forall {master}. FieldSettings master
amtSettings Maybe [Text]
forall a. Maybe a
Nothing
(FormResult (Maybe FilePath)
fileRes, FieldView App
fileView) <- Field (HandlerFor App) FilePath
-> FieldSettings App
-> Maybe (Maybe FilePath)
-> MForm
(HandlerFor App) (FormResult (Maybe FilePath), FieldView App)
forall site (m :: * -> *) a.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> MForm m (FormResult (Maybe a), FieldView site)
mopt Field (HandlerFor App) FilePath
fileField' FieldSettings App
forall {master}. FieldSettings master
fileSettings Maybe (Maybe FilePath)
forall a. Maybe a
Nothing
let
(FormResult [Posting]
postingsRes, [(Int, (Text, Text, Maybe Text, Maybe Text))]
displayRows) = FormResult [Text]
-> FormResult [Text]
-> (FormResult [Posting],
[(Int, (Text, Text, Maybe Text, Maybe Text))])
validatePostings FormResult [Text]
acctsRes FormResult [Text]
amtsRes
formRes :: FormResult (Transaction, FilePath)
formRes = FilePath
-> FormResult Day
-> FormResult (Maybe Text)
-> FormResult [Posting]
-> FormResult (Maybe FilePath)
-> FormResult (Transaction, FilePath)
validateTransaction FilePath
deffile FormResult Day
dateRes FormResult (Maybe Text)
descRes FormResult [Posting]
postingsRes FormResult (Maybe FilePath)
fileRes
(FormResult (Transaction, FilePath), WidgetFor App ())
-> RWST
(Maybe (Env, FileEnv), App, [Text])
Enctype
Ints
(HandlerFor App)
(FormResult (Transaction, FilePath), WidgetFor App ())
forall a.
a
-> RWST
(Maybe (Env, FileEnv), App, [Text]) Enctype Ints (HandlerFor App) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult (Transaction, FilePath)
formRes, $(widgetFile "add-form"))
where
dateField :: Field (HandlerFor App) Day
dateField = Field (HandlerFor App) Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Field (HandlerFor App) Text
-> (Field (HandlerFor App) Text -> Field (HandlerFor App) Day)
-> Field (HandlerFor App) Day
forall a b. a -> (a -> b) -> b
& (Text -> Handler (Either Text Day))
-> (Day -> Text)
-> Field (HandlerFor App) Text
-> Field (HandlerFor App) Day
forall (m :: * -> *) msg a b.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> m (Either msg b)) -> (b -> a) -> Field m a -> Field m b
checkMMap (Either Text Day -> Handler (Either Text Day)
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Day -> Handler (Either Text Day))
-> (Text -> Either Text Day) -> Text -> Handler (Either Text Day)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EFDay -> Day) -> Either Text EFDay -> Either Text Day
forall b c d. (b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right EFDay -> Day
fromEFDay (Either Text EFDay -> Either Text Day)
-> (Text -> Either Text EFDay) -> Text -> Either Text Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text EFDay
validateDate) (FilePath -> Text
T.pack (FilePath -> Text) -> (Day -> FilePath) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> FilePath
forall a. Show a => a -> FilePath
show)
where
validateDate :: Text -> Either Text EFDay
validateDate Text
s =
(HledgerParseErrors -> Text)
-> Either HledgerParseErrors EFDay -> Either Text EFDay
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> HledgerParseErrors -> Text
forall a b. a -> b -> a
const (Text
"Invalid date format" :: Text)) (Either HledgerParseErrors EFDay -> Either Text EFDay)
-> Either HledgerParseErrors EFDay -> Either Text EFDay
forall a b. (a -> b) -> a -> b
$
Day -> Text -> Either HledgerParseErrors EFDay
fixSmartDateStrEither' Day
today (Text -> Text
T.strip Text
s)
listField :: Field (HandlerFor App) [Text]
listField = Field
{ fieldParse :: [Text]
-> [FileInfo]
-> Handler
(Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
fieldParse = Handler
(Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
-> [FileInfo]
-> Handler
(Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
forall a b. a -> b -> a
const (Handler
(Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
-> [FileInfo]
-> Handler
(Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])))
-> ([Text]
-> Handler
(Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])))
-> [Text]
-> [FileInfo]
-> Handler
(Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])
-> Handler
(Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])
-> Handler
(Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])))
-> ([Text]
-> Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
-> [Text]
-> Handler
(Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Text]
-> Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])
forall a b. b -> Either a b
Right (Maybe [Text]
-> Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
-> ([Text] -> Maybe [Text])
-> [Text]
-> Either
(SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text])
-> ([Text] -> [Text]) -> [Text] -> Maybe [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Text -> Bool
T.null
, fieldView :: FieldViewFunc (HandlerFor App) [Text]
fieldView = FilePath -> FieldViewFunc (HandlerFor App) [Text]
forall a. FilePath -> a
error' FilePath
"listField should not be used for rendering"
, fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
}
fileField' :: Field Handler FilePath
fileField' :: Field (HandlerFor App) FilePath
fileField' = [(Text, FilePath)] -> Field (HandlerFor App) FilePath
forall a site msg.
(Eq a, RenderMessage site FormMessage, RenderMessage site msg) =>
[(msg, a)] -> Field (HandlerFor site) a
selectFieldList [(FilePath -> Text
T.pack FilePath
f, FilePath
f) | FilePath
f <- [FilePath]
fs] Field (HandlerFor App) FilePath
-> (Field (HandlerFor App) FilePath
-> Field (HandlerFor App) FilePath)
-> Field (HandlerFor App) FilePath
forall a b. a -> (a -> b) -> b
& (FilePath -> Either FormMessage FilePath)
-> Field (HandlerFor App) FilePath
-> Field (HandlerFor App) FilePath
forall (m :: * -> *) msg a.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> Either msg a) -> Field m a -> Field m a
check FilePath -> Either FormMessage FilePath
validateFilepath
where
fs :: [FilePath]
fs = Journal -> [FilePath]
journalFilePaths Journal
j
validateFilepath :: FilePath -> Either FormMessage FilePath
validateFilepath :: FilePath -> Either FormMessage FilePath
validateFilepath FilePath
f
| FilePath
f FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
fs = FilePath -> Either FormMessage FilePath
forall a b. b -> Either a b
Right FilePath
f
| Bool
otherwise = FormMessage -> Either FormMessage FilePath
forall a b. a -> Either a b
Left (FormMessage -> Either FormMessage FilePath)
-> FormMessage -> Either FormMessage FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInputNotFound (Text -> FormMessage) -> Text -> FormMessage
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
f
dateSettings :: FieldSettings master
dateSettings = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"date" Maybe (SomeMessage master)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"date") [(Text
"class", Text
"form-control input-lg"), (Text
"placeholder", Text
"Date")]
descSettings :: FieldSettings master
descSettings = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"desc" Maybe (SomeMessage master)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"description") [(Text
"class", Text
"form-control input-lg typeahead"), (Text
"placeholder", Text
"Description"), (Text
"size", Text
"40")]
acctSettings :: FieldSettings master
acctSettings = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"account" Maybe (SomeMessage master)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"account") []
amtSettings :: FieldSettings master
amtSettings = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"amount" Maybe (SomeMessage master)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"amount") []
fileSettings :: FieldSettings master
fileSettings = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"file" Maybe (SomeMessage master)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"file") [(Text
"class", Text
"form-control input-lg")]
validateTransaction ::
FilePath -> FormResult Day -> FormResult (Maybe Text) -> FormResult [Posting] -> FormResult (Maybe FilePath)
-> FormResult (Transaction, FilePath)
validateTransaction :: FilePath
-> FormResult Day
-> FormResult (Maybe Text)
-> FormResult [Posting]
-> FormResult (Maybe FilePath)
-> FormResult (Transaction, FilePath)
validateTransaction FilePath
deffile FormResult Day
dateRes FormResult (Maybe Text)
descRes FormResult [Posting]
postingsRes FormResult (Maybe FilePath)
fileRes =
case Day
-> Maybe Text
-> [Posting]
-> Maybe FilePath
-> (Transaction, FilePath)
makeTransaction (Day
-> Maybe Text
-> [Posting]
-> Maybe FilePath
-> (Transaction, FilePath))
-> FormResult Day
-> FormResult
(Maybe Text
-> [Posting] -> Maybe FilePath -> (Transaction, FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormResult Day
dateRes FormResult
(Maybe Text
-> [Posting] -> Maybe FilePath -> (Transaction, FilePath))
-> FormResult (Maybe Text)
-> FormResult
([Posting] -> Maybe FilePath -> (Transaction, FilePath))
forall a b. FormResult (a -> b) -> FormResult a -> FormResult b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult (Maybe Text)
descRes FormResult ([Posting] -> Maybe FilePath -> (Transaction, FilePath))
-> FormResult [Posting]
-> FormResult (Maybe FilePath -> (Transaction, FilePath))
forall a b. FormResult (a -> b) -> FormResult a -> FormResult b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult [Posting]
postingsRes FormResult (Maybe FilePath -> (Transaction, FilePath))
-> FormResult (Maybe FilePath)
-> FormResult (Transaction, FilePath)
forall a b. FormResult (a -> b) -> FormResult a -> FormResult b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult (Maybe FilePath)
fileRes of
FormSuccess (Transaction
txn,FilePath
f) -> case BalancingOpts -> Transaction -> Either FilePath Transaction
balanceTransaction BalancingOpts
defbalancingopts Transaction
txn of
Left FilePath
e -> [Text] -> FormResult (Transaction, FilePath)
forall a. [Text] -> FormResult a
FormFailure [FilePath -> Text
T.pack FilePath
e]
Right Transaction
txn' -> (Transaction, FilePath) -> FormResult (Transaction, FilePath)
forall a. a -> FormResult a
FormSuccess (Transaction
txn',FilePath
f)
FormResult (Transaction, FilePath)
x -> FormResult (Transaction, FilePath)
x
where
makeTransaction :: Day
-> Maybe Text
-> [Posting]
-> Maybe FilePath
-> (Transaction, FilePath)
makeTransaction Day
date Maybe Text
mdesc [Posting]
postings Maybe FilePath
mfile =
(Transaction
nulltransaction {
tdate = date
,tdescription = fromMaybe "" mdesc
,tpostings = postings
,tsourcepos = (initialPos f, initialPos f)
}, FilePath
f)
where f :: FilePath
f = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
deffile Maybe FilePath
mfile
validatePostings ::
FormResult [Text] -> FormResult [Text]
-> (FormResult [Posting], [(Int, (Text, Text, Maybe Text, Maybe Text))])
validatePostings :: FormResult [Text]
-> FormResult [Text]
-> (FormResult [Posting],
[(Int, (Text, Text, Maybe Text, Maybe Text))])
validatePostings FormResult [Text]
acctsRes FormResult [Text]
amtsRes = let
rows :: [(Text, Text)]
rows :: [(Text, Text)]
rows = ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text, Text) -> (Text, Text) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Text
"", Text
"")) ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text] -> [(Text, Text)]
forall a. a -> [a] -> [a] -> [(a, a)]
zipDefault Text
"" ([Text] -> FormResult [Text] -> [Text]
forall a. a -> FormResult a -> a
formSuccess [] FormResult [Text]
acctsRes) ([Text] -> FormResult [Text] -> [Text]
forall a. a -> FormResult a -> a
formSuccess [] FormResult [Text]
amtsRes)
postings :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
postings :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
postings = ((Bool, [(Text, Text)])
-> Maybe
((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)])))
-> (Bool, [(Text, Text)])
-> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (Bool, [(Text, Text)])
-> Maybe
((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
go (Bool
True, [(Text, Text)]
rows)
where
go :: (Bool, [(Text, Text)])
-> Maybe
((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
go (Bool
True, (Text
x, Text
""):(Text, Text)
y:[(Text, Text)]
xs) = ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
-> Maybe
((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
forall a. a -> Maybe a
Just ((Text
x, Text
"", Either Text Text
-> Either Text Amount -> Either (Maybe Text, Maybe Text) Posting
forall {a} {a}.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
checkAccount Text
x) (Text -> Either Text Amount
forall a b. a -> Either a b
Left Text
"Missing amount")), (Bool
True, (Text, Text)
y(Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:[(Text, Text)]
xs))
go (Bool
True, (Text
x, Text
""):[(Text, Text)]
xs) = ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
-> Maybe
((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
forall a. a -> Maybe a
Just ((Text
x, Text
"", Either Text Text
-> Either Text Amount -> Either (Maybe Text, Maybe Text) Posting
forall {a} {a}.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
checkAccount Text
x) (Amount -> Either Text Amount
forall a b. b -> Either a b
Right Amount
missingamt)), (Bool
False, [(Text, Text)]
xs))
go (Bool
False, (Text
x, Text
""):[(Text, Text)]
xs) = ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
-> Maybe
((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
forall a. a -> Maybe a
Just ((Text
x, Text
"", Either Text Text
-> Either Text Amount -> Either (Maybe Text, Maybe Text) Posting
forall {a} {a}.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
checkAccount Text
x) (Text -> Either Text Amount
forall a b. a -> Either a b
Left Text
"Missing amount")), (Bool
False, [(Text, Text)]
xs))
go (Bool
_, (Text
"", Text
y):[(Text, Text)]
xs) = ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
-> Maybe
((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
forall a. a -> Maybe a
Just ((Text
"", Text
y, Either Text Text
-> Either Text Amount -> Either (Maybe Text, Maybe Text) Posting
forall {a} {a}.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"Missing account") (Text -> Either Text Amount
checkAmount Text
y)), (Bool
False, [(Text, Text)]
xs))
go (Bool
_, (Text
x, Text
y):[(Text, Text)]
xs) = ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
-> Maybe
((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
forall a. a -> Maybe a
Just ((Text
x, Text
y, Either Text Text
-> Either Text Amount -> Either (Maybe Text, Maybe Text) Posting
forall {a} {a}.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
checkAccount Text
x) (Text -> Either Text Amount
checkAmount Text
y)), (Bool
True, [(Text, Text)]
xs))
go (Bool
_, []) = Maybe
((Text, Text, Either (Maybe Text, Maybe Text) Posting),
(Bool, [(Text, Text)]))
forall a. Maybe a
Nothing
zipRow :: Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Left a
e) (Left a
e') = (Maybe a, Maybe a) -> Either (Maybe a, Maybe a) Posting
forall a b. a -> Either a b
Left (a -> Maybe a
forall a. a -> Maybe a
Just a
e, a -> Maybe a
forall a. a -> Maybe a
Just a
e')
zipRow (Left a
e) (Right Amount
_) = (Maybe a, Maybe a) -> Either (Maybe a, Maybe a) Posting
forall a b. a -> Either a b
Left (a -> Maybe a
forall a. a -> Maybe a
Just a
e, Maybe a
forall a. Maybe a
Nothing)
zipRow (Right Text
_) (Left a
e) = (Maybe a, Maybe a) -> Either (Maybe a, Maybe a) Posting
forall a b. a -> Either a b
Left (Maybe a
forall a. Maybe a
Nothing, a -> Maybe a
forall a. a -> Maybe a
Just a
e)
zipRow (Right Text
acct') (Right Amount
amt) = Posting -> Either (Maybe a, Maybe a) Posting
forall a b. b -> Either a b
Right (Posting
nullposting {paccount = acct, ptype = atype, pamount = mixedAmount amt})
where
acct :: Text
acct = Text -> Text
accountNameWithoutPostingType Text
acct'
atype :: PostingType
atype = Text -> PostingType
accountNamePostingType Text
acct'
errorToFormMsg :: Either HledgerParseErrors c -> Either Text c
errorToFormMsg = (HledgerParseErrors -> Text)
-> Either HledgerParseErrors c -> Either Text c
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"Invalid value: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text)
-> (HledgerParseErrors -> Text) -> HledgerParseErrors -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text)
-> (HledgerParseErrors -> FilePath) -> HledgerParseErrors -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(FilePath -> ParseError Text HledgerParseErrorData -> FilePath)
-> FilePath
-> NonEmpty (ParseError Text HledgerParseErrorData)
-> FilePath
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\FilePath
s ParseError Text HledgerParseErrorData
a -> FilePath
s FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ParseError Text HledgerParseErrorData -> FilePath
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> FilePath
parseErrorTextPretty ParseError Text HledgerParseErrorData
a) FilePath
"" (NonEmpty (ParseError Text HledgerParseErrorData) -> FilePath)
-> (HledgerParseErrors
-> NonEmpty (ParseError Text HledgerParseErrorData))
-> HledgerParseErrors
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
HledgerParseErrors
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors)
checkAccount :: Text -> Either Text Text
checkAccount = Either HledgerParseErrors Text -> Either Text Text
forall {c}. Either HledgerParseErrors c -> Either Text c
errorToFormMsg (Either HledgerParseErrors Text -> Either Text Text)
-> (Text -> Either HledgerParseErrors Text)
-> Text
-> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec HledgerParseErrorData Text Text
-> FilePath -> Text -> Either HledgerParseErrors Text
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec HledgerParseErrorData Text Text
forall (m :: * -> *). TextParser m Text
accountnamep Parsec HledgerParseErrorData Text Text
-> ParsecT HledgerParseErrorData Text Identity ()
-> Parsec HledgerParseErrorData Text Text
forall a b.
ParsecT HledgerParseErrorData Text Identity a
-> ParsecT HledgerParseErrorData Text Identity b
-> ParsecT HledgerParseErrorData Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT HledgerParseErrorData Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) FilePath
"" (Text -> Either HledgerParseErrors Text)
-> (Text -> Text) -> Text -> Either HledgerParseErrors Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
checkAmount :: Text -> Either Text Amount
checkAmount = Either HledgerParseErrors Amount -> Either Text Amount
forall {c}. Either HledgerParseErrors c -> Either Text c
errorToFormMsg (Either HledgerParseErrors Amount -> Either Text Amount)
-> (Text -> Either HledgerParseErrors Amount)
-> Text
-> Either Text Amount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec HledgerParseErrorData Text Amount
-> FilePath -> Text -> Either HledgerParseErrors Amount
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (StateT Journal (ParsecT HledgerParseErrorData Text Identity) Amount
-> Journal -> Parsec HledgerParseErrorData Text Amount
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT Journal (ParsecT HledgerParseErrorData Text Identity) Amount
forall (m :: * -> *). JournalParser m Amount
amountp StateT Journal (ParsecT HledgerParseErrorData Text Identity) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text Identity) ()
-> StateT
Journal (ParsecT HledgerParseErrorData Text Identity) Amount
forall a b.
StateT Journal (ParsecT HledgerParseErrorData Text Identity) a
-> StateT Journal (ParsecT HledgerParseErrorData Text Identity) b
-> StateT Journal (ParsecT HledgerParseErrorData Text Identity) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT HledgerParseErrorData Text Identity) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) Journal
nulljournal) FilePath
"" (Text -> Either HledgerParseErrors Amount)
-> (Text -> Text) -> Text -> Either HledgerParseErrors Amount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
result :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
result :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
result = case (FormResult [Text]
acctsRes, FormResult [Text]
amtsRes) of
(FormResult [Text]
FormMissing, FormResult [Text]
FormMissing) -> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
postings
(FormResult [Text], FormResult [Text])
_ -> case [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
postings of
[] -> [ (Text
"", Text
"", (Maybe Text, Maybe Text) -> Either (Maybe Text, Maybe Text) Posting
forall a b. a -> Either a b
Left (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Missing account", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Missing amount"))
, (Text
"", Text
"", (Maybe Text, Maybe Text) -> Either (Maybe Text, Maybe Text) Posting
forall a b. a -> Either a b
Left (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Missing account", Maybe Text
forall a. Maybe a
Nothing))
]
[(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
xs -> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
xs
display' :: [(Text, Text, Maybe Text, Maybe Text)]
display' = (((Text, Text, Either (Maybe Text, Maybe Text) Posting)
-> (Text, Text, Maybe Text, Maybe Text))
-> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
-> [(Text, Text, Maybe Text, Maybe Text)])
-> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
-> ((Text, Text, Either (Maybe Text, Maybe Text) Posting)
-> (Text, Text, Maybe Text, Maybe Text))
-> [(Text, Text, Maybe Text, Maybe Text)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text, Text, Either (Maybe Text, Maybe Text) Posting)
-> (Text, Text, Maybe Text, Maybe Text))
-> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
-> [(Text, Text, Maybe Text, Maybe Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
result (((Text, Text, Either (Maybe Text, Maybe Text) Posting)
-> (Text, Text, Maybe Text, Maybe Text))
-> [(Text, Text, Maybe Text, Maybe Text)])
-> ((Text, Text, Either (Maybe Text, Maybe Text) Posting)
-> (Text, Text, Maybe Text, Maybe Text))
-> [(Text, Text, Maybe Text, Maybe Text)]
forall a b. (a -> b) -> a -> b
$ \(Text
acc, Text
amt, Either (Maybe Text, Maybe Text) Posting
res) -> case Either (Maybe Text, Maybe Text) Posting
res of
Left (Maybe Text
mAccountErr, Maybe Text
mAmountErr) -> (Text
acc, Text
amt, Maybe Text
mAccountErr, Maybe Text
mAmountErr)
Right Posting
_ -> (Text
acc, Text
amt, Maybe Text
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing)
display :: [(Text, Text, Maybe Text, Maybe Text)]
display = [(Text, Text, Maybe Text, Maybe Text)]
display' [(Text, Text, Maybe Text, Maybe Text)]
-> [(Text, Text, Maybe Text, Maybe Text)]
-> [(Text, Text, Maybe Text, Maybe Text)]
forall a. [a] -> [a] -> [a]
++ Int
-> (Text, Text, Maybe Text, Maybe Text)
-> [(Text, Text, Maybe Text, Maybe Text)]
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [(Text, Text, Maybe Text, Maybe Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text, Maybe Text, Maybe Text)]
display') (Text
"", Text
"", Maybe Text
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing)
formResult :: FormResult [Posting]
formResult = case ((Text, Text, Either (Maybe Text, Maybe Text) Posting)
-> Either (Maybe Text, Maybe Text) Posting)
-> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
-> Either (Maybe Text, Maybe Text) [Posting]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(Text
_, Text
_, Either (Maybe Text, Maybe Text) Posting
x) -> Either (Maybe Text, Maybe Text) Posting
x) [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
result of
Left (Maybe Text, Maybe Text)
_ -> [Text] -> FormResult [Posting]
forall a. [Text] -> FormResult a
FormFailure [Text
"Postings validation failed"]
Right [Posting]
xs -> [Posting] -> FormResult [Posting]
forall a. a -> FormResult a
FormSuccess [Posting]
xs
in (FormResult [Posting]
formResult, [Int]
-> [(Text, Text, Maybe Text, Maybe Text)]
-> [(Int, (Text, Text, Maybe Text, Maybe Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1 :: Int)..] [(Text, Text, Maybe Text, Maybe Text)]
display)
toBloodhoundJson :: [Text] -> Markup
toBloodhoundJson :: [Text] -> Markup
toBloodhoundJson [Text]
ts =
Text -> Markup
preEscapedText (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [
Text
"[",
Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (
(Text
"{\"value\":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)(Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}")(Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Text -> Text
b64wrap
) [Text]
ts,
Text
"]"
]
where
b64wrap :: Text -> Text
b64wrap = (Text
"decodeBase64EncodedText(\""Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"\")") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
encodeBase64
zipDefault :: a -> [a] -> [a] -> [(a, a)]
zipDefault :: forall a. a -> [a] -> [a] -> [(a, a)]
zipDefault a
def (a
b:[a]
bs) (a
c:[a]
cs) = (a
b, a
c)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:(a -> [a] -> [a] -> [(a, a)]
forall a. a -> [a] -> [a] -> [(a, a)]
zipDefault a
def [a]
bs [a]
cs)
zipDefault a
def (a
b:[a]
bs) [] = (a
b, a
def)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:(a -> [a] -> [a] -> [(a, a)]
forall a. a -> [a] -> [a] -> [(a, a)]
zipDefault a
def [a]
bs [])
zipDefault a
def [] (a
c:[a]
cs) = (a
def, a
c)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:(a -> [a] -> [a] -> [(a, a)]
forall a. a -> [a] -> [a] -> [(a, a)]
zipDefault a
def [] [a]
cs)
zipDefault a
_ [a]
_ [a]
_ = []
formSuccess :: a -> FormResult a -> a
formSuccess :: forall a. a -> FormResult a -> a
formSuccess a
def FormResult a
res = case FormResult a
res of
FormSuccess a
x -> a
x
FormResult a
_ -> a
def