    {-# LANGUAGE OverloadedStrings, CPP #-}

    module Network.Wai.Logger.Apache (
        IPAddrSource(..)
      , apacheLogStr
      , serverpushLogStr
      ) where

    #ifndef MIN_VERSION_base
    #define MIN_VERSION_base(x,y,z) 1
    #endif
    #ifndef MIN_VERSION_wai
    #define MIN_VERSION_wai(x,y,z) 1
    #endif

    import Data.ByteString.Char8 (ByteString)
    import qualified Data.ByteString.Char8 as BS
    import Data.List (find)
    import Data.Maybe (fromMaybe)
    #if MIN_VERSION_base(4,5,0)
    import Data.Monoid ((<>))
    #else
    import Data.Monoid (mappend)
    #endif
    import Network.HTTP.Types (Status, statusCode)
    import Network.HTTP.Types.Header (HeaderName)
    import Network.Wai (Request(..))
    import Network.Wai.Logger.IP
    import System.Log.FastLogger

    -- $setup
    -- >>> :set -XOverloadedStrings
    -- >>> import Network.Wai (defaultRequest)

    -- | Source from which the IP source address of the client is obtained.
    data IPAddrSource =
      -- | From the peer address of the HTTP connection.
        FromSocket
      -- | From X-Real-IP: or X-Forwarded-For: in the HTTP header.
      | FromHeader
      -- | From a custom HTTP header, useful in proxied environment.
      | FromHeaderCustom [HeaderName]
      -- | From the peer address if header is not found.
      | FromFallback

    -- | Apache style log format.
    apacheLogStr :: ToLogStr user => IPAddrSource -> (Request -> Maybe user) -> FormattedTime -> Request -> Status -> Maybe Integer -> LogStr
    apacheLogStr :: forall user.
    ToLogStr user =>
    IPAddrSource
    -> (Request -> Maybe user)
    -> ByteString
    -> Request
    -> Status
    -> Maybe Integer
    -> LogStr
    apacheLogStr IPAddrSource
    ipsrc Request -> Maybe user
    userget ByteString
    tmstr Request
    req Status
    status Maybe Integer
    msize =
          ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (IPAddrSource -> Request -> ByteString
    getSourceIP IPAddrSource
    ipsrc Request
    req)
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    " - "
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr -> (user -> LogStr) -> Maybe user -> LogStr
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe LogStr
    "-" user -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (Request -> Maybe user
    userget Request
    req)
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    " ["
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr ByteString
    tmstr
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    "] \""
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (Request -> ByteString
    requestMethod Request
    req)
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    " "
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr ByteString
    path
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    " "
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> String -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (HttpVersion -> String
    forall a. Show a => a -> String
    show (Request -> HttpVersion
    httpVersion Request
    req))
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    "\" "
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> String -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (Int -> String
    forall a. Show a => a -> String
    show (Status -> Int
    statusCode Status
    status))
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    " "
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> String -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (String -> (Integer -> String) -> Maybe Integer -> String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe String
    "-" Integer -> String
    forall a. Show a => a -> String
    show Maybe Integer
    msize)
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    " \""
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe ByteString
    "" Maybe ByteString
    mr)
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    "\" \""
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe ByteString
    "" Maybe ByteString
    mua)
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    "\"\n"
      where
        path :: ByteString
    path = Request -> ByteString
    rawPathInfo Request
    req ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> Request -> ByteString
    rawQueryString Request
    req
    #if !MIN_VERSION_base(4,5,0)
        (<>) = mappend
    #endif
    #if MIN_VERSION_wai(3,2,0)
        mr :: Maybe ByteString
    mr  = Request -> Maybe ByteString
    requestHeaderReferer Request
    req
        mua :: Maybe ByteString
    mua = Request -> Maybe ByteString
    requestHeaderUserAgent Request
    req
    #else
        mr  = lookup "referer" $ requestHeaders req
        mua = lookup "user-agent" $ requestHeaders req
    #endif

    -- | HTTP/2 Push log format in the Apache style.
    serverpushLogStr :: ToLogStr user => IPAddrSource -> (Request -> Maybe user) -> FormattedTime -> Request -> ByteString -> Integer -> LogStr
    serverpushLogStr :: forall user.
    ToLogStr user =>
    IPAddrSource
    -> (Request -> Maybe user)
    -> ByteString
    -> Request
    -> ByteString
    -> Integer
    -> LogStr
    serverpushLogStr IPAddrSource
    ipsrc Request -> Maybe user
    userget ByteString
    tmstr Request
    req ByteString
    path Integer
    size =
          ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (IPAddrSource -> Request -> ByteString
    getSourceIP IPAddrSource
    ipsrc Request
    req)
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    " - "
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr -> (user -> LogStr) -> Maybe user -> LogStr
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe LogStr
    "-" user -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (Request -> Maybe user
    userget Request
    req)
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    " ["
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr ByteString
    tmstr
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    "] \"PUSH "
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr ByteString
    path
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    " HTTP/2\" 200 "
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> String -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (Integer -> String
    forall a. Show a => a -> String
    show Integer
    size)
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    " \""
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr ByteString
    ref
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    "\" \""
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr (ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe ByteString
    "" Maybe ByteString
    mua)
      LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    "\"\n"
      where
        ref :: ByteString
    ref  = Request -> ByteString
    rawPathInfo Request
    req
    #if !MIN_VERSION_base(4,5,0)
        (<>) = mappend
    #endif
    #if MIN_VERSION_wai(3,2,0)
        mua :: Maybe ByteString
    mua = Request -> Maybe ByteString
    requestHeaderUserAgent Request
    req
    #else
        mua = lookup "user-agent" $ requestHeaders req
    #endif

    -- getSourceIP = getSourceIP fromString fromByteString

    getSourceIP :: IPAddrSource -> Request -> ByteString
    getSourceIP :: IPAddrSource -> Request -> ByteString
    getSourceIP IPAddrSource
    FromSocket = Request -> ByteString
    getSourceFromSocket
    getSourceIP IPAddrSource
    FromHeader = Request -> ByteString
    getSourceFromHeader
    getSourceIP IPAddrSource
    FromFallback = Request -> ByteString
    getSourceFromFallback
    getSourceIP (FromHeaderCustom [HeaderName]
    hs) = ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe ByteString
    "-" (Maybe ByteString -> ByteString)
    -> (Request -> Maybe ByteString) -> Request -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [HeaderName] -> Request -> Maybe ByteString
    getSourceFromHeaderCustom [HeaderName]
    hs

    -- |
    -- >>> getSourceFromSocket defaultRequest
    -- "0.0.0.0"
    getSourceFromSocket :: Request -> ByteString
    getSourceFromSocket :: Request -> ByteString
    getSourceFromSocket = String -> ByteString
    BS.pack (String -> ByteString)
    -> (Request -> String) -> Request -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SockAddr -> String
    showSockAddr (SockAddr -> String) -> (Request -> SockAddr) -> Request -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Request -> SockAddr
    remoteHost

    -- |
    -- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Real-IP", "127.0.0.1") ] }
    -- "127.0.0.1"
    -- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Forwarded-For", "127.0.0.1") ] }
    -- "127.0.0.1"
    -- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("Something", "127.0.0.1") ] }
    -- "-"
    -- >>> getSourceFromHeader defaultRequest { requestHeaders = [] }
    -- "-"
    getSourceFromHeader :: Request -> ByteString
    getSourceFromHeader :: Request -> ByteString
    getSourceFromHeader = ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe ByteString
    "-" (Maybe ByteString -> ByteString)
    -> (Request -> Maybe ByteString) -> Request -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Request -> Maybe ByteString
    getSource

    -- |
    -- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Real-IP", "127.0.0.1") ] }
    -- "127.0.0.1"
    -- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Forwarded-For", "127.0.0.1") ] }
    -- "127.0.0.1"
    -- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("Something", "127.0.0.1") ] }
    -- "0.0.0.0"
    -- >>> getSourceFromFallback defaultRequest { requestHeaders = [] }
    -- "0.0.0.0"
    getSourceFromFallback :: Request -> ByteString
    getSourceFromFallback :: Request -> ByteString
    getSourceFromFallback Request
    req = ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe (Request -> ByteString
    getSourceFromSocket Request
    req) (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Request -> Maybe ByteString
    getSource Request
    req

    -- |
    -- >>> getSource defaultRequest { requestHeaders = [ ("X-Real-IP", "127.0.0.1") ] }
    -- Just "127.0.0.1"
    -- >>> getSource defaultRequest { requestHeaders = [ ("X-Forwarded-For", "127.0.0.1") ] }
    -- Just "127.0.0.1"
    -- >>> getSource defaultRequest { requestHeaders = [ ("Something", "127.0.0.1") ] }
    -- Nothing
    -- >>> getSource defaultRequest
    -- Nothing
    getSource :: Request -> Maybe ByteString
    getSource :: Request -> Maybe ByteString
    getSource = [HeaderName] -> Request -> Maybe ByteString
    getSourceFromHeaders [HeaderName
    "x-real-ip", HeaderName
    "x-forwarded-for"]

    getSourceFromHeaders :: [HeaderName] -> Request -> Maybe ByteString
    getSourceFromHeaders :: [HeaderName] -> Request -> Maybe ByteString
    getSourceFromHeaders [HeaderName]
    headerNames Request
    req = Maybe ByteString
    addr
      where
        maddr :: Maybe (HeaderName, ByteString)
    maddr = ((HeaderName, ByteString) -> Bool)
    -> [(HeaderName, ByteString)] -> Maybe (HeaderName, ByteString)
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    find (\(HeaderName
    name,ByteString
    _) -> HeaderName
    name HeaderName -> [HeaderName] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [HeaderName]
    headerNames) [(HeaderName, ByteString)]
    hdrs
        addr :: Maybe ByteString
    addr = ((HeaderName, ByteString) -> ByteString)
    -> Maybe (HeaderName, ByteString) -> Maybe ByteString
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (HeaderName, ByteString) -> ByteString
    forall a b. (a, b) -> b
    snd Maybe (HeaderName, ByteString)
    maddr
        hdrs :: [(HeaderName, ByteString)]
    hdrs = Request -> [(HeaderName, ByteString)]
    requestHeaders Request
    req

    getSourceFromHeaderCustom :: [HeaderName] -> Request -> Maybe ByteString
    getSourceFromHeaderCustom :: [HeaderName] -> Request -> Maybe ByteString
    getSourceFromHeaderCustom [HeaderName]
    hs = [HeaderName] -> Request -> Maybe ByteString
    getSourceFromHeaders [HeaderName]
    hs