62 lines
2.2 KiB
Haskell
62 lines
2.2 KiB
Haskell
-- | Add form data & handler. (The layout and js are defined in
|
|
-- Foundation so that the add form can be in the default layout for
|
|
-- all views.)
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Handler.AddForm
|
|
( AddForm(..)
|
|
, addForm
|
|
, addFormHamlet
|
|
) where
|
|
|
|
import Data.List (sort, nub)
|
|
import Data.Semigroup ((<>))
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Time.Calendar
|
|
import Text.Blaze.Internal (preEscapedString)
|
|
import Text.Hamlet (hamletFile)
|
|
import Text.JSON
|
|
import Yesod (HtmlUrl, HandlerSite, RenderMessage)
|
|
import Yesod.Form
|
|
|
|
import Hledger
|
|
|
|
-- Part of the data required from the add form.
|
|
-- Don't know how to handle the variable posting fields with yesod-form yet.
|
|
-- XXX Variable postings fields
|
|
data AddForm = AddForm
|
|
{ addFormDate :: Day
|
|
, addFormDescription :: Maybe Text
|
|
, addFormJournalFile :: Maybe Text
|
|
} deriving Show
|
|
|
|
addForm :: (RenderMessage (HandlerSite m) FormMessage, Monad m) => Day -> Journal -> FormInput m AddForm
|
|
addForm today j = AddForm
|
|
<$> ireq (checkMMap (pure . validateDate) (T.pack . show) textField) "date"
|
|
<*> iopt textField "description"
|
|
<*> iopt (check validateJournalFile textField) "journal"
|
|
where
|
|
validateJournalFile :: Text -> Either FormMessage Text
|
|
validateJournalFile f
|
|
| T.unpack f `elem` journalFilePaths j = Right f
|
|
| otherwise = Left $ MsgInvalidEntry $ "the selected journal file \"" <> f <> "\"is unknown"
|
|
validateDate :: Text -> Either FormMessage Day
|
|
validateDate s = case fixSmartDateStrEither' today (T.strip s) of
|
|
Right d -> Right d
|
|
Left _ -> Left $ MsgInvalidEntry $ "could not parse date \"" <> s <> "\":"
|
|
|
|
addFormHamlet :: Journal -> t -> HtmlUrl t
|
|
addFormHamlet j r = $(hamletFile "templates/add-form.hamlet")
|
|
where
|
|
descriptions = sort $ nub $ tdescription <$> jtxns j
|
|
accts = journalAccountNamesDeclaredOrImplied j
|
|
escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>" -- #236
|
|
listToJsonValueObjArrayStr as = preEscapedString $ escapeJSSpecialChars $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("value", showJSON a)]) as
|
|
postingnums = [1..4 :: Int]
|
|
filepaths = fst <$> jfiles j
|