{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | This module provides facilities for patching incoming 'Requests' to -- correct the value of 'rqClientAddr' if the snap server is running behind a -- proxy. -- -- Example usage: -- -- @ -- m :: Snap () -- m = undefined -- code goes here -- -- applicationHandler :: Snap () -- applicationHandler = behindProxy X_Forwarded_For m -- @ -- module Snap.Util.Proxy ( ProxyType(..) , behindProxy ) where ------------------------------------------------------------------------------ import Control.Applicative (Alternative ((<|>))) import Control.Monad (mfilter) import qualified Data.ByteString.Char8 as S (breakEnd, dropWhile, null, readInt, spanEnd) import Data.Char (isSpace) import Data.Maybe (fromMaybe) import Snap.Core (MonadSnap, Request (rqClientAddr, rqClientPort), getHeader, modifyRequest) ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | What kind of proxy is this? Affects which headers 'behindProxy' pulls the -- original remote address from. -- -- Currently only proxy servers that send @X-Forwarded-For@ or @Forwarded-For@ -- are supported. data ProxyType = NoProxy -- ^ no proxy, leave the request alone | X_Forwarded_For -- ^ Use the @Forwarded-For@ or -- @X-Forwarded-For@ header deriving (Read, Show, Eq, Ord) ------------------------------------------------------------------------------ -- | Rewrite 'rqClientAddr' if we're behind a proxy. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> import qualified "Snap.Test" as T -- ghci> let r = T.get \"\/foo\" M.empty >> T.addHeader \"X-Forwarded-For\" \"1.2.3.4\" -- ghci> let h = 'Snap.Core.getsRequest' 'rqClientAddr' >>= 'Snap.Core.writeBS') -- ghci> T.runHandler r h -- HTTP\/1.1 200 OK -- server: Snap\/test -- date: Fri, 08 Aug 2014 14:32:29 GMT -- -- 127.0.0.1 -- ghci> T.runHandler r ('behindProxy' 'X_Forwarded_For' h) -- HTTP\/1.1 200 OK -- server: Snap\/test -- date: Fri, 08 Aug 2014 14:33:02 GMT -- -- 1.2.3.4 -- @ behindProxy :: MonadSnap m => ProxyType -> m a -> m a behindProxy NoProxy = id behindProxy X_Forwarded_For = ((modifyRequest xForwardedFor) >>) {-# INLINE behindProxy #-} ------------------------------------------------------------------------------ xForwardedFor :: Request -> Request xForwardedFor req = req { rqClientAddr = ip , rqClientPort = port } where extract = fst . S.spanEnd isSpace . S.dropWhile isSpace . snd . S.breakEnd (== ',') ip = fromMaybe (rqClientAddr req) $ mfilter (not . S.null) $ fmap extract $ getHeader "Forwarded-For" req <|> getHeader "X-Forwarded-For" req port = maybe (rqClientPort req) fst $ (S.readInt =<<) $ fmap extract $ getHeader "Forwarded-Port" req <|> getHeader "X-Forwarded-Port" req {-# INLINE xForwardedFor #-}