diff --git a/Network/Wai/Logger/Apache.hs b/Network/Wai/Logger/Apache.hs --- a/Network/Wai/Logger/Apache.hs +++ b/Network/Wai/Logger/Apache.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} +{-# LANGUAGE OverloadedStrings, CPP, TupleSections #-} module Network.Wai.Logger.Apache ( IPAddrSource(..) @@ -18,7 +18,7 @@ import Data.List (find) import Data.Maybe (fromMaybe) #if MIN_VERSION_base(4,5,0) -import Data.Monoid ((<>)) +import Data.Monoid ((<>), First (..)) #else import Data.Monoid (mappend) #endif @@ -36,12 +36,30 @@ data IPAddrSource = -- | From the peer address of the HTTP connection. FromSocket - -- | From X-Real-IP: or X-Forwarded-For: in the HTTP header. + -- | From @X-Real-IP@ or @X-Forwarded-For@ in the HTTP header. + -- + -- This picks either @X-Real-IP@ or @X-Forwarded-For@ depending on which of these + -- headers comes first in the ordered list of request headers. + -- + -- If the @X-Forwarded-For@ header is picked, the value will be assumed to be a + -- comma-separated list of IP addresses. The value will be parsed, and the + -- left-most IP address will be used (which is mostly likely to be the actual + -- client IP address). | FromHeader -- | From a custom HTTP header, useful in proxied environment. + -- + -- The header value will be assumed to be a comma-separated list of IP + -- addresses. The value will be parsed, and the left-most IP address will be + -- used (which is mostly likely to be the actual client IP address). + -- + -- Note that this still works as expected for a single IP address. | FromHeaderCustom [HeaderName] - -- | From the peer address if header is not found. + -- | Just like 'FromHeader', but falls back on the peer address if header is not found. | FromFallback + -- | This gives you the most flexibility to figure out the IP source address + -- from the 'Request'. The returned 'ByteString' is used as the IP source + -- address. + | FromRequest (Request -> ByteString) -- | Apache style log format. apacheLogStr :: ToLogStr user => IPAddrSource -> (Request -> Maybe user) -> FormattedTime -> Request -> Status -> Maybe Integer -> LogStr @@ -107,13 +125,12 @@ mua = lookup "user-agent" $ requestHeaders req #endif --- getSourceIP = getSourceIP fromString fromByteString - getSourceIP :: IPAddrSource -> Request -> ByteString getSourceIP FromSocket = getSourceFromSocket getSourceIP FromHeader = getSourceFromHeader getSourceIP FromFallback = getSourceFromFallback getSourceIP (FromHeaderCustom hs) = fromMaybe "-" . getSourceFromHeaderCustom hs +getSourceIP (FromRequest fromReq) = fromReq -- | -- >>> getSourceFromSocket defaultRequest @@ -130,6 +147,20 @@ -- "-" -- >>> getSourceFromHeader defaultRequest { requestHeaders = [] } -- "-" +-- +-- 'getSourceFromHeader' uses the first instance of either @"X-Real-IP"@ or +-- @"X-Forwarded-For"@ that it finds in the ordered header list: +-- +-- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Real-IP", "1.2.3.4"), ("X-Forwarded-For", "5.6.7.8") ] } +-- "1.2.3.4" +-- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8"), ("X-Real-IP", "1.2.3.4") ] } +-- "5.6.7.8" +-- +-- 'getSourceFromHeader' handles pulling out the first IP in the +-- comma-separated IP list in X-Forwarded-For: +-- +-- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8, 10.11.12.13, 1.2.3.4") ] } +-- "5.6.7.8" getSourceFromHeader :: Request -> ByteString getSourceFromHeader = fromMaybe "-" . getSource @@ -142,6 +173,20 @@ -- "0.0.0.0" -- >>> getSourceFromFallback defaultRequest { requestHeaders = [] } -- "0.0.0.0" +-- +-- 'getSourceFromFallback' uses the first instance of either @"X-Real-IP"@ or +-- @"X-Forwarded-For"@ that it finds in the ordered header list: +-- +-- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Real-IP", "1.2.3.4"), ("X-Forwarded-For", "5.6.7.8") ] } +-- "1.2.3.4" +-- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8"), ("X-Real-IP", "1.2.3.4") ] } +-- "5.6.7.8" +-- +-- 'getSourceFromFallback' handles pulling out the first IP in the +-- comma-separated IP list in X-Forwarded-For: +-- +-- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8, 10.11.12.13, 1.2.3.4") ] } +-- "5.6.7.8" getSourceFromFallback :: Request -> ByteString getSourceFromFallback req = fromMaybe (getSourceFromSocket req) $ getSource req @@ -154,15 +199,73 @@ -- Nothing -- >>> getSource defaultRequest -- Nothing +-- +-- 'getSource' uses the first instance of either @"X-Real-IP"@ or +-- @"X-Forwarded-For"@ that it finds in the ordered header list: +-- +-- >>> getSource defaultRequest { requestHeaders = [ ("X-Real-IP", "1.2.3.4"), ("X-Forwarded-For", "5.6.7.8") ] } +-- Just "1.2.3.4" +-- >>> getSource defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8"), ("X-Real-IP", "1.2.3.4") ] } +-- Just "5.6.7.8" +-- +-- 'getSource' handles pulling out the first IP in the comma-separated IP list +-- in X-Forwarded-For: +-- +-- >>> getSource defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8, 10.11.12.13, 1.2.3.4") ] } +-- Just "5.6.7.8" getSource :: Request -> Maybe ByteString -getSource = getSourceFromHeaders ["x-real-ip", "x-forwarded-for"] +getSource = getSourceFromHeaders [("x-real-ip", id), ("x-forwarded-for", firstIpInXFF)] -getSourceFromHeaders :: [HeaderName] -> Request -> Maybe ByteString -getSourceFromHeaders headerNames req = addr +-- | Pull out the first IP in a comma-separated list of X-Forwarded-For IPs. +-- +-- >>> firstIpInXFF "1.2.3.4, 5.6.7.8, 10.11.12.13" +-- "1.2.3.4" +-- +-- If there are no commas, just return the whole input ByteString: +-- +-- >>> firstIpInXFF "5.6.7.8" +-- "5.6.7.8" +-- +-- Note that this function doesn't make sure the input is actually an IP address: +-- +-- >>> firstIpInXFF "hello, world" +-- "hello" +firstIpInXFF :: ByteString -> ByteString +firstIpInXFF = BS.takeWhile (/= ',') + +getSourceFromHeaders :: [(HeaderName, ByteString -> ByteString)] -> Request -> Maybe ByteString +getSourceFromHeaders headerNamesAndPostProc req = getFirst $ foldMap f $ requestHeaders req where - maddr = find (\(name,_) -> name `elem` headerNames) hdrs - addr = fmap snd maddr - hdrs = requestHeaders req + -- Take a header name and value from the request, and try match it against + -- the list of headers and post-processing functions. If it matches, + -- return the ByteString resulting from applying the post-processing function + -- to the header value. + f :: (HeaderName, ByteString) -> First ByteString + f (headerNameFromReq, headerValFromReq) = + let maybePostProc = find (\(headerNameFromPostProc, _) -> headerNameFromReq == headerNameFromPostProc) headerNamesAndPostProc + in First $ fmap (\(_, postProc) -> postProc headerValFromReq) maybePostProc +-- | +-- >>> getSourceFromHeaderCustom ["x-foobar"] defaultRequest { requestHeaders = [ ("X-catdog", "1.2.3.4"), ("X-Foobar", "5.6.7.8"), ("Other", "1.1.1.1") ] } +-- Just "5.6.7.8" +-- +-- If none of the headers in the passed-in list are in the 'Request', then return 'Nothing': +-- +-- >>> getSourceFromHeaderCustom ["x-foobar", "baz"] defaultRequest { requestHeaders = [ ("abb", "1.2.3.4"), ("xyz", "5.6.7.8") ] } +-- Nothing +-- +-- 'getSourceFromHeaderCustom' uses the first instance of any header in the +-- passed in list that it finds in the ordered header list from the request: +-- +-- >>> getSourceFromHeaderCustom ["x-foobar", "baz"] defaultRequest { requestHeaders = [ ("baz", "1.2.3.4"), ("x-foobar", "5.6.7.8") ] } +-- Just "1.2.3.4" +-- +-- 'getSourceFromHeaderCustom' splits the value of the header it finds by @,@ +-- and uses the first item. This makes it easy to use with headers like +-- @X-Forwarded-For@, which are expected to have a comma-separated list of IP +-- addresses: +-- +-- >>> getSourceFromHeaderCustom ["x-foobar"] defaultRequest { requestHeaders = [ ("X-Foobar", "5.6.7.8, 10.11.12.13, 1.2.3.4") ] } +-- Just "5.6.7.8" getSourceFromHeaderCustom :: [HeaderName] -> Request -> Maybe ByteString -getSourceFromHeaderCustom hs = getSourceFromHeaders hs +getSourceFromHeaderCustom hs = getSourceFromHeaders (fmap (,firstIpInXFF) hs) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,33 +1,7 @@ -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -#warning You are configuring this package without cabal-doctest installed. \ - The doctests test-suite will not work as a result. \ - To fix this, install cabal-doctest before configuring. -#endif - import Distribution.Simple main :: IO () main = defaultMain - -#endif diff --git a/wai-logger.cabal b/wai-logger.cabal --- a/wai-logger.cabal +++ b/wai-logger.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: wai-logger -version: 2.4.1 +version: 2.5.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto