diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,9 @@ +# ChangeLog for wai-logger + +## 2.5.1 + +* Security: request-derived fields (IP from headers, user, method, + path, Referer, User-Agent) are now escaped like Apache's + `ap_escape_logitem` to prevent log injection. +* The IP taken from X-Real-IP or X-Forwarded-For is now the first + token only. diff --git a/Network/Wai/Logger.hs b/Network/Wai/Logger.hs --- a/Network/Wai/Logger.hs +++ b/Network/Wai/Logger.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} + -- | Apache style logger for WAI applications. -- -- An example: @@ -5,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) @@ -18,48 +21,58 @@ -- > run 3000 $ logApp aplogger -- > -- > logApp :: ApacheLogger -> Application --- > logApp aplogger req = do +-- > logApp aplogger req response = do -- > liftIO $ aplogger req status (Just len) --- > return $ responseBuilder status hdr msg +-- > response $ responseBuilder status hdr msg -- > where -- > status = status200 --- > hdr = [("Content-Type", "text/plain") --- > ,("Content-Length", BS.pack (show len))] +-- > hdr = [("Content-Type", "text/plain")] -- > pong = "PONG" +-- > msg = byteString pong -- > len = fromIntegral $ BS.length pong --- > msg = toLogStr pong - module Network.Wai.Logger ( - -- * High level functions - ApacheLogger - , withStdoutLogger - -- * Creating a logger - , ApacheLoggerActions(..) - , initLogger - -- * Types - , IPAddrSource(..) - , LogType(..) - , FileLogSpec(..) - -- * Date cacher - , clockDateCacher - , ZonedDate - , DateCacheGetter - , DateCacheUpdater - -- * Utilities - , logCheck - , showSockAddr - ) where + -- * High level functions + ApacheLogger, + withStdoutLogger, + ServerPushLogger, -import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction) -import Control.Exception (handle, SomeException(..), bracket) -import Control.Monad (when, void) + -- * Creating a logger + ApacheLoggerActions, + apacheLogger, + serverpushLogger, + logRotator, + logRemover, + initLoggerUser, + initLogger, + + -- * Types + IPAddrSource (..), + LogType' (..), + LogType, + FileLogSpec (..), + + -- * Utilities + showSockAddr, + logCheck, + + -- * Backward compability + clockDateCacher, + ZonedDate, + DateCacheGetter, + DateCacheUpdater, +) where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>)) +#endif +import Control.Exception (bracket) +import Control.Monad (void) +import Data.ByteString (ByteString) import Network.HTTP.Types (Status) import Network.Wai (Request) -import System.IO (withFile, hFileSize, IOMode(..)) import System.Log.FastLogger import Network.Wai.Logger.Apache -import Network.Wai.Logger.Date import Network.Wai.Logger.IP (showSockAddr) ---------------------------------------------------------------- @@ -72,8 +85,8 @@ app aplogger where setup = do - (getter, _updater) <- clockDateCacher - apf <- initLogger FromFallback (LogStdout 4096) getter + tgetter <- newTimeCache simpleTimeFormat + apf <- initLogger FromFallback (LogStdout 4096) tgetter let aplogger = apacheLogger apf remover = logRemover apf return (aplogger, remover) @@ -84,118 +97,110 @@ -- | Apache style logger. type ApacheLogger = Request -> Status -> Maybe Integer -> IO () -data ApacheLoggerActions = ApacheLoggerActions { - apacheLogger :: ApacheLogger - -- | Rotating log files. - -- This is explicitly called from your program. - -- Probably, 10 seconds is proper. - , logRotator :: IO () - -- | Removing resources relating Apache logger. - , logRemover :: IO () - } +-- | HTTP/2 server push logger in Apache style. +type ServerPushLogger = Request -> ByteString -> Integer -> IO () --- | Logger Type. -data LogType = LogNone -- ^ No logging. - | LogStdout BufSize -- ^ Logging to stdout. - -- 'BufSize' is a buffer size - -- for each capability. - | LogFile FileLogSpec BufSize -- ^ Logging to a file. - -- 'BufSize' is a buffer size - -- for each capability. - | LogCallback (LogStr -> IO ()) (IO ()) +-- | Function set of Apache style logger. +data ApacheLoggerActions = ApacheLoggerActions + { apacheLogger :: ApacheLogger + -- ^ The Apache logger. + , serverpushLogger :: ServerPushLogger + -- ^ The HTTP/2 server push logger. + , logRotator :: IO () + -- ^ This is obsoleted. Rotation is done on-demand. + -- So, this is now an empty action. + , logRemover :: IO () + -- ^ Removing resources relating to Apache logger. + -- E.g. flushing and deallocating internal buffers. + } ---------------------------------------------------------------- --- | --- Creating 'ApacheLogger' according to 'LogType'. -initLogger :: IPAddrSource -> LogType -> DateCacheGetter - -> IO ApacheLoggerActions -initLogger _ LogNone _ = noLoggerInit -initLogger ipsrc (LogStdout size) dateget = stdoutLoggerInit ipsrc size dateget -initLogger ipsrc (LogFile spec size) dateget = fileLoggerInit ipsrc spec size dateget -initLogger ipsrc (LogCallback cb flush) dateget = callbackLoggerInit ipsrc cb flush dateget - ----------------------------------------------------------------- +-- | 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 + } -noLoggerInit :: IO ApacheLoggerActions -noLoggerInit = return ApacheLoggerActions { - apacheLogger = noLogger - , logRotator = noRotator - , logRemover = noRemover - } +initLogger + :: IPAddrSource + -> LogType + -> IO FormattedTime + -> IO ApacheLoggerActions +initLogger = initLoggerUser nouser where - noLogger _ _ _ = return () - noRotator = return () - noRemover = return () - -stdoutLoggerInit :: IPAddrSource -> BufSize -> DateCacheGetter - -> IO ApacheLoggerActions -stdoutLoggerInit ipsrc size dateget = do - lgrset <- newStdoutLoggerSet size - let logger = apache (pushLogStr lgrset) ipsrc dateget - noRotator = return () - remover = rmLoggerSet lgrset - return ApacheLoggerActions { - apacheLogger = logger - , logRotator = noRotator - , logRemover = remover - } - -fileLoggerInit :: IPAddrSource -> FileLogSpec -> BufSize -> DateCacheGetter - -> IO ApacheLoggerActions -fileLoggerInit ipsrc spec size dateget = do - lgrset <- newFileLoggerSet size $ log_file spec - let logger = apache (pushLogStr lgrset) ipsrc dateget - rotator = logFileRotator lgrset spec - remover = rmLoggerSet lgrset - return ApacheLoggerActions { - apacheLogger = logger - , logRotator = rotator - , logRemover = remover - } + nouser :: Maybe (Request -> Maybe ByteString) + nouser = Nothing -callbackLoggerInit :: IPAddrSource -> (LogStr -> IO ()) -> IO () -> DateCacheGetter - -> IO ApacheLoggerActions -callbackLoggerInit ipsrc cb flush dateget = do - flush' <- mkAutoUpdate defaultUpdateSettings - { updateAction = flush - } - let logger a b c = apache cb ipsrc dateget a b c >> flush' - noRotator = return () - remover = return () - return ApacheLoggerActions { - apacheLogger = logger - , logRotator = noRotator - , logRemover = remover - } +--- | 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 (LogFileTimedRotate spec _) = check (timed_log_file spec) +logCheck (LogCallback _ _) = return () ---------------------------------------------------------------- -apache :: (LogStr -> IO ()) -> IPAddrSource -> DateCacheGetter -> 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) -logFileRotator :: LoggerSet -> FileLogSpec -> IO () -logFileRotator lgrset spec = do - over <- isOver - when over $ do - rotate spec - renewLoggerSet lgrset - where - file = log_file spec - isOver = handle (\(SomeException _) -> return False) $ do - siz <- withFile file ReadMode hFileSize - return (siz > log_file_size spec) +--------------------------------------------------------------- ----------------------------------------------------------------- +-- | Getting cached 'ZonedDate'. +type DateCacheGetter = IO ZonedDate +-- | Updateing cached 'ZonedDate'. This should be called every second. +-- See the source code of 'withStdoutLogger'. +type DateCacheUpdater = IO () + +-- | A type for zoned date. +type ZonedDate = FormattedTime + -- | --- Checking if a log file can be written if 'LogType' is 'LogFile'. -logCheck :: LogType -> IO () -logCheck LogNone = return () -logCheck (LogStdout _) = return () -logCheck (LogFile spec _) = check spec -logCheck (LogCallback _ _) = return () +-- Returning 'DateCacheGetter' and 'DateCacheUpdater'. +-- +-- Note: Since version 2.1.2, this function uses the auto-update package +-- internally, and therefore the @DateCacheUpdater@ value returned need +-- not be called. To wit, the return value is in fact an empty action. +clockDateCacher :: IO (DateCacheGetter, DateCacheUpdater) +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,78 +1,219 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Network.Wai.Logger.Apache ( - IPAddrSource(..) - , apacheLogStr - ) where + 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 qualified Data.ByteString as B import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS -import Data.CaseInsensitive (CI) +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Unsafe as BU +import Data.Char (isSpace) import Data.List (find) import Data.Maybe (fromMaybe) +import Data.Word (Word8) +import Foreign.Ptr (Ptr) +import Foreign.Storable (pokeByteOff) #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.Wai (Request(..)) -import Network.Wai.Logger.Date +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. - | FromHeader - -- | From the peer address if header is not found. - | FromFallback +data IPAddrSource + = -- | From the peer address of the HTTP connection. + FromSocket + | -- | 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 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 -> ZonedDate -> Request -> Status -> Maybe Integer -> LogStr -apacheLogStr ipsrc tmstr req status msize = - toLogStr (getSourceIP ipsrc req) - <> " - - [" - <> toLogStr tmstr - <> "] \"" - <> toLogStr (requestMethod req) - <> " " - <> toLogStr (rawPathInfo req) - <> " " - <> toLogStr (show (httpVersion req)) - <> "\" " - <> toLogStr (show (statusCode status)) - <> " " - <> toLogStr (maybe "-" show msize) - <> " \"" - <> toLogStr (lookupRequestField' "referer" req) - <> "\" \"" - <> toLogStr (lookupRequestField' "user-agent" req) - <> "\"\n" +apacheLogStr + :: ToLogStr user + => IPAddrSource + -> (Request -> Maybe user) + -> FormattedTime + -> Request + -> Status + -> Maybe Integer + -> LogStr +apacheLogStr ipsrc userget tmstr req status msize = + toLogStr (escapeLogItem (getSourceIP ipsrc req)) + <> " - " + <> maybe "-" escapeUser (userget req) + <> " [" + <> toLogStr tmstr + <> "] \"" + <> toLogStr (escapeLogItem (requestMethod req)) + <> " " + <> toLogStr (escapeLogItem path) + <> " " + <> toLogStr (show (httpVersion req)) + <> "\" " + <> toLogStr (show (statusCode status)) + <> " " + <> toLogStr (maybe "-" show msize) + <> " \"" + <> toLogStr (escapeLogItem (fromMaybe "" mr)) + <> "\" \"" + <> toLogStr (escapeLogItem (fromMaybe "" mua)) + <> "\"\n" where + path = rawPathInfo req <> rawQueryString req #if !MIN_VERSION_base(4,5,0) (<>) = mappend #endif +#if MIN_VERSION_wai(3,2,0) + mr = requestHeaderReferer req + mua = requestHeaderUserAgent req +#else + mr = lookup "referer" $ requestHeaders req + mua = lookup "user-agent" $ requestHeaders req +#endif -lookupRequestField' :: CI ByteString -> Request -> ByteString -lookupRequestField' k req = fromMaybe "" . lookup k $ requestHeaders req +-- | 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 (escapeLogItem (getSourceIP ipsrc req)) + <> " - " + <> maybe "-" escapeUser (userget req) + <> " [" + <> toLogStr tmstr + <> "] \"PUSH " + <> toLogStr (escapeLogItem path) + <> " HTTP/2\" 200 " + <> toLogStr (show size) + <> " \"" + <> toLogStr (escapeLogItem ref) + <> "\" \"" + <> toLogStr (escapeLogItem (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 = getSourceIP fromString fromByteString +escapeUser :: ToLogStr user => user -> LogStr +escapeUser = toLogStr . escapeLogItem . fromLogStr . toLogStr +-- | Escaping a request-derived field as Apache's @ap_escape_logitem@ does. +-- No copy is made if nothing needs to be escaped. +-- +-- >>> escapeLogItem "Mozilla/5.0" +-- "Mozilla/5.0" +-- >>> escapeLogItem "a\"b\\c\r\n\x01\x7f\xe3" +-- "a\\\"b\\\\c\\r\\n\\x01\\x7f\\xe3" +escapeLogItem :: ByteString -> ByteString +escapeLogItem bs + | extra == 0 = bs + | otherwise = BI.unsafeCreate (len + extra) $ \p -> fill p 0 0 + where + len = B.length bs + extra = B.foldl' (\n w -> n + escapeLen w) 0 bs + fill :: Ptr Word8 -> Int -> Int -> IO () + fill p i j + | i >= len = return () + | otherwise = do + let w = BU.unsafeIndex bs i + case escapeLen w of + 0 -> do + pokeByteOff p j w + fill p (i + 1) (j + 1) + 1 -> do + pokeByteOff p j backslash + pokeByteOff p (j + 1) (escapeChar w) + fill p (i + 1) (j + 2) + _ -> do + pokeByteOff p j backslash + pokeByteOff p (j + 1) (0x78 :: Word8) -- 'x' + pokeByteOff p (j + 2) (hex (w `div` 16)) + pokeByteOff p (j + 3) (hex (w `mod` 16)) + fill p (i + 1) (j + 4) + backslash = 0x5c :: Word8 + hex :: Word8 -> Word8 + hex n + | n < 10 = 0x30 + n + | otherwise = 0x57 + n -- lower case as Apache + +-- Number of extra bytes needed to escape a byte. +escapeLen :: Word8 -> Int +escapeLen w + | w == 0x22 || w == 0x5c = 1 -- '"' and '\\' + | w >= 0x20 && w < 0x7f = 0 + | w >= 0x08 && w <= 0x0d && w /= 0x0c = 1 -- \b \t \n \v \r + | otherwise = 3 + +escapeChar :: Word8 -> Word8 +escapeChar 0x08 = 0x62 -- b +escapeChar 0x09 = 0x74 -- t +escapeChar 0x0a = 0x6e -- n +escapeChar 0x0b = 0x76 -- v +escapeChar 0x0d = 0x72 -- r +escapeChar w = w -- '"' and '\\' + 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 @@ -86,11 +227,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") ] } @@ -101,6 +256,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 @@ -113,9 +282,82 @@ -- 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", firstIpInXFF), ("x-forwarded-for", firstIpInXFF)] + +-- | Pull out the first IP in a comma-separated list of X-Forwarded-For IPs. +-- Leading white spaces are skipped and the IP ends at a white space. +-- +-- >>> firstIpInXFF "1.2.3.4, 5.6.7.8, 10.11.12.13" +-- "1.2.3.4" +-- >>> firstIpInXFF " 1.2.3.4 , 5.6.7.8" +-- "1.2.3.4" +-- +-- If there are no commas or white spaces, 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 (\c -> c /= ',' && not (isSpace c)) . BS.dropWhile isSpace + +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/Date.hs b/Network/Wai/Logger/Date.hs deleted file mode 100644 --- a/Network/Wai/Logger/Date.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} - --- | --- Formatting time is slow. --- This package provides mechanisms to cache formatted date. -module Network.Wai.Logger.Date ( - -- * Types - DateCacheGetter - , DateCacheUpdater - , ZonedDate - -- * Cache configuration - , DateCacheConf(..) - , zonedDateCacheConf - -- * Date cacher - , clockDateCacher - ) where - -import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction) -import Data.ByteString (ByteString) -#if WINDOWS -import qualified Data.ByteString.Char8 as BS -import Data.Time -import System.Locale -#else -import Data.UnixTime (formatUnixTime, fromEpochTime) -import System.Posix (EpochTime, epochTime) -#endif - ----------------------------------------------------------------- - --- | Getting cached 'ZonedDate'. -type DateCacheGetter = IO ZonedDate --- | Updateing cached 'ZonedDate'. This should be called every second. --- See the source code of 'withStdoutLogger'. -type DateCacheUpdater = IO () - ----------------------------------------------------------------- - --- | A type for zoned date. -type ZonedDate = ByteString - ----------------------------------------------------------------- - -data DateCacheConf t = DateCacheConf { - -- | A function to get a time. E.g 'epochTime' and 'getCurrentTime'. - getTime :: IO t - -- | A function to format a time. - , formatDate :: t -> IO ByteString - } - -#if WINDOWS --- | Zoned date cacher using UTC. -zonedDateCacheConf :: DateCacheConf UTCTime -zonedDateCacheConf = DateCacheConf { - getTime = getCurrentTime - , formatDate = \ut -> do - zt <- utcToLocalZonedTime ut - return $ BS.pack $ formatTime defaultTimeLocale "%d/%b/%Y:%T %z" zt - } -#else --- | Zoned date cacher using UnixTime. -zonedDateCacheConf :: DateCacheConf EpochTime -zonedDateCacheConf = DateCacheConf { - getTime = epochTime - , formatDate = formatUnixTime "%d/%b/%Y:%T %z" . fromEpochTime - } -#endif - ----------------------------------------------------------------- - --- | --- Returning 'DateCacheGetter' and 'DateCacheUpdater'. --- --- Note: Since version 2.1.2, this function uses the auto-update package --- internally, and therefore the @DateCacheUpdater@ value returned need --- not be called. To wit, the return value is in fact an empty action. - -clockDateCacher :: IO (DateCacheGetter, DateCacheUpdater) -clockDateCacher = do - getter <- mkAutoUpdate defaultUpdateSettings - { updateAction = getTime zonedDateCacheConf - >>= formatDate zonedDateCacheConf - } - return (getter, return ()) diff --git a/Network/Wai/Logger/IORef.hs b/Network/Wai/Logger/IORef.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Logger/IORef.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} + +module Network.Wai.Logger.IORef ( + IORef, + newIORef, + readIORef, + writeIORef, + atomicModifyIORef', +) where + +import Data.IORef + +#if !MIN_VERSION_base(4, 6, 0) +atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORef' ref f = do + b <- atomicModifyIORef ref + (\x -> let (a, b) = f x + in (a, a `seq` b)) + b `seq` return b +#endif 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 @@ -1,11 +1,12 @@ module Network.Wai.Logger.IP ( - NumericAddress, showSockAddr - ) where + NumericAddress, + showSockAddr, +) where import Data.Bits (shift, (.&.)) import Data.Word (Word32) -import Network.Socket (SockAddr(..)) -import System.ByteOrder (ByteOrder(..), byteOrder) +import Network.Socket (SockAddr (..)) +import System.ByteOrder (ByteOrder (..), byteOrder) import Text.Printf (printf) -- | A type for IP address in numeric string representation. @@ -13,7 +14,7 @@ showIPv4 :: Word32 -> Bool -> NumericAddress showIPv4 w32 little - | little = show b1 ++ "." ++ show b2 ++ "." ++ show b3 ++ "." ++ show b4 + | little = show b1 ++ "." ++ show b2 ++ "." ++ show b3 ++ "." ++ show b4 | otherwise = show b4 ++ "." ++ show b3 ++ "." ++ show b2 ++ "." ++ show b1 where t1 = w32 @@ -25,25 +26,26 @@ b3 = t3 .&. 0x000000ff b4 = t4 .&. 0x000000ff -showIPv6 :: (Word32,Word32,Word32,Word32) -> String -showIPv6 (w1,w2,w3,w4) = +showIPv6 :: (Word32, Word32, Word32, Word32) -> String +showIPv6 (w1, w2, w3, w4) = printf "%x:%x:%x:%x:%x:%x:%x:%x" s1 s2 s3 s4 s5 s6 s7 s8 where - (s1,s2) = split16 w1 - (s3,s4) = split16 w2 - (s5,s6) = split16 w3 - (s7,s8) = split16 w4 - split16 w = (h1,h2) + (s1, s2) = split16 w1 + (s3, s4) = split16 w2 + (s5, s6) = split16 w3 + (s7, s8) = split16 w4 + split16 w = (h1, h2) where h1 = shift w (-16) .&. 0x0000ffff h2 = w .&. 0x0000ffff + -- | Convert 'SockAddr' to 'NumericAddress'. If the address is -- IPv4-embedded IPv6 address, the IPv4 is extracted. showSockAddr :: SockAddr -> NumericAddress -- HostAddr is network byte order. -showSockAddr (SockAddrInet _ addr4) = showIPv4 addr4 (byteOrder == LittleEndian) +showSockAddr (SockAddrInet _ addr4) = showIPv4 addr4 (byteOrder == LittleEndian) -- HostAddr6 is host byte order. -showSockAddr (SockAddrInet6 _ _ (0,0,0x0000ffff,addr4) _) = showIPv4 addr4 False -showSockAddr (SockAddrInet6 _ _ (0,0,0,1) _) = "::1" -showSockAddr (SockAddrInet6 _ _ addr6 _) = showIPv6 addr6 -showSockAddr _ = "unknownSocket" +showSockAddr (SockAddrInet6 _ _ (0, 0, 0x0000ffff, addr4) _) = showIPv4 addr4 False +showSockAddr (SockAddrInet6 _ _ (0, 0, 0, 1) _) = "::1" +showSockAddr (SockAddrInet6 _ _ addr6 _) = showIPv6 addr6 +showSockAddr (SockAddrUnix _) = "-" diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,8 @@ +{-# OPTIONS_GHC -Wall #-} + +module Main (main) where + import Distribution.Simple + +main :: IO () main = defaultMain diff --git a/test/ApacheSpec.hs b/test/ApacheSpec.hs new file mode 100644 --- /dev/null +++ b/test/ApacheSpec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ApacheSpec (spec) where + +import qualified Data.ByteString.Char8 as BS +import Data.IORef +import Network.HTTP.Types (status200) +import Network.Wai +import Network.Wai.Logger +import System.Log.FastLogger + +import Test.Hspec + +spec :: Spec +spec = describe "apacheLogger" $ do + it "escapes request-derived fields" $ do + let req = + defaultRequest + { rawPathInfo = "/a\"b" + , requestHeaders = [("X-Forwarded-For", " 1.2.3.4 \"x\"\n, 5.6.7.8")] + , requestHeaderUserAgent = Just "evil\" \"injected\r\nfoo\\" + , requestHeaderReferer = Just "\x01\x7f" + } + logLine FromHeader req + `shouldReturn` "1.2.3.4 - - [date] \"GET /a\\\"b HTTP/1.0\" 200 4 \"\\x01\\x7f\" \"evil\\\" \\\"injected\\r\\nfoo\\\\\"\n" + it "does not change ordinary fields" $ do + let req = + defaultRequest + { rawPathInfo = "/index.html" + , rawQueryString = "?q=1" + , requestHeaders = [("X-Real-IP", "9.8.7.6")] + , requestHeaderUserAgent = Just "Mozilla/5.0 (X11)" + } + logLine FromHeader req + `shouldReturn` "9.8.7.6 - - [date] \"GET /index.html?q=1 HTTP/1.0\" 200 4 \"\" \"Mozilla/5.0 (X11)\"\n" + +logLine :: IPAddrSource -> Request -> IO BS.ByteString +logLine ipsrc req = do + ref <- newIORef "" + let cb s = modifyIORef ref (<> fromLogStr s) + lgr <- initLogger ipsrc (LogCallback cb (return ())) (return "date") + apacheLogger lgr req status200 (Just 4) + readIORef ref diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import Test.DocTest - -main :: IO () -main = doctest [ - "-idist/build/autogen/" - , "-optP-include" - , "-optPdist/build/autogen/cabal_macros.h" - , "Network/Wai/Logger.hs" - ] diff --git a/wai-logger.cabal b/wai-logger.cabal --- a/wai-logger.cabal +++ b/wai-logger.cabal @@ -1,49 +1,57 @@ -Name: wai-logger -Version: 2.2.0 -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.1 +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.Date - Network.Wai.Logger.IP - Build-Depends: base >= 4 && < 5 - , auto-update - , blaze-builder - , byteorder - , bytestring - , case-insensitive - , fast-logger >= 2.2 - , 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 +extra-source-files: ChangeLog.md -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 +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 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tools: hspec-discover >=2.6 + hs-source-dirs: test + other-modules: ApacheSpec + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4 && <5, + bytestring, + fast-logger, + hspec, + http-types, + wai, + wai-logger