{-# 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 :: String -> Text -> Form Text editForm String f Text txt = 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" forall a b. (a -> b) -> a -> b $ \Html extra -> do (FormResult Textarea tRes, FieldView (HandlerSite Handler) tView) <- 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 forall (m :: * -> *). (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Textarea textareaField forall {master}. FieldSettings master fs (forall a. a -> Maybe a Just (Text -> Textarea Textarea Text txt)) forall (f :: * -> *) a. Applicative f => a -> f a pure (Textarea -> Text unTextarea forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> FormResult Textarea tRes, $(widgetFile "edit-form")) where fs :: FieldSettings master fs = forall master. SomeMessage master -> Maybe (SomeMessage master) -> Maybe Text -> Maybe Text -> [(Text, Text)] -> FieldSettings master FieldSettings SomeMessage master "text" forall (m :: * -> *) a. MonadPlus m => m a mzero forall (m :: * -> *) a. MonadPlus m => m a mzero forall (m :: * -> *) a. MonadPlus m => m a mzero [(Text "class", Text "form-control"), (Text "rows", Text "25")] getEditR :: FilePath -> Handler () getEditR :: String -> Handler () getEditR String f = do Handler () checkServerSideUiEnabled String -> Handler () postEditR String f postEditR :: FilePath -> Handler () postEditR :: String -> Handler () postEditR String f = do Handler () checkServerSideUiEnabled VD {[Capability] caps :: ViewData -> [Capability] caps :: [Capability] caps, Journal j :: ViewData -> Journal j :: Journal j} <- Handler ViewData getViewData forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Capability CapManage 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 'manage' capability") (String f', Text txt) <- forall m. String -> Journal -> HandlerFor m (String, Text) journalFile404 String f Journal j ((FormResult Text 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 (String -> Text -> Form Text editForm String f' Text txt) Text newtxt <- forall (m :: * -> *) a. Applicative m => m a -> FormResult a -> m a fromFormSuccess (forall {site} {a} {a} {c}. (Yesod site, ToMarkup a, ToWidget site a) => a -> a -> HandlerFor site c showForm Widget view Enctype enctype) FormResult Text res forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a) runExceptT (forall (m :: * -> *). MonadHandler m => String -> Text -> ExceptT String m () writeJournalTextIfValidAndChanged String f Text newtxt) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Left String e -> do forall (m :: * -> *). MonadHandler m => Html -> m () setMessage forall a b. (a -> b) -> a -> b $ Html "Failed to load journal: " forall a. Semigroup a => a -> a -> a <> forall a. ToMarkup a => a -> Html toHtml String e forall {site} {a} {a} {c}. (Yesod site, ToMarkup a, ToWidget site a) => a -> a -> HandlerFor site c showForm Widget view Enctype enctype Right () -> do forall (m :: * -> *). MonadHandler m => Html -> m () setMessage forall a b. (a -> b) -> a -> b $ Html "Saved journal " forall a. Semigroup a => a -> a -> a <> forall a. ToMarkup a => a -> Html toHtml String f forall a. Semigroup a => a -> a -> a <> Html "\n" 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 = forall (m :: * -> *) c a. (MonadHandler m, ToTypedContent c) => c -> m a sendResponse forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< forall site. Yesod site => WidgetFor site () -> HandlerFor site Html defaultLayout forall a b. (a -> b) -> a -> b $ do forall (m :: * -> *). MonadWidget m => Html -> m () setTitle Html "Edit journal" [whamlet|<form method=post enctype=#{enctype}>^{view}|]