{-# 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}
      |]

-- Add a single new transaction, send as JSON via PUT, to the journal.
-- The web form handler above should probably use PUT as well.
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