Permalink
Browse files

Add actions for setting the rqRemoteAddr field based on the content o…

…f a header
  • Loading branch information...
1 parent 7384c9c commit 951b20a280150164ee615b07f71e4f8e82dbaab9 Carl Howells committed Jun 18, 2010
Showing with 23 additions and 0 deletions.
  1. +21 −0 src/Snap/Internal/Types.hs
  2. +2 −0 src/Snap/Types.hs
View
21 src/Snap/Internal/Types.hs
@@ -13,6 +13,7 @@ import Control.Monad.State.Strict
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.CIByteString as CIB
import Data.IORef
import qualified Data.Iteratee as Iter
import Data.Maybe
@@ -459,6 +460,26 @@ withResponse = (getResponse >>=)
------------------------------------------------------------------------------
+-- | Modifies the 'Request' in the state to set the 'rqRemoteAddr'
+-- field to the value in the X-Forwarded-For header. If the header is
+-- not present, this action has no effect.
+ipHeaderFilter :: Snap ()
+ipHeaderFilter = ipHeaderFilter' "x-forwarded-for"
+
+
+------------------------------------------------------------------------------
+-- | Modifies the 'Request' in the state to set the 'rqRemoteAddr'
+-- field to the value from the header specified. If the header
+-- specified is not present, this action has no effect.
+ipHeaderFilter' :: CIB.CIByteString -> Snap ()
+ipHeaderFilter' header = do
+ headerContents <- getHeader header <$> getRequest
+
+ let setIP ip = modifyRequest $ \rq -> rq { rqRemoteAddr = ip }
+ maybe (return ()) setIP headerContents
+
+
+------------------------------------------------------------------------------
-- | This exception is thrown if the handler you supply to 'runSnap' fails.
data NoHandlerException = NoHandlerException
deriving (Eq, Typeable)
View
2 src/Snap/Types.hs
@@ -57,6 +57,8 @@ module Snap.Types
, addHeader
, setHeader
, getHeader
+ , ipHeaderFilter
+ , ipHeaderFilter'
-- ** Requests
, rqServerName

0 comments on commit 951b20a

Please sign in to comment.