Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Take out SnapletHeist

  • Loading branch information...
commit 33cc5726b0b4c7dbb4d5f3c5f8880a06dddb0bad 1 parent 5788e83
@mightybyte mightybyte authored
View
1  snap-extras.cabal
@@ -46,6 +46,7 @@ Library
, errors >= 1.3.1 && < 1.4
, filepath
, heist >= 0.10
+ , mtl >= 2.0 && < 2.2
, safe
, snap >= 0.10
, snap-core >= 0.7
View
24 src/Snap/Extras/CoreUtils.hs
@@ -14,16 +14,19 @@ module Snap.Extras.CoreUtils
, reqParam
, readParam
, readMayParam
+ , redirectReferer
+ , redirectRefererFunc
, dirify
, undirify
) where
-------------------------------------------------------------------------------
-import Snap.Core
+import Control.Monad
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
-import Control.Monad
+import Data.Maybe
import Safe
+import Snap.Core
-------------------------------------------------------------------------------
@@ -116,6 +119,23 @@ readMayParam k = do
------------------------------------------------------------------------------
+-- | Redirects back to the refering page. If there is no Referer header, then
+-- redirect to /.
+redirectReferer :: MonadSnap m => m b
+redirectReferer = redirectRefererFunc (fromMaybe "/")
+
+
+------------------------------------------------------------------------------
+-- | Redirects back to the refering page. If there is no Referer header, then
+-- redirect to /.
+redirectRefererFunc :: MonadSnap m => (Maybe ByteString -> ByteString) -> m b
+redirectRefererFunc f = do
+ req <- getRequest
+ let referer = getHeader "Referer" req
+ redirect $ f referer
+
+
+------------------------------------------------------------------------------
-- | If the current rqURI does not have a trailing slash, then redirect to the
-- same page with a slash added.
dirify :: MonadSnap m => m ()
View
13 src/Snap/Extras/FlashNotice.hs
@@ -12,6 +12,7 @@ module Snap.Extras.FlashNotice
-------------------------------------------------------------------------------
import Control.Monad
+import Control.Monad.Trans
import Data.Lens.Common
import Data.Text (Text)
import qualified Data.Text as T
@@ -64,16 +65,16 @@ flashError session msg = withSession session $ with session $ setInSession "_err
--
-- Ex: <flash type='warning'/>
-- Ex: <flash type='success'/>
-flashSplice :: Lens b (Snaplet SessionManager) -> SnapletISplice b v
+flashSplice :: Lens b (Snaplet SessionManager) -> SnapletISplice b
flashSplice session = do
- typ <- liftHeist $ liftM (getAttribute "type") getParamNode
+ typ <- liftM (getAttribute "type") getParamNode
let typ' = maybe "warning" id typ
let k = T.concat ["_", typ']
- msg <- liftHandler $ withTop session $ getFromSession k
+ msg <- lift $ withTop session $ getFromSession k
case msg of
- Nothing -> liftHeist $ return []
+ Nothing -> return []
Just msg' -> do
- liftHandler $ withTop session $ deleteFromSession k >> commitSession
- liftHeist $ callTemplateWithText "_flash"
+ lift $ withTop session $ deleteFromSession k >> commitSession
+ callTemplateWithText "_flash"
[ ("type", typ') , ("message", msg') ]
View
12 src/Snap/Extras/SpliceUtils.hs
@@ -39,9 +39,9 @@ addUtilSplices = addSplices utilSplices
-------------------------------------------------------------------------------
-- | A list of splices offered in this module
-utilSplices :: [(Text, SnapletISplice b v)]
+utilSplices :: [(Text, SnapletISplice b)]
utilSplices =
- [ ("rqparam", liftHeist paramSplice)
+ [ ("rqparam", paramSplice)
]
@@ -158,11 +158,11 @@ scriptsSplice dir prefix = do
-- This will look for an entry inside your .cfg file:
--
-- > beta-functions-enabled = true
-ifFlagSplice :: SnapletISplice b v
+ifFlagSplice :: SnapletISplice b
ifFlagSplice = do
- Element t ats es <- liftHeist getParamNode
- conf <- liftHandler getSnapletUserConfig
- liftHeist $ case lookup "ref" ats of
+ Element t ats es <- getParamNode
+ conf <- lift getSnapletUserConfig
+ case lookup "ref" ats of
Nothing -> return []
Just flag -> do
res <- liftIO $ C.lookup conf flag
View
2  src/Snap/Extras/Tabs.hs
@@ -39,7 +39,7 @@ import qualified Text.XmlHtml as X
-------------------------------------------------------------------------------
initTabs :: HasHeist b => Initializer b v ()
initTabs = do
- addSplices [ ("tabs", liftHeist tabsSplice) ]
+ addSplices [ ("tabs", tabsSplice) ]
-------------------
Please sign in to comment.
Something went wrong with that request. Please try again.