diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for wai-extra +## 3.1.5 + +* `Network.Wai.Middleware.RealIp`: Add a new middleware to infer the remote IP address from headers [#834](https://github.com/yesodweb/wai/pull/834) + ## 3.1.4.1 * `Network.Wai.Middleware.Gzip`: Add `Vary: Accept-Encoding` header to responses [#829](https://github.com/yesodweb/wai/pull/829) diff --git a/Network/Wai/Middleware/RealIp.hs b/Network/Wai/Middleware/RealIp.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/RealIp.hs @@ -0,0 +1,94 @@ +-- | Infer the remote IP address using headers +module Network.Wai.Middleware.RealIp + ( realIp + , realIpHeader + , realIpTrusted + , defaultTrusted + , ipInRange + ) where + +import qualified Data.ByteString.Char8 as B8 (unpack, split) +import qualified Data.IP as IP +import Data.Maybe (fromMaybe, mapMaybe, listToMaybe) +import Network.HTTP.Types (HeaderName, RequestHeaders) +import Network.Wai +import Text.Read (readMaybe) + +-- | Infer the remote IP address from the @X-Forwarded-For@ header, +-- trusting requests from any private IP address. See 'realIpHeader' and +-- 'realIpTrusted' for more information and options. +-- +-- @since 3.1.5 +realIp :: Middleware +realIp = realIpHeader "X-Forwarded-For" + +-- | Infer the remote IP address using the given header, trusting +-- requests from any private IP address. See 'realIpTrusted' for more +-- information and options. +-- +-- @since 3.1.5 +realIpHeader :: HeaderName -> Middleware +realIpHeader header = + realIpTrusted header $ \ip -> any (ipInRange ip) defaultTrusted + +-- | Infer the remote IP address using the given header, but only if the +-- request came from an IP that is trusted by the provided predicate. +-- +-- The last non-trusted address is used to replace the 'remoteHost' in +-- the 'Request', unless all present IP addresses are trusted, in which +-- case the first address is used. Invalid IP addresses are ignored, and +-- the remoteHost value remains unaltered if no valid IP addresses are +-- found. +-- +-- Examples: +-- +-- @ realIpTrusted "X-Forwarded-For" $ flip ipInRange "10.0.0.0/8" @ +-- +-- @ realIpTrusted "X-Real-Ip" $ \\ip -> any (ipInRange ip) defaultTrusted @ +-- +-- @since 3.1.5 +realIpTrusted :: HeaderName -> (IP.IP -> Bool) -> Middleware +realIpTrusted header isTrusted app req respond = app req' respond + where + req' = fromMaybe req $ do + (ip, port) <- IP.fromSockAddr (remoteHost req) + ip' <- if isTrusted ip + then findRealIp (requestHeaders req) header isTrusted + else Nothing + Just $ req { remoteHost = IP.toSockAddr (ip', port) } + +-- | Standard private IP ranges. +-- +-- @since 3.1.5 +defaultTrusted :: [IP.IPRange] +defaultTrusted = [ "127.0.0.0/8" + , "10.0.0.0/8" + , "172.16.0.0/12" + , "192.168.0.0/16" + , "::1/128" + , "fc00::/7" + ] + +-- | Check if the given IP address is in the given range. +-- +-- IPv4 addresses can be checked against IPv6 ranges, but testing an +-- IPv6 address against an IPv4 range is always 'False'. +-- +-- @since 3.1.5 +ipInRange :: IP.IP -> IP.IPRange -> Bool +ipInRange (IP.IPv4 ip) (IP.IPv4Range r) = ip `IP.isMatchedTo` r +ipInRange (IP.IPv6 ip) (IP.IPv6Range r) = ip `IP.isMatchedTo` r +ipInRange (IP.IPv4 ip) (IP.IPv6Range r) = IP.ipv4ToIPv6 ip `IP.isMatchedTo` r +ipInRange _ _ = False + + +findRealIp :: RequestHeaders -> HeaderName -> (IP.IP -> Bool) -> Maybe IP.IP +findRealIp reqHeaders header isTrusted = + case (nonTrusted, ips) of + ([], xs) -> listToMaybe xs + (xs, _) -> listToMaybe $ reverse xs + where + -- account for repeated headers + headerVals = [ v | (k, v) <- reqHeaders, k == header ] + ips = mapMaybe (readMaybe . B8.unpack) $ concatMap (B8.split ',') headerVals + nonTrusted = filter (not . isTrusted) ips diff --git a/test/Network/Wai/Middleware/RealIpSpec.hs b/test/Network/Wai/Middleware/RealIpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/RealIpSpec.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.Middleware.RealIpSpec + ( spec + ) where + +import Test.Hspec + +import qualified Data.ByteString.Lazy.Char8 as B8 +import qualified Data.IP as IP +import Network.HTTP.Types (status200, RequestHeaders) +import Network.Wai +import Network.Wai.Middleware.RealIp +import Network.Wai.Test + +spec :: Spec +spec = do + describe "realIp" $ do + it "does nothing when header is missing" $ do + resp <- runApp "127.0.0.1" [] realIp + simpleBody resp `shouldBe` "127.0.0.1" + + it "uses X-Forwarded-For when present" $ do + let headers = [("X-Forwarded-For", "1.1.1.1")] + resp <- runApp "127.0.0.1" headers realIp + simpleBody resp `shouldBe` "1.1.1.1" + + it "ignores X-Forwarded-For from non-trusted ip" $ do + let headers = [("X-Forwarded-For", "1.1.1.1")] + resp <- runApp "1.2.3.4" headers realIp + simpleBody resp `shouldBe` "1.2.3.4" + + it "ignores trusted ip addresses in X-Forwarded-For" $ do + let headers = [("X-Forwarded-For", "1.1.1.1, 10.0.0.1")] + resp <- runApp "127.0.0.1" headers realIp + simpleBody resp `shouldBe` "1.1.1.1" + + it "ignores invalid ip addresses" $ do + let headers1 = [("X-Forwarded-For", "1.1.1")] + resp1 <- runApp "127.0.0.1" headers1 realIp + let headers2 = [("X-Forwarded-For", "1.1.1.1,foo")] + resp2 <- runApp "127.0.0.1" headers2 realIp + + simpleBody resp1 `shouldBe` "127.0.0.1" + simpleBody resp2 `shouldBe` "1.1.1.1" + + it "takes the last non-trusted address" $ do + let headers = [("X-Forwarded-For", "1.1.1.1, 2.2.2.2, 10.0.0.1")] + resp <- runApp "127.0.0.1" headers realIp + simpleBody resp `shouldBe` "2.2.2.2" + + it "takes the first address when all are trusted" $ do + let headers = [("X-Forwarded-For", "192.168.0.1, 10.0.0.2, 10.0.0.1")] + resp <- runApp "127.0.0.1" headers realIp + simpleBody resp `shouldBe` "192.168.0.1" + + it "handles repeated headers" $ do + let headers = [("X-Forwarded-For", "1.1.1.1"), ("X-Forwarded-For", "2.2.2.2")] + resp <- runApp "127.0.0.1" headers realIp + simpleBody resp `shouldBe` "2.2.2.2" + + it "handles ipv6 addresses" $ do + let headers = [("X-Forwarded-For", "2001:db8::ff00:42:8329,10.0.0.1")] + resp <- runApp "::1" headers realIp + simpleBody resp `shouldBe` "2001:db8::ff00:42:8329" + + describe "realIpHeader" $ do + it "uses specified header" $ do + let headers = [("X-Forwarded-For", "1.1.1.1"), ("X-Real-Ip", "2.2.2.2")] + resp <- runApp "127.0.0.1" headers $ realIpHeader "X-Real-Ip" + simpleBody resp `shouldBe` "2.2.2.2" + + describe "realIpTrusted" $ do + it "uses provided trusted predicate" $ do + let headers = [("X-Forwarded-For", "10.0.0.1, 1.1.1.1")] + isTrusted1 ip = any (ipInRange ip) ["127.0.0.1/32", "1.1.1.1/32"] + isTrusted2 = flip ipInRange "1.1.1.1/32" + + resp1 <- runApp "127.0.0.1" headers $ realIpTrusted "X-Forwarded-For" isTrusted1 + resp2 <- runApp "10.0.0.2" headers $ realIpTrusted "X-Forwarded-For" isTrusted2 + + simpleBody resp1 `shouldBe` "10.0.0.1" + simpleBody resp2 `shouldBe` "10.0.0.2" + + +runApp :: IP.IP -> RequestHeaders -> Middleware -> IO SResponse +runApp ip hs mw = runSession + (request defaultRequest { remoteHost = IP.toSockAddr (ip, 80), requestHeaders = hs }) $ mw app + where + app req respond = respond $ responseLBS status200 [] $ renderIp req + renderIp = B8.pack . maybe "" (show . fst) . IP.fromSockAddr . remoteHost diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -1,5 +1,5 @@ Name: wai-extra -Version: 3.1.4.1 +Version: 3.1.5 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality: @@ -114,7 +114,7 @@ , vault , zlib , aeson - , iproute + , iproute >= 1.7.8 , http2 , HUnit , call-stack @@ -150,6 +150,7 @@ Network.Wai.Middleware.ForceSSL Network.Wai.Middleware.Routed Network.Wai.Middleware.Timeout + Network.Wai.Middleware.RealIp Network.Wai.Parse Network.Wai.Request Network.Wai.UrlMap @@ -191,6 +192,7 @@ Network.Wai.Middleware.RoutedSpec Network.Wai.Middleware.StripHeadersSpec Network.Wai.Middleware.TimeoutSpec + Network.Wai.Middleware.RealIpSpec WaiExtraSpec build-depends: base >= 4 && < 5 , wai-extra @@ -209,6 +211,7 @@ , case-insensitive , http2 , aeson + , iproute ghc-options: -Wall default-language: Haskell2010