Take out SnapletHeist

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

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
 -------------------------------------------------------------------------------
 
 
@@ -115,6 +118,23 @@ readMayParam k = do
   return $ readMay . B.unpack =<< p
 
 
+------------------------------------------------------------------------------
+-- | 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.

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') ]
 

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

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