wai-extra 3.0.10 → 3.0.10.1
raw patch · 27 files changed
+265/−122 lines, 27 filesdep +aesondep +iproutedep ~network
Dependencies added: aeson, iproute
Dependency ranges changed: network
Files
- ChangeLog.md +5/−0
- Network/Wai/EventSource.hs +3/−5
- Network/Wai/EventSource/EventStream.hs +3/−1
- Network/Wai/Handler/CGI.hs +10/−11
- Network/Wai/Middleware/AcceptOverride.hs +0/−2
- Network/Wai/Middleware/AddHeaders.hs +1/−1
- Network/Wai/Middleware/Approot.hs +2/−4
- Network/Wai/Middleware/Autohead.hs +3/−1
- Network/Wai/Middleware/CleanPath.hs +5/−3
- Network/Wai/Middleware/ForceSSL.hs +0/−1
- Network/Wai/Middleware/Gzip.hs +15/−17
- Network/Wai/Middleware/HttpAuth.hs +7/−6
- Network/Wai/Middleware/Jsonp.hs +10/−10
- Network/Wai/Middleware/Local.hs +1/−1
- Network/Wai/Middleware/MethodOverride.hs +0/−1
- Network/Wai/Middleware/MethodOverridePost.hs +6/−3
- Network/Wai/Middleware/RequestLogger.hs +67/−37
- Network/Wai/Middleware/RequestLogger/Internal.hs +6/−2
- Network/Wai/Middleware/RequestLogger/JSON.hs +99/−0
- Network/Wai/Middleware/Rewrite.hs +0/−1
- Network/Wai/Middleware/StreamFile.hs +2/−3
- Network/Wai/Middleware/Vhost.hs +5/−3
- Network/Wai/Parse.hs +2/−2
- Network/Wai/Request.hs +1/−1
- Network/Wai/UrlMap.hs +2/−2
- test/Network/Wai/Middleware/RoutedSpec.hs +2/−2
- wai-extra.cabal +8/−2
ChangeLog.md view
@@ -1,3 +1,8 @@+## 3.0.11++* Add constructor for more detailed custom output formats for RequestLogger+* Add JSON output formatter for RequestLogger+ ## 3.0.10 * Adding Request Body to RequestLogger [#401](https://github.com/yesodweb/wai/pull/401)
Network/Wai/EventSource.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-| A WAI adapter to the HTML5 Server-Sent Events API. -}@@ -8,12 +7,11 @@ eventSourceAppIO ) where -import Blaze.ByteString.Builder (Builder) import Data.Function (fix) import Control.Concurrent.Chan (Chan, dupChan, readChan) import Control.Monad.IO.Class (liftIO)-import Network.HTTP.Types (status200)-import Network.Wai (Application, Response, responseStream)+import Network.HTTP.Types (status200, hContentType)+import Network.Wai (Application, responseStream) import Network.Wai.EventSource.EventStream @@ -30,7 +28,7 @@ eventSourceAppIO src _ sendResponse = sendResponse $ responseStream status200- [("Content-Type", "text/event-stream")]+ [(hContentType, "text/event-stream")] $ \sendChunk flush -> fix $ \loop -> do se <- src case eventToBuilder se of
Network/Wai/EventSource/EventStream.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} {- code adapted by Mathias Billman originaly from Chris Smith https://github.com/cdsmith/gloss-web -} {-|@@ -11,7 +11,9 @@ import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char8+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid+#endif {-| Type representing a communication over an event stream. This can be an
Network/Wai/Handler/CGI.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes, CPP #-} -- | Backend for Common Gateway Interface. Almost all users should use the -- 'run' function. module Network.Wai.Handler.CGI@@ -21,15 +19,16 @@ import Data.Char (toLower) import qualified System.IO import qualified Data.String as String-import Data.Monoid (mconcat, mempty) import Blaze.ByteString.Builder (fromByteString, toLazyByteString, flush) import Blaze.ByteString.Builder.Char8 (fromChar, fromString) import Data.ByteString.Lazy.Internal (defaultChunkSize) import System.IO (Handle)-import Network.HTTP.Types (Status (..))+import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength) import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI-import Data.Monoid (mappend)+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (mconcat, mempty, mappend)+#endif import qualified Data.Streaming.Blaze as Blaze import Data.Function (fix) import Control.Monad (unless, void)@@ -118,7 +117,7 @@ , vault = mempty , requestBodyLength = KnownLength $ fromIntegral contentLength , requestHeaderHost = lookup "host" reqHeaders- , requestHeaderRange = lookup "range" reqHeaders+ , requestHeaderRange = lookup hRange reqHeaders } void $ app env $ \res -> case (xsendfile, res) of@@ -162,13 +161,13 @@ , fromByteString " not supported" ] fixHeaders h =- case lookup "content-type" h of- Nothing -> ("Content-Type", "text/html; charset=utf-8") : h+ case lookup hContentType h of+ Nothing -> (hContentType, "text/html; charset=utf-8") : h Just _ -> h cleanupVarName :: String -> CI.CI B.ByteString-cleanupVarName "CONTENT_TYPE" = "Content-Type"-cleanupVarName "CONTENT_LENGTH" = "Content-Length"+cleanupVarName "CONTENT_TYPE" = hContentType+cleanupVarName "CONTENT_LENGTH" = hContentLength cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name" cleanupVarName s = case s of
Network/Wai/Middleware/AcceptOverride.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Network.Wai.Middleware.AcceptOverride ( acceptOverride ) where
Network/Wai/Middleware/AddHeaders.hs view
@@ -5,7 +5,7 @@ ( addHeaders ) where -import Network.HTTP.Types (ResponseHeaders, Header)+import Network.HTTP.Types (Header) import Network.Wai (Middleware, modifyResponse, mapResponseHeaders) import Network.Wai.Internal (Response(..)) import Data.ByteString (ByteString)
Network/Wai/Middleware/Approot.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-} -- | Middleware for establishing the root of the application. -- -- Many application need the ability to create URLs referring back to the@@ -29,13 +28,12 @@ import Control.Exception (Exception, throw) import Data.ByteString (ByteString)-import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) import qualified Data.Vault.Lazy as V-import Network.Wai (Request, vault, Middleware, requestHeaderHost)-import Network.Wai.Request (appearsSecure, guessApproot)+import Network.Wai (Request, vault, Middleware)+import Network.Wai.Request (guessApproot) import System.Environment (getEnvironment) import System.IO.Unsafe (unsafePerformIO)
Network/Wai/Middleware/Autohead.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} -- | Automatically produce responses to HEAD requests based on the underlying -- applications GET response. module Network.Wai.Middleware.Autohead (autohead) where import Network.Wai+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty)+#endif autohead :: Middleware autohead app req sendResponse
Network/Wai/Middleware/CleanPath.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module Network.Wai.Middleware.CleanPath ( cleanPath ) where@@ -6,9 +6,11 @@ import Network.Wai import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L-import Network.HTTP.Types (status301)+import Network.HTTP.Types (status301, hLocation) import Data.Text (Text)+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat)+#endif cleanPath :: ([Text] -> Either B.ByteString [Text]) -> B.ByteString@@ -19,7 +21,7 @@ Right pieces -> app pieces env sendResponse Left p -> sendResponse $ responseLBS status301- [("Location", mconcat [prefix, p, suffix])]+ [(hLocation, mconcat [prefix, p, suffix])] $ L.empty where -- include the query string if present
Network/Wai/Middleware/ForceSSL.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-} -- | Redirect non-SSL requests to https -- -- Since 3.0.7
Network/Wai/Middleware/Gzip.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Gzip@@ -29,9 +27,8 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString as S import Data.Default.Class-import Network.HTTP.Types (Status, Header)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Resource (runResourceT)+import Network.HTTP.Types ( Status, Header, hContentEncoding, hUserAgent+ , hContentType, hContentLength) import System.Directory (doesFileExist, createDirectoryIfMissing) import Blaze.ByteString.Builder (fromByteString) import Control.Exception (try, SomeException)@@ -45,6 +42,7 @@ import Control.Exception (throwIO) import qualified System.IO as IO import Data.ByteString.Lazy.Internal (defaultChunkSize)+import Data.Word8 (_semicolon) data GzipSettings = GzipSettings { gzipFiles :: GzipFiles@@ -61,7 +59,7 @@ defaultCheckMime bs = S8.isPrefixOf "text/" bs || bs' `Set.member` toCompress where- bs' = fst $ S.breakByte 59 bs -- semicolon+ bs' = fst $ S.break (== _semicolon) bs toCompress = Set.fromList [ "application/json" , "application/javascript"@@ -85,7 +83,7 @@ then case (res, gzipFiles set) of (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->- case lookup "content-type" hs of+ case lookup hContentType hs of Just m | gzipCheckMime set m -> compressFile s hs file cache sendResponse _ -> sendResponse res@@ -94,9 +92,9 @@ where enc = fromMaybe [] $ (splitCommas . S8.unpack) `fmap` lookup "Accept-Encoding" (requestHeaders env)- ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env+ ua = fromMaybe "" $ lookup hUserAgent $ requestHeaders env isMSIE6 = "MSIE 6" `S.isInfixOf` ua- isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res+ isEncoded res = isJust $ lookup hContentEncoding $ responseHeaders res compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a compressFile s hs file cache sendResponse = do@@ -118,7 +116,7 @@ Z.PRNext bs -> do S.hPut outH bs loop- Z.PRError e -> throwIO e+ Z.PRError ex -> throwIO ex fix $ \loop -> do bs <- S.hGetSome inH defaultChunkSize unless (S.null bs) $ do@@ -145,11 +143,11 @@ -> (Response -> IO a) -> IO a compressE set res sendResponse =- case lookup "content-type" hs of+ case lookup hContentType hs of Just m | gzipCheckMime set m -> let hs' = fixHeaders hs in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do- (blazeRecv, blazeFinish) <- B.newBlazeRecv B.defaultStrategy+ (blazeRecv, _) <- B.newBlazeRecv B.defaultStrategy deflate <- Z.initDeflate 1 (Z.WindowBits 31) let sendBuilder builder = do popper <- blazeRecv builder@@ -164,8 +162,8 @@ deflatePopper $ Z.flushDeflate deflate flush deflatePopper popper = fix $ \loop -> do- res <- popper- case res of+ result <- popper+ case result of Z.PRDone -> return () Z.PRNext bs' -> do sendChunk $ fromByteString bs'@@ -183,9 +181,9 @@ -- different length after gzip compression. fixHeaders :: [Header] -> [Header] fixHeaders =- (("Content-Encoding", "gzip") :) . filter notLength+ ((hContentEncoding, "gzip") :) . filter notLength where- notLength (x, _) = x /= "content-length"+ notLength (x, _) = x /= hContentLength splitCommas :: String -> [String] splitCommas [] = []
Network/Wai/Middleware/HttpAuth.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings, TupleSections #-}+{-# LANGUAGE RecordWildCards, TupleSections, CPP #-} -- | Implements HTTP Basic Authentication. -- -- This module may add digest authentication in the future.@@ -14,13 +14,14 @@ , extractBasicAuth , extractBearerAuth ) where-+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Data.ByteString (ByteString) import Data.ByteString.Base64 (decodeLenient) import Data.String (IsString (..)) import Data.Word8 (isSpace, _colon, toLower)-import Network.HTTP.Types (status401)+import Network.HTTP.Types (status401, hContentType, hAuthorization) import Network.Wai import qualified Data.ByteString as S@@ -47,7 +48,7 @@ else authOnNoAuth authRealm req sendResponse where check =- case (lookup "Authorization" $ requestHeaders req)+ case (lookup hAuthorization $ requestHeaders req) >>= extractBasicAuth of Nothing -> return False Just (username, password) -> checkCreds username password@@ -84,7 +85,7 @@ { authRealm = fromString s , authOnNoAuth = \realm _req f -> f $ responseLBS status401- [ ("Content-Type", "text/plain")+ [ (hContentType, "text/plain") , ("WWW-Authenticate", S.concat [ "Basic realm=\"" , realm@@ -108,7 +109,7 @@ where extract encoded = let raw = decodeLenient encoded- (username, password') = S.breakByte _colon raw+ (username, password') = S.break (== _colon) raw in ((username,) . snd) <$> S.uncons password' -- | Extract bearer authentication data from __Authorization__ header
Network/Wai/Middleware/Jsonp.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, CPP #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Jsonp@@ -19,14 +18,15 @@ import Network.Wai.Internal import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8-import Blaze.ByteString.Builder (Builder, copyByteString)+import Blaze.ByteString.Builder (copyByteString) import Blaze.ByteString.Builder.Char8 (fromChar)+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mappend)+#endif import Control.Monad (join) import Data.Maybe (fromMaybe) import qualified Data.ByteString as S-import Data.CaseInsensitive (CI)-import Network.HTTP.Types (Status)+import Network.HTTP.Types (hAccept, hContentType) -- | Wrap json responses in a jsonp callback. --@@ -37,7 +37,7 @@ -- callback function. jsonp :: Middleware jsonp app env sendResponse = do- let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env+ let accept = fromMaybe B8.empty $ lookup hAccept $ requestHeaders env let callback :: Maybe B8.ByteString callback = if B8.pack "text/javascript" `B8.isInfixOf` accept@@ -47,7 +47,7 @@ case callback of Nothing -> env Just _ -> env- { requestHeaders = changeVal "Accept"+ { requestHeaders = changeVal hAccept "application/json" $ requestHeaders env }@@ -72,17 +72,17 @@ (s, hs, wb) = responseToStream r checkJSON hs =- case lookup "Content-Type" hs of+ case lookup hContentType hs of Just x | B8.pack "application/json" `S.isPrefixOf` x -> Just $ fixHeaders hs _ -> Nothing- fixHeaders = changeVal "Content-Type" "text/javascript"+ fixHeaders = changeVal hContentType "text/javascript" addCallback cb s hs wb = wb $ \body -> sendResponse $ responseStream s hs $ \sendChunk flush -> do sendChunk $ copyByteString cb `mappend` fromChar '('- body sendChunk flush+ _ <- body sendChunk flush sendChunk $ fromChar ')' changeVal :: Eq a
Network/Wai/Middleware/Local.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE CPP #-} -- | Only allow local connections. -- module Network.Wai.Middleware.Local
Network/Wai/Middleware/MethodOverride.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.MethodOverride ( methodOverride ) where
Network/Wai/Middleware/MethodOverridePost.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------- -- | Module : Network.Wai.Middleware.MethodOverridePost --@@ -9,8 +9,11 @@ ) where import Network.Wai-import Network.HTTP.Types (parseQuery)+import Network.HTTP.Types (parseQuery, hContentType)++#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat, mempty)+#endif import Data.IORef import Data.ByteString.Lazy (toChunks) @@ -27,7 +30,7 @@ -- methodOverridePost :: Middleware methodOverridePost app req send =- case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of+ case (requestMethod req, lookup hContentType (requestHeaders req)) of ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send _ -> app req send
Network/Wai/Middleware/RequestLogger.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}- -- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should -- not use CPP. module Network.Wai.Middleware.RequestLogger@@ -15,12 +13,14 @@ , destination , OutputFormat (..) , OutputFormatter+ , OutputFormatterWithDetails , Destination (..) , Callback , IPAddrSource (..) ) where import System.IO (Handle, stdout)+import qualified Blaze.ByteString.Builder as B import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack, unpack) import Control.Monad.IO.Class (liftIO)@@ -29,18 +29,15 @@ import Network.HTTP.Types as H import Data.Maybe (fromMaybe) import Data.Monoid (mconcat, (<>))-import Data.Time (getCurrentTime, diffUTCTime)--import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)+import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)+import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File+ , getRequestBodyType) import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Char8 as S8- import System.Console.ANSI import Data.IORef.Lifted import System.IO.Unsafe-import Control.Monad (unless)-import Network.Wai.Internal (Response (ResponseRaw))-+import Network.Wai.Internal (Response (..)) import Data.Default.Class (Default (def)) import Network.Wai.Logger import Network.Wai.Middleware.RequestLogger.Internal@@ -49,8 +46,11 @@ data OutputFormat = Apache IPAddrSource | Detailed Bool -- ^ use colors? | CustomOutputFormat OutputFormatter+ | CustomOutputFormatWithDetails OutputFormatterWithDetails type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr+type OutputFormatterWithDetails =+ ZonedDate -> Request -> Status -> Maybe Integer -> NominalDiffTime -> [S8.ByteString] -> B.Builder -> LogStr data Destination = Handle Handle | Logger LoggerSet@@ -98,12 +98,15 @@ (\str -> callback str >> flusher) useColors CustomOutputFormat formatter -> do+ getDate <- getDateGetter flusher+ return $ customMiddleware callback getDate formatter+ CustomOutputFormatWithDetails formatter -> do getdate <- getDateGetter flusher- return $ customMiddleware callback getdate formatter+ return $ customMiddlewareWithDetails callback getdate formatter apacheMiddleware :: ApacheLoggerActions -> Middleware apacheMiddleware ala app req sendResponse = app req $ \res -> do- let msize = lookup "content-length" (responseHeaders res) >>= readInt'+ let msize = lookup H.hContentLength (responseHeaders res) >>= readInt' readInt' bs = case S8.readInteger bs of Just (i, "") -> Just i@@ -118,6 +121,22 @@ liftIO $ cb $ formatter date req (responseStatus res) Nothing sendResponse res +customMiddlewareWithDetails :: Callback -> IO ZonedDate -> OutputFormatterWithDetails -> Middleware+customMiddlewareWithDetails cb getdate formatter app req sendResponse = do+ (req', reqBody) <- getRequestBody req+ t0 <- getCurrentTime+ app req' $ \res -> do+ t1 <- getCurrentTime+ date <- liftIO getdate+ -- We use Nothing for the response size since we generally don't know it+ builderIO <- newIORef $ B.fromByteString ""+ res' <- recordChunks builderIO res+ rspRcv <- sendResponse res'+ _ <- liftIO . cb .+ formatter date req' (responseStatus res') Nothing (t1 `diffUTCTime` t0) reqBody =<<+ readIORef builderIO+ return rspRcv+ -- | Production request logger middleware. {-# NOINLINE logStdout #-} logStdout :: Middleware@@ -187,40 +206,51 @@ "5" -> ansiColor' Magenta t _ -> ansiColor' Blue t +recordChunks :: IORef B.Builder -> Response -> IO Response+recordChunks i (ResponseStream s h sb) =+ return . ResponseStream s h $ (\send flush -> sb (\b -> modifyIORef i (<> b) >> send b) flush)+recordChunks i (ResponseBuilder s h b) =+ modifyIORef i (<> b) >> (return $ ResponseBuilder s h b)+recordChunks _ r =+ return r++getRequestBody :: Request -> IO (Request, [S8.ByteString])+getRequestBody req = do+ let loop front = do+ bs <- requestBody req+ if S8.null bs+ then return $ front []+ else loop $ front . (bs:)+ body <- loop id+ -- logging the body here consumes it, so fill it back up+ -- obviously not efficient, but this is the development logger+ --+ -- Note: previously, we simply used CL.sourceList. However,+ -- that meant that you could read the request body in twice.+ -- While that in itself is not a problem, the issue is that,+ -- in production, you wouldn't be able to do this, and+ -- therefore some bugs wouldn't show up during testing. This+ -- implementation ensures that each chunk is only returned+ -- once.+ ichunks <- newIORef body+ let rbody = atomicModifyIORef ichunks $ \chunks ->+ case chunks of+ [] -> ([], S8.empty)+ x:y -> (y, x)+ let req' = req { requestBody = rbody }+ return (req', body)+ detailedMiddleware' :: Callback -> (Color -> BS.ByteString -> [BS.ByteString]) -> (BS.ByteString -> [BS.ByteString]) -> (BS.ByteString -> BS.ByteString -> [BS.ByteString]) -> Middleware detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do- let mlen = lookup "content-length" (requestHeaders req) >>= readInt+ let mlen = lookup H.hContentLength (requestHeaders req) >>= readInt (req', body) <- case mlen of -- log the request body if it is small- Just len | len <= 2048 -> do- let loop front = do- bs <- requestBody req- if S8.null bs- then return $ front []- else loop $ front . (bs:)- body <- loop id- -- logging the body here consumes it, so fill it back up- -- obviously not efficient, but this is the development logger- --- -- Note: previously, we simply used CL.sourceList. However,- -- that meant that you could read the request body in twice.- -- While that in itself is not a problem, the issue is that,- -- in production, you wouldn't be able to do this, and- -- therefore some bugs wouldn't show up during testing. This- -- implementation ensures that each chunk is only returned- -- once.- ichunks <- newIORef body- let rbody = atomicModifyIORef ichunks $ \chunks ->- case chunks of- [] -> ([], S8.empty)- x:y -> (y, x)- let req' = req { requestBody = rbody }- return (req', body)+ Just len | len <= 2048 -> getRequestBody req _ -> return (req, []) let reqbodylog _ = if null body then [""] else ansiColor White " Request Body: " <> body <> ["\n"]@@ -231,7 +261,7 @@ return $ collectPostParams postParams let getParams = map emptyGetParam $ queryString req- accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req+ accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req params = let par | not $ null postParams = [pack (show postParams)] | not $ null getParams = [pack (show getParams)] | otherwise = []
Network/Wai/Middleware/RequestLogger/Internal.hs view
@@ -8,9 +8,10 @@ import Data.ByteString (ByteString) import Network.Wai.Logger (clockDateCacher)+#if !MIN_VERSION_wai_logger(2, 2, 0) import Control.Concurrent (forkIO, threadDelay) import Control.Monad (forever)-+#endif import System.Log.FastLogger (LogStr, fromLogStr) logToByteString :: LogStr -> ByteString@@ -18,12 +19,15 @@ getDateGetter :: IO () -- ^ flusher -> IO (IO ByteString)+#if !MIN_VERSION_wai_logger(2, 2, 0) getDateGetter flusher = do (getter, updater) <- clockDateCacher-#if !MIN_VERSION_wai_logger(2, 2, 0) _ <- forkIO $ forever $ do threadDelay 1000000 updater flusher+#else+getDateGetter _ = do+ (getter, _) <- clockDateCacher #endif return getter
+ Network/Wai/Middleware/RequestLogger/JSON.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE RecordWildCards #-}++module Network.Wai.Middleware.RequestLogger.JSON (formatAsJSON) where++import qualified Blaze.ByteString.Builder as BB+import Data.Aeson+import Data.CaseInsensitive (original)+import Data.Monoid ((<>))+import qualified Data.ByteString.Char8 as S8+import Data.IP+import qualified Data.Text as T+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import Data.Time (NominalDiffTime)+import Data.Word (Word32)+import Network.HTTP.Types as H+import Network.Socket (SockAddr (..), PortNumber)+import Network.Wai+import Network.Wai.Middleware.RequestLogger+import System.Log.FastLogger (toLogStr)+import Text.Printf (printf)++formatAsJSON :: OutputFormatterWithDetails+formatAsJSON date req status responseSize duration reqBody response =+ toLogStr (encode $+ object+ [ "request" .= requestToJSON duration req reqBody+ , "response" .=+ object+ [ "status" .= statusCode status+ , "size" .= responseSize+ , "body" .=+ if statusCode status >= 400+ then Just . decodeUtf8 . BB.toByteString $ response+ else Nothing+ ]+ , "time" .= decodeUtf8 date+ ]) <> "\n"++word32ToHostAddress :: Word32 -> Text+word32ToHostAddress = T.intercalate "." . map (T.pack . show) . fromIPv4 . fromHostAddress++readAsDouble :: String -> Double+readAsDouble = read++requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value+requestToJSON duration req reqBody =+ object+ [ "method" .= decodeUtf8 (requestMethod req)+ , "path" .= decodeUtf8 (rawPathInfo req)+ , "queryString" .= map queryItemToJSON (queryString req)+ , "durationMs" .= (readAsDouble . printf "%.2f" . rationalToDouble $ toRational duration * 1000)+ , "size" .= requestBodyLengthToJSON (requestBodyLength req)+ , "body" .= decodeUtf8 (S8.concat reqBody)+ , "remoteHost" .= sockToJSON (remoteHost req)+ , "httpVersion" .= httpVersionToJSON (httpVersion req)+ , "headers" .= requestHeadersToJSON (requestHeaders req)+ ]+ where+ rationalToDouble :: Rational -> Double+ rationalToDouble = fromRational++sockToJSON :: SockAddr -> Value+sockToJSON (SockAddrInet pn ha) =+ object+ [ "port" .= portToJSON pn+ , "hostAddress" .= word32ToHostAddress ha+ ]+sockToJSON (SockAddrInet6 pn _ ha _) =+ object+ [ "port" .= portToJSON pn+ , "hostAddress" .= ha+ ]+sockToJSON (SockAddrUnix sock) =+ object [ "unix" .= sock ]+sockToJSON (SockAddrCan i) =+ object [ "can" .= i ]++queryItemToJSON :: QueryItem -> Value+queryItemToJSON (name, mValue) = toJSON (decodeUtf8 name, fmap decodeUtf8 mValue)++requestHeadersToJSON :: RequestHeaders -> Value+requestHeadersToJSON = toJSON . map hToJ where+ -- Redact cookies+ hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text)+ hToJ hd = headerToJSON hd++headerToJSON :: Header -> Value+headerToJSON (headerName, header) = toJSON (decodeUtf8 . original $ headerName, decodeUtf8 header)++portToJSON :: PortNumber -> Value+portToJSON = toJSON . toInteger++httpVersionToJSON :: HttpVersion -> Value+httpVersionToJSON (HttpVersion major minor) = String $ T.pack (show major) <> "." <> T.pack (show minor)++requestBodyLengthToJSON :: RequestBodyLength -> Value+requestBodyLengthToJSON ChunkedBody = String "Unknown"+requestBodyLengthToJSON (KnownLength l) = toJSON l
Network/Wai/Middleware/Rewrite.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.Rewrite ( rewrite, rewritePure ) where
Network/Wai/Middleware/StreamFile.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | -- -- Since 3.0.4@@ -11,6 +9,7 @@ import Network.Wai (Middleware, responseToStream) import qualified Data.ByteString.Char8 as S8 import System.PosixCompat (getFileStatus, fileSize, FileOffset)+import Network.HTTP.Types (hContentLength) -- |Convert ResponseFile type responses into ResponseStream type --@@ -34,7 +33,7 @@ sendBody :: StreamingBody -> IO ResponseReceived sendBody body = do len <- getFileSize fp- let hs' = ("Content-Length", (S8.pack (show len))) : hs+ let hs' = (hContentLength, (S8.pack (show len))) : hs sendResponse $ responseStream s hs' body _ -> sendResponse res
Network/Wai/Middleware/Vhost.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where+{-# LANGUAGE CPP #-}+ module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where import Network.Wai @@ -7,7 +7,9 @@ import qualified Data.Text.Encoding as TE import Data.Text (Text) import qualified Data.ByteString as BS+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mappend)+#endif vhost :: [(Request -> Bool, Application)] -> Application -> Application vhost vhosts def req =@@ -27,7 +29,7 @@ redirectTo :: BS.ByteString -> Response redirectTo location = responseLBS H.status301- [ ("Content-Type", "text/plain") , ("Location", location) ] "Redirect"+ [ (H.hContentType, "text/plain") , (H.hLocation, location) ] "Redirect" redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response redirectToLogged logger loc = do
Network/Wai/Parse.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeFamilies #-}@@ -45,6 +44,7 @@ import Control.Monad (when, unless) import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState) import Data.IORef+import Network.HTTP.Types (hContentType) breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s =@@ -140,7 +140,7 @@ getRequestBodyType :: Request -> Maybe RequestBodyType getRequestBodyType req = do- ctype' <- lookup "Content-Type" $ requestHeaders req+ ctype' <- lookup hContentType $ requestHeaders req let (ctype, attrs) = parseContentType ctype' case ctype of "application/x-www-form-urlencoded" -> return UrlEncoded
Network/Wai/Request.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Some helpers for interrogating a WAI 'Request'. module Network.Wai.Request@@ -32,6 +31,7 @@ , ("HTTP_X_FORWARDED_SSL" , (== "on")) , ("HTTP_X_FORWARDED_SCHEME", (== "https")) , ("HTTP_X_FORWARDED_PROTO" , ((== ["https"]) . take 1 . C.split ','))+ , ("X-Forwarded-Proto" , (== "https")) -- Used by Nginx and AWS ELB. ] where
Network/Wai/UrlMap.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-} {- | This module gives you a way to mount applications under sub-URIs. For example:@@ -93,7 +93,7 @@ Nothing -> sendResponse $ responseLBS status404- [("content-type", "text/plain")]+ [(hContentType, "text/plain")] "Not found\n" where
test/Network/Wai/Middleware/RoutedSpec.hs view
@@ -9,7 +9,7 @@ import Network.Wai.Middleware.Routed import Network.Wai.Middleware.ForceSSL (forceSSL) -import Network.HTTP.Types (methodPost, status200, status301, status307)+import Network.HTTP.Types (hContentType, status200) import Network.Wai import Network.Wai.Test import Data.ByteString (ByteString)@@ -39,7 +39,7 @@ jsonApp :: Application jsonApp _req cps = cps $ responseLBS status200- [("Content-Type", "application/json")]+ [(hContentType, "application/json")] "{\"foo\":\"bar\"}" testDPath :: ByteString -> Session SResponse
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 3.0.10+Version: 3.0.10.1 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality:@@ -87,7 +87,7 @@ , wai >= 3.0.3.0 && < 3.1 , old-locale >= 1.0.0.2 && < 1.1 , time >= 1.1.4- , network >= 2.2.1.5+ , network >= 2.6.1.0 , directory >= 1.0.1 , transformers >= 0.2.2 , blaze-builder >= 0.2.1.4 && < 0.5@@ -110,12 +110,17 @@ , unix-compat , cookie , vault+ , zlib+ , aeson+ , iproute if os(windows) cpp-options: -DWINDOWS else build-depends: unix + extensions: OverloadedStrings+ Exposed-modules: Network.Wai.Handler.CGI Network.Wai.Handler.SCGI Network.Wai.Middleware.AcceptOverride@@ -125,6 +130,7 @@ Network.Wai.Middleware.CleanPath Network.Wai.Middleware.Local Network.Wai.Middleware.RequestLogger+ Network.Wai.Middleware.RequestLogger.JSON Network.Wai.Middleware.Gzip Network.Wai.Middleware.Jsonp Network.Wai.Middleware.MethodOverride