{-# 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