diff --git a/Network/Wai/Logger.hs b/Network/Wai/Logger.hs --- a/Network/Wai/Logger.hs +++ b/Network/Wai/Logger.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} -- | Apache style logger for WAI applications. -- @@ -7,7 +8,7 @@ -- > {-# LANGUAGE OverloadedStrings #-} -- > module Main where -- > --- > import Blaze.ByteString.Builder (fromByteString) +-- > import Data.ByteString.Builder (byteString) -- > import Control.Monad.IO.Class (liftIO) -- > import qualified Data.ByteString.Char8 as BS -- > import Network.HTTP.Types (status200) @@ -27,19 +28,25 @@ -- > status = status200 -- > hdr = [("Content-Type", "text/plain")] -- > pong = "PONG" --- > msg = fromByteString pong +-- > msg = byteString pong -- > len = fromIntegral $ BS.length pong module Network.Wai.Logger ( -- * High level functions ApacheLogger , withStdoutLogger + , ServerPushLogger -- * Creating a logger - , ApacheLoggerActions(..) + , ApacheLoggerActions + , apacheLogger + , serverpushLogger + , logRotator + , logRemover + , initLoggerUser , initLogger -- * Types , IPAddrSource(..) - , LogType(..) + , LogType'(..), LogType , FileLogSpec(..) -- * Utilities , showSockAddr @@ -56,6 +63,7 @@ #endif import Control.Exception (bracket) import Control.Monad (void) +import Data.ByteString (ByteString) import Network.HTTP.Types (Status) import Network.Wai (Request) import System.Log.FastLogger @@ -85,12 +93,19 @@ -- | Apache style logger. type ApacheLogger = Request -> Status -> Maybe Integer -> IO () +-- | HTTP/2 server push logger in Apache style. +type ServerPushLogger = Request -> ByteString -> Integer -> IO () + +-- | Function set of Apache style logger. data ApacheLoggerActions = ApacheLoggerActions { + -- | The Apache logger. apacheLogger :: ApacheLogger + -- | The HTTP/2 server push logger. + , serverpushLogger :: ServerPushLogger -- | This is obsoleted. Rotation is done on-demand. -- So, this is now an empty action. , logRotator :: IO () - -- | Removing resources relating Apache logger. + -- | Removing resources relating to Apache logger. -- E.g. flushing and deallocating internal buffers. , logRemover :: IO () } @@ -98,28 +113,46 @@ ---------------------------------------------------------------- -- | Creating 'ApacheLogger' according to 'LogType'. +initLoggerUser :: ToLogStr user => Maybe (Request -> Maybe user) -> IPAddrSource -> LogType -> IO FormattedTime + -> IO ApacheLoggerActions +initLoggerUser ugetter ipsrc typ tgetter = do + (fl, cleanUp) <- newFastLogger typ + return $ ApacheLoggerActions { + apacheLogger = apache fl ipsrc ugetter tgetter + , serverpushLogger = serverpush fl ipsrc ugetter tgetter + , logRotator = return () + , logRemover = cleanUp + } + initLogger :: IPAddrSource -> LogType -> IO FormattedTime -> IO ApacheLoggerActions -initLogger ipsrc typ tgetter = do - (fl, cleanUp) <- newFastLogger typ - return $ ApacheLoggerActions (apache fl ipsrc tgetter) (return ()) cleanUp +initLogger = initLoggerUser nouser + where + nouser :: Maybe (Request -> Maybe ByteString) + nouser = Nothing --- | Checking if a log file can be written if 'LogType' is 'LogFileNoRotate' or 'LogFile'. logCheck :: LogType -> IO () logCheck LogNone = return () logCheck (LogStdout _) = return () logCheck (LogStderr _) = return () -logCheck (LogFileNoRotate fp _) = check fp -logCheck (LogFile spec _) = check (log_file spec) +logCheck (LogFileNoRotate fp _) = check fp +logCheck (LogFile spec _) = check (log_file spec) +logCheck (LogFileTimedRotate spec _) = check (timed_log_file spec) logCheck (LogCallback _ _) = return () ---------------------------------------------------------------- -apache :: (LogStr -> IO ()) -> IPAddrSource -> IO FormattedTime -> ApacheLogger -apache cb ipsrc dateget req st mlen = do +apache :: ToLogStr user => (LogStr -> IO ()) -> IPAddrSource -> Maybe (Request -> Maybe user) -> IO FormattedTime -> ApacheLogger +apache cb ipsrc userget dateget req st mlen = do zdata <- dateget - cb (apacheLogStr ipsrc zdata req st mlen) + cb (apacheLogStr ipsrc (justGetUser userget) zdata req st mlen) +serverpush :: ToLogStr user => (LogStr -> IO ()) -> IPAddrSource -> Maybe (Request -> Maybe user) -> IO FormattedTime -> ServerPushLogger +serverpush cb ipsrc userget dateget req path size = do + zdata <- dateget + cb (serverpushLogStr ipsrc (justGetUser userget) zdata req path size) + --------------------------------------------------------------- -- | Getting cached 'ZonedDate'. @@ -142,3 +175,7 @@ clockDateCacher = do tgetter <- newTimeCache simpleTimeFormat return (tgetter, return ()) + +justGetUser :: Maybe (Request -> Maybe user) -> (Request -> Maybe user) +justGetUser (Just getter) = getter +justGetUser Nothing = \_ -> Nothing 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,8 +1,9 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} +{-# LANGUAGE OverloadedStrings, CPP, TupleSections #-} module Network.Wai.Logger.Apache ( IPAddrSource(..) , apacheLogStr + , serverpushLogStr ) where #ifndef MIN_VERSION_base @@ -17,38 +18,61 @@ 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 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.Test +-- >>> 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. + -- | 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 the peer address if header is not found. + -- | 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] + -- | 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 :: IPAddrSource -> FormattedTime -> Request -> Status -> Maybe Integer -> LogStr -apacheLogStr ipsrc tmstr req status msize = +apacheLogStr :: ToLogStr user => IPAddrSource -> (Request -> Maybe user) -> FormattedTime -> Request -> Status -> Maybe Integer -> LogStr +apacheLogStr ipsrc userget tmstr req status msize = toLogStr (getSourceIP ipsrc req) - <> " - - [" + <> " - " + <> maybe "-" toLogStr (userget req) + <> " [" <> toLogStr tmstr <> "] \"" <> toLogStr (requestMethod req) <> " " - <> toLogStr (rawPathInfo req) + <> toLogStr path <> " " <> toLogStr (show (httpVersion req)) <> "\" " @@ -61,6 +85,7 @@ <> toLogStr (fromMaybe "" mua) <> "\"\n" where + path = rawPathInfo req <> rawQueryString req #if !MIN_VERSION_base(4,5,0) (<>) = mappend #endif @@ -72,12 +97,40 @@ mua = lookup "user-agent" $ requestHeaders req #endif --- getSourceIP = getSourceIP fromString fromByteString +-- | HTTP/2 Push log format in the Apache style. +serverpushLogStr :: ToLogStr user => IPAddrSource -> (Request -> Maybe user) -> FormattedTime -> Request -> ByteString -> Integer -> LogStr +serverpushLogStr ipsrc userget tmstr req path size = + toLogStr (getSourceIP ipsrc req) + <> " - " + <> maybe "-" toLogStr (userget req) + <> " [" + <> toLogStr tmstr + <> "] \"PUSH " + <> toLogStr path + <> " HTTP/2\" 200 " + <> toLogStr (show size) + <> " \"" + <> toLogStr ref + <> "\" \"" + <> toLogStr (fromMaybe "" mua) + <> "\"\n" + where + ref = rawPathInfo req +#if !MIN_VERSION_base(4,5,0) + (<>) = mappend +#endif +#if MIN_VERSION_wai(3,2,0) + mua = requestHeaderUserAgent req +#else + mua = lookup "user-agent" $ requestHeaders req +#endif getSourceIP :: IPAddrSource -> Request -> ByteString -getSourceIP FromSocket = getSourceFromSocket -getSourceIP FromHeader = getSourceFromHeader +getSourceIP FromSocket = getSourceFromSocket +getSourceIP FromHeader = getSourceFromHeader getSourceIP FromFallback = getSourceFromFallback +getSourceIP (FromHeaderCustom hs) = fromMaybe "-" . getSourceFromHeaderCustom hs +getSourceIP (FromRequest fromReq) = fromReq -- | -- >>> getSourceFromSocket defaultRequest @@ -91,11 +144,25 @@ -- >>> 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' 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 +getSourceFromHeader = fromMaybe "-" . getSource -- | -- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Real-IP", "127.0.0.1") ] } @@ -106,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 @@ -118,9 +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 req = addr +getSource = getSourceFromHeaders [("x-real-ip", id), ("x-forwarded-for", firstIpInXFF)] + +-- | 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 (\x -> fst x `elem` ["x-real-ip", "x-forwarded-for"]) 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 (fmap (,firstIpInXFF) hs) diff --git a/Network/Wai/Logger/IP.hs b/Network/Wai/Logger/IP.hs --- a/Network/Wai/Logger/IP.hs +++ b/Network/Wai/Logger/IP.hs @@ -46,4 +46,4 @@ showSockAddr (SockAddrInet6 _ _ (0,0,0x0000ffff,addr4) _) = showIPv4 addr4 False showSockAddr (SockAddrInet6 _ _ (0,0,0,1) _) = "::1" showSockAddr (SockAddrInet6 _ _ addr6 _) = showIPv6 addr6 -showSockAddr _ = "unknownSocket" +showSockAddr (SockAddrUnix _) = "-" diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,7 @@ +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + import Distribution.Simple + +main :: IO () main = defaultMain diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import Test.DocTest - -main :: IO () -main = doctest ["Network"] diff --git a/wai-logger.cabal b/wai-logger.cabal --- a/wai-logger.cabal +++ b/wai-logger.cabal @@ -1,48 +1,39 @@ -Name: wai-logger -Version: 2.2.7 -Author: Kazu Yamamoto -Maintainer: Kazu Yamamoto -License: BSD3 -License-File: LICENSE -Synopsis: A logging system for WAI -Description: A logging system for WAI -Category: Web, Yesod -Cabal-Version: >= 1.10 -Build-Type: Simple +cabal-version: >=1.10 +name: wai-logger +version: 2.5.0 +license: BSD3 +license-file: LICENSE +maintainer: Kazu Yamamoto +author: Kazu Yamamoto +tested-with: + ghc ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.3 -Library - Default-Language: Haskell2010 - GHC-Options: -Wall - Exposed-Modules: Network.Wai.Logger - Other-Modules: Network.Wai.Logger.Apache - Network.Wai.Logger.IP - Network.Wai.Logger.IORef - Build-Depends: base >= 4 && < 5 - , blaze-builder - , byteorder - , bytestring - , case-insensitive - , fast-logger >= 2.4.5 - , http-types - , network - , wai >= 2.0.0 - if os(windows) - Cpp-Options: -DWINDOWS - Build-Depends: time - , old-locale - else - Build-Depends: unix - , unix-time >= 0.2.2 +synopsis: A logging system for WAI +description: A logging system for WAI(Web Application Interface) +category: Web, Yesod +build-type: Simple -Test-Suite doctest - Type: exitcode-stdio-1.0 - Default-Language: Haskell2010 - HS-Source-Dirs: test - Ghc-Options: -Wall - Main-Is: doctests.hs - Build-Depends: base - , doctest >= 0.10.1 +source-repository head + type: git + location: https://github.com/kazu-yamamoto/logger.git -Source-Repository head - Type: git - Location: git://github.com/kazu-yamamoto/logger.git +library + exposed-modules: Network.Wai.Logger + other-modules: + Network.Wai.Logger.Apache + Network.Wai.Logger.IP + Network.Wai.Logger.IORef + + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4 && <5, + byteorder, + bytestring, + fast-logger >=3, + http-types, + network, + wai >=2.0.0 + + if impl(ghc >=8) + default-extensions: Strict StrictData