{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Hledger.Web.Handler.EditR
  ( getEditR
  , postEditR
  ) where

import Control.Monad.Except (runExceptT)
import Hledger.Web.Import
import Hledger.Web.Widget.Common
       (fromFormSuccess, helplink, journalFile404, writeJournalTextIfValidAndChanged)

editForm :: FilePath -> Text -> Form Text
editForm :: FilePath -> Text -> Form Text
editForm FilePath
f Text
txt =
  Text
-> (Html
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
         Enctype
         Ints
         Handler
         (FormResult Text, WidgetFor (HandlerSite Handler) ()))
-> Html
-> RWST
     (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
     Enctype
     Ints
     Handler
     (FormResult Text, WidgetFor (HandlerSite Handler) ())
forall (m :: * -> *) a.
Monad m =>
Text
-> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
-> Html
-> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
identifyForm Text
"edit" ((Html
  -> RWST
       (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
       Enctype
       Ints
       Handler
       (FormResult Text, WidgetFor (HandlerSite Handler) ()))
 -> Html
 -> RWST
      (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
      Enctype
      Ints
      Handler
      (FormResult Text, WidgetFor (HandlerSite Handler) ()))
-> (Html
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
         Enctype
         Ints
         Handler
         (FormResult Text, WidgetFor (HandlerSite Handler) ()))
-> Html
-> RWST
     (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
     Enctype
     Ints
     Handler
     (FormResult Text, WidgetFor (HandlerSite Handler) ())
forall a b. (a -> b) -> a -> b
$ \Html
extra -> do
    (tRes, tView) <- Field Handler Textarea
-> FieldSettings (HandlerSite Handler)
-> Maybe Textarea
-> MForm
     Handler (FormResult Textarea, FieldView (HandlerSite Handler))
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field Handler Textarea
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Textarea
textareaField FieldSettings (HandlerSite Handler)
forall {master}. FieldSettings master
fs (Textarea -> Maybe Textarea
forall a. a -> Maybe a
Just (Text -> Textarea
Textarea Text
txt))
    pure (unTextarea <$> tRes, $(widgetFile "edit-form"))
  where
    fs :: FieldSettings master
fs = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"text" Maybe (SomeMessage master)
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero Maybe Text
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero Maybe Text
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero [(Text
"class", Text
"form-control"), (Text
"rows", Text
"25")]

getEditR :: FilePath -> Handler ()
getEditR :: FilePath -> Handler ()
getEditR FilePath
f = do
  Handler ()
checkServerSideUiEnabled
  FilePath -> Handler ()
postEditR FilePath
f

postEditR :: FilePath -> Handler ()
postEditR :: FilePath -> Handler ()
postEditR FilePath
f = do
  Handler ()
checkServerSideUiEnabled
  VD {j} <- Handler ViewData
getViewData
  require EditPermission

  (f', txt) <- journalFile404 f j
  ((res, view), enctype) <- runFormPost (editForm f' txt)
  newtxt <- fromFormSuccess (showForm view enctype) res
  runExceptT (writeJournalTextIfValidAndChanged f newtxt) >>= \case
    Left FilePath
e -> do
      Html -> Handler ()
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage (Html -> Handler ()) -> Html -> Handler ()
forall a b. (a -> b) -> a -> b
$ Html
"Failed to load journal: " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml FilePath
e
      Widget -> Enctype -> Handler ()
forall {site} {a} {a} {c}.
(Yesod site, ToMarkup a, ToWidget site a) =>
a -> a -> HandlerFor site c
showForm Widget
view Enctype
enctype
    Right () -> do
      Html -> Handler ()
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage (Html -> Handler ()) -> Html -> Handler ()
forall a b. (a -> b) -> a -> b
$ Html
"Saved journal " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml FilePath
f Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
"\n"
      Route App -> Handler ()
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route App
JournalR
  where
    showForm :: a -> a -> HandlerFor site c
showForm a
view a
enctype =
      Html -> HandlerFor site c
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse (Html -> HandlerFor site c)
-> (WidgetFor site () -> HandlerFor site Html)
-> WidgetFor site ()
-> HandlerFor site c
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< WidgetFor site () -> HandlerFor site Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout (WidgetFor site () -> HandlerFor site c)
-> WidgetFor site () -> HandlerFor site c
forall a b. (a -> b) -> a -> b
$ do
        Html -> WidgetFor site ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Edit journal"
        [whamlet|<form method=post enctype=#{enctype}>^{view}|]