module Snap.Utils.TargetPage where
import Control.Applicative ((<$>))
import Control.Monad.Trans (lift)
import Data.Monoid (mempty)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Heist (HeistConfig (..))
import Heist.Compiled (yieldRuntimeText)
import Heist.Interpreted (textSplice)
import Heist.SpliceAPI (( #! ))
import Network.HTTP.Types (urlDecode, urlEncode)
import Snap.Core (MonadSnap, getParam, getRequest, redirect,
rqURI)
import Snap.Snaplet (Initializer, Snaplet)
import Snap.Snaplet.Heist (HasHeist, Heist, SnapletCSplice,
SnapletISplice, addConfig)
import Snap.Utils.Alert (AlertType (..), alertRedirect')
import Snap.Utils.Types (URL)
deferFromTargetPage :: MonadSnap m => Text -> URL -> m a
deferFromTargetPage msg interimUrl =
deferFromTargetPage' msg interimUrl =<< rqURI <$> getRequest
deferFromTargetPage' :: MonadSnap m => Text -> URL -> URL -> m a
deferFromTargetPage' msg interimUrl targetUrl =
alertRedirect' Warning msg interimUrl . (:[]) . ("target-page",) $
urlEncode True targetUrl
continueToTargetPage :: MonadSnap m => m a -> m a
continueToTargetPage noTargetPage =
getParam "target-page" >>= maybe noTargetPage hasTargetPage
where hasTargetPage = redirect . urlDecode True
addTargetPageSplice :: HasHeist b => Snaplet (Heist b) -> Initializer b v ()
addTargetPageSplice h = addConfig h $ mempty
{ hcCompiledSplices = ("target-page" #! targetPageCSplice)
, hcInterpretedSplices = ("target-page" #! targetPageISplice)
}
targetPageISplice :: SnapletISplice b
targetPageISplice = do
targetPage <- getParam "target-page"
textSplice $ maybe "" (T.append "target-page=" . T.decodeUtf8) targetPage
targetPageCSplice :: SnapletCSplice b
targetPageCSplice = return . yieldRuntimeText . lift $ do
targetPage <- getParam "target-page"
return $ maybe "" (T.append "target-page=" . T.decodeUtf8) targetPage