145 lines
5.8 KiB
Haskell
145 lines
5.8 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# 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.List (dropWhileEnd, nub, sort, unfoldr)
|
|
import Data.Maybe (isJust)
|
|
import Data.Semigroup ((<>))
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Time (Day)
|
|
import Text.Blaze.Internal (Markup, preEscapedString)
|
|
import Text.JSON
|
|
import Text.Megaparsec (eof, errorBundlePretty, runParser)
|
|
import Yesod
|
|
|
|
import Hledger
|
|
import Hledger.Web.Settings (widgetFile)
|
|
|
|
addModal ::
|
|
( MonadWidget m
|
|
, r ~ Route (HandlerSite m)
|
|
#if MIN_VERSION_yesod(1,6,0)
|
|
, m ~ WidgetFor (HandlerSite m)
|
|
#else
|
|
, m ~ WidgetT (HandlerSite m) IO
|
|
#endif
|
|
, RenderMessage (HandlerSite m) FormMessage
|
|
)
|
|
=> r -> Journal -> Day -> m ()
|
|
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
|
|
#if MIN_VERSION_yesod(1,6,0)
|
|
-> MForm m (FormResult Transaction, WidgetFor site ())
|
|
#else
|
|
-> MForm m (FormResult Transaction, WidgetT site IO ())
|
|
#endif
|
|
addForm j today = identifyForm "add" $ \extra -> do
|
|
(dateRes, dateView) <- mreq dateField dateFS Nothing
|
|
(descRes, descView) <- mreq textField descFS Nothing
|
|
(acctRes, _) <- mreq listField acctFS Nothing
|
|
(amtRes, _) <- mreq listField amtFS Nothing
|
|
|
|
let (msgs', postRes) = case validatePostings <$> acctRes <*> amtRes of
|
|
FormSuccess (Left es) -> (es, FormFailure ["Postings validation failed"])
|
|
FormSuccess (Right xs) -> ([], FormSuccess xs)
|
|
FormMissing -> ([], FormMissing)
|
|
FormFailure es -> ([], FormFailure es)
|
|
msgs = zip [(1 :: Int)..] $ msgs' ++ replicate (4 - length msgs') ("", "", Nothing, Nothing)
|
|
|
|
let descriptions = sort $ nub $ tdescription <$> jtxns j
|
|
escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>" -- #236
|
|
listToJsonValueObjArrayStr = preEscapedString . escapeJSSpecialChars .
|
|
encode . JSArray . fmap (\a -> JSObject $ toJSObject [("value", showJSON a)])
|
|
journals = fst <$> jfiles j
|
|
|
|
pure (makeTransaction <$> dateRes <*> descRes <*> postRes, $(widgetFile "add-form"))
|
|
where
|
|
makeTransaction date desc postings =
|
|
nulltransaction {tdate = date, tdescription = desc, tpostings = postings}
|
|
|
|
dateFS = FieldSettings "date" Nothing Nothing (Just "date")
|
|
[("class", "form-control input-lg"), ("placeholder", "Date")]
|
|
descFS = FieldSettings "desc" Nothing Nothing (Just "description")
|
|
[("class", "form-control input-lg typeahead"), ("placeholder", "Description"), ("size", "40")]
|
|
acctFS = FieldSettings "amount" Nothing Nothing (Just "account") []
|
|
amtFS = FieldSettings "amount" Nothing Nothing (Just "amount") []
|
|
dateField = checkMMap (pure . validateDate) (T.pack . show) textField
|
|
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!"
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
validatePostings :: [Text] -> [Text] -> Either [(Text, Text, Maybe Text, Maybe Text)] [Posting]
|
|
validatePostings a b =
|
|
case traverse id $ (\(_, _, x) -> x) <$> postings of
|
|
Left _ -> Left $ foldr catPostings [] postings
|
|
Right [] -> Left
|
|
[ ("", "", Just "Missing account", Just "Missing amount")
|
|
, ("", "", Just "Missing account", Nothing)
|
|
]
|
|
Right [p] -> Left
|
|
[ (paccount p, T.pack . showMixedAmountWithoutPrice $ pamount p, Nothing, Nothing)
|
|
, ("", "", Just "Missing account", Nothing)
|
|
]
|
|
Right xs -> Right xs
|
|
where
|
|
postings = unfoldr go (True, a, b)
|
|
|
|
go (_, x:xs, y:ys) = Just ((x, y, zipPosting (validateAccount x) (validateAmount y)), (True, xs, ys))
|
|
go (True, x:y:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Left "Missing amount")), (True, y:xs, []))
|
|
go (True, x:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Right missingamt)), (False, xs, []))
|
|
go (False, x:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Left "Missing amount")), (False, xs, []))
|
|
go (_, [], y:ys) = Just (("", y, zipPosting (Left "Missing account") (validateAmount y)), (False, [], ys))
|
|
go (_, [], []) = Nothing
|
|
|
|
zipPosting = zipEither (\acc amt -> nullposting {paccount = acc, pamount = Mixed [amt]})
|
|
|
|
catPostings (t, t', Left (e, e')) xs = (t, t', e, e') : xs
|
|
catPostings (t, t', Right _) xs = (t, t', Nothing, Nothing) : xs
|
|
|
|
errorToFormMsg = first (("Invalid value: " <>) . T.pack . errorBundlePretty)
|
|
validateAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip
|
|
validateAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) mempty) "" . T.strip
|
|
|
|
-- Modification of Align, from the `these` package
|
|
zipEither :: (a -> a' -> r) -> Either e a -> Either e' a' -> Either (Maybe e, Maybe e') r
|
|
zipEither f a b = case (a, b) of
|
|
(Right a', Right b') -> Right (f a' b')
|
|
(Left a', Right _) -> Left (Just a', Nothing)
|
|
(Right _, Left b') -> Left (Nothing, Just b')
|
|
(Left a', Left b') -> Left (Just a', Just b')
|