Globally defined get parameters & headers

package.yaml

@@ -108,6 +108,7 @@ dependencies:
   - mmorph
   - clientsession
   - monad-memo
+  - xss-sanitize
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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
         }

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
 

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

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

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)

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)

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) {