From cc1241fa205beee103fe39d1c1c9e0523c74edfb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jakub=20Z=C3=A1rybnick=C3=BD?= Date: Tue, 12 Jun 2018 18:56:53 +0200 Subject: [PATCH] web: Add yesod-form-generated AddForm, add GET & POST /add --- hledger-web/config/routes | 9 +- hledger-web/hledger-web.cabal | 4 +- hledger-web/package.yaml | 4 +- hledger-web/src/Application.hs | 20 ++- hledger-web/src/Foundation.hs | 65 +++++----- hledger-web/src/Handler/AddForm.hs | 61 --------- hledger-web/src/Handler/AddR.hs | 95 ++++---------- hledger-web/src/Handler/Common.hs | 118 ++---------------- hledger-web/src/Handler/EditR.hs | 67 +++++----- hledger-web/src/Handler/ImportR.hs | 41 +++--- hledger-web/src/Handler/JournalR.hs | 15 +-- hledger-web/src/Handler/RegisterR.hs | 13 +- hledger-web/src/Handler/RootR.hs | 8 -- hledger-web/src/Import.hs | 18 ++- hledger-web/src/Widget/AddForm.hs | 115 +++++++++++++++++ hledger-web/src/Widget/Common.hs | 92 ++++++++++++++ hledger-web/static/hledger.js | 79 +++--------- hledger-web/templates/add-form.hamlet | 80 ++++++------ .../templates/default-layout-wrapper.hamlet | 60 +-------- hledger-web/templates/default-layout.hamlet | 51 +++++++- hledger-web/templates/edit-form.hamlet | 12 +- hledger-web/templates/import-form.hamlet | 2 - hledger-web/templates/journal.hamlet | 10 ++ hledger-web/templates/register.hamlet | 10 ++ 24 files changed, 504 insertions(+), 545 deletions(-) delete mode 100644 hledger-web/src/Handler/AddForm.hs delete mode 100644 hledger-web/src/Handler/RootR.hs create mode 100644 hledger-web/src/Widget/AddForm.hs create mode 100644 hledger-web/src/Widget/Common.hs diff --git a/hledger-web/config/routes b/hledger-web/config/routes index 8aec08b24..bc49cf0d2 100644 --- a/hledger-web/config/routes +++ b/hledger-web/config/routes @@ -4,9 +4,6 @@ / RootR GET /journal JournalR GET /register RegisterR GET -/add AddR POST -/edit EditR POST -/import ImportR POST - --- /accounts AccountsR GET --- /api/accounts AccountsJsonR GET +/add AddR GET POST +/edit EditR GET POST +/import ImportR GET POST diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal index 17c6c4318..09cfe8df3 100644 --- a/hledger-web/hledger-web.cabal +++ b/hledger-web/hledger-web.cabal @@ -123,14 +123,12 @@ library exposed-modules: Application Foundation - Handler.AddForm Handler.AddR Handler.Common Handler.EditR Handler.ImportR Handler.JournalR Handler.RegisterR - Handler.RootR Hledger.Web Hledger.Web.Main Hledger.Web.WebOptions @@ -138,6 +136,8 @@ library Settings Settings.Development Settings.StaticFiles + Widget.AddForm + Widget.Common other-modules: Paths_hledger_web ghc-options: -Wall diff --git a/hledger-web/package.yaml b/hledger-web/package.yaml index 97426672a..a44b2037d 100644 --- a/hledger-web/package.yaml +++ b/hledger-web/package.yaml @@ -118,14 +118,12 @@ library: exposed-modules: - Application - Foundation - - Handler.AddForm - Handler.AddR - Handler.Common - Handler.EditR - Handler.ImportR - Handler.JournalR - Handler.RegisterR - - Handler.RootR - Hledger.Web - Hledger.Web.Main - Hledger.Web.WebOptions @@ -133,6 +131,8 @@ library: - Settings - Settings.Development - Settings.StaticFiles + - Widget.AddForm + - Widget.Common executables: hledger-web: diff --git a/hledger-web/src/Application.hs b/hledger-web/src/Application.hs index 251d6a879..697316d64 100644 --- a/hledger-web/src/Application.hs +++ b/hledger-web/src/Application.hs @@ -1,10 +1,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP, OverloadedStrings, TemplateHaskell #-} module Application - ( makeApplication - , getApplicationDev - , makeFoundation - ) where + ( makeApplication + , getApplicationDev + , makeFoundation + ) where import Import @@ -15,15 +15,13 @@ import Network.HTTP.Client (defaultManagerSettings) import Network.HTTP.Conduit (newManager) import Yesod.Default.Config import Yesod.Default.Main (defaultDevelApp) -import Yesod.Default.Handlers (getFaviconR, getRobotsR) -import Handler.AddR (postAddR) -import Handler.EditR (postEditR) -import Handler.ImportR (postImportR) +import Handler.AddR (getAddR, postAddR) +import Handler.Common (getFaviconR, getRobotsR, getRootR) +import Handler.EditR (getEditR, postEditR) +import Handler.ImportR (getImportR, postImportR) import Handler.JournalR (getJournalR) import Handler.RegisterR (getRegisterR) -import Handler.RootR (getRootR) - import Hledger.Data (Journal, nulljournal) import Hledger.Read (readJournalFile) import Hledger.Utils (error') @@ -46,7 +44,7 @@ makeApplication opts' j' conf' = do logWare <$> toWaiAppPlain foundation where logWare | development = logStdoutDev - | serve_ opts' = logStdout + | serve_ opts' = logStdout | otherwise = id makeFoundation :: AppConfig DefaultEnv Extra -> WebOpts -> IO App diff --git a/hledger-web/src/Foundation.hs b/hledger-web/src/Foundation.hs index df7e1fbff..24fe05062 100644 --- a/hledger-web/src/Foundation.hs +++ b/hledger-web/src/Foundation.hs @@ -6,7 +6,6 @@ module Foundation where import Data.IORef (IORef, readIORef, writeIORef) -import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -14,16 +13,15 @@ import Data.Time.Calendar (Day) import Network.HTTP.Conduit (Manager) import System.FilePath (takeFileName) import Text.Blaze (Markup) -import Text.Blaze.Html.Renderer.String (renderHtml) import Text.Hamlet (hamletFile) import Yesod import Yesod.Static import Yesod.Default.Config -import Handler.AddForm -import Handler.Common (balanceReportAsHtml) +import Settings (Extra(..), widgetFile) import Settings.StaticFiles -import Settings (widgetFile, Extra (..)) +import Widget.Common (balanceReportAsHtml) + #ifndef DEVELOPMENT import Settings (staticDir) import Text.Jasmine (minifym) @@ -87,7 +85,8 @@ instance Yesod App where defaultLayout widget = do master <- getYesod - VD{am, here, j, opts, q, qopts, showsidebar} <- getViewData + here <- fromMaybe RootR <$> getCurrentRoute + VD {am, j, opts, q, qopts, showsidebar} <- getViewData msg <- getMessage let journalcurrent = if here == JournalR then "inacct" else "" :: Text @@ -152,18 +151,17 @@ instance RenderMessage App FormMessage where -- XXX Parameter p - show/hide postings -- | A bundle of data useful for hledger-web request handlers and templates. -data ViewData = VD { - opts :: WebOpts -- ^ the command-line options at startup - ,here :: AppRoute -- ^ the current route - ,today :: Day -- ^ today's date (for queries containing relative dates) - ,j :: Journal -- ^ the up-to-date parsed unfiltered journal - ,q :: Text -- ^ the current q parameter, the main query expression - ,m :: Query -- ^ a query parsed from the q parameter - ,qopts :: [QueryOpt] -- ^ query options parsed from the q parameter - ,am :: Query -- ^ a query parsed from the accounts sidebar query expr ("a" parameter) - ,aopts :: [QueryOpt] -- ^ query options parsed from the accounts sidebar query expr - ,showsidebar :: Bool -- ^ current showsidebar cookie value - } deriving (Show) +data ViewData = VD + { opts :: WebOpts -- ^ the command-line options at startup + , today :: Day -- ^ today's date (for queries containing relative dates) + , j :: Journal -- ^ the up-to-date parsed unfiltered journal + , q :: Text -- ^ the current q parameter, the main query expression + , m :: Query -- ^ a query parsed from the q parameter + , qopts :: [QueryOpt] -- ^ query options parsed from the q parameter + , am :: Query -- ^ a query parsed from the accounts sidebar query expr ("a" parameter) + , aopts :: [QueryOpt] -- ^ query options parsed from the accounts sidebar query expr + , showsidebar :: Bool -- ^ current showsidebar cookie value + } deriving (Show) instance Show Text.Blaze.Markup where show _ = "" @@ -178,7 +176,6 @@ viewdataWithDateAndParams d q a = (acctsmatcher, acctsopts) = parseQuery d a in VD { opts = defwebopts - , here = RootR , today = d , j = nulljournal , q = q @@ -191,22 +188,20 @@ viewdataWithDateAndParams d q a = -- | Gather data used by handlers and templates in the current request. getViewData :: Handler ViewData -getViewData = getCurrentRoute >>= \case - Nothing -> return nullviewdata - Just here -> do - App {appOpts, appJournal = jref} <- getYesod - let opts@WebOpts {cliopts_ = copts@CliOpts {reportopts_ = ropts}} = appOpts - today <- liftIO getCurrentDay - (j, merr) <- getCurrentJournal jref copts {reportopts_ = ropts {no_elide_ = True}} today - case merr of - Just err -> setMessage (toHtml err) - Nothing -> pure () - q <- fromMaybe "" <$> lookupGetParam "q" - a <- fromMaybe "" <$> lookupGetParam "a" - showsidebar <- shouldShowSidebar - return - (viewdataWithDateAndParams today q a) - {here, j, opts, showsidebar, today} +getViewData = do + App {appOpts, appJournal = jref} <- getYesod + let opts@WebOpts {cliopts_ = copts@CliOpts {reportopts_ = ropts}} = appOpts + today <- liftIO getCurrentDay + (j, merr) <- getCurrentJournal jref copts {reportopts_ = ropts {no_elide_ = True}} today + case merr of + Just err -> setMessage (toHtml err) + Nothing -> pure () + q <- fromMaybe "" <$> lookupGetParam "q" + a <- fromMaybe "" <$> lookupGetParam "a" + showsidebar <- shouldShowSidebar + return + (viewdataWithDateAndParams today q a) + {j, opts, showsidebar, today} -- | Find out if the sidebar should be visible. Show it, unless there is a -- showsidebar cookie set to "0", or a ?sidebar=0 query parameter. diff --git a/hledger-web/src/Handler/AddForm.hs b/hledger-web/src/Handler/AddForm.hs deleted file mode 100644 index 6fd872155..000000000 --- a/hledger-web/src/Handler/AddForm.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | 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>" -- #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/src/Handler/AddR.hs b/hledger-web/src/Handler/AddR.hs index 79ca33f03..c6509c054 100644 --- a/hledger-web/src/Handler/AddR.hs +++ b/hledger-web/src/Handler/AddR.hs @@ -1,85 +1,38 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} module Handler.AddR - ( postAddR + ( getAddR + , postAddR ) where import Import -import Control.Monad.State.Strict (evalStateT) -import Data.List (dropWhileEnd, sort) -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) +import Widget.AddForm (addForm) -postAddR :: Handler () +getAddR :: Handler Html +getAddR = do + VD {j, today} <- getViewData + (view, enctype) <- generateFormPost $ addForm j today + defaultLayout [whamlet|
^{view}|] + +postAddR :: Handler Html postAddR = do - VD{today, j} <- getViewData - -- 1. process the fixed fields with yesod-form - runInputPostResult (addForm today j) >>= \case - FormMissing -> bail ["there is no form data"] - FormFailure errs -> bail errs - 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 - when (pnum == 0) (bail ["at least one posting must be entered"]) - when (map fst acctparams /= [1..pnum] || map fst amtparams `notElem` [[1..pnum], [1..pnum-1]]) - (bail ["the posting parameters are malformed"]) + VD{j, today} <- getViewData + ((res, view), enctype) <- runFormPost $ addForm j today + case res of + FormMissing -> defaultLayout [whamlet|
^{view}|] + FormFailure _ -> defaultLayout [whamlet|
^{view}|] + FormSuccess t -> do + liftIO $ do + -- XXX(?) move into balanceTransaction + ensureJournalFileExists (journalFilePath j) + appendToJournalFileOrStdout (journalFilePath j) (showTransaction $ txnTieKnot t) + setMessage "Transaction added." + redirect JournalR - let eaccts = runParser (accountnamep <* eof) "" . textstrip . snd <$> acctparams - eamts = runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd <$> amtparams - (acctErrs, accts) = partitionEithers eaccts - (amtErrs, amts') = partitionEithers eamts - amts | length amts' == pnum = amts' - | otherwise = amts' ++ [missingamt] - errs = T.pack . parseErrorPretty <$> acctErrs ++ amtErrs - unless (null errs) (bail errs) - - let etxn = balanceTransaction Nothing $ nulltransaction - { tdate = addFormDate form - , tdescription = fromMaybe "" $ addFormDescription form - , tpostings = (\(ac, am) -> nullposting {paccount = ac, pamount = Mixed [am]}) <$> zip accts amts - } - case etxn of - Left errs' -> bail (fmap T.pack . maybeToList . headMay $ lines errs') - Right t -> do - -- 3. all fields look good and form a balanced transaction; append it to the file - liftIO (appendTransaction journalfile t) - setMessage "Transaction added." - redirect JournalR - where - bail :: [Text] -> Handler () - bail xs = showErrors xs >> redirect (JournalR, [("add","1")]) - -parseNumberedParameters :: Text -> [(Text, Text)] -> [(Int, Text)] -parseNumberedParameters s = - dropWhileEnd (T.null . snd) . sort . 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/src/Handler/Common.hs b/hledger-web/src/Handler/Common.hs index d3c49e3f8..2dc311d46 100644 --- a/hledger-web/src/Handler/Common.hs +++ b/hledger-web/src/Handler/Common.hs @@ -1,111 +1,11 @@ -{-# LANGUAGE CPP, OverloadedStrings, QuasiQuotes, NamedFieldPuns #-} --- | Common page components and rendering helpers. --- For global page layout, see Application.hs. +module Handler.Common + ( getRootR + , getFaviconR + , getRobotsR + ) where -module Handler.Common where +import Import +import Yesod.Default.Handlers (getFaviconR, getRobotsR) -import Data.Semigroup ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Calendar (Day, toGregorian) -import Text.Blaze (ToMarkup) -import Text.Blaze.Internal (preEscapedString) -import Yesod - -import Settings (manualurl) - -import Hledger - --- -- | Navigation link, preserving parameters and possibly highlighted. --- navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute --- navlink VD{..} s dest title = [hamlet| --- #{s} --- |] --- where u' = (dest, if null q then [] else [("q", pack q)]) --- style | dest == here = "navlinkcurrent" --- | otherwise = "navlink" :: Text - --- -- | Links to the various journal editing forms. --- editlinks :: HtmlUrl AppRoute --- editlinks = [hamlet| --- edit --- \ | # --- add --- import transactions --- |] - --- | Link to a topic in the manual. -helplink :: Text -> Text -> HtmlUrl r -helplink topic label = [hamlet|#{label}|] - where u = manualurl <> if T.null topic then "" else T.cons '#' topic - ----------------------------------------------------------------------- --- hledger report renderers - --- | Render a "BalanceReport" as html. -balanceReportAsHtml :: r -> Journal -> [QueryOpt] -> BalanceReport -> HtmlUrl r -balanceReportAsHtml registerR j qopts (items, total) = [hamlet| -$forall (acct, adisplay, aindent, abal) <- items - - -
- \#{indent aindent} - - #{adisplay} - $if hasSubs acct - only - - ^{mixedAmountAsHtml abal} - - - - ^{mixedAmountAsHtml total} -|] where - l = ledgerFromJournal Any j - inacctClass acct = case inAccountQuery qopts of - Just m' -> if m' `matchesAccount` acct then "inacct" else "" - Nothing -> "" :: Text - hasSubs acct = maybe True (not . null . asubs) (ledgerAccount l acct) - indent a = preEscapedString $ concat $ replicate (2 + 2 * a) " " - acctLink acct = (registerR, [("q", accountQuery acct)]) - acctOnlyLink acct = (registerR, [("q", accountOnlyQuery acct)]) - -accountQuery :: AccountName -> Text -accountQuery = ("inacct:" <>) . quoteIfSpaced - -accountOnlyQuery :: AccountName -> Text -accountOnlyQuery = ("inacctonly:" <>) . quoteIfSpaced - -numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int, Bool, Bool, TransactionsReportItem)] -numberTransactionsReportItems [] = [] -numberTransactionsReportItems items = number 0 nulldate items - where - number :: Int -> Day -> [TransactionsReportItem] -> [(Int, Bool, Bool, TransactionsReportItem)] - number _ _ [] = [] - number n prevd (i@(t, _, _, _, _, _):rest) = (n+1, newday, newmonth, i): number (n+1) d rest - where - d = tdate t - newday = d /= prevd - newmonth = dm /= prevdm || dy /= prevdy - (dy, dm, _) = toGregorian d - (prevdy, prevdm, _) = toGregorian prevd - -mixedAmountAsHtml :: MixedAmount -> HtmlUrl a -mixedAmountAsHtml b = [hamlet| -$forall t <- ts - #{t} -
-|] where - ts = lines (showMixedAmountWithoutPrice b) - c = case isNegativeMixedAmount b of - Just True -> "negative amount" :: Text - _ -> "positive amount" - -showErrors :: ToMarkup a => [a] -> HandlerFor m () -showErrors errs = setMessage [shamlet| -Errors:
-$forall e <- errs - \#{e}
-|] +getRootR :: Handler Html +getRootR = redirect JournalR diff --git a/hledger-web/src/Handler/EditR.hs b/hledger-web/src/Handler/EditR.hs index 58657c8dc..b815f6c3f 100644 --- a/hledger-web/src/Handler/EditR.hs +++ b/hledger-web/src/Handler/EditR.hs @@ -1,46 +1,49 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Handler.EditR - ( postEditR + ( getEditR + , postEditR ) where import Import -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Except import qualified Data.Text as T -import Text.Printf (printf) - -import Handler.Common (showErrors) import Hledger import Hledger.Cli.Utils --- | Handle a post from the journal edit form. -postEditR :: Handler () -postEditR = runE $ do - VD {j} <- lift getViewData - -- get form input values, or validation errors. - text <- ExceptT $ maybe (Left "No value provided") Right <$> lookupPostParam "text" - journalpath <- ExceptT $ maybe - (Right . T.pack $ journalFilePath j) - (\f -> - if T.unpack f `elem` journalFilePaths j - then Right f - else Left "unrecognised journal file path") <$> - lookupPostParam "journal" - -- try to avoid unnecessary backups or saving invalid data - let tnew = T.filter (/= '\r') text +editForm :: [(FilePath, Text)] -> Markup -> MForm Handler (FormResult (FilePath, Text), Widget) +editForm journals = identifyForm "import" $ \extra -> do + let files = fst <$> journals + (jRes, jView) <- mreq (selectFieldList ((\x -> (T.pack x, x)) <$> files)) "journal" (listToMaybe files) + (tRes, tView) <- mreq textareaField "text" (Textarea . snd <$> listToMaybe journals) + pure ((,) <$> jRes <*> (unTextarea <$> tRes), [whamlet| + #{extra} +

+ ^{fvInput jView}
+ ^{fvInput tView} + + |]) - jE <- liftIO $ readJournal def (Just $ T.unpack journalpath) tnew - _ <- ExceptT . pure $ first T.pack jE - _ <- liftIO $ writeFileWithBackupIfChanged (T.unpack journalpath) tnew - setMessage $ toHtml (printf "Saved journal %s\n" (show journalpath) :: String) - redirect JournalR - where - runE :: ExceptT Text Handler () -> Handler () - runE f = runExceptT f >>= \case - Left e -> showErrors [e] >> redirect JournalR - Right x -> pure x +getEditR :: Handler Html +getEditR = do + VD {j} <- getViewData + (view, enctype) <- generateFormPost (editForm $ jfiles j) + defaultLayout [whamlet|^{view}|] + +postEditR :: Handler Html +postEditR = do + VD {j} <- getViewData + ((res, view), enctype) <- runFormPost (editForm $ jfiles j) + case res of + FormMissing -> defaultLayout [whamlet|^{view}|] + FormFailure _ -> defaultLayout [whamlet|^{view}|] + FormSuccess (journalPath, text) -> do + -- try to avoid unnecessary backups or saving invalid data + _ <- liftIO $ first T.pack <$> readJournal def (Just journalPath) text + _ <- liftIO $ writeFileWithBackupIfChanged journalPath text + setMessage $ toHtml (printf "Saved journal %s\n" journalPath :: String) + redirect JournalR diff --git a/hledger-web/src/Handler/ImportR.hs b/hledger-web/src/Handler/ImportR.hs index c209639f1..60cf407d4 100644 --- a/hledger-web/src/Handler/ImportR.hs +++ b/hledger-web/src/Handler/ImportR.hs @@ -1,29 +1,36 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Handler.ImportR - ( postImportR + ( getImportR + , postImportR ) where import Import -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Except +importForm :: Markup -> MForm Handler (FormResult FileInfo, Widget) +importForm = identifyForm "import" $ \extra -> do + (res, view) <- mreq fileField "file" Nothing + pure (res, [whamlet| + #{extra} +

+ Hello, my name is # + ^{fvInput view} + + |]) -import Handler.Common (showErrors) +getImportR :: Handler Html +getImportR = do + (view, enctype) <- generateFormPost importForm + defaultLayout [whamlet|^{view}|] -- | Handle a post from the journal import form. -postImportR :: Handler () -postImportR = runE $ do - ((res, _), _) <- lift . runFormPost . renderDivs $ areq fileField "file" Nothing +postImportR :: Handler Html +postImportR = do + ((res, view), enctype) <- runFormPost importForm case res of - FormMissing -> throwE ["No file provided"] - FormFailure es -> throwE es + FormMissing -> defaultLayout [whamlet|^{view}|] + FormFailure _ -> defaultLayout [whamlet|^{view}|] FormSuccess _ -> do - setMessage "File uploaded successfully" - redirect JournalR - where - runE :: ExceptT [Text] Handler () -> Handler () - runE f = runExceptT f >>= \case - Left e -> showErrors e >> redirect JournalR - Right x -> pure x + setMessage "File uploaded successfully" + redirect JournalR diff --git a/hledger-web/src/Handler/JournalR.hs b/hledger-web/src/Handler/JournalR.hs index 5eba56978..06abdf33b 100644 --- a/hledger-web/src/Handler/JournalR.hs +++ b/hledger-web/src/Handler/JournalR.hs @@ -9,21 +9,17 @@ module Handler.JournalR where import Import -import Handler.Common (accountQuery, mixedAmountAsHtml) - +import Hledger import Hledger.Cli.CliOptions -import Hledger.Data -import Hledger.Query -import Hledger.Reports -import Hledger.Utils import Hledger.Web.WebOptions +import Widget.AddForm (addForm) +import Widget.Common (accountQuery, mixedAmountAsHtml) -- | The formatted journal view, with sidebar. +-- XXX like registerReportAsHtml getJournalR :: Handler Html getJournalR = do - VD{j, m, opts, qopts} <- getViewData - -- XXX like registerReportAsHtml - + VD{j, m, opts, qopts, today} <- getViewData let title = case inAccount qopts of Nothing -> "General Journal" Just (a, inclsubs) -> "Transactions in " <> a <> if inclsubs then "" else " (excluding subaccounts)" @@ -31,6 +27,7 @@ getJournalR = do acctlink a = (RegisterR, [("q", accountQuery a)]) (_, items) = journalTransactionsReport (reportopts_ $ cliopts_ opts) j m + (addView, addEnctype) <- generateFormPost (addForm j today) defaultLayout $ do setTitle "journal - hledger-web" $(widgetFile "journal") diff --git a/hledger-web/src/Handler/RegisterR.hs b/hledger-web/src/Handler/RegisterR.hs index 02b9ed732..0462a2f6c 100644 --- a/hledger-web/src/Handler/RegisterR.hs +++ b/hledger-web/src/Handler/RegisterR.hs @@ -10,22 +10,20 @@ module Handler.RegisterR where import Import -import Data.Time import Data.List (intersperse) import qualified Data.Text as T -import Safe (headMay) import Text.Hamlet (hamletFile) -import Handler.Common (mixedAmountAsHtml, numberTransactionsReportItems) - import Hledger import Hledger.Cli.CliOptions import Hledger.Web.WebOptions +import Widget.AddForm (addForm) +import Widget.Common (mixedAmountAsHtml, numberTransactionsReportItems) -- | The main journal/account register view, with accounts sidebar. getRegisterR :: Handler Html getRegisterR = do - VD{j, m, opts, qopts} <- getViewData + VD{j, m, opts, qopts, today} <- getViewData let (a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts s1 = if inclsubs then "" else " (excluding subaccounts)" s2 = if m /= Any then ", filtered" else "" @@ -39,6 +37,7 @@ getRegisterR = do | newd = "newday" | otherwise = "" :: Text + (addView, addEnctype) <- generateFormPost (addForm j today) defaultLayout $ do setTitle "register - hledger-web" $(widgetFile "register") @@ -50,12 +49,12 @@ registerChartHtml percommoditytxnreports = $(hamletFile "templates/chart.hamlet" -- have to make sure plot is not called when our container (maincontent) -- is hidden, eg with add form toggled where - charttitle = case maybe "" (fst.snd) $ headMay percommoditytxnreports of + charttitle = case maybe "" (fst . snd) $ listToMaybe percommoditytxnreports of "" -> "" s -> s <> ":" colorForCommodity = fromMaybe 0 . flip lookup commoditiesIndex commoditiesIndex = zip (map fst percommoditytxnreports) [0..] :: [(CommoditySymbol,Int)] - simpleMixedAmountQuantity = maybe 0 aquantity . headMay . amounts + simpleMixedAmountQuantity = maybe 0 aquantity . listToMaybe . amounts shownull c = if null c then " " else c dayToJsTimestamp :: Day -> Integer diff --git a/hledger-web/src/Handler/RootR.hs b/hledger-web/src/Handler/RootR.hs deleted file mode 100644 index 28186d304..000000000 --- a/hledger-web/src/Handler/RootR.hs +++ /dev/null @@ -1,8 +0,0 @@ --- | Site root and misc. handlers. - -module Handler.RootR where - -import Import - -getRootR :: Handler Html -getRootR = redirect JournalR diff --git a/hledger-web/src/Import.hs b/hledger-web/src/Import.hs index 54994bb9a..dc8d8afc3 100644 --- a/hledger-web/src/Import.hs +++ b/hledger-web/src/Import.hs @@ -7,12 +7,20 @@ import Prelude as Import hiding (head, init, last, readFile, tail, writeFile) import Yesod as Import hiding (Route (..)) -import Control.Monad as Import (when, unless, void) -import Data.Bifunctor as Import (first, second, bimap) -import Data.Default as Import (Default(def)) -import Data.Either as Import (lefts, rights, partitionEithers) -import Data.Maybe as Import (fromMaybe, maybeToList, mapMaybe, isJust) +import Control.Arrow as Import ((&&&)) +import Control.Monad as Import +import Data.Bifunctor as Import +import Data.Default as Import +import Data.Either as Import +import Data.Foldable as Import +import Data.List as Import (foldl', unfoldr) +import Data.Maybe as Import import Data.Text as Import (Text) +import Data.Time as Import hiding (parseTime) +import Data.Traversable as Import +import Data.Void as Import (Void) +import Text.Blaze as Import (Markup) +import Text.Printf as Import (printf) import Foundation as Import import Settings as Import diff --git a/hledger-web/src/Widget/AddForm.hs b/hledger-web/src/Widget/AddForm.hs new file mode 100644 index 000000000..edfeab86a --- /dev/null +++ b/hledger-web/src/Widget/AddForm.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Widget.AddForm + ( addForm + ) 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, parseErrorPretty, runParser) +import Yesod + +import Hledger +import Settings (widgetFile) + +-- XXX -

- -
- +
+
+ ^{fvInput dateView} +
+ + $maybe err <- fvErrors dateView + #{err} +
+
+ ^{fvInput descView} + $maybe err <- fvErrors descView + #{err} +
+
+
-
- $forall n <- postingnums -
-
- -
- +
+ $forall (n, (acc, amt, accE, amtE)) <- msgs +
+
+ + $maybe err <- accE + _{err} +
+ + $maybe err <- amtE + _{err} -
-
-