{-# 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{[Capability]
caps :: ViewData -> [Capability]
caps :: [Capability]
caps, Journal
j :: ViewData -> Journal
j :: Journal
j, Day
today :: ViewData -> Day
today :: Day
today} <- Handler ViewData
getViewData
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Capability
CapAdd forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Capability]
caps) (forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied Text
"Missing the 'add' capability")
((FormResult (Transaction, String)
res, Widget
view), Enctype
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 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
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
ensureJournalFileExists String
f
String -> Text -> IO ()
appendToJournalFileOrStdout String
f (Transaction -> Text
showTransaction Transaction
t')
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage Html
"Transaction added."
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route App
JournalR
FormResult (Transaction, String)
FormMissing -> 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
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMarkup a => a -> Html
preEscapedToHtml forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"\n" Text
"<br>") [Text]
errs
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 =
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout [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{[Capability]
caps :: [Capability]
caps :: ViewData -> [Capability]
caps, Journal
j :: Journal
j :: ViewData -> Journal
j, WebOpts
opts :: ViewData -> WebOpts
opts :: WebOpts
opts} <- Handler ViewData
getViewData
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Capability
CapAdd forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Capability]
caps) (forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied Text
"Missing the 'add' capability")
(Result Transaction
r :: Result Transaction) <- forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody
case Result Transaction
r of
Error String
err -> forall (m :: * -> *) c a.
(MonadHandler m, ToJSON c) =>
Status -> c -> m a
sendStatusJSON Status
status400 (String
"could not parse json: " forall a. [a] -> [a] -> [a]
++ String
err ::String)
Success Transaction
t -> do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Journal -> CliOpts -> Transaction -> IO Journal
journalAddTransaction Journal
j (WebOpts -> CliOpts
cliopts_ WebOpts
opts) Transaction
t
forall (m :: * -> *) a.
MonadHandler m =>
Route (HandlerSite m) -> m a
sendResponseCreated Route App
TransactionsR