diff --git a/package.yaml b/package.yaml index 20a50b6c5..6c3077b78 100644 --- a/package.yaml +++ b/package.yaml @@ -108,6 +108,7 @@ dependencies: - mmorph - clientsession - monad-memo + - xss-sanitize other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Foundation.hs b/src/Foundation.hs index 71893e2b3..da72da1af 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -16,8 +16,6 @@ import Auth.PWHash import Auth.Dummy import Jobs.Types -import Handler.Utils.Templates (siteModalId, modalParameter) - import qualified Network.Wai as W (pathInfo) import Yesod.Default.Util (addStaticContentExternal) @@ -768,7 +766,7 @@ siteLayout headingOverride widget = do master <- getYesod let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master - isModal <- isJust <$> siteModalId + isModal <- hasCustomHeader HeaderIsModal mcurrentRoute <- getCurrentRoute @@ -806,7 +804,7 @@ siteLayout headingOverride widget = do return (c, courseRoute, items') mmsgs <- if - | isModal -> return [] + | isModal -> getMessages | otherwise -> do applySystemMessages authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags @@ -987,7 +985,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the { menuItemType = NavbarRight , menuItemLabel = MsgMenuHelp , menuItemIcon = Just "question" - , menuItemRoute = SomeRoute (HelpR, catMaybes [("site", ) . toPathPiece <$> mCurrentRoute]) + , menuItemRoute = SomeRoute (HelpR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mCurrentRoute]) , menuItemModal = True , menuItemAccessCallback' = return True } diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index a301af506..430583bf8 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -257,31 +257,24 @@ getHelpR, postHelpR :: Handler Html getHelpR = postHelpR postHelpR = do mUid <- maybeAuthId - mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField "site" + mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer) ((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 e78d86214..d1c9d3e4b 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,5 +589,16 @@ multiActionA FieldSettings{..} acts defAction = formToAForm $ do } ]) - - +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 -> mapM_ (addMessage Error . toHtml) errs >> mzero + 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/Handler/Utils/Templates.hs b/src/Handler/Utils/Templates.hs index ed4f0111a..14f8ce38c 100644 --- a/src/Handler/Utils/Templates.hs +++ b/src/Handler/Utils/Templates.hs @@ -7,12 +7,6 @@ import Import.NoFoundation lipsum :: WidgetT site IO () lipsum = $(widgetFile "widgets/lipsum") -modalParameter :: Text -modalParameter = "_modal" - -siteModalId :: MonadHandler m => m (Maybe Text) -siteModalId = lookupGetParam modalParameter - modal :: WidgetT site IO () -> Either (Route site) (WidgetT site IO ()) -> WidgetT site IO () modal modalTrigger modalContent = do let modalDynamic = isLeft modalContent diff --git a/src/Utils.hs b/src/Utils.hs index f51c03c23..a451eb70b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -52,6 +52,8 @@ import Text.Shakespeare.Text (st) import qualified Data.Aeson as Aeson +import Data.Universe + ----------- @@ -476,3 +478,37 @@ tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromM getSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v) -- ^ `lookupSessionJson` followed by `deleteSession` getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key) + +-------------------- +-- GET Parameters -- +-------------------- + +data GlobalGetParam = GetReferer + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe GlobalGetParam +instance Finite GlobalGetParam +nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1) + +lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result) +lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident) + +hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool +hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident) + +--------------------------------- +-- Custom HTTP Request-Headers -- +--------------------------------- + +data CustomHeader = HeaderIsModal + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe CustomHeader +instance Finite CustomHeader +nullaryPathPiece ''CustomHeader (intercalate "-" . drop 1 . splitCamel) + +lookupCustomHeader :: (MonadHandler m, PathPiece result) => CustomHeader -> m (Maybe result) +lookupCustomHeader ident = (>>= fromPathPiece . decodeUtf8) <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) + +hasCustomHeader :: MonadHandler m => CustomHeader -> m Bool +hasCustomHeader ident = isJust <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 7c806d996..7cf7f653f 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,6 +1,9 @@ module Utils.Message ( MessageClass(..) + , UnknownMessageClass(..) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget + , Message(..) + , messageI, messageIHamlet, messageFile, messageWidget ) where @@ -17,6 +20,10 @@ import Text.Hamlet import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift) +import Text.Blaze (preEscapedText) +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.HTML.SanitizeXSS (sanitizeBalance) + data MessageClass = Error | Warning | Info | Success deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift) @@ -31,13 +38,47 @@ deriveJSON defaultOptions nullaryPathPiece ''MessageClass camelToPathPiece derivePersistField "MessageClass" +newtype UnknownMessageClass = UnknownMessageClass Text + deriving (Eq, Ord, Read, Show, Generic, Typeable) -addMessage :: MonadHandler m => MessageClass-> Html -> m () +instance Exception UnknownMessageClass + + +data Message = Message + { messageClass :: MessageClass + , messageContent :: Html + } + +instance Eq Message where + a == b = ((==) `on` messageClass) a b && ((==) `on` renderHtml . messageContent) a b + +instance Ord Message where + a `compare` b = (compare `on` messageClass) a b `mappend` (compare `on` renderHtml . messageContent) a b + +instance ToJSON Message where + toJSON Message{..} = object + [ "class" .= messageClass + , "content" .= renderHtml messageContent + ] + +instance FromJSON Message where + parseJSON = withObject "Message" $ \o -> do + messageClass <- o .: "class" + messageContent <- preEscapedText . sanitizeBalance <$> o .: "content" + return Message{..} + + +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 @@ -46,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 @@ -58,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-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index b5b94d5d1..c293b607a 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -17,10 +17,4 @@ $newline never