1{-# LANGUAGE OverloadedStrings, CPP #-}
2
3module Network.Wai.Logger.Apache (
4    IPAddrSource(..)
5  , apacheLogStr
6  , serverpushLogStr
7  ) where
8
9#ifndef MIN_VERSION_base
10#define MIN_VERSION_base(x,y,z) 1
11#endif
12#ifndef MIN_VERSION_wai
13#define MIN_VERSION_wai(x,y,z) 1
14#endif
15
16import Data.ByteString.Char8 (ByteString)
17import qualified Data.ByteString.Char8 as BS
18import Data.List (find)
19import Data.Maybe (fromMaybe)
20#if MIN_VERSION_base(4,5,0)
21import Data.Monoid ((<>))
22#else
23import Data.Monoid (mappend)
24#endif
25import Network.HTTP.Types (Status, statusCode)
26import Network.Wai (Request(..))
27import Network.Wai.Logger.IP
28import System.Log.FastLogger
29
30-- $setup
31-- >>> :set -XOverloadedStrings
32-- >>> import Network.Wai (defaultRequest)
33
34-- | Source from which the IP source address of the client is obtained.
35data IPAddrSource =
36  -- | From the peer address of the HTTP connection.
37    FromSocket
38  -- | From X-Real-IP: or X-Forwarded-For: in the HTTP header.
39  | FromHeader
40  -- | From the peer address if header is not found.
41  | FromFallback
42
43-- | Apache style log format.
44apacheLogStr :: IPAddrSource -> FormattedTime -> Request -> Status -> Maybe Integer -> LogStr
45apacheLogStr ipsrc tmstr req status msize =
46      toLogStr (getSourceIP ipsrc req)
47  <> " - - ["
48  <> toLogStr tmstr
49  <> "] \""
50  <> toLogStr (requestMethod req)
51  <> " "
52  <> toLogStr path
53  <> " "
54  <> toLogStr (show (httpVersion req))
55  <> "\" "
56  <> toLogStr (show (statusCode status))
57  <> " "
58  <> toLogStr (maybe "-" show msize)
59  <> " \""
60  <> toLogStr (fromMaybe "" mr)
61  <> "\" \""
62  <> toLogStr (fromMaybe "" mua)
63  <> "\"\n"
64  where
65    path = rawPathInfo req <> rawQueryString req
66#if !MIN_VERSION_base(4,5,0)
67    (<>) = mappend
68#endif
69#if MIN_VERSION_wai(3,2,0)
70    mr  = requestHeaderReferer req
71    mua = requestHeaderUserAgent req
72#else
73    mr  = lookup "referer" $ requestHeaders req
74    mua = lookup "user-agent" $ requestHeaders req
75#endif
76
77-- | HTTP/2 Push log format in the Apache style.
78serverpushLogStr :: IPAddrSource -> FormattedTime -> Request -> ByteString -> Integer -> LogStr
79serverpushLogStr ipsrc tmstr req path size =
80      toLogStr (getSourceIP ipsrc req)
81  <> " - - ["
82  <> toLogStr tmstr
83  <> "] \"PUSH "
84  <> toLogStr path
85  <> " HTTP/2\" 200 "
86  <> toLogStr (show size)
87  <> " \""
88  <> toLogStr ref
89  <> "\" \""
90  <> toLogStr (fromMaybe "" mua)
91  <> "\"\n"
92  where
93    ref  = rawPathInfo req
94#if !MIN_VERSION_base(4,5,0)
95    (<>) = mappend
96#endif
97#if MIN_VERSION_wai(3,2,0)
98    mua = requestHeaderUserAgent req
99#else
100    mua = lookup "user-agent" $ requestHeaders req
101#endif
102
103-- getSourceIP = getSourceIP fromString fromByteString
104
105getSourceIP :: IPAddrSource -> Request -> ByteString
106getSourceIP FromSocket   = getSourceFromSocket
107getSourceIP FromHeader   = getSourceFromHeader
108getSourceIP FromFallback = getSourceFromFallback
109
110-- |
111-- >>> getSourceFromSocket defaultRequest
112-- "0.0.0.0"
113getSourceFromSocket :: Request -> ByteString
114getSourceFromSocket = BS.pack . showSockAddr . remoteHost
115
116-- |
117-- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Real-IP", "127.0.0.1") ] }
118-- "127.0.0.1"
119-- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Forwarded-For", "127.0.0.1") ] }
120-- "127.0.0.1"
121-- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("Something", "127.0.0.1") ] }
122-- ""
123-- >>> getSourceFromHeader defaultRequest { requestHeaders = [] }
124-- ""
125getSourceFromHeader :: Request -> ByteString
126getSourceFromHeader = fromMaybe "" . getSource
127
128-- |
129-- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Real-IP", "127.0.0.1") ] }
130-- "127.0.0.1"
131-- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Forwarded-For", "127.0.0.1") ] }
132-- "127.0.0.1"
133-- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("Something", "127.0.0.1") ] }
134-- "0.0.0.0"
135-- >>> getSourceFromFallback defaultRequest { requestHeaders = [] }
136-- "0.0.0.0"
137getSourceFromFallback :: Request -> ByteString
138getSourceFromFallback req = fromMaybe (getSourceFromSocket req) $ getSource req
139
140-- |
141-- >>> getSource defaultRequest { requestHeaders = [ ("X-Real-IP", "127.0.0.1") ] }
142-- Just "127.0.0.1"
143-- >>> getSource defaultRequest { requestHeaders = [ ("X-Forwarded-For", "127.0.0.1") ] }
144-- Just "127.0.0.1"
145-- >>> getSource defaultRequest { requestHeaders = [ ("Something", "127.0.0.1") ] }
146-- Nothing
147-- >>> getSource defaultRequest
148-- Nothing
149getSource :: Request -> Maybe ByteString
150getSource req = addr
151  where
152    maddr = find (\x -> fst x `elem` ["x-real-ip", "x-forwarded-for"]) hdrs
153    addr = fmap snd maddr
154    hdrs = requestHeaders req
155