wai-extra 3.1.8 → 3.1.9
raw patch · 49 files changed
+560/−460 lines, 49 filesdep ~http2dep ~wai
Dependency ranges changed: http2, wai
Files
- ChangeLog.md +4/−0
- Network/Wai/EventSource.hs +8/−8
- Network/Wai/EventSource/EventStream.hs +4/−4
- Network/Wai/Handler/CGI.hs +23/−26
- Network/Wai/Handler/SCGI.hs +9/−8
- Network/Wai/Header.hs +1/−1
- Network/Wai/Middleware/AcceptOverride.hs +1/−1
- Network/Wai/Middleware/AddHeaders.hs +7/−7
- Network/Wai/Middleware/Approot.hs +13/−12
- Network/Wai/Middleware/Autohead.hs +1/−2
- Network/Wai/Middleware/CleanPath.hs +9/−7
- Network/Wai/Middleware/ForceDomain.hs +9/−4
- Network/Wai/Middleware/ForceSSL.hs +5/−3
- Network/Wai/Middleware/Gzip.hs +110/−89
- Network/Wai/Middleware/HealthCheckEndpoint.hs +37/−0
- Network/Wai/Middleware/HttpAuth.hs +9/−7
- Network/Wai/Middleware/Jsonp.hs +9/−8
- Network/Wai/Middleware/Local.hs +5/−6
- Network/Wai/Middleware/MethodOverride.hs +1/−1
- Network/Wai/Middleware/MethodOverridePost.hs +5/−6
- Network/Wai/Middleware/RealIp.hs +3/−3
- Network/Wai/Middleware/RequestLogger.hs +30/−23
- Network/Wai/Middleware/RequestLogger/Internal.hs +4/−3
- Network/Wai/Middleware/RequestLogger/JSON.hs +9/−6
- Network/Wai/Middleware/RequestSizeLimit.hs +14/−10
- Network/Wai/Middleware/RequestSizeLimit/Internal.hs +1/−1
- Network/Wai/Middleware/Rewrite.hs +7/−7
- Network/Wai/Middleware/Routed.hs +1/−1
- Network/Wai/Middleware/StreamFile.hs +3/−4
- Network/Wai/Middleware/StripHeaders.hs +3/−3
- Network/Wai/Middleware/Vhost.hs +10/−5
- Network/Wai/Parse.hs +27/−21
- Network/Wai/Request.hs +9/−10
- Network/Wai/Test.hs +18/−19
- Network/Wai/Test/Internal.hs +4/−4
- Network/Wai/UrlMap.hs +7/−6
- example/Main.hs +2/−2
- test/Network/Wai/Middleware/ApprootSpec.hs +5/−5
- test/Network/Wai/Middleware/ForceSSLSpec.hs +7/−4
- test/Network/Wai/Middleware/RealIpSpec.hs +3/−3
- test/Network/Wai/Middleware/RequestSizeLimitSpec.hs +42/−36
- test/Network/Wai/Middleware/RoutedSpec.hs +5/−6
- test/Network/Wai/Middleware/StripHeadersSpec.hs +8/−7
- test/Network/Wai/Middleware/TimeoutSpec.hs +2/−3
- test/Network/Wai/ParseSpec.hs +18/−12
- test/Network/Wai/RequestSpec.hs +4/−5
- test/Network/Wai/TestSpec.hs +11/−21
- test/WaiExtraSpec.hs +27/−29
- wai-extra.cabal +6/−1
ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog for wai-extra +## 3.1.9++* Added `HealthCheckEndpoint` `Middleware`s for health check [#877](https://github.com/yesodweb/wai/pull/877)+ ## 3.1.8 * Added an `ApacheWithSettings` output format for `RequestLogger` that allows request filtering similar to `DetailedWithSettings` and logging of the current user via wai-logger's `initLoggerUser` [#866](https://github.com/yesodweb/wai/pull/866)
Network/Wai/EventSource.hs view
@@ -9,17 +9,17 @@ There is a small example using these functions in the @example@ directory. -} module Network.Wai.EventSource (- ServerEvent(..),+ ServerEvent (..), eventSourceAppChan, eventSourceAppIO,- eventStreamAppRaw- ) where+ eventStreamAppRaw,+) where -import Data.Function (fix)-import Control.Concurrent.Chan (Chan, dupChan, readChan)-import Control.Monad.IO.Class (liftIO)-import Network.HTTP.Types (status200, hContentType)-import Network.Wai (Application, responseStream)+import Control.Concurrent.Chan (Chan, dupChan, readChan)+import Control.Monad.IO.Class (liftIO)+import Data.Function (fix)+import Network.HTTP.Types (hContentType, status200)+import Network.Wai (Application, responseStream) import Network.Wai.EventSource.EventStream
Network/Wai/EventSource/EventStream.hs view
@@ -5,9 +5,9 @@ Internal module, usually you don't need to use it. -} module Network.Wai.EventSource.EventStream (- ServerEvent(..),- eventToBuilder- ) where+ ServerEvent (..),+ eventToBuilder,+) where import Data.ByteString.Builder #if __GLASGOW_HASKELL__ < 710@@ -68,7 +68,7 @@ eventToBuilder (RetryEvent n) = Just $ field retryField (string8 . show $ n) eventToBuilder (CloseEvent) = Nothing eventToBuilder (ServerEvent n i d)= Just $- (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl+ name n (evid i $ mconcat (map (field dataField) d)) `mappend` nl where name Nothing = id name (Just n') = mappend (field nameField n')
Network/Wai/Handler/CGI.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE RankNTypes, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} -- | Backend for Common Gateway Interface. Almost all users should use the -- 'run' function. module Network.Wai.Handler.CGI@@ -8,35 +9,33 @@ , requestBodyFunc ) where -import Network.Wai-import Network.Wai.Internal-import Network.Socket (getAddrInfo, addrAddress)-import Data.IORef-import Data.Maybe (fromMaybe)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy as L+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (mconcat, mempty, mappend)+#endif import Control.Arrow ((***))-import Data.Char (toLower)-import qualified System.IO-import qualified Data.String as String-import Data.ByteString.Builder (byteString, toLazyByteString, char7, string8)+import Control.Monad (unless, void)+import Data.ByteString.Builder (byteString, char7, string8, toLazyByteString) import Data.ByteString.Builder.Extra (flush)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Internal (defaultChunkSize)-import System.IO (Handle)-import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength)-import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (mconcat, mempty, mappend)-#endif--import qualified Data.Streaming.ByteString.Builder as Builder+import Data.Char (toLower) import Data.Function (fix)-import Control.Monad (unless, void)-+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import qualified Data.Streaming.ByteString.Builder as Builder+import qualified Data.String as String+import Network.HTTP.Types (Status (..), hContentLength, hContentType, hRange)+import qualified Network.HTTP.Types as H+import Network.Socket (addrAddress, getAddrInfo)+import Network.Wai+import Network.Wai.Internal #if WINDOWS import System.Environment (getEnvironment) #else+import System.IO (Handle)+import qualified System.IO import qualified System.Posix.Env.ByteString as Env getEnvironment :: IO [(String, String)]@@ -90,9 +89,7 @@ case lookup "REMOTE_ADDR" vars of Just x -> x Nothing ->- case lookup "REMOTE_HOST" vars of- Just x -> x- Nothing -> ""+ fromMaybe "" $ lookup "REMOTE_HOST" vars isSecure' = case map toLower $ lookup' "SERVER_PROTOCOL" vars of "https" -> True@@ -160,7 +157,7 @@ ] sfBuilder s hs sf fp = mconcat [ headers s hs- , header $ (byteString sf, string8 fp)+ , header (byteString sf, string8 fp) , char7 '\n' , byteString sf , byteString " not supported"
Network/Wai/Handler/SCGI.hs view
@@ -1,20 +1,21 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-} module Network.Wai.Handler.SCGI ( run , runSendfile ) where -import Network.Wai-import Network.Wai.Handler.CGI (runGeneric, requestBodyFunc)-import Foreign.Ptr-import Foreign.Marshal.Alloc-import Foreign.C import Data.ByteString (ByteString) import qualified Data.ByteString as S-import qualified Data.ByteString.Unsafe as S import qualified Data.ByteString.Char8 as S8-import Data.IORef import Data.ByteString.Lazy.Internal (defaultChunkSize)+import qualified Data.ByteString.Unsafe as S+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Foreign.C (CChar, CInt (..))+import Foreign.Marshal.Alloc (free, mallocBytes)+import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Network.Wai (Application)+import Network.Wai.Handler.CGI (requestBodyFunc, runGeneric) run :: Application -> IO () run app = runOne Nothing app >> run app
Network/Wai/Header.hs view
@@ -14,5 +14,5 @@ readInt :: S8.ByteString -> Maybe Integer readInt bs = case S8.readInteger bs of- Just (i, rest) | S8.null rest -> Just i+ Just (i, rest) | S8.null rest -> Just i _ -> Nothing
Network/Wai/Middleware/AcceptOverride.hs view
@@ -2,9 +2,9 @@ ( acceptOverride ) where -import Network.Wai import Control.Monad (join) import Data.ByteString (ByteString)+import Network.Wai acceptOverride :: Middleware acceptOverride app req =
Network/Wai/Middleware/AddHeaders.hs view
@@ -5,14 +5,14 @@ ( addHeaders ) where -import Network.HTTP.Types (Header)-import Network.Wai (Middleware, modifyResponse, mapResponseHeaders)-import Network.Wai.Internal (Response(..))-import Data.ByteString (ByteString)--import qualified Data.CaseInsensitive as CI import Control.Arrow (first)+import Data.ByteString (ByteString)+import qualified Data.CaseInsensitive as CI+import Network.HTTP.Types (Header)+import Network.Wai (Middleware, mapResponseHeaders, modifyResponse)+import Network.Wai.Internal (Response (..)) + addHeaders :: [(ByteString, ByteString)] -> Middleware -- ^ Prepend a list of headers without any checks --@@ -21,4 +21,4 @@ addHeaders h = modifyResponse $ addHeaders' (map (first CI.mk) h) addHeaders' :: [Header] -> Response -> Response-addHeaders' h = mapResponseHeaders (\hs -> h ++ hs)+addHeaders' h = mapResponseHeaders (h ++)
Network/Wai/Middleware/Approot.hs view
@@ -26,17 +26,18 @@ , getApprootMay ) where -import Control.Exception (Exception, throw)-import Data.ByteString (ByteString)+import Control.Exception (Exception, throw)+import Data.ByteString (ByteString) 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)-import Network.Wai.Request (guessApproot)-import System.Environment (getEnvironment)-import System.IO.Unsafe (unsafePerformIO)+import Data.Maybe (fromMaybe)+import Data.Typeable (Typeable)+import qualified Data.Vault.Lazy as V+import Network.Wai (Middleware, Request, vault)+import System.Environment (getEnvironment)+import System.IO.Unsafe (unsafePerformIO) +import Network.Wai.Request (guessApproot)+ approotKey :: V.Key ByteString approotKey = unsafePerformIO V.newKey {-# NOINLINE approotKey #-}@@ -70,9 +71,9 @@ envFallbackNamed :: String -> IO Middleware envFallbackNamed name = do env <- getEnvironment- case lookup name env of- Just s -> return $ hardcoded $ S8.pack s- Nothing -> return fromRequest+ pure $ case lookup name env of+ Just s -> hardcoded $ S8.pack s+ Nothing -> fromRequest -- | Hard-code the given value as the approot. --
Network/Wai/Middleware/Autohead.hs view
@@ -3,10 +3,10 @@ -- applications GET response. module Network.Wai.Middleware.Autohead (autohead) where -import Network.Wai #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) #endif+import Network.Wai (Middleware, requestMethod, responseBuilder, responseToStream) autohead :: Middleware autohead app req sendResponse@@ -14,4 +14,3 @@ let (s, hs, _) = responseToStream res sendResponse $ responseBuilder s hs mempty | otherwise = app req sendResponse-
Network/Wai/Middleware/CleanPath.hs view
@@ -3,14 +3,14 @@ ( cleanPath ) where -import Network.Wai import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L-import Network.HTTP.Types (status301, hLocation)-import Data.Text (Text) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat) #endif+import Data.Text (Text)+import Network.HTTP.Types (hLocation, status301)+import Network.Wai (Application, pathInfo, rawQueryString, responseLBS) cleanPath :: ([Text] -> Either B.ByteString [Text]) -> B.ByteString@@ -19,10 +19,12 @@ cleanPath splitter prefix app env sendResponse = case splitter $ pathInfo env of Right pieces -> app pieces env sendResponse- Left p -> sendResponse- $ responseLBS status301- [(hLocation, mconcat [prefix, p, suffix])]- $ L.empty+ Left p ->+ sendResponse $+ responseLBS+ status301+ [(hLocation, mconcat [prefix, p, suffix])]+ L.empty where -- include the query string if present suffix =
Network/Wai/Middleware/ForceDomain.hs view
@@ -1,15 +1,20 @@+{-# LANGUAGE CPP #-} -- | -- -- @since 3.0.14 module Network.Wai.Middleware.ForceDomain where import Data.ByteString (ByteString)-import Data.Monoid ((<>), mempty)+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (mempty)+#endif+#endif import Network.HTTP.Types (hLocation, methodGet, status301, status307)-import Prelude+import Network.Wai (Middleware, Request (..), responseBuilder) -import Network.Wai-import Network.Wai.Request+import Network.Wai.Request (appearsSecure) -- | Force a domain by redirecting. -- The `checkDomain` function takes the current domain and checks whether it is correct.
Network/Wai/Middleware/ForceSSL.hs view
@@ -6,16 +6,18 @@ ( forceSSL ) where -import Network.Wai-import Network.Wai.Request #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) import Data.Monoid (mempty) #endif-+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>))+#endif import Network.HTTP.Types (hLocation, methodGet, status301, status307)+import Network.Wai (Middleware, Request (..), Response, responseBuilder)++import Network.Wai.Request (appearsSecure) -- | For requests that don't appear secure, redirect to https --
Network/Wai/Middleware/Gzip.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Gzip@@ -22,30 +23,36 @@ , defaultCheckMime ) where -import Network.Wai-import Data.Maybe (fromMaybe, isJust)-import qualified Data.ByteString.Char8 as S8+import Control.Exception (SomeException, throwIO, try)+import Control.Monad (unless) import qualified Data.ByteString as S-import Data.Default.Class-import Network.HTTP.Types ( Status, Header, hContentEncoding, hUserAgent- , hContentType, hContentLength)-import Network.HTTP.Types.Header (hVary)-import System.Directory (doesFileExist, createDirectoryIfMissing) import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Builder.Extra as Blaze (flush)-import Control.Exception (try, SomeException)+import qualified Data.ByteString.Char8 as S8+import Data.ByteString.Lazy.Internal (defaultChunkSize)+import Data.Default.Class (Default (..))+import Data.Function (fix)+import Data.Maybe (isJust) import qualified Data.Set as Set-import Network.Wai.Header-import Network.Wai.Internal import qualified Data.Streaming.ByteString.Builder as B import qualified Data.Streaming.Zlib as Z-import Control.Monad (unless)-import Data.Function (fix)-import Control.Exception (throwIO)+import Data.Word8 (_comma, _semicolon, _space)+import Network.HTTP.Types (+ Header,+ Status,+ hContentEncoding,+ hContentLength,+ hContentType,+ hUserAgent,+ )+import Network.HTTP.Types.Header (hAcceptEncoding, hVary)+import Network.Wai+import Network.Wai.Internal (Response (..))+import System.Directory (createDirectoryIfMissing, doesFileExist) import qualified System.IO as IO-import Data.ByteString.Lazy.Internal (defaultChunkSize)-import Data.Word8 (_semicolon, _space, _comma) +import Network.Wai.Header (contentLength)+ data GzipSettings = GzipSettings { gzipFiles :: GzipFiles , gzipCheckMime :: S.ByteString -> Bool@@ -94,49 +101,67 @@ -- Will only be applied based on the 'gzipCheckMime' setting. For default -- behavior, see 'defaultCheckMime'. gzip :: GzipSettings -> Middleware-gzip set app env sendResponse' = app env $ \res ->- case res of- ResponseRaw{} -> sendResponse res- ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res- _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) && (bigEnough res)- then- let runAction x = case x of- (ResponseFile s hs file Nothing, GzipPreCompressed nextAction) ->- let- compressedVersion = file ++ ".gz"- in- doesFileExist compressedVersion >>= \y ->- if y- then (sendResponse $ ResponseFile s (fixHeaders hs) compressedVersion Nothing)- else (runAction (ResponseFile s hs file Nothing, nextAction))- (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->- case lookup hContentType hs of- Just m- | gzipCheckMime set m -> compressFile s hs file cache sendResponse- _ -> sendResponse res- (ResponseFile {}, GzipIgnore) -> sendResponse res- _ -> compressE set res sendResponse- in runAction (res, gzipFiles set)- else sendResponse res+gzip set app req sendResponse'+ | skipCompress = app req sendResponse+ | otherwise = app req . checkCompress $ \res ->+ let runAction x = case x of+ (ResponseRaw{}, _) -> sendResponse res+ -- Always skip if 'GzipIgnore'+ (ResponseFile {}, GzipIgnore) -> sendResponse res+ -- If there's a compressed version of the file, we send that.+ (ResponseFile s hs file Nothing, GzipPreCompressed nextAction) ->+ let compressedVersion = file ++ ".gz"+ in doesFileExist compressedVersion >>= \y ->+ if y+ then sendResponse $ ResponseFile s (fixHeaders hs) compressedVersion Nothing+ else runAction (ResponseFile s hs file Nothing, nextAction)+ -- Skip if it's not a MIME type we want to compress+ _ | not $ isCorrectMime (responseHeaders res) -> sendResponse res+ -- Use static caching logic+ (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->+ compressFile s hs file cache sendResponse+ -- Use streaming logic+ _ -> compressE res sendResponse+ in runAction (res, gzipFiles set) where+ isCorrectMime =+ maybe False (gzipCheckMime set) . lookup hContentType sendResponse = sendResponse' . mapResponseHeaders (vary:) vary = (hVary, "Accept-Encoding")- enc = fromMaybe [] $ splitCommas- `fmap` lookup "Accept-Encoding" (requestHeaders env)- ua = fromMaybe "" $ lookup hUserAgent $ requestHeaders env- isMSIE6 = "MSIE 6" `S.isInfixOf` ua- isEncoded res = isJust $ lookup hContentEncoding $ responseHeaders res - bigEnough rsp = case contentLength (responseHeaders rsp) of- Nothing -> True -- This could be a streaming case- Just len -> len >= minimumLength+ -- Can we skip from just looking at the 'Request'?+ skipCompress =+ not acceptsGZipEncoding || isMSIE6+ where+ reqHdrs = requestHeaders req+ acceptsGZipEncoding =+ maybe False (elem "gzip" . splitCommas) $ hAcceptEncoding `lookup` reqHdrs+ isMSIE6 =+ maybe False ("MSIE 6" `S.isInfixOf`) $ hUserAgent `lookup` reqHdrs - -- For a small enough response, gzipping will actually increase the size- -- Potentially for anything less than 860 bytes gzipping could be a net loss- -- The actual number is application specific though and may need to be adjusted- -- http://webmasters.stackexchange.com/questions/31750/what-is-recommended-minimum-object-size-for-gzip-performance-benefits- minimumLength = 860+ -- Can we skip just by looking at the current 'Response'?+ checkCompress :: (Response -> IO ResponseReceived) -> Response -> IO ResponseReceived+ checkCompress f res =+ if isEncodedAlready || notBigEnough+ then sendResponse res+ else f res+ where+ resHdrs = responseHeaders res+ isEncodedAlready = isJust $ hContentEncoding `lookup` resHdrs+ notBigEnough =+ maybe+ False -- This could be a streaming case+ (< minimumLength)+ $ contentLength resHdrs +-- For a small enough response, gzipping will actually increase the size+-- Potentially for anything less than 860 bytes gzipping could be a net loss+-- The actual number is application specific though and may need to be adjusted+-- http://webmasters.stackexchange.com/questions/31750/what-is-recommended-minimum-object-size-for-gzip-performance-benefits+minimumLength :: Integer+minimumLength = 860++-- TODO: Add ETag functionality compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a compressFile s hs file cache sendResponse = do e <- doesFileExist tmpfile@@ -179,42 +204,38 @@ safe '_' = '_' safe _ = '_' -compressE :: GzipSettings- -> Response- -> (Response -> IO a)- -> IO a-compressE set res sendResponse =- 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, _) <- B.newBuilderRecv B.defaultStrategy- deflate <- Z.initDeflate 1 (Z.WindowBits 31)- let sendBuilder builder = do- popper <- blazeRecv builder- fix $ \loop -> do- bs <- popper- unless (S.null bs) $ do- sendBS bs- loop- sendBS bs = Z.feedDeflate deflate bs >>= deflatePopper- flushBuilder = do- sendBuilder Blaze.flush- deflatePopper $ Z.flushDeflate deflate- flush- deflatePopper popper = fix $ \loop -> do- result <- popper- case result of- Z.PRDone -> return ()- Z.PRNext bs' -> do- sendChunk $ byteString bs'- loop- Z.PRError e -> throwIO e-- body sendBuilder flushBuilder+compressE :: Response+ -> (Response -> IO ResponseReceived)+ -> IO ResponseReceived+compressE res sendResponse =+ wb $ \body -> sendResponse $+ responseStream s (fixHeaders hs) $ \sendChunk flush -> do+ (blazeRecv, _) <- B.newBuilderRecv B.defaultStrategy+ deflate <- Z.initDeflate 1 (Z.WindowBits 31)+ let sendBuilder builder = do+ popper <- blazeRecv builder+ fix $ \loop -> do+ bs <- popper+ unless (S.null bs) $ do+ sendBS bs+ loop+ sendBS bs = Z.feedDeflate deflate bs >>= deflatePopper+ flushBuilder = do sendBuilder Blaze.flush- deflatePopper $ Z.finishDeflate deflate- _ -> sendResponse res+ deflatePopper $ Z.flushDeflate deflate+ flush+ deflatePopper popper = fix $ \loop -> do+ result <- popper+ case result of+ Z.PRDone -> return ()+ Z.PRNext bs' -> do+ sendChunk $ byteString bs'+ loop+ Z.PRError e -> throwIO e++ body sendBuilder flushBuilder+ sendBuilder Blaze.flush+ deflatePopper $ Z.finishDeflate deflate where (s, hs, wb) = responseToStream res
+ Network/Wai/Middleware/HealthCheckEndpoint.hs view
@@ -0,0 +1,37 @@+---------------------------------------------------------+-- |+-- Module : Network.Wai.Middleware.HealthCheckEndpoint+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Add empty endpoint (for Health check tests)+--+---------------------------------------------------------+module Network.Wai.Middleware.HealthCheckEndpoint+ ( healthCheck,+ voidEndpoint,+ )+where++import Data.ByteString (ByteString)+import Network.HTTP.Types (status200)+import Network.Wai++-- | Add empty endpoint (for Health check tests) called \"/_healthz\"+--+-- @since 3.1.9+healthCheck :: Middleware+healthCheck = voidEndpoint "/_healthz"++-- | Add empty endpoint+--+-- @since 3.1.9+voidEndpoint :: ByteString -> Middleware+voidEndpoint endpointPath router request respond =+ if rawPathInfo request == endpointPath+ then respond $ responseLBS status200 mempty "-"+ else router request respond
Network/Wai/Middleware/HttpAuth.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE RecordWildCards, TupleSections, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} -- | Implements HTTP Basic Authentication. -- -- This module may add digest authentication in the future.@@ -15,17 +17,17 @@ , extractBasicAuth , extractBearerAuth ) where+ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Data.ByteString (ByteString)+import qualified Data.ByteString as S import Data.ByteString.Base64 (decodeLenient) import Data.String (IsString (..))-import Data.Word8 (isSpace, _colon, toLower)-import Network.HTTP.Types (status401, hContentType, hAuthorization)-import Network.Wai--import qualified Data.ByteString as S+import Data.Word8 (isSpace, toLower, _colon)+import Network.HTTP.Types (hAuthorization, hContentType, status401)+import Network.Wai (Application, Middleware, Request (requestHeaders), responseLBS) -- | Check if a given username and password is valid.@@ -57,7 +59,7 @@ else authOnNoAuth authRealm req sendResponse where check =- case (lookup hAuthorization $ requestHeaders req)+ case lookup hAuthorization (requestHeaders req) >>= extractBasicAuth of Nothing -> return False Just (username, password) -> checkCreds req username password
Network/Wai/Middleware/Jsonp.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE RankNTypes, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Jsonp@@ -14,19 +15,19 @@ --------------------------------------------------------- module Network.Wai.Middleware.Jsonp (jsonp) where -import Network.Wai-import Network.Wai.Internal+import Control.Monad (join) import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B8-import Data.ByteString.Builder.Extra (byteStringCopy)+import qualified Data.ByteString as S import Data.ByteString.Builder (char7)+import Data.ByteString.Builder.Extra (byteStringCopy)+import qualified Data.ByteString.Char8 as B8+import Data.Maybe (fromMaybe) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mappend) #endif-import Control.Monad (join)-import Data.Maybe (fromMaybe)-import qualified Data.ByteString as S import Network.HTTP.Types (hAccept, hContentType)+import Network.Wai+import Network.Wai.Internal -- | Wrap json responses in a jsonp callback. --
Network/Wai/Middleware/Local.hs view
@@ -5,10 +5,10 @@ ( local ) where -import Network.Wai (Middleware,remoteHost, Response)-import Network.Socket (SockAddr(..))+import Network.Socket (SockAddr (..))+import Network.Wai (Middleware, Response, remoteHost) --- | This middleware rejects non-local connections with a specific response. +-- | This middleware rejects non-local connections with a specific response. -- It is useful when supporting web-based local applications, which would -- typically want to reject external connections. @@ -19,8 +19,7 @@ #if !defined(mingw32_HOST_OS) && !defined(_WIN32) SockAddrUnix _ -> f r k #endif- _ -> k $ resp+ _ -> k resp where home :: Integer- home = 127 + (256 * 256 * 256) * 1-+ home = 127 + (256 * 256 * 256)
Network/Wai/Middleware/MethodOverride.hs view
@@ -2,8 +2,8 @@ ( methodOverride ) where -import Network.Wai import Control.Monad (join)+import Network.Wai (Middleware, queryString, requestMethod) -- | Overriding of HTTP request method via `_method` query string parameter. --
Network/Wai/Middleware/MethodOverridePost.hs view
@@ -8,14 +8,13 @@ ( methodOverridePost ) where -import Network.Wai-import Network.HTTP.Types (parseQuery, hContentType)-+import Data.ByteString.Lazy (toChunks)+import Data.IORef (atomicModifyIORef, newIORef) #if __GLASGOW_HASKELL__ < 710-import Data.Monoid (mconcat, mempty)+import Data.Monoid (mconcat, mempty) #endif-import Data.IORef-import Data.ByteString.Lazy (toChunks)+import Network.HTTP.Types (hContentType, parseQuery)+import Network.Wai -- | Allows overriding of the HTTP request method via the _method post string parameter. --
Network/Wai/Middleware/RealIp.hs view
@@ -7,11 +7,11 @@ , ipInRange ) where -import qualified Data.ByteString.Char8 as B8 (unpack, split)+import qualified Data.ByteString.Char8 as B8 (split, unpack) import qualified Data.IP as IP-import Data.Maybe (fromMaybe, mapMaybe, listToMaybe)+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Network.HTTP.Types (HeaderName, RequestHeaders)-import Network.Wai+import Network.Wai (Middleware, remoteHost, requestHeaders) import Text.Read (readMaybe) -- | Infer the remote IP address from the @X-Forwarded-For@ header,
Network/Wai/Middleware/RequestLogger.hs view
@@ -28,36 +28,43 @@ , IPAddrSource (..) ) where -import System.IO (Handle, hFlush, stdout)-import qualified Data.ByteString.Builder as B (Builder, byteString)-import qualified Data.ByteString as BS-import Data.ByteString.Char8 (pack) import Control.Monad (when) import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as B (Builder, byteString)+import Data.ByteString.Char8 (pack)+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as LBS+import Data.Default.Class (Default (def))+import Data.IORef+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Monoid (mconcat, (<>))+import Data.Text.Encoding (decodeUtf8')+import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)+import Network.HTTP.Types as H import Network.Wai ( Request(..), requestBodyLength, RequestBodyLength(..) , Middleware , Response, responseStatus, responseHeaders+ , getRequestBodyChunk )-import System.Log.FastLogger-import Network.HTTP.Types as H-import Data.Maybe (fromMaybe, isJust, mapMaybe)-import Data.Monoid (mconcat, (<>))-import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime, UTCTime)-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-import System.IO.Unsafe import Network.Wai.Internal (Response (..))-import Data.Default.Class (Default (def)) import Network.Wai.Logger-import Network.Wai.Middleware.RequestLogger.Internal+import System.Console.ANSI+import System.IO (Handle, hFlush, stdout)+import System.IO.Unsafe (unsafePerformIO)+import System.Log.FastLogger+ import Network.Wai.Header (contentLength)-import Data.Text.Encoding (decodeUtf8')-import Network.Wai (Request)+import Network.Wai.Middleware.RequestLogger.Internal+import Network.Wai.Parse+ ( Param+ , File+ , fileName+ , getRequestBodyType+ , lbsBackEnd+ , sinkRequestBody+ ) -- | The logging format. data OutputFormat@@ -360,14 +367,14 @@ 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)+ 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+ bs <- getRequestBodyChunk req if S8.null bs then return $ front [] else loop $ front . (bs:)@@ -468,7 +475,7 @@ collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param] collectPostParams (postParams, files) = postParams ++ map (\(k,v) -> (k, "FILE: " <> fileName v)) files- + mkRequestLog :: (Foldable t, ToLogStr m) => t m -> t m -> m -> LogStr mkRequestLog params reqbody accept = foldMap toLogStr (ansiMethod (requestMethod req))
Network/Wai/Middleware/RequestLogger/Internal.hs view
@@ -3,15 +3,16 @@ -- -- https://github.com/yesodweb/wai/issues/192 module Network.Wai.Middleware.RequestLogger.Internal- ( module Network.Wai.Middleware.RequestLogger.Internal+ ( getDateGetter+ , logToByteString ) where -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 Data.ByteString (ByteString)+import Network.Wai.Logger (clockDateCacher) import System.Log.FastLogger (LogStr, fromLogStr) logToByteString :: LogStr -> ByteString
Network/Wai/Middleware/RequestLogger/JSON.hs view
@@ -8,26 +8,29 @@ , requestToJSON ) where +import Data.Aeson import qualified Data.ByteString.Builder as BB (toLazyByteString)+import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Lazy (toStrict)-import Data.Aeson import Data.CaseInsensitive (original)+import Data.IP (fromHostAddress, fromIPv4) import Data.Maybe (maybeToList)+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>))-import qualified Data.ByteString.Char8 as S8-import Data.IP-import qualified Data.Text as T+#endif import Data.Text (Text)+import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Time (NominalDiffTime) import Data.Word (Word32) import Network.HTTP.Types as H-import Network.Socket (SockAddr (..), PortNumber)+import Network.Socket (PortNumber, SockAddr (..)) import Network.Wai-import Network.Wai.Middleware.RequestLogger import System.Log.FastLogger (toLogStr) import Text.Printf (printf)++import Network.Wai.Middleware.RequestLogger formatAsJSON :: OutputFormatterWithDetails formatAsJSON date req status responseSize duration reqBody response =
Network/Wai/Middleware/RequestSizeLimit.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | The functions in this module allow you to limit the total size of incoming request bodies. -- -- Limiting incoming request body size helps protect your server against denial-of-service (DOS) attacks,@@ -14,16 +15,19 @@ , setOnLengthExceeded ) where -import Network.Wai-import Network.Wai.Request+import Control.Exception (catch, try) import qualified Data.ByteString.Lazy as BSL-import Data.Word (Word64)-import Network.HTTP.Types.Status (requestEntityTooLarge413) import qualified Data.ByteString.Lazy.Char8 as LS8-import Control.Exception (try, catch)+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>))-import Network.Wai.Middleware.RequestSizeLimit.Internal (RequestSizeLimitSettings(..), setMaxLengthForRequest, setOnLengthExceeded)+#endif+import Data.Word (Word64)+import Network.HTTP.Types.Status (requestEntityTooLarge413)+import Network.Wai +import Network.Wai.Middleware.RequestSizeLimit.Internal (RequestSizeLimitSettings (..), setMaxLengthForRequest, setOnLengthExceeded)+import Network.Wai.Request+ -- | Create a 'RequestSizeLimitSettings' with these settings: -- -- * 2MB size limit for all requests@@ -43,7 +47,7 @@ -- @since 3.1.1 requestSizeLimitMiddleware :: RequestSizeLimitSettings -> Middleware requestSizeLimitMiddleware settings app req sendResponse = do- maybeMaxLen <- (maxLengthForRequest settings) req+ maybeMaxLen <- maxLengthForRequest settings req case maybeMaxLen of Nothing -> app req sendResponse@@ -56,7 +60,7 @@ Right newReq -> app newReq sendResponse `catch` \(RequestSizeException _maxLen) -> handleLengthExceeded maxLen where- handleLengthExceeded maxLen = (onLengthExceeded settings) maxLen app req sendResponse+ handleLengthExceeded maxLen = onLengthExceeded settings maxLen app req sendResponse tooLargeResponse :: Word64 -> RequestBodyLength -> Response tooLargeResponse maxLen bodyLen = responseLBS@@ -64,10 +68,10 @@ [("Content-Type", "text/plain")] (BSL.concat [ "Request body too large to be processed. The maximum size is "- , (LS8.pack (show maxLen))+ , LS8.pack (show maxLen) , " bytes; your request body was " , case bodyLen of- KnownLength knownLen -> (LS8.pack (show knownLen)) <> " bytes."+ KnownLength knownLen -> LS8.pack (show knownLen) <> " bytes." ChunkedBody -> "split into chunks, whose total size is unknown, but exceeded the limit." , " If you're the developer of this site, you can configure the maximum length with `requestSizeLimitMiddleware`." ])
Network/Wai/Middleware/RequestSizeLimit/Internal.hs view
@@ -5,8 +5,8 @@ , setOnLengthExceeded ) where -import Network.Wai import Data.Word (Word64)+import Network.Wai (Middleware, Request) -- | Settings to configure 'requestSizeLimitMiddleware'. --
Network/Wai/Middleware/Rewrite.hs view
@@ -39,18 +39,18 @@ , rewriteRequestPure ) where -import Network.Wai+-- GHC ≤ 7.10 does not export Applicative functions from the prelude.+#if __GLASGOW_HASKELL__ <= 710+import Control.Applicative+#endif import Control.Monad.IO.Class (liftIO)+import Data.Functor.Identity (Identity (..)) import Data.Text (Text)-import Data.Functor.Identity (Identity(..))-import qualified Data.Text.Encoding as TE import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import Network.HTTP.Types as H+import Network.Wai --- GHC ≤ 7.10 does not export Applicative functions from the prelude.-#if __GLASGOW_HASKELL__ <= 710-import Control.Applicative-#endif -- $howto -- This module provides 'Middleware' to rewrite URL paths. It also provides
Network/Wai/Middleware/Routed.hs view
@@ -6,9 +6,9 @@ , hostedMiddleware ) where -import Network.Wai import Data.ByteString (ByteString) import Data.Text (Text)+import Network.Wai -- | Apply a middleware based on a test of pathInfo --
Network/Wai/Middleware/StreamFile.hs view
@@ -4,12 +4,11 @@ module Network.Wai.Middleware.StreamFile (streamFile) where -import Network.Wai (responseStream)-import Network.Wai.Internal-import Network.Wai (Middleware, responseToStream) import qualified Data.ByteString.Char8 as S8-import System.Directory (getFileSize) import Network.HTTP.Types (hContentLength)+import Network.Wai (Middleware, responseStream, responseToStream)+import Network.Wai.Internal+import System.Directory (getFileSize) -- |Convert ResponseFile type responses into ResponseStream type --
Network/Wai/Middleware/StripHeaders.hs view
@@ -14,11 +14,11 @@ , stripHeadersIf ) where -import Network.Wai (Middleware, Request, modifyResponse, mapResponseHeaders, ifRequest)+import Data.ByteString (ByteString)+import qualified Data.CaseInsensitive as CI+import Network.Wai (Middleware, Request, modifyResponse, mapResponseHeaders, ifRequest) import Network.Wai.Internal (Response)-import Data.ByteString (ByteString) -import qualified Data.CaseInsensitive as CI stripHeader :: ByteString -> (Response -> Response) stripHeader h = mapResponseHeaders (filter (\ hdr -> fst hdr /= CI.mk h))
Network/Wai/Middleware/Vhost.hs view
@@ -1,15 +1,20 @@ {-# LANGUAGE CPP #-}- module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where+module Network.Wai.Middleware.Vhost+ ( vhost+ , redirectWWW+ , redirectTo+ , redirectToLogged+ ) where -import Network.Wai -import Network.HTTP.Types as H-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+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types as H+import Network.Wai vhost :: [(Request -> Bool, Application)] -> Application -> Application vhost vhosts def req =
Network/Wai/Parse.hs view
@@ -48,30 +48,36 @@ #endif ) where +import Prelude hiding (lines)++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif+import Data.CaseInsensitive (mk)+import Control.Exception (catchJust) import qualified Control.Exception as E+import Control.Monad (guard, unless, when)+import Control.Monad.Trans.Resource (InternalState, allocate, register, release, runInternalState) import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8-import Data.Word (Word8)+import qualified Data.ByteString.Lazy as L+import Data.Function (fix, on)+import Data.IORef import Data.Int (Int64)-import Data.Maybe (catMaybes, fromMaybe) import Data.List (sortBy)-import Data.Function (on, fix)-import System.Directory (removeFile, getTemporaryDirectory)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Word (Word8)+import Network.HTTP.Types (hContentType)+import qualified Network.HTTP.Types as H+import Network.Wai+import System.Directory (getTemporaryDirectory, removeFile) import System.IO (hClose, openBinaryTempFile) import System.IO.Error (isDoesNotExistError)-import Network.Wai-import qualified Network.HTTP.Types as H-import Control.Applicative ((<$>))-import Control.Exception (catchJust)-import Control.Monad (when, unless, guard)-import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)-import Data.IORef-import Network.HTTP.Types (hContentType)-import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )-import Data.CaseInsensitive (mk)--import Prelude hiding (lines)+#if MIN_VERSION_http2(3,0,0)+import Network.HTTP2.Frame (ErrorCodeId (..), HTTP2Error (..))+#else+import Network.HTTP2 (ErrorCodeId (..), HTTP2Error (..))+#endif breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s =@@ -458,7 +464,7 @@ E.throwIO $ ConnectionError (UnknownErrorCode 431) "Request Header Fields Too Large" Nothing -> return ()- return $ Just $ killCR $ res+ return . Just $ killCR res takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString] takeLines' lineLength maxLines source =@@ -498,7 +504,7 @@ else return bs leftover :: Source -> S.ByteString -> IO ()-leftover (Source _ ref) bs = writeIORef ref bs+leftover (Source _ ref) = writeIORef ref parsePiecesEx :: ParseRequestBodyOptions -> BackEnd y@@ -537,7 +543,7 @@ fi0 = FileInfo filename ct () fs = catMaybes [ prboMaxFileSize o , subtract filesSize <$> prboMaxFilesSize o ]- mfs = if fs == [] then Nothing else Just $ minimum fs+ mfs = if null fs then Nothing else Just $ minimum fs ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs let newFilesSize = filesSize + fileSize add $ Right (name, fi0 { fileContent = y })@@ -573,7 +579,7 @@ contType = mk $ S8.pack "Content-Type" parsePair s = let (x, y) = breakDiscard 58 s -- colon- in (mk $ x, S.dropWhile (== 32) y) -- space+ in (mk x, S.dropWhile (== 32) y) -- space data Bound = FoundBound S.ByteString S.ByteString
Network/Wai/Request.hs view
@@ -8,17 +8,16 @@ , requestSizeCheck ) where +import Control.Exception (Exception, throwIO) import Data.ByteString (ByteString)-import Data.Maybe (fromMaybe)-import Network.HTTP.Types (HeaderName)-import Network.Wai- import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C-import Control.Exception (Exception, throwIO)+import Data.IORef (atomicModifyIORef', newIORef)+import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) import Data.Word (Word64)-import Data.IORef (atomicModifyIORef', newIORef)+import Network.HTTP.Types (HeaderName)+import Network.Wai -- | Does this request appear to have been made over an SSL connection?@@ -38,7 +37,7 @@ [ ("HTTPS" , (== "on")) , ("HTTP_X_FORWARDED_SSL" , (== "on")) , ("HTTP_X_FORWARDED_SCHEME", (== "https"))- , ("HTTP_X_FORWARDED_PROTO" , ((== ["https"]) . take 1 . C.split ','))+ , ("HTTP_X_FORWARDED_PROTO" , (== ["https"]) . take 1 . C.split ',') , ("X-Forwarded-Proto" , (== "https")) -- Used by Nginx and AWS ELB. ] @@ -56,12 +55,12 @@ guessApproot :: Request -> ByteString guessApproot req = (if appearsSecure req then "https://" else "http://") `S.append`- (fromMaybe "localhost" $ requestHeaderHost req)+ fromMaybe "localhost" (requestHeaderHost req) -- | see 'requestSizeCheck' -- -- @since 3.0.15-data RequestSizeException+newtype RequestSizeException = RequestSizeException Word64 deriving (Eq, Ord, Typeable) @@ -69,7 +68,7 @@ instance Show RequestSizeException where showsPrec p (RequestSizeException limit) =- showString ("Request Body is larger than ") . showsPrec p limit . showString " bytes."+ showString "Request Body is larger than " . showsPrec p limit . showString " bytes." -- | Check request body size to avoid server crash when request is too large. --
Network/Wai/Test.hs view
@@ -36,30 +36,30 @@ import Data.Monoid (mempty, mappend) #endif -import Network.Wai-import Network.Wai.Internal (ResponseReceived (ResponseReceived))-import Network.Wai.Test.Internal+import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask, runReaderT) import qualified Control.Monad.Trans.State as ST-import Control.Monad.Trans.Reader (runReaderT, ask)-import Control.Monad (unless)-import qualified Data.Map as Map-import qualified Web.Cookie as Cookie import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString as S import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Network.HTTP.Types as H+import Data.CallStack (HasCallStack) import Data.CaseInsensitive (CI)-import qualified Data.ByteString as S+import Data.IORef+import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.Encoding as TE-import Data.IORef import Data.Time.Clock (getCurrentTime)+import qualified Network.HTTP.Types as H+import Network.Wai+import Network.Wai.Internal (ResponseReceived (ResponseReceived))+import Network.Wai.Test.Internal import qualified Test.HUnit as HUnit-import Data.CallStack (HasCallStack)+import qualified Web.Cookie as Cookie -- | --@@ -79,16 +79,15 @@ -- Since 3.0.6 setClientCookie :: Cookie.SetCookie -> Session () setClientCookie c =- modifyClientCookies- (Map.insert (Cookie.setCookieName c) c)+ modifyClientCookies $+ Map.insert (Cookie.setCookieName c) c -- | -- -- Since 3.0.6 deleteClientCookie :: ByteString -> Session ()-deleteClientCookie cookieName =- modifyClientCookies- (Map.delete cookieName)+deleteClientCookie =+ modifyClientCookies . Map.delete -- | See also: 'runSessionWith'. runSession :: Session a -> Application -> IO a@@ -123,9 +122,9 @@ setPath :: Request -> S8.ByteString -> Request setPath req path = req { pathInfo = segments- , rawPathInfo = (L8.toStrict . toLazyByteString) (H.encodePathSegments segments)+ , rawPathInfo = L8.toStrict . toLazyByteString $ H.encodePathSegments segments , queryString = query- , rawQueryString = (H.renderQuery True query)+ , rawQueryString = H.renderQuery True query } where (segments, query) = H.decodePath path
Network/Wai/Test/Internal.hs view
@@ -1,12 +1,12 @@ module Network.Wai.Test.Internal where -import Network.Wai-import qualified Control.Monad.Trans.State as ST import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import qualified Control.Monad.Trans.State as ST+import Data.ByteString (ByteString) import Data.Map (Map) import qualified Data.Map as Map+import Network.Wai (Application) import qualified Web.Cookie as Cookie-import Data.ByteString (ByteString) type Session = ReaderT Application (ST.StateT ClientState IO) @@ -15,7 +15,7 @@ -- Since 3.0.6 type ClientCookies = Map ByteString Cookie.SetCookie -data ClientState = ClientState+newtype ClientState = ClientState { clientCookies :: ClientCookies }
Network/Wai/UrlMap.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-} {- | This module gives you a way to mount applications under sub-URIs. For example: @@ -22,17 +23,17 @@ mount', mount, mountRoot,- mapUrls+ mapUrls, ) where import Control.Applicative-import Data.List+import qualified Data.ByteString as B+import Data.List (stripPrefix) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Data.ByteString as B-import Network.HTTP.Types-import Network.Wai+import Network.HTTP.Types (hContentType, status404)+import Network.Wai (Application, Request (pathInfo, rawPathInfo), responseLBS) type Path = [Text] newtype UrlMap' a = UrlMap' { unUrlMap :: [(Path, a)] }
example/Main.hs view
@@ -4,7 +4,7 @@ import Data.ByteString.Builder (string8) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Chan-import Control.Monad+import Control.Monad (forever) import Data.Time.Clock.POSIX (getPOSIXTime) import Network.HTTP.Types (status200) import Network.Wai (Application, Middleware, pathInfo, responseFile)@@ -38,7 +38,7 @@ [string8 . show $ time] eventRaw :: (ServerEvent -> IO ()) -> IO () -> IO ()-eventRaw = handle 0+eventRaw = handle (0 :: Int) where handle counter emit flush = do threadDelay 1000000
test/Network/Wai/Middleware/ApprootSpec.hs view
@@ -4,13 +4,13 @@ , spec ) where +import Data.ByteString (ByteString)+import Network.HTTP.Types (RequestHeaders, status200)+import Network.Wai import Test.Hspec -import Network.Wai.Middleware.Approot-import Network.Wai.Test-import Network.Wai-import Network.HTTP.Types-import Data.ByteString (ByteString)+import Network.Wai.Middleware.Approot (fromRequest, getApproot)+import Network.Wai.Test (SResponse (simpleHeaders), request, runSession) main :: IO () main = hspec spec
test/Network/Wai/Middleware/ForceSSLSpec.hs view
@@ -1,18 +1,21 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.ForceSSLSpec ( main , spec ) where -import Test.Hspec -import Network.Wai.Middleware.ForceSSL--import Control.Monad+import Control.Monad (forM_) import Data.ByteString (ByteString)+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>))+#endif import Network.HTTP.Types (methodPost, status200, status301, status307) import Network.Wai+import Test.Hspec++import Network.Wai.Middleware.ForceSSL (forceSSL) import Network.Wai.Test main :: IO ()
test/Network/Wai/Middleware/RealIpSpec.hs view
@@ -4,12 +4,12 @@ ( spec ) where -import Test.Hspec- import qualified Data.ByteString.Lazy.Char8 as B8 import qualified Data.IP as IP-import Network.HTTP.Types (status200, RequestHeaders)+import Network.HTTP.Types (RequestHeaders, status200) import Network.Wai+import Test.Hspec+ import Network.Wai.Middleware.RealIp import Network.Wai.Test
test/Network/Wai/Middleware/RequestSizeLimitSpec.hs view
@@ -1,20 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.RequestSizeLimitSpec (main, spec) where -import Test.Hspec--import Network.Wai-import Network.Wai.Test+import Control.Monad (replicateM)+import Data.Aeson (encode, object, (.=)) import Data.ByteString (ByteString) import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8-import Network.Wai.Middleware.RequestSizeLimit-import Network.HTTP.Types.Status (status200, status413)-import Control.Monad (replicateM)-import Data.Aeson (encode, object, (.=))+import qualified Data.ByteString.Lazy as L import Data.Text (Text)+import Network.HTTP.Types (hContentLength, status200, status413)+import Network.Wai+import Test.Hspec +import Network.Wai.Middleware.RequestSizeLimit+import Network.Wai.Test+ main :: IO () main = hspec spec @@ -26,7 +26,7 @@ describe "JSON response" $ do runStrictBodyTests "returns 413 for request bodies > 10 bytes, when streaming the whole body" tenByteLimitJSONSettings "1234567890a" (isStatus413 >> isJSONContentType)- runStrictBodyTests "returns 200 for request bodies <= 10 bytes, when streaming the whole body" tenByteLimitJSONSettings "1234567890" (isStatus200)+ runStrictBodyTests "returns 200 for request bodies <= 10 bytes, when streaming the whole body" tenByteLimitJSONSettings "1234567890" isStatus200 describe "Per-request sizes" $ do @@ -35,8 +35,8 @@ { pathInfo = ["upload", "image"] } "1234567890a" settings =- setMaxLengthForRequest - (\req -> if pathInfo req == ["upload", "image"] then pure $ Just 20 else pure $ Just 10)+ setMaxLengthForRequest+ (\req' -> if pathInfo req' == ["upload", "image"] then pure $ Just 20 else pure $ Just 10) defaultRequestSizeLimitSettings resp <- runStrictBodyApp settings req isStatus200 resp@@ -55,11 +55,11 @@ simpleStatus resp `shouldBe` status200 where- tenByteLimitSettings = + tenByteLimitSettings = setMaxLengthForRequest (\_req -> pure $ Just 10) defaultRequestSizeLimitSettings- tenByteLimitJSONSettings = + tenByteLimitJSONSettings = setOnLengthExceeded (\_maxLen _app _req sendResponse -> sendResponse $ responseLBS status413 [("Content-Type", "application/json")] (encode $ object ["error" .= ("request size too large" :: Text)])) tenByteLimitSettings@@ -72,43 +72,49 @@ deriving (Show, Eq) runStrictBodyTests :: String -> RequestSizeLimitSettings -> ByteString -> (SResponse -> Expectation) -> Spec-runStrictBodyTests name settings requestBody runExpectations = describe name $ do+runStrictBodyTests name settings reqBody runExpectations = describe name $ do it "chunked" $ do- let req = mkRequestWithBytestring requestBody UseChunked+ let req = mkRequestWithBytestring reqBody UseChunked resp <- runStrictBodyApp settings req runExpectations resp it "non-chunked" $ do- let req = mkRequestWithBytestring requestBody UseKnownLength+ let req = mkRequestWithBytestring reqBody UseKnownLength resp <- runStrictBodyApp settings req runExpectations resp where mkRequestWithBytestring :: ByteString -> LengthType -> SRequest- mkRequestWithBytestring body lengthType = SRequest defaultRequest- { requestHeaders =- if lengthType == UseKnownLength- then [("content-length", S8.pack $ show $ S.length body)]- else []- , requestMethod = "POST"- , requestBodyLength =- if lengthType == UseKnownLength- then KnownLength $ fromIntegral $ S.length body- else ChunkedBody- } $ L.fromChunks $ map S.singleton $ S.unpack body+ mkRequestWithBytestring body lengthType =+ SRequest adjustedRequest $+ L.fromChunks $ map S.singleton $ S.unpack body+ where+ adjustedRequest = defaultRequest+ { requestHeaders =+ [ (hContentLength, S8.pack $ show $ S.length body)+ | lengthType == UseKnownLength+ ]+ , requestMethod = "POST"+ , requestBodyLength =+ if lengthType == UseKnownLength+ then KnownLength $ fromIntegral $ S.length body+ else ChunkedBody+ } runStrictBodyApp :: RequestSizeLimitSettings -> SRequest -> IO SResponse-runStrictBodyApp settings req = runSession- (srequest req) $ (requestSizeLimitMiddleware settings) app+runStrictBodyApp settings req =+ runSession (srequest req) $+ requestSizeLimitMiddleware settings app where- app req respond = do- _body <- strictRequestBody req+ app req' respond = do+ _body <- strictRequestBody req' respond $ responseLBS status200 [] "" runStreamingChunkApp :: Int -> RequestSizeLimitSettings -> Request -> IO SResponse-runStreamingChunkApp times settings req = runSession- (request req) $ (requestSizeLimitMiddleware settings) app+runStreamingChunkApp times settings req =+ runSession (request req) $+ requestSizeLimitMiddleware settings app where- app req respond = do- _chunks <- replicateM times (getRequestBodyChunk req)+ app req' respond = do+ _chunks <- replicateM times (getRequestBodyChunk req') respond $ responseLBS status200 [] ""
test/Network/Wai/Middleware/RoutedSpec.hs view
@@ -4,16 +4,15 @@ , spec ) where +import Data.ByteString (ByteString)+import Data.String (IsString)+import Network.HTTP.Types (hContentType, status200)+import Network.Wai+import Network.Wai.Test import Test.Hspec import Network.Wai.Middleware.Routed import Network.Wai.Middleware.ForceSSL (forceSSL)--import Network.HTTP.Types (hContentType, status200)-import Network.Wai-import Network.Wai.Test-import Data.ByteString (ByteString)-import Data.String (IsString) main :: IO () main = hspec spec
test/Network/Wai/Middleware/StripHeadersSpec.hs view
@@ -1,22 +1,23 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.StripHeadersSpec ( main , spec ) where -import Test.Hspec--import Network.Wai.Middleware.AddHeaders-import Network.Wai.Middleware.StripHeaders- import Control.Arrow (first) import Data.ByteString (ByteString)+import qualified Data.CaseInsensitive as CI+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>))+#endif import Network.HTTP.Types (status200) import Network.Wai-import Network.Wai.Test+import Network.Wai.Test (SResponse (simpleHeaders), request, runSession)+import Test.Hspec -import qualified Data.CaseInsensitive as CI+import Network.Wai.Middleware.AddHeaders (addHeaders)+import Network.Wai.Middleware.StripHeaders (stripHeaderIf, stripHeadersIf) main :: IO ()
test/Network/Wai/Middleware/TimeoutSpec.hs view
@@ -1,14 +1,13 @@ {-# LANGUAGE OverloadedStrings #-}- module Network.Wai.Middleware.TimeoutSpec ( spec ) where -import Test.Hspec- import Control.Concurrent (threadDelay) import Network.HTTP.Types (status200, status503, status504) import Network.Wai+import Test.Hspec+ import Network.Wai.Middleware.Timeout import Network.Wai.Test
test/Network/Wai/ParseSpec.hs view
@@ -1,24 +1,30 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.ParseSpec (main, spec) where -import Test.Hspec-import Test.HUnit--import System.IO-import Data.Monoid-import qualified Data.IORef as I+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid+#endif+import Control.Monad.Trans.Resource (runResourceT, withInternalState) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L+import qualified Data.IORef as I import qualified Data.Text as TS import qualified Data.Text.Encoding as TE-import Control.Monad.Trans.Resource (withInternalState, runResourceT)-import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )+#if MIN_VERSION_http2(3,0,0)+import Network.HTTP2.Frame (ErrorCodeId (..), HTTP2Error (..))+#else+import Network.HTTP2 (ErrorCodeId (..), HTTP2Error (..))+#endif+import Network.Wai (Request (requestBody, requestHeaders), defaultRequest)+import System.IO (IOMode (ReadMode), withFile)+import Test.HUnit (Assertion, (@=?), (@?=))+import Test.Hspec -import Network.Wai-import Network.Wai.Test-import Network.Wai.Parse-import WaiExtraSpec (toRequest)+import Network.Wai.Parse+import Network.Wai.Test (SRequest (SRequest))+import WaiExtraSpec (toRequest) main :: IO () main = hspec spec
test/Network/Wai/RequestSpec.hs view
@@ -4,15 +4,14 @@ , spec ) where -import Test.Hspec +import Control.Exception (try)+import Control.Monad (forever) import Data.ByteString (ByteString) import Network.HTTP.Types (HeaderName)-import Network.Wai (Request(..), defaultRequest, RequestBodyLength(..))-+import Network.Wai (Request (..), RequestBodyLength (..), defaultRequest) import Network.Wai.Request-import Control.Exception (try)-import Control.Monad (forever)+import Test.Hspec main :: IO () main = hspec spec
test/Network/Wai/TestSpec.hs view
@@ -1,28 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Wai.TestSpec (main, spec) where -import Control.Monad (void)-+import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, toLazyByteString)+import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.IORef as IORef- import qualified Data.Text.Encoding as TE--import Data.Time.Calendar (fromGregorian)-import Data.Time.Clock (UTCTime(..))--import Test.Hspec--import Network.Wai-import Network.Wai.Test--import Network.HTTP.Types (status200)--import qualified Data.ByteString.Lazy.Char8 as L8-import Data.ByteString.Builder (Builder, toLazyByteString)-import Data.ByteString (ByteString)-+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (..))+import Network.HTTP.Types (status200)+import Network.Wai+import Test.Hspec import qualified Web.Cookie as Cookie +import Network.Wai.Test+ main :: IO () main = hspec spec @@ -222,6 +215,3 @@ request $ setPath defaultRequest "/get" simpleBody sresp `shouldBe` "[]"---
test/WaiExtraSpec.hs view
@@ -2,42 +2,40 @@ {-# LANGUAGE OverloadedStrings #-} module WaiExtraSpec (spec, toRequest) where -import Test.Hspec-import Test.HUnit hiding (Test)-#if MIN_VERSION_base(4,8,0)-import Data.Monoid ((<>))-#else-import Data.Monoid (mempty, mappend, (<>))-#endif--import Network.Wai-import Network.Wai.Test-import Network.Wai.UrlMap+import Codec.Compression.GZip (decompress)+import Control.Applicative ((<|>))+import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L-import qualified Data.Text.Lazy as T+import qualified Data.IORef as I+import Data.Maybe (fromMaybe)+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (mempty, mappend)+#endif+#endif import qualified Data.Text as TS import qualified Data.Text.Encoding as TE-import Control.Applicative--import Network.Wai.Middleware.Jsonp-import Network.Wai.Middleware.Gzip-import Network.Wai.Middleware.Vhost-import Network.Wai.Middleware.Autohead-import Network.Wai.Middleware.MethodOverride-import Network.Wai.Middleware.MethodOverridePost-import Network.Wai.Middleware.AcceptOverride-import Network.Wai.Middleware.RequestLogger-import Codec.Compression.GZip (decompress)-import Network.Wai.Middleware.StreamFile--import Control.Monad.IO.Class (liftIO)-import Data.Maybe (fromMaybe)+import qualified Data.Text.Lazy as T import Network.HTTP.Types (status200)-import System.Log.FastLogger+import Network.Wai+import System.Log.FastLogger (fromLogStr)+import Test.HUnit (Assertion, (@?=))+import Test.Hspec -import qualified Data.IORef as I+import Network.Wai.Middleware.AcceptOverride (acceptOverride)+import Network.Wai.Middleware.Autohead (autohead)+import Network.Wai.Middleware.Gzip (def, defaultCheckMime, gzip)+import Network.Wai.Middleware.Jsonp (jsonp)+import Network.Wai.Middleware.MethodOverride (methodOverride)+import Network.Wai.Middleware.MethodOverridePost (methodOverridePost)+import Network.Wai.Middleware.RequestLogger+import Network.Wai.Middleware.StreamFile (streamFile)+import Network.Wai.Middleware.Vhost (vhost)+import Network.Wai.Test+import Network.Wai.UrlMap (mapUrls, mount, mountRoot) spec :: Spec spec = do
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 3.1.8+Version: 3.1.9 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality:@@ -31,6 +31,10 @@ . Negotiate HTTP payload gzip compression. .+ * Health check endpoint+ .+ Add an empty health check endpoint.+ . * HTTP Basic Authentication . WAI Basic Authentication Middleware which uses Authorization header.@@ -129,6 +133,7 @@ Network.Wai.Middleware.Approot Network.Wai.Middleware.Autohead Network.Wai.Middleware.CleanPath+ Network.Wai.Middleware.HealthCheckEndpoint Network.Wai.Middleware.Local Network.Wai.Middleware.RequestLogger Network.Wai.Middleware.RequestLogger.JSON