Add refererLink splice

ozataman · Apr 3, 2013 · e9b7ad0 · e9b7ad0
1 parent 33801ee
commit e9b7ad0
Show file tree

Hide file tree

Showing 2 changed files with 13 additions and 0 deletions.
diff --git a/src/Snap/Extras/SpliceUtils/Compiled.hs b/src/Snap/Extras/SpliceUtils/Compiled.hs
@@ -19,9 +19,15 @@ import           Text.XmlHtml
 
 utilSplices :: MonadSnap m => [(Text, Splice m)]
 utilSplices = [ ("rqparam", paramSplice)
+              , ("refererLink", refererCSplice)
               ]
 
 
+refererCSplice :: MonadSnap m => Splice m
+refererCSplice = return $ yieldRuntimeText $ return .
+    maybe "/" T.decodeUtf8 =<< lift (getsRequest (getHeader "Referer"))
+
+
 ------------------------------------------------------------------------------
 -- | Gets the value of a request parameter.  Example use:
 --

diff --git a/src/Snap/Extras/SpliceUtils/Interpreted.hs b/src/Snap/Extras/SpliceUtils/Interpreted.hs
@@ -8,6 +8,7 @@ module Snap.Extras.SpliceUtils.Interpreted
     , runTextAreas
     , scriptsSplice
     , ifFlagSplice
+    , refererSplice
     ) where
 
 -------------------------------------------------------------------------------
@@ -32,9 +33,15 @@ import           Text.XmlHtml
 utilSplices :: [(Text, SnapletISplice b)]
 utilSplices =
   [ ("rqparam", paramSplice)
+  , ("refererLink", refererSplice)
   ]
 
 
+refererSplice :: MonadSnap m => Splice m
+refererSplice =
+  textSplice . maybe "/" T.decodeUtf8 =<< lift (getsRequest (getHeader "Referer"))
+
+
 ------------------------------------------------------------------------------
 -- | Gets the value of a request parameter.  Example use:
 --