diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index c90238b0e..430583bf8 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -261,27 +261,20 @@ postHelpR = do ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid - case res of - FormSuccess HelpForm{..} -> do - now <- liftIO getCurrentTime - hfReferer' <- traverse toTextUrl hfReferer - queueJob' JobHelpRequest - { jSender = hfUserId - , jHelpRequest = hfRequest - , jRequestTime = now - , jReferer = hfReferer' - } - -- redirect $ HelpR - addMessageI Success MsgHelpSent - return () - {-selectRep $ do - provideJson () - provideRep (redirect $ HelpR :: Handler Html) -} - FormMissing -> return () - FormFailure errs -> mapM_ (addMessage Error . toHtml) errs + formResultModal res HelpR $ \HelpForm{..} -> do + now <- liftIO getCurrentTime + hfReferer' <- traverse toTextUrl hfReferer + queueJob' JobHelpRequest + { jSender = hfUserId + , jHelpRequest = hfRequest + , jRequestTime = now + , jReferer = hfReferer' + } + tell . pure =<< messageI Success MsgHelpSent defaultLayout $ do setTitle "Hilfe" -- TODO: International + isModal <- hasCustomHeader HeaderIsModal $(widgetFile "help") diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 77065cfaf..32a1d28d9 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1,6 +1,7 @@ module Handler.Utils.Form ( module Handler.Utils.Form , module Utils.Form + , MonadWriter(..) ) where import Utils.Form @@ -35,6 +36,7 @@ import qualified Data.Set as Set import Data.Map (Map, (!)) import qualified Data.Map as Map +import Control.Monad.Trans.Writer (execWriterT, WriterT) import Control.Monad.Writer.Class import Data.Scientific (Scientific) @@ -587,9 +589,16 @@ multiActionA FieldSettings{..} acts defAction = formToAForm $ do } ]) -formResultModal :: MonadHandler m => FormResult a -> (a -> m ()) -> m () -formResultModal res handler = do - formResult res handler - whenM (hasCustomHeader HeaderIsModal) $ do - messages <- mapM (\(cl, co) -> maybe (throwM $ UnknownMessageClass cl) (return . flip Message co) $ fromPathPiece cl) =<< getMessages - sendResponse $ toJSON messages +formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () +formResultModal res finalDest handler = maybeT_ $ do + messages <- case res of + FormMissing -> mzero + FormFailure errs -> return $ map (Message Error . toHtml) errs + FormSuccess val -> lift . execWriterT $ handler val + + isModal <- hasCustomHeader HeaderIsModal + if + | isModal -> sendResponse $ toJSON messages + | otherwise -> do + forM_ messages $ \Message{..} -> addMessage messageClass messageContent + redirect finalDest diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 724850167..2d819bc32 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,8 +1,9 @@ module Utils.Message ( MessageClass(..) , UnknownMessageClass(..) - , Message(..) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget + , Message(..) + , messageI, messageIHamlet, messageFile, messageWidget ) where @@ -67,12 +68,17 @@ instance FromJSON Message where return Message{..} -addMessage :: MonadHandler m => MessageClass-> Html -> m () +addMessage :: MonadHandler m => MessageClass -> Html -> m () addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc) addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m () addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc) +messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m Message +messageI messageClass msg = do + messageContent <- toHtml . ($ msg) <$> getMessageRender + return Message{..} + addMessageIHamlet :: ( MonadHandler m , RenderMessage (HandlerSite m) msg , HandlerSite m ~ site @@ -81,9 +87,20 @@ addMessageIHamlet mc iHamlet = do mr <- getMessageRender ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) +messageIHamlet :: ( MonadHandler m + , RenderMessage (HandlerSite m) msg + , HandlerSite m ~ site + ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m Message +messageIHamlet mc iHamlet = do + mr <- getMessageRender + Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr) + addMessageFile :: MessageClass -> FilePath -> ExpQ addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] +messageFile :: MessageClass -> FilePath -> ExpQ +messageFile mc tPath = [e|messageIHamlet mc $(ihamletFile tPath)|] + addMessageWidget :: forall m site. ( MonadHandler m , HandlerSite m ~ site @@ -93,3 +110,12 @@ addMessageWidget :: forall m site. addMessageWidget mc wgt = do PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site)) + +messageWidget :: forall m site. + ( MonadHandler m + , HandlerSite m ~ site + , Yesod site + ) => MessageClass -> WidgetT site IO () -> m Message +messageWidget mc wgt = do + PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt + messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site)) diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 9cae5ae39..c889c20b8 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -28,7 +28,7 @@ $if not isModal ^{pageactionprime} -