210 lines
8.2 KiB
Haskell
210 lines
8.2 KiB
Haskell
{-# 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)
|
|
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.Foundation -- (App, Form, Handler, Widget)
|
|
import Hledger.Web.Settings (widgetFile)
|
|
|
|
-- addModal ::
|
|
-- ( MonadWidget m
|
|
-- , r ~ Route (HandlerSite m)
|
|
-- , m ~ WidgetFor (HandlerSite m)
|
|
-- , RenderMessage (HandlerSite m) FormMessage
|
|
-- )
|
|
-- => r -> Journal -> Day -> m ()
|
|
addModal :: Route App -> Journal -> Day -> Widget
|
|
addModal addR j today = do
|
|
(addView, addEnctype) <- generateFormPost (addForm j today)
|
|
[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 ::
|
|
-- (site ~ HandlerSite m, RenderMessage site FormMessage, MonadHandler m)
|
|
-- => Journal
|
|
-- -> Day
|
|
-- -> Markup
|
|
-- -> MForm m (FormResult Transaction, WidgetFor site ())
|
|
addForm ::
|
|
(MonadHandler m, RenderMessage (HandlerSite m) FormMessage) =>
|
|
Journal -> Day -> Markup ->
|
|
MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ())
|
|
addForm j today = identifyForm "add" $ \extra -> do
|
|
let -- bindings used in add-form.hamlet
|
|
descriptions = foldMap S.fromList [journalPayeesDeclaredOrUsed j, journalDescriptions j]
|
|
files = fst <$> jfiles j
|
|
(dateRes, dateView) <- mreq dateField dateSettings Nothing
|
|
(descRes, descView) <- mreq textField descSettings Nothing
|
|
(acctRes, _) <- mreq listField "account" Nothing
|
|
(amtRes , _) <- mreq listField "amount" Nothing
|
|
let (postRes, displayRows) = validatePostings acctRes amtRes
|
|
pure (validateTransaction dateRes descRes postRes, $(widgetFile "add-form"))
|
|
|
|
where
|
|
-- field settings
|
|
dateSettings = FieldSettings "date" Nothing Nothing (Just "date")
|
|
[("class", "form-control input-lg"), ("placeholder", "Date")]
|
|
descSettings = FieldSettings "desc" Nothing Nothing (Just "description")
|
|
[("class", "form-control input-lg typeahead"), ("placeholder", "Description"), ("size", "40")]
|
|
|
|
-- custom field types
|
|
dateField = checkMMap (pure . validateDate) (T.pack . show) textField
|
|
where
|
|
validateDate s =
|
|
first (const ("Invalid date format" :: Text)) $
|
|
fixSmartDateStrEither' today (T.strip s)
|
|
listField = Field
|
|
{ fieldParse = const . pure . Right . Just . dropWhileEnd T.null
|
|
, fieldView = error "Don't render using this!" -- PARTIAL:
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
-- helpers used in add-form.hamlet
|
|
toBloodhoundJson :: [Text] -> Markup
|
|
toBloodhoundJson ts =
|
|
-- This used to work, but since 1.16, it seems like something changed.
|
|
-- toJSON ("a"::Text) gives String "a" instead of "a", etc.
|
|
-- preEscapedString . escapeJSSpecialChars . show . toJSON
|
|
|
|
preEscapedText $ T.concat [
|
|
"[",
|
|
T.intercalate "," $ map (
|
|
("{\"value\":" <>).
|
|
(<> "}").
|
|
-- This will convert a value such as ``hledger!`` into
|
|
-- ``atob("aGxlZGdlciE=")``. When this gets evaluated on the client,
|
|
-- the resulting string is ``hledger!`` again. The same data is
|
|
-- passed, but the user-controlled bit of that string can only use
|
|
-- characters [a-zA-Z0-9+=/], making it impossible to break out of
|
|
-- string context.
|
|
b64wrap
|
|
) ts,
|
|
"]"
|
|
]
|
|
where
|
|
b64wrap = ("atob(\""<>) . (<>"\")") . encodeBase64
|
|
|
|
validateTransaction ::
|
|
FormResult Day
|
|
-> FormResult Text
|
|
-> FormResult [Posting]
|
|
-> FormResult Transaction
|
|
validateTransaction dateRes descRes postingsRes =
|
|
case makeTransaction <$> dateRes <*> descRes <*> postingsRes of
|
|
FormSuccess txn -> case balanceTransaction defbalancingopts txn of
|
|
Left e -> FormFailure [T.pack e]
|
|
Right txn' -> FormSuccess txn'
|
|
x -> x
|
|
where
|
|
makeTransaction date desc postings =
|
|
nulltransaction {
|
|
tdate = date
|
|
,tdescription = desc
|
|
,tpostings = postings
|
|
}
|
|
|
|
-- | Parse a list of postings out of a list of accounts and a corresponding list
|
|
-- of amounts
|
|
validatePostings ::
|
|
FormResult [Text]
|
|
-> FormResult [Text]
|
|
-> (FormResult [Posting], [(Int, (Text, Text, Maybe Text, Maybe Text))])
|
|
validatePostings acctRes amtRes = let
|
|
|
|
-- Zip accounts and amounts, fill in missing values and drop empty rows.
|
|
rows :: [(Text, Text)]
|
|
rows = filter (/= ("", "")) $ zipDefault "" (formSuccess [] acctRes) (formSuccess [] amtRes)
|
|
|
|
-- Parse values and check for incomplete rows with only an account or an amount.
|
|
-- The boolean in unfoldr state is for special handling of 'missingamt', where
|
|
-- one row may have only an account and not an amount.
|
|
postings :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
|
|
postings = unfoldr go (True, rows)
|
|
go (True, (x, ""):y:xs) = Just ((x, "", zipRow (checkAccount x) (Left "Missing amount")), (True, y:xs))
|
|
go (True, (x, ""):xs) = Just ((x, "", zipRow (checkAccount x) (Right missingamt)), (False, xs))
|
|
go (False, (x, ""):xs) = Just ((x, "", zipRow (checkAccount x) (Left "Missing amount")), (False, xs))
|
|
go (_, ("", y):xs) = Just (("", y, zipRow (Left "Missing account") (checkAmount y)), (False, xs))
|
|
go (_, (x, y):xs) = Just ((x, y, zipRow (checkAccount x) (checkAmount y)), (True, xs))
|
|
go (_, []) = Nothing
|
|
|
|
zipRow (Left e) (Left e') = Left (Just e, Just e')
|
|
zipRow (Left e) (Right _) = Left (Just e, Nothing)
|
|
zipRow (Right _) (Left e) = Left (Nothing, Just e)
|
|
zipRow (Right acct') (Right amt) = Right (nullposting {paccount = acct, ptype = atype, pamount = mixedAmount amt})
|
|
where
|
|
acct = accountNameWithoutPostingType acct'
|
|
atype = accountNamePostingType acct'
|
|
|
|
errorToFormMsg = first (("Invalid value: " <>) . T.pack .
|
|
foldl (\s a -> s <> parseErrorTextPretty a) "" .
|
|
bundleErrors)
|
|
checkAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip
|
|
checkAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) nulljournal) "" . T.strip
|
|
|
|
-- Add errors to forms with zero rows if the form is not a FormMissing
|
|
result :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
|
|
result = case (acctRes, amtRes) of
|
|
(FormMissing, FormMissing) -> postings
|
|
_ -> case postings of
|
|
[] -> [ ("", "", Left (Just "Missing account", Just "Missing amount"))
|
|
, ("", "", Left (Just "Missing account", Nothing))
|
|
]
|
|
xs -> xs
|
|
|
|
-- Prepare rows for rendering - resolve Eithers into error messages and pad to
|
|
-- at least four rows
|
|
display' = flip fmap result $ \(acc, amt, res) -> case res of
|
|
Left (mAccountErr, mAmountErr) -> (acc, amt, mAccountErr, mAmountErr)
|
|
Right _ -> (acc, amt, Nothing, Nothing)
|
|
display = display' ++ replicate (4 - length display') ("", "", Nothing, Nothing)
|
|
|
|
-- And finally prepare the final FormResult [Posting]
|
|
formResult = case traverse (\(_, _, x) -> x) result of
|
|
Left _ -> FormFailure ["Postings validation failed"]
|
|
Right xs -> FormSuccess xs
|
|
|
|
in (formResult, zip [(1 :: Int)..] display)
|
|
|
|
|
|
zipDefault :: a -> [a] -> [a] -> [(a, a)]
|
|
zipDefault def (b:bs) (c:cs) = (b, c):(zipDefault def bs cs)
|
|
zipDefault def (b:bs) [] = (b, def):(zipDefault def bs [])
|
|
zipDefault def [] (c:cs) = (def, c):(zipDefault def [] cs)
|
|
zipDefault _ _ _ = []
|
|
|
|
formSuccess :: a -> FormResult a -> a
|
|
formSuccess def res = case res of
|
|
FormSuccess x -> x
|
|
_ -> def
|