1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE QuasiQuotes #-}
6{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE TemplateHaskell #-}
8
9module Hledger.Web.Widget.AddForm
10  ( addForm
11  , addModal
12  ) where
13
14import Control.Monad.State.Strict (evalStateT)
15import Data.Bifunctor (first)
16import Data.List (dropWhileEnd, intercalate, unfoldr)
17import Data.List.Extra (nubSort)
18import Data.Maybe (isJust)
19#if !(MIN_VERSION_base(4,13,0))
20import Data.Semigroup ((<>))
21#endif
22import Data.Text (Text)
23import qualified Data.Text as T
24import Data.Time (Day)
25import Text.Blaze.Internal (Markup, preEscapedString)
26import Text.Megaparsec (bundleErrors, eof, parseErrorTextPretty, runParser)
27import Yesod
28
29import Hledger
30import Hledger.Web.Settings (widgetFile)
31
32addModal ::
33     ( MonadWidget m
34     , r ~ Route (HandlerSite m)
35#if MIN_VERSION_yesod(1,6,0)
36     , m ~ WidgetFor (HandlerSite m)
37#else
38     , m ~ WidgetT (HandlerSite m) IO
39#endif
40     , RenderMessage (HandlerSite m) FormMessage
41     )
42  => r -> Journal -> Day -> m ()
43addModal addR j today = do
44  (addView, addEnctype) <- generateFormPost (addForm j today)
45  [whamlet|
46<div .modal #addmodal tabindex="-1" role="dialog" aria-labelledby="addLabel" aria-hidden="true">
47  <div .modal-dialog .modal-lg>
48    <div .modal-content>
49      <div .modal-header>
50        <button type="button" .close data-dismiss="modal" aria-hidden="true">&times;
51        <h3 .modal-title #addLabel>Add a transaction
52      <div .modal-body>
53        <form#addform.form action=@{addR} method=POST enctype=#{addEnctype}>
54          ^{addView}
55|]
56
57addForm ::
58     (site ~ HandlerSite m, RenderMessage site FormMessage, MonadHandler m)
59  => Journal
60  -> Day
61  -> Markup
62#if MIN_VERSION_yesod(1,6,0)
63  -> MForm m (FormResult Transaction, WidgetFor site ())
64#else
65  -> MForm m (FormResult Transaction, WidgetT site IO ())
66#endif
67addForm j today = identifyForm "add" $ \extra -> do
68  (dateRes, dateView) <- mreq dateField dateFS Nothing
69  (descRes, descView) <- mreq textField descFS Nothing
70  (acctRes, _) <- mreq listField acctFS Nothing
71  (amtRes, _) <- mreq listField amtFS Nothing
72  let (postRes, displayRows) = validatePostings acctRes amtRes
73
74  -- bindings used in add-form.hamlet
75  let descriptions = nubSort $ tdescription <$> jtxns j
76      journals = fst <$> jfiles j
77
78  pure (validateTransaction dateRes descRes postRes, $(widgetFile "add-form"))
79
80  where
81    dateFS = FieldSettings "date" Nothing Nothing (Just "date")
82      [("class", "form-control input-lg"), ("placeholder", "Date")]
83    descFS = FieldSettings "desc" Nothing Nothing (Just "description")
84      [("class", "form-control input-lg typeahead"), ("placeholder", "Description"), ("size", "40")]
85    acctFS = FieldSettings "amount" Nothing Nothing (Just "account") []
86    amtFS = FieldSettings "amount" Nothing Nothing (Just "amount") []
87    dateField = checkMMap (pure . validateDate) (T.pack . show) textField
88    validateDate s =
89      first (const ("Invalid date format" :: Text)) $
90      fixSmartDateStrEither' today (T.strip s)
91
92    listField = Field
93      { fieldParse = const . pure . Right . Just . dropWhileEnd T.null
94      , fieldView = error "Don't render using this!"  -- PARTIAL:
95      , fieldEnctype = UrlEncoded
96      }
97
98    -- Used in add-form.hamlet
99    toBloodhoundJson :: [Text] -> Markup
100    toBloodhoundJson ts =
101      -- This used to work, but since 1.16, it seems like something changed.
102      -- toJSON ("a"::Text) gives String "a" instead of "a", etc.
103      -- preEscapedString . escapeJSSpecialChars . show . toJSON
104      preEscapedString $ concat [
105        "[",
106        intercalate "," $ map (
107          ("{\"value\":" ++).
108          (++"}").
109          show .
110          -- avoid https://github.com/simonmichael/hledger/issues/236
111          T.replace "</script>" "<\\/script>"
112          ) ts,
113        "]"
114        ]
115      where
116
117validateTransaction ::
118     FormResult Day
119  -> FormResult Text
120  -> FormResult [Posting]
121  -> FormResult Transaction
122validateTransaction dateRes descRes postingsRes =
123  case makeTransaction <$> dateRes <*> descRes <*> postingsRes of
124    FormSuccess txn -> case balanceTransaction Nothing txn of
125      Left e -> FormFailure [T.pack e]
126      Right txn' -> FormSuccess txn'
127    x -> x
128  where
129    makeTransaction date desc postings =
130      nulltransaction {tdate = date, tdescription = desc, tpostings = postings}
131
132
133-- | Parse a list of postings out of a list of accounts and a corresponding list
134-- of amounts
135validatePostings ::
136     FormResult [Text]
137  -> FormResult [Text]
138  -> (FormResult [Posting], [(Int, (Text, Text, Maybe Text, Maybe Text))])
139validatePostings acctRes amtRes = let
140
141  -- Zip accounts and amounts, fill in missing values and drop empty rows.
142  rows :: [(Text, Text)]
143  rows = filter (/= ("", "")) $ zipDefault "" (formSuccess [] acctRes) (formSuccess [] amtRes)
144
145  -- Parse values and check for incomplete rows with only an account or an amount.
146  -- The boolean in unfoldr state is for special handling of 'missingamt', where
147  -- one row may have only an account and not an amount.
148  postings :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
149  postings = unfoldr go (True, rows)
150  go (True, (x, ""):y:xs) = Just ((x, "", zipRow (checkAccount x) (Left "Missing amount")), (True, y:xs))
151  go (True, (x, ""):xs) = Just ((x, "", zipRow (checkAccount x) (Right missingamt)), (False, xs))
152  go (False, (x, ""):xs) = Just ((x, "", zipRow (checkAccount x) (Left "Missing amount")), (False, xs))
153  go (_, ("", y):xs) = Just (("", y, zipRow (Left "Missing account") (checkAmount y)), (False, xs))
154  go (_, (x, y):xs) = Just ((x, y, zipRow (checkAccount x) (checkAmount y)), (True, xs))
155  go (_, []) = Nothing
156
157  zipRow (Left e) (Left e') = Left (Just e, Just e')
158  zipRow (Left e) (Right _) = Left (Just e, Nothing)
159  zipRow (Right _) (Left e) = Left (Nothing, Just e)
160  zipRow (Right acct) (Right amt) = Right (nullposting {paccount = acct, pamount = Mixed [amt]})
161
162  errorToFormMsg = first (("Invalid value: " <>) . T.pack .
163                          foldl (\s a -> s <> parseErrorTextPretty a) "" .
164                          bundleErrors)
165  checkAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip
166  checkAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) nulljournal) "" . T.strip
167
168  -- Add errors to forms with zero or one rows if the form is not a FormMissing
169  result :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
170  result = case (acctRes, amtRes) of
171    (FormMissing, FormMissing) -> postings
172    _ -> case postings of
173      [] -> [ ("", "", Left (Just "Missing account", Just "Missing amount"))
174           , ("", "", Left (Just "Missing account", Nothing))
175           ]
176      [x] -> [x, ("", "", Left (Just "Missing account", Nothing))]
177      xs -> xs
178
179  -- Prepare rows for rendering - resolve Eithers into error messages and pad to
180  -- at least four rows
181  display' = flip fmap result $ \(acc, amt, res) -> case res of
182    Left (mAccountErr, mAmountErr) -> (acc, amt, mAccountErr, mAmountErr)
183    Right _ -> (acc, amt, Nothing, Nothing)
184  display = display' ++ replicate (4 - length display') ("", "", Nothing, Nothing)
185
186  -- And finally prepare the final FormResult [Posting]
187  formResult = case traverse (\(_, _, x) -> x) result of
188    Left _ -> FormFailure ["Postings validation failed"]
189    Right xs -> FormSuccess xs
190
191  in (formResult, zip [(1 :: Int)..] display)
192
193
194zipDefault :: a -> [a] -> [a] -> [(a, a)]
195zipDefault def (b:bs) (c:cs) = (b, c):(zipDefault def bs cs)
196zipDefault def (b:bs) [] = (b, def):(zipDefault def bs [])
197zipDefault def [] (c:cs) = (def, c):(zipDefault def [] cs)
198zipDefault _ _ _ = []
199
200formSuccess :: a -> FormResult a -> a
201formSuccess def res = case res of
202  FormSuccess x -> x
203  _ -> def
204