{-# 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
  Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Capability
CapAdd Capability -> [Capability] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Capability]
caps) (Text -> Handler ()
forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied Text
"Missing the 'add' capability")

  ((FormResult Transaction
res, WidgetFor App ()
view), Enctype
enctype) <- (Markup
 -> MForm
      (HandlerFor App) (FormResult Transaction, WidgetFor App ()))
-> HandlerFor
     App ((FormResult Transaction, WidgetFor App ()), Enctype)
forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadResource m,
 MonadHandler m) =>
(Markup -> MForm m (FormResult a, xml))
-> m ((FormResult a, xml), Enctype)
runFormPost ((Markup
  -> MForm
       (HandlerFor App) (FormResult Transaction, WidgetFor App ()))
 -> HandlerFor
      App ((FormResult Transaction, WidgetFor App ()), Enctype))
-> (Markup
    -> MForm
         (HandlerFor App) (FormResult Transaction, WidgetFor App ()))
-> HandlerFor
     App ((FormResult Transaction, WidgetFor App ()), Enctype)
forall a b. (a -> b) -> a -> b
$ Journal
-> Day
-> Markup
-> MForm
     (HandlerFor App) (FormResult Transaction, WidgetFor App ())
forall site (m :: * -> *).
(site ~ HandlerSite m, RenderMessage site FormMessage,
 MonadHandler m) =>
Journal
-> Day
-> Markup
-> MForm m (FormResult Transaction, WidgetFor site ())
addForm Journal
j Day
today
  case FormResult Transaction
res of
    FormSuccess Transaction
res' -> do
      let t :: Transaction
t = Transaction -> Transaction
txnTieKnot Transaction
res'
      -- XXX(?) move into balanceTransaction
      IO () -> Handler ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
ensureJournalFileExists (Journal -> FilePath
journalFilePath Journal
j)
      -- XXX why not journalAddTransaction ?
      IO () -> Handler ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
appendToJournalFileOrStdout (Journal -> FilePath
journalFilePath Journal
j) (Transaction -> Text
showTransaction Transaction
t)
      Markup -> Handler ()
forall (m :: * -> *). MonadHandler m => Markup -> m ()
setMessage Markup
"Transaction added."
      Route App -> Handler ()
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route App
JournalR
    FormResult Transaction
FormMissing -> WidgetFor App () -> Enctype -> Handler ()
forall site a a b.
(Yesod site, ToMarkup a, ToWidget site a) =>
a -> a -> HandlerFor site b
showForm WidgetFor App ()
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_ (Markup -> Handler ()
forall (m :: * -> *). MonadHandler m => Markup -> m ()
setMessage (Markup -> Handler ()) -> (Text -> Markup) -> Text -> Handler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Markup
forall a. ToMarkup a => a -> Markup
preEscapedToHtml (Text -> Markup) -> (Text -> Text) -> Text -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"\n" Text
"<br>") [Text]
errs
      WidgetFor App () -> Enctype -> Handler ()
forall site a a b.
(Yesod site, ToMarkup a, ToWidget site a) =>
a -> a -> HandlerFor site b
showForm WidgetFor App ()
view Enctype
enctype
  where
    showForm :: a -> a -> HandlerFor site b
showForm a
view a
enctype =
      Markup -> HandlerFor site b
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse (Markup -> HandlerFor site b)
-> HandlerFor site Markup -> HandlerFor site b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< WidgetFor site () -> HandlerFor site Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout [whamlet|
        <h2>Add transaction
        <div .row style="margin-top:1em">
          <form#addform.form.col-xs-12.col-md-8 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
  Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Capability
CapAdd Capability -> [Capability] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Capability]
caps) (Text -> Handler ()
forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied Text
"Missing the 'add' capability")

  (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 FilePath
err -> Status -> FilePath -> Handler RepJson
forall (m :: * -> *) c a.
(MonadHandler m, ToJSON c) =>
Status -> c -> m a
sendStatusJSON Status
status400 (FilePath
"could not parse json: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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 (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