{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hledger.Web.Handler.AddR
( getAddR
, postAddR
, putAddR
) where
import Data.Aeson.Types (Result(..))
import qualified Data.Text as T
import Network.HTTP.Types.Status (status400)
import Text.Blaze.Html (preEscapedToHtml)
import Yesod
import Hledger
import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout, journalAddTransaction)
import Hledger.Web.Import
import Hledger.Web.WebOptions (WebOpts(..))
import Hledger.Web.Widget.AddForm (addForm)
getAddR :: Handler ()
getAddR :: Handler ()
getAddR = do
Handler ()
checkServerSideUiEnabled
Handler ()
postAddR
postAddR :: Handler ()
postAddR :: Handler ()
postAddR = do
Handler ()
checkServerSideUiEnabled
VD{Journal
j :: Journal
j :: ViewData -> Journal
j, Day
today :: Day
today :: ViewData -> Day
today} <- Handler ViewData
getViewData
Permission -> Handler ()
require Permission
AddPermission
((FormResult (Transaction, String)
res, Widget
view), Enctype
enctype) <- (Html
-> MForm
(HandlerFor App) (FormResult (Transaction, String), Widget))
-> Handler ((FormResult (Transaction, String), Widget), Enctype)
forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadResource m,
MonadHandler m) =>
(Html -> MForm m (FormResult a, xml))
-> m ((FormResult a, xml), Enctype)
runFormPost ((Html
-> MForm
(HandlerFor App) (FormResult (Transaction, String), Widget))
-> Handler ((FormResult (Transaction, String), Widget), Enctype))
-> (Html
-> MForm
(HandlerFor App) (FormResult (Transaction, String), Widget))
-> Handler ((FormResult (Transaction, String), Widget), Enctype)
forall a b. (a -> b) -> a -> b
$ Journal
-> Day
-> Html
-> MForm
(HandlerFor App) (FormResult (Transaction, String), Widget)
addForm Journal
j Day
today
case FormResult (Transaction, String)
res of
FormSuccess (Transaction
t,String
f) -> do
let t' :: Transaction
t' = Transaction -> Transaction
txnTieKnot Transaction
t
IO () -> Handler ()
forall a. IO a -> HandlerFor App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
ensureJournalFileExists String
f
String -> Text -> IO ()
appendToJournalFileOrStdout String
f (Transaction -> Text
showTransaction Transaction
t')
Html -> Handler ()
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage Html
"Transaction added."
Route App -> Handler ()
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route App
JournalR
FormResult (Transaction, String)
FormMissing -> Widget -> Enctype -> Handler ()
forall {site} {a} {a} {b}.
(Yesod site, ToMarkup a, ToWidget site a) =>
a -> a -> HandlerFor site b
showForm Widget
view Enctype
enctype
FormFailure [Text]
errs -> do
(Text -> Handler ()) -> [Text] -> Handler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Html -> Handler ()
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage (Html -> Handler ()) -> (Text -> Html) -> Text -> Handler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml (Text -> Html) -> (Text -> Text) -> Text -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\n" Text
"<br>") [Text]
errs
Widget -> Enctype -> Handler ()
forall {site} {a} {a} {b}.
(Yesod site, ToMarkup a, ToWidget site a) =>
a -> a -> HandlerFor site b
showForm Widget
view Enctype
enctype
where
showForm :: a -> a -> HandlerFor site b
showForm a
view a
enctype =
Html -> HandlerFor site b
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse (Html -> HandlerFor site b)
-> HandlerFor site Html -> HandlerFor site b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< WidgetFor site () -> HandlerFor site Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout WidgetFor site ()
[whamlet|
<h2>Add transaction
<div .row style="margin-top:1em">
<form#addform.form.col-xs-12.col-sm-11 method=post enctype=#{enctype}>
^{view}
|]
putAddR :: Handler RepJson
putAddR :: Handler RepJson
putAddR = do
VD{Journal
j :: ViewData -> Journal
j :: Journal
j, WebOpts
opts :: WebOpts
opts :: ViewData -> WebOpts
opts} <- Handler ViewData
getViewData
Permission -> Handler ()
require Permission
AddPermission
(Result Transaction
r :: Result Transaction) <- HandlerFor App (Result Transaction)
forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody
case Result Transaction
r of
Error String
err -> Status -> String -> Handler RepJson
forall (m :: * -> *) c a.
(MonadHandler m, ToJSON c) =>
Status -> c -> m a
sendStatusJSON Status
status400 (String
"could not parse json: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err ::String)
Success Transaction
t -> do
HandlerFor App Journal -> Handler ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (HandlerFor App Journal -> Handler ())
-> HandlerFor App Journal -> Handler ()
forall a b. (a -> b) -> a -> b
$ IO Journal -> HandlerFor App Journal
forall a. IO a -> HandlerFor App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Journal -> HandlerFor App Journal)
-> IO Journal -> HandlerFor App Journal
forall a b. (a -> b) -> a -> b
$ Journal -> CliOpts -> Transaction -> IO Journal
journalAddTransaction Journal
j (WebOpts -> CliOpts
cliopts_ WebOpts
opts) Transaction
t
Route (HandlerSite (HandlerFor App)) -> Handler RepJson
forall (m :: * -> *) a.
MonadHandler m =>
Route (HandlerSite m) -> m a
sendResponseCreated Route (HandlerSite (HandlerFor App))
Route App
TransactionsR