{-# 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.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 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 :: IPAddrSource
-> (Request -> Maybe user)
-> FormattedTime
-> Request
-> Status
-> Maybe Integer
-> LogStr
apacheLogStr IPAddrSource
ipsrc Request -> Maybe user
userget FormattedTime
tmstr Request
req Status
status Maybe Integer
msize =
      FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (IPAddrSource -> Request -> FormattedTime
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
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr FormattedTime
tmstr
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] \""
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> FormattedTime
requestMethod Request
req)
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" "
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr FormattedTime
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
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (FormattedTime -> Maybe FormattedTime -> FormattedTime
forall a. a -> Maybe a -> a
fromMaybe FormattedTime
"" Maybe FormattedTime
mr)
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\" \""
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (FormattedTime -> Maybe FormattedTime -> FormattedTime
forall a. a -> Maybe a -> a
fromMaybe FormattedTime
"" Maybe FormattedTime
mua)
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\"\n"
  where
    path :: FormattedTime
path = Request -> FormattedTime
rawPathInfo Request
req FormattedTime -> FormattedTime -> FormattedTime
forall a. Semigroup a => a -> a -> a
<> Request -> FormattedTime
rawQueryString Request
req
#if !MIN_VERSION_base(4,5,0)
    (<>) = mappend
#endif
#if MIN_VERSION_wai(3,2,0)
    mr :: Maybe FormattedTime
mr  = Request -> Maybe FormattedTime
requestHeaderReferer Request
req
    mua :: Maybe FormattedTime
mua = Request -> Maybe FormattedTime
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 :: IPAddrSource
-> (Request -> Maybe user)
-> FormattedTime
-> Request
-> FormattedTime
-> Integer
-> LogStr
serverpushLogStr IPAddrSource
ipsrc Request -> Maybe user
userget FormattedTime
tmstr Request
req FormattedTime
path Integer
size =
      FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (IPAddrSource -> Request -> FormattedTime
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
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr FormattedTime
tmstr
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] \"PUSH "
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr FormattedTime
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
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr FormattedTime
ref
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\" \""
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (FormattedTime -> Maybe FormattedTime -> FormattedTime
forall a. a -> Maybe a -> a
fromMaybe FormattedTime
"" Maybe FormattedTime
mua)
  LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\"\n"
  where
    ref :: FormattedTime
ref  = Request -> FormattedTime
rawPathInfo Request
req
#if !MIN_VERSION_base(4,5,0)
    (<>) = mappend
#endif
#if MIN_VERSION_wai(3,2,0)
    mua :: Maybe FormattedTime
mua = Request -> Maybe FormattedTime
requestHeaderUserAgent Request
req
#else
    mua = lookup "user-agent" $ requestHeaders req
#endif

-- getSourceIP = getSourceIP fromString fromByteString

getSourceIP :: IPAddrSource -> Request -> ByteString
getSourceIP :: IPAddrSource -> Request -> FormattedTime
getSourceIP IPAddrSource
FromSocket   = Request -> FormattedTime
getSourceFromSocket
getSourceIP IPAddrSource
FromHeader   = Request -> FormattedTime
getSourceFromHeader
getSourceIP IPAddrSource
FromFallback = Request -> FormattedTime
getSourceFromFallback

-- |
-- >>> getSourceFromSocket defaultRequest
-- "0.0.0.0"
getSourceFromSocket :: Request -> ByteString
getSourceFromSocket :: Request -> FormattedTime
getSourceFromSocket = String -> FormattedTime
BS.pack (String -> FormattedTime)
-> (Request -> String) -> Request -> FormattedTime
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 -> FormattedTime
getSourceFromHeader = FormattedTime -> Maybe FormattedTime -> FormattedTime
forall a. a -> Maybe a -> a
fromMaybe FormattedTime
"-" (Maybe FormattedTime -> FormattedTime)
-> (Request -> Maybe FormattedTime) -> Request -> FormattedTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Maybe FormattedTime
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 -> FormattedTime
getSourceFromFallback Request
req = FormattedTime -> Maybe FormattedTime -> FormattedTime
forall a. a -> Maybe a -> a
fromMaybe (Request -> FormattedTime
getSourceFromSocket Request
req) (Maybe FormattedTime -> FormattedTime)
-> Maybe FormattedTime -> FormattedTime
forall a b. (a -> b) -> a -> b
$ Request -> Maybe FormattedTime
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 FormattedTime
getSource Request
req = Maybe FormattedTime
addr
  where
    maddr :: Maybe (HeaderName, FormattedTime)
maddr = ((HeaderName, FormattedTime) -> Bool)
-> [(HeaderName, FormattedTime)]
-> Maybe (HeaderName, FormattedTime)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(HeaderName, FormattedTime)
x -> (HeaderName, FormattedTime) -> HeaderName
forall a b. (a, b) -> a
fst (HeaderName, FormattedTime)
x HeaderName -> [HeaderName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HeaderName
"x-real-ip", HeaderName
"x-forwarded-for"]) [(HeaderName, FormattedTime)]
hdrs
    addr :: Maybe FormattedTime
addr = ((HeaderName, FormattedTime) -> FormattedTime)
-> Maybe (HeaderName, FormattedTime) -> Maybe FormattedTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HeaderName, FormattedTime) -> FormattedTime
forall a b. (a, b) -> b
snd Maybe (HeaderName, FormattedTime)
maddr
    hdrs :: [(HeaderName, FormattedTime)]
hdrs = Request -> [(HeaderName, FormattedTime)]
requestHeaders Request
req