diff --git a/hledger-web/Application.hs b/hledger-web/Application.hs index ab072754d..ca87b20b3 100644 --- a/hledger-web/Application.hs +++ b/hledger-web/Application.hs @@ -19,9 +19,10 @@ import Yesod.Default.Handlers (getFaviconR, getRobotsR) -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! +import Handler.AddR (postAddR) +import Handler.JournalR (getJournalR) +import Handler.RegisterR (getRegisterR) import Handler.RootR (getRootR) -import Handler.JournalR (getJournalR, postJournalR) -import Handler.RegisterR (getRegisterR, postRegisterR) import Handler.SidebarR (getSidebarR) import Hledger.Data (Journal, nulljournal) diff --git a/hledger-web/Foundation.hs b/hledger-web/Foundation.hs index 52f535412..554042067 100644 --- a/hledger-web/Foundation.hs +++ b/hledger-web/Foundation.hs @@ -6,20 +6,19 @@ module Foundation where import Data.IORef (IORef, readIORef, writeIORef) -import Data.List (isPrefixOf, sort, nub) +import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Time.Calendar (Day) import Network.HTTP.Conduit (Manager) import Text.Blaze (Markup) -import Text.Blaze.Internal (preEscapedString) import Text.Blaze.Html.Renderer.String (renderHtml) import Text.Hamlet (hamletFile) -import Text.JSON import Yesod import Yesod.Static import Yesod.Default.Config +import Handler.AddForm import Settings.StaticFiles import Settings (widgetFile, Extra (..)) #ifndef DEVELOPMENT @@ -233,104 +232,3 @@ getCurrentJournal jref opts d = do -- referentially transparent manner (allowing multiple reads). getLastMessage :: Handler (Maybe Html) getLastMessage = cached getMessage - --- add form dialog, part of the default template - --- | Add transaction form. -addform :: Journal -> HtmlUrl AppRoute -addform j = [hamlet| - -" "<\\/script>" -- #236 - listToJsonValueObjArrayStr as = preEscapedString $ escapeJSSpecialChars $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("value", showJSON a)]) as - numpostings = 4 - postingnums = [1..numpostings] - filepaths = map fst $ jfiles j - postingfields :: Int -> HtmlUrl AppRoute - postingfields n = [hamlet| -
-
- -
- -|] - where - acctvar = "account" ++ show n - acctph = "Account " ++ show n - amtvar = "amount" ++ show n - amtph = "Amount " ++ show n - grpvar = "grp" ++ show n - -journalselect :: [FilePath] -> HtmlUrl AppRoute -journalselect journalfilepaths = [hamlet| - -|] diff --git a/hledger-web/Handler/AddForm.hs b/hledger-web/Handler/AddForm.hs index 68e2d544f..6fd872155 100644 --- a/hledger-web/Handler/AddForm.hs +++ b/hledger-web/Handler/AddForm.hs @@ -1,24 +1,30 @@ -{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, NamedFieldPuns, ScopedTypeVariables, TypeFamilies #-} -- | 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.) -module Handler.AddForm where +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} -import Import +module Handler.AddForm + ( AddForm(..) + , addForm + , addFormHamlet + ) where -import Control.Monad.State.Strict (evalStateT) -import Data.List (sortBy) +import Data.List (sort, nub) +import Data.Semigroup ((<>)) +import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar -import Data.Void (Void) -import Safe (headMay) -import Text.Blaze (ToMarkup) -import Text.Megaparsec -import Text.Megaparsec.Char +import Text.Blaze.Internal (preEscapedString) +import Text.Hamlet (hamletFile) +import Text.JSON +import Yesod (HtmlUrl, HandlerSite, RenderMessage) +import Yesod.Form import Hledger -import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout) -- Part of the data required from the add form. -- Don't know how to handle the variable posting fields with yesod-form yet. @@ -29,7 +35,7 @@ data AddForm = AddForm , addFormJournalFile :: Maybe Text } deriving Show -addForm :: Day -> Journal -> FormInput Handler AddForm +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" @@ -44,79 +50,12 @@ addForm today j = AddForm Right d -> Right d Left _ -> Left $ MsgInvalidEntry $ "could not parse date \"" <> s <> "\":" -postAddForm :: Handler Html -postAddForm = do - -- 1. process the fixed fields with yesod-form - VD{today, j} <- getViewData - formresult <- runInputPostResult (addForm today j) - - ok <- case formresult of - FormMissing -> showErrors ["there is no form data" :: Text] >> return False - FormFailure errs -> showErrors errs >> return False - FormSuccess dat -> do - let AddForm{ - addFormDate =date - ,addFormDescription=mdesc - ,addFormJournalFile=mjournalfile - } = dat - desc = fromMaybe "" mdesc - journalfile = maybe (journalFilePath j) T.unpack mjournalfile - - -- 2. the fixed fields look good; now process the posting fields adhocly, - -- getting either errors or a balanced transaction - - (params,_) <- runRequestBody - let acctparams = parseNumberedParameters "account" params - amtparams = parseNumberedParameters "amount" params - num = length acctparams - paramErrs | num == 0 = ["at least one posting must be entered"] - | map fst acctparams == [1..num] && - map fst amtparams `elem` [[1..num], [1..num-1]] = [] - | otherwise = ["the posting parameters are malformed"] - eaccts = map (runParser (accountnamep <* eof) "" . textstrip . snd) acctparams - eamts = map (runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd) amtparams - (accts, acctErrs) = (rights eaccts, map show $ lefts eaccts) - (amts', amtErrs) = (rights eamts, map show $ lefts eamts) - amts | length amts' == num = amts' - | otherwise = amts' ++ [missingamt] - errs = if not (null paramErrs) then paramErrs else (acctErrs ++ amtErrs) - etxn | not $ null errs = Left errs - | otherwise = either (Left . maybeToList . headMay . lines) Right - (balanceTransaction Nothing $ nulltransaction { - tdate=date - ,tdescription=desc - ,tpostings=[nullposting{paccount=acct, pamount=Mixed [amt]} | (acct,amt) <- zip accts amts] - }) - case etxn of - Left errs -> showErrors errs >> return False - Right t -> do - -- 3. all fields look good and form a balanced transaction; append it to the file - liftIO (appendTransaction journalfile t) - setMessage [shamlet|Transaction added.|] - return True - - if ok then redirect JournalR else redirect (JournalR, [("add","1")]) - -parseNumberedParameters :: Text -> [(Text, Text)] -> [(Int, Text)] -parseNumberedParameters s = - reverse . dropWhile (T.null . snd) . sortBy (flip compare) . mapMaybe parseNum - where - parseNum :: (Text, Text) -> Maybe (Int, Text) - parseNum (k, v) = case parsewith paramnamep k of - Left (_ :: ParseError Char Void) -> Nothing - Right k' -> Just (k', v) - paramnamep = string s *> (read <$> some digitChar) <* eof - --- XXX move into balanceTransaction -appendTransaction :: FilePath -> Transaction -> IO () -appendTransaction journalfile t = do - ensureJournalFileExists journalfile - appendToJournalFileOrStdout journalfile $ - showTransaction (txnTieKnot t) - -showErrors :: ToMarkup a => [a] -> Handler () -showErrors errs = setMessage [shamlet| -Errors:
-$forall e<-errs - \#{e}
-|] +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>" -- #236 + listToJsonValueObjArrayStr as = preEscapedString $ escapeJSSpecialChars $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("value", showJSON a)]) as + postingnums = [1..4 :: Int] + filepaths = fst <$> jfiles j diff --git a/hledger-web/Handler/AddR.hs b/hledger-web/Handler/AddR.hs new file mode 100644 index 000000000..66f7b9173 --- /dev/null +++ b/hledger-web/Handler/AddR.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Handler.AddR + ( postAddR + ) where + +import Import + +import Control.Monad.State.Strict (evalStateT) +import Data.List (sortBy) +import qualified Data.Text as T +import Data.Void (Void) +import Safe (headMay) +import Text.Megaparsec +import Text.Megaparsec.Char + +import Handler.AddForm (AddForm(..), addForm) +import Handler.Common (showErrors) + +import Hledger +import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout) + +postAddR :: Handler Html +postAddR = do + -- 1. process the fixed fields with yesod-form + VD{today, j} <- getViewData + formresult <- runInputPostResult (addForm today j) + + ok <- case formresult of + FormMissing -> showErrors ["there is no form data" :: Text] >> return False + FormFailure errs -> showErrors errs >> return False + FormSuccess form -> do + let journalfile = maybe (journalFilePath j) T.unpack $ addFormJournalFile form + + -- 2. the fixed fields look good; now process the posting fields adhocly, + -- getting either errors or a balanced transaction + (params,_) <- runRequestBody + let acctparams = parseNumberedParameters "account" params + amtparams = parseNumberedParameters "amount" params + pnum = length acctparams + paramErrs | pnum == 0 = ["at least one posting must be entered"] + | map fst acctparams == [1..pnum] && + map fst amtparams `elem` [[1..pnum], [1..pnum-1]] = [] + | otherwise = ["the posting parameters are malformed"] + eaccts = map (runParser (accountnamep <* eof) "" . textstrip . snd) acctparams + eamts = map (runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd) amtparams + (accts, acctErrs) = (rights eaccts, map show $ lefts eaccts) + (amts', amtErrs) = (rights eamts, map show $ lefts eamts) + amts | length amts' == pnum = amts' + | otherwise = amts' ++ [missingamt] + errs = if not (null paramErrs) then paramErrs else acctErrs ++ amtErrs + etxn | not $ null errs = Left errs + | otherwise = either (Left . maybeToList . headMay . lines) Right + (balanceTransaction Nothing $ nulltransaction { + tdate = addFormDate form + ,tdescription = fromMaybe "" $ addFormDescription form + ,tpostings=[nullposting{paccount=acct, pamount=Mixed [amt]} | (acct,amt) <- zip accts amts] + }) + case etxn of + Left errs' -> showErrors errs' >> return False + Right t -> do + -- 3. all fields look good and form a balanced transaction; append it to the file + liftIO (appendTransaction journalfile t) + setMessage [shamlet|Transaction added.|] + return True + + if ok then redirect JournalR else redirect (JournalR, [("add","1")]) + +parseNumberedParameters :: Text -> [(Text, Text)] -> [(Int, Text)] +parseNumberedParameters s = + reverse . dropWhile (T.null . snd) . sortBy (flip compare) . mapMaybe parseNum + where + parseNum :: (Text, Text) -> Maybe (Int, Text) + parseNum (k, v) = case parsewith paramnamep k of + Left (_ :: ParseError Char Void) -> Nothing + Right k' -> Just (k', v) + paramnamep = string s *> (read <$> some digitChar) <* eof + +-- XXX move into balanceTransaction +appendTransaction :: FilePath -> Transaction -> IO () +appendTransaction journalfile t = do + ensureJournalFileExists journalfile + appendToJournalFileOrStdout journalfile $ + showTransaction (txnTieKnot t) diff --git a/hledger-web/Handler/Common.hs b/hledger-web/Handler/Common.hs index ee123710d..fad5fe281 100644 --- a/hledger-web/Handler/Common.hs +++ b/hledger-web/Handler/Common.hs @@ -9,6 +9,7 @@ import Import import qualified Data.Text as T import Data.Time.Calendar (Day, toGregorian) import System.FilePath (takeFileName) +import Text.Blaze (ToMarkup) import Text.Blaze.Internal (preEscapedString) import Text.Printf (printf) @@ -51,7 +52,6 @@ topbar VD{j, showsidebar} = [hamlet|

#{title} - |] where title = takeFileName $ journalFilePath j @@ -106,15 +106,13 @@ searchform VD{q, here} = [hamlet|
- $if filtering + $if not (T.null q)