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

-- 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{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