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..301ca8939 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 @@ -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..c90238b0e 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -257,7 +257,7 @@ 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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index e78d86214..77065cfaf 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -587,5 +587,9 @@ 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 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..724850167 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,5 +1,7 @@ module Utils.Message ( MessageClass(..) + , UnknownMessageClass(..) + , Message(..) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget ) where @@ -17,6 +19,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,6 +37,35 @@ deriveJSON defaultOptions nullaryPathPiece ''MessageClass camelToPathPiece derivePersistField "MessageClass" +data UnknownMessageClass = UnknownMessageClass !Text + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +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) diff --git a/templates/standalone/modal.julius b/templates/standalone/modal.julius index 61760f730..5ca78ae33 100644 --- a/templates/standalone/modal.julius +++ b/templates/standalone/modal.julius @@ -59,17 +59,14 @@ if ('dynamic' in modal.dataset) { var dynamicContentURL = trigger.getAttribute('href'); - var i = dynamicContentURL.indexOf('?'); - if (i === -1) { - dynamicContentURL = dynamicContentURL + "?" + #{String modalParameter}; - } else { - dynamicContentURL = dynamicContentURL.slice(0,i) + "?" + #{String modalParameter} + "&" + dynamicContentURL.slice(i + 1); - } console.log(dynamicContentURL); if (dynamicContentURL.length > 0) { fetch(dynamicContentURL, { credentials: 'same-origin', + headers: { + #{String (toPathPiece HeaderIsModal)}: 'True' + } }).then(function(response) { return response.text(); }).then(function(body) {