wai-logger 2.2.7 → 2.5.1
raw patch · 10 files changed
Files
- ChangeLog.md +9/−0
- Network/Wai/Logger.hs +103/−41
- Network/Wai/Logger/Apache.hs +281/−44
- Network/Wai/Logger/IORef.hs +6/−6
- Network/Wai/Logger/IP.hs +19/−17
- Setup.hs +6/−0
- test/ApacheSpec.hs +43/−0
- test/Spec.hs +1/−0
- test/doctests.hs +0/−6
- wai-logger.cabal +54/−45
+ ChangeLog.md view
@@ -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.
Network/Wai/Logger.hs view
@@ -1,4 +1,5 @@ {-# 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,35 +28,46 @@ -- > 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- -- * Creating a logger- , ApacheLoggerActions(..)- , initLogger- -- * Types- , IPAddrSource(..)- , LogType(..)- , FileLogSpec(..)- -- * Utilities- , showSockAddr- , logCheck- -- * Backward compability- , clockDateCacher- , ZonedDate- , DateCacheGetter- , DateCacheUpdater- ) where+ -- * High level functions+ ApacheLogger,+ withStdoutLogger,+ ServerPushLogger, + -- * 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.Log.FastLogger@@ -85,41 +97,87 @@ -- | Apache style logger. type ApacheLogger = Request -> Status -> Maybe Integer -> IO () -data ApacheLoggerActions = ApacheLoggerActions {- apacheLogger :: ApacheLogger- -- | This is obsoleted. Rotation is done on-demand.+-- | HTTP/2 server push logger in Apache style.+type ServerPushLogger = Request -> ByteString -> Integer -> 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.- , logRotator :: IO ()- -- | Removing resources relating Apache logger.+ , logRemover :: IO ()+ -- ^ Removing resources relating to Apache logger. -- E.g. flushing and deallocating internal buffers.- , logRemover :: IO ()- }+ } ---------------------------------------------------------------- -- | Creating 'ApacheLogger' according to 'LogType'.-initLogger :: IPAddrSource -> LogType -> IO FormattedTime- -> IO ApacheLoggerActions-initLogger ipsrc typ tgetter = do+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 (apache fl ipsrc tgetter) (return ()) cleanUp+ 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 = 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 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 -> 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 +200,7 @@ clockDateCacher = do tgetter <- newTimeCache simpleTimeFormat return (tgetter, return ())++justGetUser :: Maybe (Request -> Maybe user) -> (Request -> Maybe user)+justGetUser (Just getter) = getter+justGetUser Nothing = \_ -> Nothing
Network/Wai/Logger/Apache.hs view
@@ -1,9 +1,12 @@-{-# 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@@ -12,55 +15,94 @@ #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 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.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 -> FormattedTime -> 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 (fromMaybe "" mr)- <> "\" \""- <> toLogStr (fromMaybe "" mua)- <> "\"\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@@ -72,12 +114,106 @@ 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 (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 +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@@ -91,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") ] }@@ -106,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 @@ -118,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)
Network/Wai/Logger/IORef.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE CPP #-} module Network.Wai.Logger.IORef (- IORef- , newIORef- , readIORef- , writeIORef- , atomicModifyIORef'- ) where+ IORef,+ newIORef,+ readIORef,+ writeIORef,+ atomicModifyIORef',+) where import Data.IORef
Network/Wai/Logger/IP.hs view
@@ -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 _) = "-"
Setup.hs view
@@ -1,2 +1,8 @@+{-# OPTIONS_GHC -Wall #-}++module Main (main) where+ import Distribution.Simple++main :: IO () main = defaultMain
+ test/ApacheSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− test/doctests.hs
@@ -1,6 +0,0 @@-module Main where--import Test.DocTest--main :: IO ()-main = doctest ["Network"]
wai-logger.cabal view
@@ -1,48 +1,57 @@-Name: wai-logger-Version: 2.2.7-Author: Kazu Yamamoto <kazu@iij.ad.jp>-Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>-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 <kazu@iij.ad.jp>+author: Kazu Yamamoto <kazu@iij.ad.jp>+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+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 >= 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++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