wai-extra 3.1.13.0 → 3.1.14
raw patch · 54 files changed
+2420/−1868 lines, 54 filesdep ~wainew-uploader
Dependency ranges changed: wai
Files
- ChangeLog.md +10/−0
- Network/Wai/EventSource.hs +26/−23
- Network/Wai/EventSource/EventStream.hs +35/−42
- Network/Wai/Handler/CGI.hs +22/−22
- Network/Wai/Handler/SCGI.hs +26/−17
- Network/Wai/Header.hs +10/−8
- Network/Wai/Middleware/AcceptOverride.hs +9/−8
- Network/Wai/Middleware/AddHeaders.hs +3/−5
- Network/Wai/Middleware/Approot.hs +20/−15
- Network/Wai/Middleware/Autohead.hs +8/−2
- Network/Wai/Middleware/CleanPath.hs +16/−14
- Network/Wai/Middleware/CombineHeaders.hs +95/−92
- Network/Wai/Middleware/ForceDomain.hs +11/−11
- Network/Wai/Middleware/ForceSSL.hs +7/−7
- Network/Wai/Middleware/Gzip.hs +120/−94
- Network/Wai/Middleware/HealthCheckEndpoint.hs +9/−8
- Network/Wai/Middleware/HttpAuth.hs +63/−48
- Network/Wai/Middleware/Jsonp.hs +26/−18
- Network/Wai/Middleware/MethodOverride.hs +4/−4
- Network/Wai/Middleware/MethodOverridePost.hs +18/−13
- Network/Wai/Middleware/RealIp.hs +26/−25
- Network/Wai/Middleware/RequestLogger.hs +301/−249
- Network/Wai/Middleware/RequestLogger/Internal.hs +9/−6
- Network/Wai/Middleware/RequestLogger/JSON.hs +94/−70
- Network/Wai/Middleware/RequestSizeLimit.hs +38/−29
- Network/Wai/Middleware/RequestSizeLimit/Internal.hs +17/−11
- Network/Wai/Middleware/Rewrite.hs +105/−80
- Network/Wai/Middleware/Routed.hs +23/−16
- Network/Wai/Middleware/Select.hs +21/−15
- Network/Wai/Middleware/StreamFile.hs +15/−16
- Network/Wai/Middleware/StripHeaders.hs +19/−14
- Network/Wai/Middleware/Timeout.hs +5/−5
- Network/Wai/Middleware/Vhost.hs +20/−15
- Network/Wai/Parse.hs +64/−32
- Network/Wai/Request.hs +31/−29
- Network/Wai/Test.hs +190/−153
- Network/Wai/UrlMap.hs +48/−40
- Network/Wai/Util.hs +6/−5
- example/Main.hs +42/−25
- test/Network/Wai/Middleware/ApprootSpec.hs +21/−13
- test/Network/Wai/Middleware/CombineHeadersSpec.hs +71/−40
- test/Network/Wai/Middleware/ForceSSLSpec.hs +26/−16
- test/Network/Wai/Middleware/RealIpSpec.hs +9/−6
- test/Network/Wai/Middleware/RequestSizeLimitSpec.hs +101/−64
- test/Network/Wai/Middleware/RoutedSpec.hs +34/−26
- test/Network/Wai/Middleware/SelectSpec.hs +46/−28
- test/Network/Wai/Middleware/StripHeadersSpec.hs +30/−15
- test/Network/Wai/Middleware/TimeoutSpec.hs +4/−3
- test/Network/Wai/ParseSpec.hs +205/−152
- test/Network/Wai/RequestSpec.hs +44/−32
- test/Network/Wai/TestSpec.hs +193/−171
- test/WaiExtraSpec.hs +3/−3
- test/sample.hs +17/−10
- wai-extra.cabal +4/−3
ChangeLog.md view
@@ -1,5 +1,15 @@ # Changelog for wai-extra +## 3.1.15++* Request parsing throws an exception rather than `error`ing [#964](https://github.com/yesodweb/wai/pull/964):+ * Add `RequestParseException` type and expose it from the `Network.Wai.Parse` module.+ * Behavior change : `parseRequestBody` and `parseRequestBodyEx` (exported from `Network.Wai.Parse`) throw `RequestParseException` rather than calling `error`.++## 3.1.14.0++* `defaultGzipSettings` now exported to not depend on `Data.Default` [#959](https://github.com/yesodweb/wai/pull/959)+ ## 3.1.13.0 * Added `Combine Headers` `Middleware` [#901](https://github.com/yesodweb/wai/pull/901)
Network/Wai/EventSource.hs view
@@ -1,13 +1,12 @@-{-|- A WAI adapter to the HTML5 Server-Sent Events API.-- If running through a proxy like Nginx you might need to add the- headers:-- > [ ("X-Accel-Buffering", "no"), ("Cache-Control", "no-cache")]-- There is a small example using these functions in the @example@ directory.--}+-- |+-- A WAI adapter to the HTML5 Server-Sent Events API.+--+-- If running through a proxy like Nginx you might need to add the+-- headers:+--+-- > [ ("X-Accel-Buffering", "no"), ("Cache-Control", "no-cache")]+--+-- There is a small example using these functions in the @example@ directory. module Network.Wai.EventSource ( ServerEvent (..), eventSourceAppChan,@@ -34,28 +33,32 @@ -- the given IO action. eventSourceAppIO :: IO ServerEvent -> Application eventSourceAppIO src _ sendResponse =- sendResponse $ responseStream- status200- [(hContentType, "text/event-stream")]+ sendResponse+ $ responseStream+ status200+ [(hContentType, "text/event-stream")] $ \sendChunk flush -> do flush fix $ \loop -> do se <- src case eventToBuilder se of Nothing -> return ()- Just b -> sendChunk b >> flush >> loop+ Just b -> sendChunk b >> flush >> loop -- | Make a new WAI EventSource application with a handler that emits events. -- -- @since 3.0.28-eventStreamAppRaw :: ((ServerEvent -> IO()) -> IO () -> IO ()) -> Application+eventStreamAppRaw :: ((ServerEvent -> IO ()) -> IO () -> IO ()) -> Application eventStreamAppRaw handler _ sendResponse =- sendResponse $ responseStream- status200- [(hContentType, "text/event-stream")]+ sendResponse+ $ responseStream+ status200+ [(hContentType, "text/event-stream")] $ \sendChunk flush -> handler (sendEvent sendChunk) flush- where- sendEvent sendChunk event =- case eventToBuilder event of- Nothing -> return ()- Just b -> sendChunk b+ where+ sendEvent sendChunk event =+ case eventToBuilder event of+ Nothing -> return ()+ Just b -> sendChunk b++{- HLint ignore eventStreamAppRaw "Use forM_" -}
Network/Wai/EventSource/EventStream.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-}+ {- code adapted by Mathias Billman originally from Chris Smith https://github.com/cdsmith/gloss-web -} -{-|- Internal module, usually you don't need to use it.--}+-- |+-- Internal module, usually you don't need to use it. module Network.Wai.EventSource.EventStream ( ServerEvent (..), eventToBuilder,@@ -13,64 +13,57 @@ #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif+import Data.Word8 (_colon, _lf) -{-|- Type representing a communication over an event stream. This can be an- actual event, a comment, a modification to the retry timer, or a special- "close" event indicating the server should close the connection.--}+-- |+-- Type representing a communication over an event stream. This can be an+-- actual event, a comment, a modification to the retry timer, or a special+-- "close" event indicating the server should close the connection. data ServerEvent- = ServerEvent {- eventName :: Maybe Builder,- eventId :: Maybe Builder,- eventData :: [Builder]+ = ServerEvent+ { eventName :: Maybe Builder+ , eventId :: Maybe Builder+ , eventData :: [Builder] }- | CommentEvent {- eventComment :: Builder+ | CommentEvent+ { eventComment :: Builder }- | RetryEvent {- eventRetry :: Int+ | RetryEvent+ { eventRetry :: Int } | CloseEvent --{-|- Newline as a Builder.--}+-- |+-- Newline as a Builder. nl :: Builder-nl = char7 '\n'-+nl = word8 _lf -{-|- Field names as Builder--}+-- |+-- Field names as Builder nameField, idField, dataField, retryField, commentField :: Builder nameField = string7 "event:" idField = string7 "id:" dataField = string7 "data:" retryField = string7 "retry:"-commentField = char7 ':'-+commentField = word8 _colon -{-|- Wraps the text as a labeled field of an event stream.--}+-- |+-- Wraps the text as a labeled field of an event stream. field :: Builder -> Builder -> Builder field l b = l `mappend` b `mappend` nl --{-|- Converts a 'ServerEvent' to its wire representation as specified by the- @text/event-stream@ content type.--}+-- |+-- Converts a 'ServerEvent' to its wire representation as specified by the+-- @text/event-stream@ content type. eventToBuilder :: ServerEvent -> Maybe Builder eventToBuilder (CommentEvent txt) = Just $ field commentField txt-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+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 where- name Nothing = id+ name Nothing = id name (Just n') = mappend (field nameField n')- evid Nothing = id- evid (Just i') = mappend (field idField i')+ evid Nothing = id+ evid (Just i') = mappend (field idField i')
Network/Wai/Handler/CGI.hs view
@@ -14,7 +14,7 @@ #endif import Control.Arrow ((***)) import Control.Monad (unless, void)-import Data.ByteString.Builder (byteString, char7, string8, toLazyByteString)+import Data.ByteString.Builder (byteString, string8, toLazyByteString, word8) import Data.ByteString.Builder.Extra (flush) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L@@ -26,6 +26,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Streaming.ByteString.Builder as Builder import qualified Data.String as String+import Data.Word8 (_lf, _space) import Network.HTTP.Types (Status (..), hContentLength, hContentType, hRange) import qualified Network.HTTP.Types as H import Network.Socket (addrAddress, getAddrInfo)@@ -89,8 +90,7 @@ remoteHost' = case lookup "REMOTE_ADDR" vars of Just x -> x- Nothing ->- fromMaybe "" $ lookup "REMOTE_HOST" vars+ Nothing -> lookup' "REMOTE_HOST" vars isSecure' = case map toLower $ lookup' "SERVER_PROTOCOL" vars of "https" -> True@@ -102,21 +102,21 @@ a:_ -> addrAddress a [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost' reqHeaders = map (cleanupVarName *** B.pack) vars- env = Request- { requestMethod = rmethod- , rawPathInfo = B.pack pinfo- , pathInfo = H.decodePathSegments $ B.pack pinfo- , rawQueryString = B.pack qstring- , queryString = H.parseQuery $ B.pack qstring- , requestHeaders = reqHeaders- , isSecure = isSecure'- , remoteHost = addr- , httpVersion = H.http11 -- FIXME- , requestBody = requestBody'- , vault = mempty- , requestBodyLength = KnownLength $ fromIntegral contentLength- , requestHeaderHost = lookup "host" reqHeaders- , requestHeaderRange = lookup hRange reqHeaders+ env =+ setRequestBodyChunks requestBody' $ defaultRequest+ { requestMethod = rmethod+ , rawPathInfo = B.pack pinfo+ , pathInfo = H.decodePathSegments $ B.pack pinfo+ , rawQueryString = B.pack qstring+ , queryString = H.parseQuery $ B.pack qstring+ , requestHeaders = reqHeaders+ , isSecure = isSecure'+ , remoteHost = addr+ , httpVersion = H.http11 -- FIXME+ , vault = mempty+ , requestBodyLength = KnownLength $ fromIntegral contentLength+ , requestHeaderHost = lookup "host" reqHeaders+ , requestHeaderRange = lookup hRange reqHeaders #if MIN_VERSION_wai(3,2,0) , requestHeaderReferer = lookup "referer" reqHeaders , requestHeaderUserAgent = lookup "user-agent" reqHeaders@@ -138,7 +138,7 @@ unless (B.null bs) $ do outputH bs loop- sendBuilder $ headers s hs `mappend` char7 '\n'+ sendBuilder $ headers s hs `mappend` word8 _lf b sendBuilder (sendBuilder flush) blazeFinish >>= maybe (return ()) outputH return ResponseReceived@@ -146,7 +146,7 @@ headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs)) status (Status i m) = (byteString "Status", mconcat [ string8 $ show i- , char7 ' '+ , word8 _space , byteString m ]) header' (x, y) = (byteString $ CI.original x, byteString y)@@ -154,12 +154,12 @@ [ x , byteString ": " , y- , char7 '\n'+ , word8 _lf ] sfBuilder s hs sf fp = mconcat [ headers s hs , header (byteString sf, string8 fp)- , char7 '\n'+ , word8 _lf , byteString sf , byteString " not supported" ]
Network/Wai/Handler/SCGI.hs view
@@ -1,16 +1,18 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-}-module Network.Wai.Handler.SCGI- ( run- , runSendfile- ) where +module Network.Wai.Handler.SCGI (+ run,+ runSendfile,+) where+ import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Lazy.Internal (defaultChunkSize) import qualified Data.ByteString.Unsafe as S import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe, listToMaybe) import Foreign.C (CChar, CInt (..)) import Foreign.Marshal.Alloc (free, mallocBytes) import Foreign.Ptr (Ptr, castPtr, nullPtr)@@ -27,13 +29,19 @@ runOne sf app = do socket <- c'accept 0 nullPtr nullPtr headersBS <- readNetstring socket- let headers@((_, conLenS):_) = parseHeaders $ S.split 0 headersBS- let conLen = case reads conLenS of- (i, _):_ -> i- [] -> 0+ let headers = parseHeaders $ S.split 0 headersBS+ let conLen =+ fromMaybe 0 $ do+ (_, conLenS) <- listToMaybe headers+ (i, _) <- listToMaybe $ reads conLenS+ pure i conLenI <- newIORef conLen- runGeneric headers (requestBodyFunc $ input socket conLenI)- (write socket) sf app+ runGeneric+ headers+ (requestBodyFunc $ input socket conLenI)+ (write socket)+ sf+ app drain socket conLenI _ <- c'close socket return ()@@ -49,8 +57,9 @@ case len of 0 -> return Nothing _ -> do- bs <- readByteString socket- $ minimum [defaultChunkSize, len, rlen]+ bs <-+ readByteString socket $+ minimum [defaultChunkSize, len, rlen] writeIORef ilen $ len - S.length bs return $ Just bs @@ -61,7 +70,7 @@ return () parseHeaders :: [S.ByteString] -> [(String, String)]-parseHeaders (x:y:z) = (S8.unpack x, S8.unpack y) : parseHeaders z+parseHeaders (x : y : z) = (S8.unpack x, S8.unpack y) : parseHeaders z parseHeaders _ = [] readNetstring :: CInt -> IO S.ByteString@@ -73,10 +82,10 @@ where readLen l = do bs <- readByteString socket 1- let [c] = S8.unpack bs- if c == ':'- then return l- else readLen $ l * 10 + (fromEnum c - fromEnum '0')+ case S8.unpack bs of+ [':'] -> return l+ [c] -> readLen $ l * 10 + (fromEnum c - fromEnum '0')+ _ -> error "Network.Wai.Handler.SCGI.readNetstring: should never happen" readByteString :: CInt -> Int -> IO S.ByteString readByteString socket len = do
Network/Wai/Header.hs view
@@ -1,9 +1,9 @@ -- | Some helpers for dealing with WAI 'Header's.-module Network.Wai.Header- ( contentLength- , parseQValueList- , replaceHeader- ) where+module Network.Wai.Header (+ contentLength,+ parseQValueList,+ replaceHeader,+) where import Control.Monad (guard) import qualified Data.ByteString as S@@ -22,8 +22,8 @@ readInt :: S8.ByteString -> Maybe Integer readInt bs = case S8.readInteger bs of- -- 'S8.all' is also 'True' for an empty string- Just (i, rest) | S8.all (== ' ') rest -> Just i+ -- 'S.all' is also 'True' for an empty string+ Just (i, rest) | S.all (== _space) rest -> Just i _ -> Nothing replaceHeader :: H.HeaderName -> S.ByteString -> [H.Header] -> [H.Header]@@ -49,7 +49,9 @@ checkQ (val, bs) = -- RFC 7231 says optional whitespace can be around the semicolon. -- So drop any before it , . and any behind it $ and drop the semicolon- (dropWhileEnd (== _space) val, parseQval . S.dropWhile (== _space) $ S.drop 1 bs)+ ( dropWhileEnd (== _space) val+ , parseQval . S.dropWhile (== _space) $ S.drop 1 bs+ ) where parseQval qVal = do q <- S.stripPrefix "q=" qVal
Network/Wai/Middleware/AcceptOverride.hs view
@@ -1,10 +1,10 @@-module Network.Wai.Middleware.AcceptOverride- ( -- $howto- acceptOverride- ) where+module Network.Wai.Middleware.AcceptOverride (+ -- $howto+ acceptOverride,+) where -import Network.Wai import Control.Monad (join)+import Network.Wai import Network.Wai.Header (replaceHeader) @@ -31,6 +31,7 @@ req' = case join $ lookup "_accept" $ queryString req of Nothing -> req- Just a -> req {- requestHeaders = replaceHeader "Accept" a $ requestHeaders req- }+ Just a ->+ req+ { requestHeaders = replaceHeader "Accept" a $ requestHeaders req+ }
Network/Wai/Middleware/AddHeaders.hs view
@@ -1,9 +1,9 @@ -- | -- -- Since 3.0.3-module Network.Wai.Middleware.AddHeaders- ( addHeaders- ) where+module Network.Wai.Middleware.AddHeaders (+ addHeaders,+) where import Control.Arrow (first) import Data.ByteString (ByteString)@@ -12,12 +12,10 @@ import Network.Wai (Middleware, mapResponseHeaders, modifyResponse) import Network.Wai.Internal (Response (..)) - addHeaders :: [(ByteString, ByteString)] -> Middleware -- ^ Prepend a list of headers without any checks -- -- Since 3.0.3- addHeaders h = modifyResponse $ addHeaders' (map (first CI.mk) h) addHeaders' :: [Header] -> Response -> Response
Network/Wai/Middleware/Approot.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+ -- | Middleware for establishing the root of the application. -- -- Many application need the ability to create URLs referring back to the@@ -13,19 +14,21 @@ -- @/foo/bar?baz=bin@. For example, if your application is hosted on -- example.com using HTTPS, the approot would be @https://example.com@. Note -- the lack of a trailing slash.-module Network.Wai.Middleware.Approot- ( -- * Middleware- approotMiddleware- -- * Common providers- , envFallback- , envFallbackNamed- , hardcoded- , fromRequest- -- * Functions for applications- , getApproot- , getApprootMay- ) where+module Network.Wai.Middleware.Approot (+ -- * Middleware+ approotMiddleware, + -- * Common providers+ envFallback,+ envFallbackNamed,+ hardcoded,+ fromRequest,++ -- * Functions for applications+ getApproot,+ getApprootMay,+) where+ import Control.Exception (Exception, throw) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8@@ -48,11 +51,13 @@ -- functionality more conveniently. -- -- Since 3.0.7-approotMiddleware :: (Request -> IO ByteString) -- ^ get the approot- -> Middleware+approotMiddleware+ :: (Request -> IO ByteString)+ -- ^ get the approot+ -> Middleware approotMiddleware getRoot app req respond = do ar <- getRoot req- let req' = req { vault = V.insert approotKey ar $ vault req }+ let req' = req{vault = V.insert approotKey ar $ vault req} app req' respond -- | Same as @'envFallbackNamed' "APPROOT"@.
Network/Wai/Middleware/Autohead.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+ -- | Automatically produce responses to HEAD requests based on the underlying -- applications GET response. module Network.Wai.Middleware.Autohead (autohead) where@@ -6,11 +7,16 @@ #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) #endif-import Network.Wai (Middleware, requestMethod, responseBuilder, responseToStream)+import Network.Wai (+ Middleware,+ requestMethod,+ responseBuilder,+ responseToStream,+ ) autohead :: Middleware autohead app req sendResponse- | requestMethod req == "HEAD" = app req { requestMethod = "GET" } $ \res -> do+ | requestMethod req == "HEAD" = app req{requestMethod = "GET"} $ \res -> do let (s, hs, _) = responseToStream res sendResponse $ responseBuilder s hs mempty | otherwise = app req sendResponse
Network/Wai/Middleware/CleanPath.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-}-module Network.Wai.Middleware.CleanPath- ( cleanPath- ) where +module Network.Wai.Middleware.CleanPath (+ cleanPath,+) where+ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L #if __GLASGOW_HASKELL__ < 710@@ -12,10 +13,11 @@ import Network.HTTP.Types (hLocation, status301) import Network.Wai (Application, pathInfo, rawQueryString, responseLBS) -cleanPath :: ([Text] -> Either B.ByteString [Text])- -> B.ByteString- -> ([Text] -> Application)- -> Application+cleanPath+ :: ([Text] -> Either B.ByteString [Text])+ -> B.ByteString+ -> ([Text] -> Application)+ -> Application cleanPath splitter prefix app env sendResponse = case splitter $ pathInfo env of Right pieces -> app pieces env sendResponse@@ -25,10 +27,10 @@ status301 [(hLocation, mconcat [prefix, p, suffix])] L.empty- where- -- include the query string if present- suffix =- case B.uncons $ rawQueryString env of- Nothing -> B.empty- Just ('?', _) -> rawQueryString env- _ -> B.cons '?' $ rawQueryString env+ where+ -- include the query string if present+ suffix =+ case B.uncons $ rawQueryString env of+ Nothing -> B.empty+ Just ('?', _) -> rawQueryString env+ _ -> B.cons '?' $ rawQueryString env
Network/Wai/Middleware/CombineHeaders.hs view
@@ -1,34 +1,35 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}-{- |-Sometimes incoming requests don't stick to the-"no duplicate headers" invariant, for a number-of possible reasons (e.g. proxy servers blindly-adding headers), or your application (or other-middleware) blindly adds headers. -In those cases, you can use this 'Middleware'-to make sure that headers that /can/ be combined-/are/ combined. (e.g. applications might only-check the first \"Accept\" header and fail, while-there might be another one that would match)- -}-module Network.Wai.Middleware.CombineHeaders- ( combineHeaders- , CombineSettings- , defaultCombineSettings- , HeaderMap- , HandleType- , defaultHeaderMap+-- |+-- Sometimes incoming requests don't stick to the+-- "no duplicate headers" invariant, for a number+-- of possible reasons (e.g. proxy servers blindly+-- adding headers), or your application (or other+-- middleware) blindly adds headers.+--+-- In those cases, you can use this 'Middleware'+-- to make sure that headers that /can/ be combined+-- /are/ combined. (e.g. applications might only+-- check the first \"Accept\" header and fail, while+-- there might be another one that would match)+module Network.Wai.Middleware.CombineHeaders (+ combineHeaders,+ CombineSettings,+ defaultCombineSettings,+ HeaderMap,+ HandleType,+ defaultHeaderMap,+ -- * Adjusting the settings- , setHeader- , removeHeader- , setHeaderMap- , regular- , keepOnly- , setRequestHeaders- , setResponseHeaders- ) where+ setHeader,+ removeHeader,+ setHeaderMap,+ regular,+ keepOnly,+ setRequestHeaders,+ setResponseHeaders,+) where import qualified Data.ByteString as B import qualified Data.List as L (foldl', reverse)@@ -36,7 +37,7 @@ import Data.Word8 (_comma, _space, _tab) import Network.HTTP.Types (Header, HeaderName, RequestHeaders) import qualified Network.HTTP.Types.Header as H-import Network.Wai (Middleware, requestHeaders, mapResponseHeaders)+import Network.Wai (Middleware, mapResponseHeaders, requestHeaders) import Network.Wai.Util (dropWhileEnd) -- | The mapping of 'HeaderName' to 'HandleType'@@ -56,14 +57,15 @@ -- combined) -- -- @since 3.1.13.0-data CombineSettings = CombineSettings {- combineHeaderMap :: HeaderMap,+data CombineSettings = CombineSettings+ { combineHeaderMap :: HeaderMap -- ^ Which headers should be combined? And how? (cf. 'HandleType')- combineRequestHeaders :: Bool,+ , combineRequestHeaders :: Bool -- ^ Should request headers be combined?- combineResponseHeaders :: Bool+ , combineResponseHeaders :: Bool -- ^ Should response headers be combined?-} deriving (Eq, Show)+ }+ deriving (Eq, Show) -- | Settings that combine request headers, -- but don't touch response headers.@@ -111,11 +113,12 @@ -- -- @since 3.1.13.0 defaultCombineSettings :: CombineSettings-defaultCombineSettings = CombineSettings {- combineHeaderMap = defaultHeaderMap,- combineRequestHeaders = True,- combineResponseHeaders = False-}+defaultCombineSettings =+ CombineSettings+ { combineHeaderMap = defaultHeaderMap+ , combineRequestHeaders = True+ , combineResponseHeaders = False+ } -- | Override the 'HeaderMap' of the 'CombineSettings' -- (default: 'defaultHeaderMap')@@ -144,18 +147,18 @@ -- @since 3.1.13.0 setHeader :: HeaderName -> HandleType -> CombineSettings -> CombineSettings setHeader name typ settings =- settings {- combineHeaderMap = M.insert name typ $ combineHeaderMap settings- }+ settings+ { combineHeaderMap = M.insert name typ $ combineHeaderMap settings+ } -- | Convenience function to remove a header from the header map. -- -- @since 3.1.13.0 removeHeader :: HeaderName -> CombineSettings -> CombineSettings removeHeader name settings =- settings {- combineHeaderMap = M.delete name $ combineHeaderMap settings- }+ settings+ { combineHeaderMap = M.delete name $ combineHeaderMap settings+ } -- | This middleware will reorganize the incoming and/or outgoing -- headers in such a way that it combines any duplicates of@@ -180,7 +183,7 @@ app newReq $ resFunc . adjustRes where newReq- | combineRequestHeaders = req { requestHeaders = mkNewHeaders oldHeaders }+ | combineRequestHeaders = req{requestHeaders = mkNewHeaders oldHeaders} | otherwise = req oldHeaders = requestHeaders req adjustRes@@ -191,14 +194,16 @@ go acc hdr@(name, _) = M.alter (checkHeader hdr) name acc checkHeader :: Header -> Maybe HeaderHandling -> Maybe HeaderHandling- checkHeader (name, newVal) = Just . \case- Nothing -> (name `M.lookup` combineHeaderMap, [newVal])- -- Yes, this reverses the order of headers, but these- -- will be reversed again in 'finishHeaders'- Just (mHandleType, hdrs) -> (mHandleType, newVal : hdrs)+ checkHeader (name, newVal) =+ Just . \case+ Nothing -> (name `M.lookup` combineHeaderMap, [newVal])+ -- Yes, this reverses the order of headers, but these+ -- will be reversed again in 'finishHeaders'+ Just (mHandleType, hdrs) -> (mHandleType, newVal : hdrs) -- | Unpack 'HeaderHandling' back into 'Header's again-finishHeaders :: HeaderName -> HeaderHandling -> RequestHeaders -> RequestHeaders+finishHeaders+ :: HeaderName -> HeaderHandling -> RequestHeaders -> RequestHeaders finishHeaders name (shouldCombine, xs) hdrs = case shouldCombine of Just typ -> (name, combinedHeader typ) : hdrs@@ -230,7 +235,7 @@ data HandleType = Regular | KeepOnly B.ByteString- deriving (Eq, Show)+ deriving (Eq, Show) -- | Use the regular strategy when combining headers. -- (i.e. merge into one header and separate values with commas)@@ -256,44 +261,42 @@ -- -- @since 3.1.13.0 defaultHeaderMap :: HeaderMap-defaultHeaderMap = M.fromList- [ (H.hAccept, Regular)- , ("Accept-CH", Regular)- , (H.hAcceptCharset, Regular)- , (H.hAcceptEncoding, Regular)- , (H.hAcceptLanguage, Regular)- , ("Accept-Post", Regular)- , ("Access-Control-Allow-Headers" , Regular) -- wildcard? yes, but can just add to list- , ("Access-Control-Allow-Methods" , Regular) -- wildcard? yes, but can just add to list- , ("Access-Control-Expose-Headers" , Regular) -- wildcard? yes, but can just add to list- , ("Access-Control-Request-Headers", Regular)- , (H.hAllow, Regular)- , ("Alt-Svc", KeepOnly "clear") -- special "clear" value (if any is "clear", only keep that one)- , (H.hCacheControl, Regular)- , ("Clear-Site-Data", KeepOnly "*") -- wildcard (if any is "*", only keep that one)-- -- If "close" and anything else is used together, it's already F-ed,- -- so just combine them.- , (H.hConnection, Regular)-- , (H.hContentEncoding, Regular)- , (H.hContentLanguage, Regular)- , ("Digest", Regular)-- -- We could handle this, but it's experimental AND- -- will be replaced by "Permissions-Policy"- -- , "Feature-Policy" -- "semicolon ';' separated"+defaultHeaderMap =+ M.fromList+ [ (H.hAccept, Regular)+ , ("Accept-CH", Regular)+ , (H.hAcceptCharset, Regular)+ , (H.hAcceptEncoding, Regular)+ , (H.hAcceptLanguage, Regular)+ , ("Accept-Post", Regular)+ , ("Access-Control-Allow-Headers", Regular) -- wildcard? yes, but can just add to list+ , ("Access-Control-Allow-Methods", Regular) -- wildcard? yes, but can just add to list+ , ("Access-Control-Expose-Headers", Regular) -- wildcard? yes, but can just add to list+ , ("Access-Control-Request-Headers", Regular)+ , (H.hAllow, Regular)+ , ("Alt-Svc", KeepOnly "clear") -- special "clear" value (if any is "clear", only keep that one)+ , (H.hCacheControl, Regular)+ , ("Clear-Site-Data", KeepOnly "*") -- wildcard (if any is "*", only keep that one)+ , -- If "close" and anything else is used together, it's already F-ed,+ -- so just combine them.+ (H.hConnection, Regular)+ , (H.hContentEncoding, Regular)+ , (H.hContentLanguage, Regular)+ , ("Digest", Regular)+ , -- We could handle this, but it's experimental AND+ -- will be replaced by "Permissions-Policy"+ -- , "Feature-Policy" -- "semicolon ';' separated" - , (H.hIfMatch, Regular)- , (H.hIfNoneMatch, KeepOnly "*") -- wildcard? (if any is "*", only keep that one)- , ("Link", Regular)- , ("Permissions-Policy", Regular)- , (H.hTE, Regular)- , ("Timing-Allow-Origin", KeepOnly "*") -- wildcard? (if any is "*", only keep that one)- , (H.hTrailer, Regular)- , (H.hTransferEncoding, Regular)- , (H.hUpgrade, Regular)- , (H.hVia, Regular)- , (H.hVary, KeepOnly "*") -- wildcard? (if any is "*", only keep that one)- , ("Want-Digest", Regular)- ]+ (H.hIfMatch, Regular)+ , (H.hIfNoneMatch, KeepOnly "*") -- wildcard? (if any is "*", only keep that one)+ , ("Link", Regular)+ , ("Permissions-Policy", Regular)+ , (H.hTE, Regular)+ , ("Timing-Allow-Origin", KeepOnly "*") -- wildcard? (if any is "*", only keep that one)+ , (H.hTrailer, Regular)+ , (H.hTransferEncoding, Regular)+ , (H.hUpgrade, Regular)+ , (H.hVia, Regular)+ , (H.hVary, KeepOnly "*") -- wildcard? (if any is "*", only keep that one)+ , ("Want-Digest", Regular)+ ]
Network/Wai/Middleware/ForceDomain.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+ -- | -- -- @since 3.0.14@@ -28,16 +29,15 @@ app req sendResponse Just domain -> sendResponse $ redirectResponse domain-- where- -- From: Network.Wai.Middleware.ForceSSL- redirectResponse domain =- responseBuilder status [(hLocation, location domain)] mempty+ where+ -- From: Network.Wai.Middleware.ForceSSL+ redirectResponse domain =+ responseBuilder status [(hLocation, location domain)] mempty - location h =- let p = if appearsSecure req then "https://" else "http://" in- p <> h <> rawPathInfo req <> rawQueryString req+ location h =+ let p = if appearsSecure req then "https://" else "http://"+ in p <> h <> rawPathInfo req <> rawQueryString req - status- | requestMethod req == methodGet = status301- | otherwise = status307+ status+ | requestMethod req == methodGet = status301+ | otherwise = status307
Network/Wai/Middleware/ForceSSL.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-}+ -- | Redirect non-SSL requests to https -- -- Since 3.0.7-module Network.Wai.Middleware.ForceSSL- ( forceSSL- ) where-+module Network.Wai.Middleware.ForceSSL (+ forceSSL,+) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>))@@ -26,12 +26,12 @@ forceSSL app req sendResponse = case (appearsSecure req, redirectResponse req) of (False, Just resp) -> sendResponse resp- _ -> app req sendResponse+ _ -> app req sendResponse redirectResponse :: Request -> Maybe Response redirectResponse req = do- host <- requestHeaderHost req- return $ responseBuilder status [(hLocation, location host)] mempty+ host <- requestHeaderHost req+ return $ responseBuilder status [(hLocation, location host)] mempty where location h = "https://" <> h <> rawPathInfo req <> rawQueryString req status
Network/Wai/Middleware/Gzip.hs view
@@ -1,4 +1,7 @@ ---------------------------------------------------------++---------------------------------------------------------+ -- | -- Module : Network.Wai.Middleware.Gzip -- Copyright : Michael Snoyman@@ -9,39 +12,45 @@ -- Portability : portable -- -- Automatic gzip compression of responses.--------------------------------------------------------------module Network.Wai.Middleware.Gzip- ( -- * How to use this module- -- $howto+module Network.Wai.Middleware.Gzip (+ -- * How to use this module+ -- $howto - -- ** The Middleware- -- $gzip- gzip+ -- ** The Middleware+ -- $gzip+ gzip, - -- ** The Settings- -- $settings- , GzipSettings- , gzipFiles- , gzipCheckMime- , gzipSizeThreshold+ -- ** The Settings+ -- $settings+ GzipSettings,+ defaultGzipSettings,+ gzipFiles,+ gzipCheckMime,+ gzipSizeThreshold, - -- ** How to handle file responses- , GzipFiles (..)+ -- ** How to handle file responses+ GzipFiles (..), - -- ** Miscellaneous- -- $miscellaneous- , defaultCheckMime- , def- ) where+ -- ** Miscellaneous+ -- $miscellaneous+ defaultCheckMime,+ def,+) where -import Control.Exception (IOException, SomeException, fromException, throwIO, try)+import Control.Exception (+ IOException,+ SomeException,+ fromException,+ throwIO,+ try,+ ) import Control.Monad (unless) import qualified Data.ByteString as S import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Builder.Extra as Blaze (flush) import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Lazy.Internal (defaultChunkSize)+import Data.Char (isAsciiLower, isAsciiUpper, isDigit) import Data.Default.Class (Default (..)) import Data.Function (fix) import Data.Maybe (isJust)@@ -107,9 +116,7 @@ -- evaluate to 'True' when applied to 'gzipCheckMime' -- (though 'GzipPreCompressed' will use the \".gz\" file regardless -- of MIME type on any 'ResponseFile' response)--- - -- $settings -- -- If you would like to use the default settings, using just 'def' is enough.@@ -123,7 +130,7 @@ -- @ -- myGzipSettings :: 'GzipSettings' -- myGzipSettings =--- 'def'+-- 'defaultGzipSettings' -- { 'gzipFiles' = 'GzipCompress' -- , 'gzipCheckMime' = myMimeCheckFunction -- , 'gzipSizeThreshold' = 860@@ -131,34 +138,34 @@ -- @ data GzipSettings = GzipSettings- { -- | Gzip behavior for files- --- -- Only applies to 'ResponseFile' ('responseFile') responses.- -- So any streamed data will be compressed based solely on the- -- response headers having the right \"Content-Type\" and- -- \"Content-Length\". (which are checked with 'gzipCheckMime'- -- and 'gzipSizeThreshold', respectively)- gzipFiles :: GzipFiles- -- | Decide which files to compress based on MIME type- --- -- The 'S.ByteString' is the value of the \"Content-Type\" response- -- header and will default to 'False' if the header is missing.- --- -- E.g. if you'd only want to compress @json@ data, you might- -- define your own function as follows:- --- -- > myCheckMime mime = mime == "application/json"+ { gzipFiles :: GzipFiles+ -- ^ Gzip behavior for files+ --+ -- Only applies to 'ResponseFile' ('responseFile') responses.+ -- So any streamed data will be compressed based solely on the+ -- response headers having the right \"Content-Type\" and+ -- \"Content-Length\". (which are checked with 'gzipCheckMime'+ -- and 'gzipSizeThreshold', respectively) , gzipCheckMime :: S.ByteString -> Bool- -- | Skip compression when the size of the response body is- -- below this amount of bytes (default: 860.)- --- -- /Setting this option to less than 150 will actually increase/- -- /the size of outgoing data if its original size is less than 150 bytes/.- --- -- This will only skip compression if the response includes a- -- \"Content-Length\" header /AND/ the length is less than this- -- threshold.+ -- ^ Decide which files to compress based on MIME type+ --+ -- The 'S.ByteString' is the value of the \"Content-Type\" response+ -- header and will default to 'False' if the header is missing.+ --+ -- E.g. if you'd only want to compress @json@ data, you might+ -- define your own function as follows:+ --+ -- > myCheckMime mime = mime == "application/json" , gzipSizeThreshold :: Integer+ -- ^ Skip compression when the size of the response body is+ -- below this amount of bytes (default: 860.)+ --+ -- /Setting this option to less than 150 will actually increase/+ -- /the size of outgoing data if its original size is less than 150 bytes/.+ --+ -- This will only skip compression if the response includes a+ -- \"Content-Length\" header /AND/ the length is less than this+ -- threshold. } -- | Gzip behavior for files.@@ -196,8 +203,18 @@ -- | Use default MIME settings; /do not/ compress files; skip -- compression on data smaller than 860 bytes. instance Default GzipSettings where- def = GzipSettings GzipIgnore defaultCheckMime minimumLength+ def = defaultGzipSettings +-- | Default settings for the 'gzip' middleware.+--+-- * Does not compress files.+-- * Uses 'defaultCheckMime'.+-- * Compession threshold set to 860 bytes.+--+-- @since 3.1.14.0+defaultGzipSettings :: GzipSettings+defaultGzipSettings = GzipSettings GzipIgnore defaultCheckMime minimumLength+ -- | MIME types that will be compressed by default: -- @text/@ @*@, @application/json@, @application/javascript@, -- @application/ecmascript@, @image/x-icon@.@@ -206,12 +223,13 @@ S8.isPrefixOf "text/" bs || bs' `Set.member` toCompress where bs' = fst $ S.break (== _semicolon) bs- toCompress = Set.fromList- [ "application/json"- , "application/javascript"- , "application/ecmascript"- , "image/x-icon"- ]+ toCompress =+ Set.fromList+ [ "application/json"+ , "application/javascript"+ , "application/ecmascript"+ , "image/x-icon"+ ] -- | Use gzip to compress the body of the response. gzip :: GzipSettings -> Middleware@@ -221,14 +239,14 @@ let runAction x = case x of (ResponseRaw{}, _) -> sendResponse res -- Always skip if 'GzipIgnore'- (ResponseFile {}, GzipIgnore) -> sendResponse res+ (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)+ 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@@ -240,12 +258,12 @@ in compressFile s hs file mETag cache sendResponse -- Use streaming logic _ -> compressE res sendResponse- in runAction (res, gzipFiles set)+ in runAction (res, gzipFiles set) where isCorrectMime = maybe False (gzipCheckMime set) . lookup hContentType sendResponse = sendResponse' . mapResponseHeaders mAddVary- acceptEncoding = "Accept-Encoding"+ acceptEncoding = "Accept-Encoding" acceptEncodingLC = "accept-encoding" -- Instead of just adding a header willy-nilly, we check if -- "Vary" is already present, and add to it if not already included.@@ -256,8 +274,9 @@ lowercase = S.map W8.toLower -- Field names are case-insensitive, so we lowercase to match hasAccEnc = acceptEncodingLC `elem` fmap lowercase vals- newH | hasAccEnc = h- | otherwise = (hVary, acceptEncoding <> ", " <> val)+ newH+ | hasAccEnc = h+ | otherwise = (hVary, acceptEncoding <> ", " <> val) in newH : hs | otherwise = h : mAddVary hs @@ -276,7 +295,8 @@ maybe False ("MSIE 6" `S.isInfixOf`) $ hUserAgent `lookup` reqHdrs -- Can we skip just by looking at the current 'Response'?- checkCompress :: (Response -> IO ResponseReceived) -> Response -> IO ResponseReceived+ checkCompress+ :: (Response -> IO ResponseReceived) -> Response -> IO ResponseReceived checkCompress continue res = if isEncodedAlready || isPartial || tooSmall then sendResponse res@@ -299,7 +319,14 @@ minimumLength :: Integer minimumLength = 860 -compressFile :: Status -> [Header] -> FilePath -> Maybe S.ByteString -> FilePath -> (Response -> IO a) -> IO a+compressFile+ :: Status+ -> [Header]+ -> FilePath+ -> Maybe S.ByteString+ -> FilePath+ -> (Response -> IO a)+ -> IO a compressFile s hs file mETag cache sendResponse = do e <- doesFileExist tmpfile if e@@ -307,25 +334,25 @@ else do createDirectoryIfMissing True cache x <- try $- IO.withBinaryFile file IO.ReadMode $ \inH ->- IO.withBinaryFile tmpfile IO.WriteMode $ \outH -> do- deflate <- Z.initDeflate 7 $ Z.WindowBits 31- -- FIXME this code should write to a temporary file, then- -- rename to the final file- let goPopper popper = fix $ \loop -> do- res <- popper- case res of- Z.PRDone -> return ()- Z.PRNext bs -> do- S.hPut outH bs- loop- Z.PRError ex -> throwIO ex- fix $ \loop -> do- bs <- S.hGetSome inH defaultChunkSize- unless (S.null bs) $ do- Z.feedDeflate deflate bs >>= goPopper- loop- goPopper $ Z.finishDeflate deflate+ IO.withBinaryFile file IO.ReadMode $ \inH ->+ IO.withBinaryFile tmpfile IO.WriteMode $ \outH -> do+ deflate <- Z.initDeflate 7 $ Z.WindowBits 31+ -- FIXME this code should write to a temporary file, then+ -- rename to the final file+ let goPopper popper = fix $ \loop -> do+ res <- popper+ case res of+ Z.PRDone -> return ()+ Z.PRNext bs -> do+ S.hPut outH bs+ loop+ Z.PRError ex -> throwIO ex+ fix $ \loop -> do+ bs <- S.hGetSome inH defaultChunkSize+ unless (S.null bs) $ do+ Z.feedDeflate deflate bs >>= goPopper+ loop+ goPopper $ Z.finishDeflate deflate either onErr (const onSucc) (x :: Either SomeException ()) where onSucc = sendResponse $ responseFile s (fixHeaders hs) tmpfile Nothing@@ -348,16 +375,15 @@ tmpfile = cache ++ '/' : map safe file ++ eTag safe c- | 'A' <= c && c <= 'Z' = c- | 'a' <= c && c <= 'z' = c- | '0' <= c && c <= '9' = c+ | isAsciiUpper c || isAsciiLower c || isDigit c = c safe '-' = '-' safe '_' = '_' safe _ = '_' -compressE :: Response- -> (Response -> IO ResponseReceived)- -> IO ResponseReceived+compressE+ :: Response+ -> (Response -> IO ResponseReceived)+ -> IO ResponseReceived compressE res sendResponse = wb $ \body -> sendResponse $ responseStream s (fixHeaders hs) $ \sendChunk flush -> do
Network/Wai/Middleware/HealthCheckEndpoint.hs view
@@ -1,4 +1,7 @@ ---------------------------------------------------------++---------------------------------------------------------+ -- | -- Module : Network.Wai.Middleware.HealthCheckEndpoint -- Copyright : Michael Snoyman@@ -9,12 +12,10 @@ -- Portability : portable -- -- Add empty endpoint (for Health check tests)--------------------------------------------------------------module Network.Wai.Middleware.HealthCheckEndpoint- ( healthCheck,+module Network.Wai.Middleware.HealthCheckEndpoint (+ healthCheck, voidEndpoint,- )+) where import Data.ByteString (ByteString)@@ -32,6 +33,6 @@ -- @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+ if rawPathInfo request == endpointPath+ then respond $ responseLBS status200 mempty "-"+ else router request respond
Network/Wai/Middleware/HttpAuth.hs view
@@ -1,23 +1,25 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-}+ -- | Implements HTTP Basic Authentication. -- -- This module may add digest authentication in the future.-module Network.Wai.Middleware.HttpAuth- ( -- * Middleware- basicAuth- , basicAuth'- , CheckCreds- , AuthSettings- , authRealm- , authOnNoAuth- , authIsProtected- -- * Helping functions- , extractBasicAuth- , extractBearerAuth- ) where+module Network.Wai.Middleware.HttpAuth (+ -- * Middleware+ basicAuth,+ basicAuth',+ CheckCreds,+ AuthSettings,+ authRealm,+ authOnNoAuth,+ authIsProtected, + -- * Helping functions+ extractBasicAuth,+ extractBearerAuth,+) where+ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif@@ -27,31 +29,38 @@ import Data.String (IsString (..)) import Data.Word8 (isSpace, toLower, _colon) import Network.HTTP.Types (hAuthorization, hContentType, status401)-import Network.Wai (Application, Middleware, Request (requestHeaders), responseLBS)-+import Network.Wai (+ Application,+ Middleware,+ Request (requestHeaders),+ responseLBS,+ ) -- | Check if a given username and password is valid.-type CheckCreds = ByteString- -> ByteString- -> IO Bool+type CheckCreds =+ ByteString+ -> ByteString+ -> IO Bool -- | Perform basic authentication. -- -- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm" -- -- @since 1.3.4-basicAuth :: CheckCreds- -> AuthSettings- -> Middleware-basicAuth checkCreds = basicAuth' (\_ -> checkCreds)+basicAuth+ :: CheckCreds+ -> AuthSettings+ -> Middleware+basicAuth = basicAuth' . const -- | Like 'basicAuth', but also passes a request to the authentication function. -- -- @since 3.0.19-basicAuth' :: (Request -> CheckCreds)- -> AuthSettings- -> Middleware-basicAuth' checkCreds AuthSettings {..} app req sendResponse = do+basicAuth'+ :: (Request -> CheckCreds)+ -> AuthSettings+ -> Middleware+basicAuth' checkCreds AuthSettings{..} app req sendResponse = do isProtected <- authIsProtected req allowed <- if isProtected then check else return True if allowed@@ -60,7 +69,7 @@ where check = case lookup hAuthorization (requestHeaders req)- >>= extractBasicAuth of+ >>= extractBasicAuth of Nothing -> return False Just (username, password) -> checkCreds req username password @@ -91,20 +100,26 @@ } instance IsString AuthSettings where- fromString s = AuthSettings- { authRealm = fromString s- , authOnNoAuth = \realm _req f -> f $ responseLBS- status401- [ (hContentType, "text/plain")- , ("WWW-Authenticate", S.concat- [ "Basic realm=\""- , realm- , "\""- ])- ]- "Basic authentication is required"- , authIsProtected = const $ return True- }+ fromString s =+ AuthSettings+ { authRealm = fromString s+ , authOnNoAuth = \realm _req f ->+ f $+ responseLBS+ status401+ [ (hContentType, "text/plain")+ ,+ ( "WWW-Authenticate"+ , S.concat+ [ "Basic realm=\""+ , realm+ , "\""+ ]+ )+ ]+ "Basic authentication is required"+ , authIsProtected = const $ return True+ } -- | Extract basic authentication data from usually __Authorization__ -- header value. Returns username and password@@ -113,14 +128,14 @@ extractBasicAuth :: ByteString -> Maybe (ByteString, ByteString) extractBasicAuth bs = let (x, y) = S.break isSpace bs- in if S.map toLower x == "basic"- then extract $ S.dropWhile isSpace y- else Nothing+ in if S.map toLower x == "basic"+ then extract $ S.dropWhile isSpace y+ else Nothing where extract encoded = let raw = decodeLenient encoded (username, password') = S.break (== _colon) raw- in ((username,) . snd) <$> S.uncons password'+ in (username,) . snd <$> S.uncons password' -- | Extract bearer authentication data from __Authorization__ header -- value. Returns bearer token@@ -129,6 +144,6 @@ extractBearerAuth :: ByteString -> Maybe ByteString extractBearerAuth bs = let (x, y) = S.break isSpace bs- in if S.map toLower x == "bearer"- then Just $ S.dropWhile isSpace y- else Nothing+ in if S.map toLower x == "bearer"+ then Just $ S.dropWhile isSpace y+ else Nothing
Network/Wai/Middleware/Jsonp.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-}+ ---------------------------------------------------------++---------------------------------------------------------+ -- | -- Module : Network.Wai.Middleware.Jsonp -- Copyright : Michael Snoyman@@ -10,8 +14,6 @@ -- Portability : portable -- -- Automatic wrapping of JSON responses to convert into JSONP.------------------------------------------------------------- module Network.Wai.Middleware.Jsonp (jsonp) where import Control.Monad (join)@@ -46,10 +48,13 @@ let env' = case callback of Nothing -> env- Just _ -> env- { requestHeaders = changeVal hAccept- "application/json"- $ requestHeaders env+ Just _ ->+ env+ { requestHeaders =+ changeVal+ hAccept+ "application/json"+ $ requestHeaders env } app env' $ \res -> case callback of@@ -59,11 +64,12 @@ go c r@(ResponseBuilder s hs b) = sendResponse $ case checkJSON hs of Nothing -> r- Just hs' -> responseBuilder s hs' $- byteStringCopy c- `mappend` char7 '('- `mappend` b- `mappend` char7 ')'+ Just hs' ->+ responseBuilder s hs' $+ byteStringCopy c+ `mappend` char7 '('+ `mappend` b+ `mappend` char7 ')' go c r = case checkJSON hs of Just hs' -> addCallback c s hs' wb@@ -85,10 +91,12 @@ _ <- body sendChunk flush sendChunk $ char7 ')' -changeVal :: Eq a- => a- -> ByteString- -> [(a, ByteString)]- -> [(a, ByteString)]-changeVal key val old = (key, val)- : filter (\(k, _) -> k /= key) old+changeVal+ :: Eq a+ => a+ -> ByteString+ -> [(a, ByteString)]+ -> [(a, ByteString)]+changeVal key val old =+ (key, val)+ : filter (\(k, _) -> k /= key) old
Network/Wai/Middleware/MethodOverride.hs view
@@ -1,6 +1,6 @@-module Network.Wai.Middleware.MethodOverride- ( methodOverride- ) where+module Network.Wai.Middleware.MethodOverride (+ methodOverride,+) where import Control.Monad (join) import Network.Wai (Middleware, queryString, requestMethod)@@ -16,5 +16,5 @@ where req' = case (requestMethod req, join $ lookup "_method" $ queryString req) of- ("POST", Just m) -> req { requestMethod = m }+ ("POST", Just m) -> req{requestMethod = m} _ -> req
Network/Wai/Middleware/MethodOverridePost.hs view
@@ -1,12 +1,15 @@ {-# LANGUAGE CPP #-}+ -----------------------------------------------------------------++-----------------------------------------------------------------+ -- | Module : Network.Wai.Middleware.MethodOverridePost -- -- Changes the request-method via first post-parameter _method.-------------------------------------------------------------------module Network.Wai.Middleware.MethodOverridePost- ( methodOverridePost- ) where+module Network.Wai.Middleware.MethodOverridePost (+ methodOverridePost,+) where import Data.ByteString.Lazy (toChunks) import Data.IORef (atomicModifyIORef, newIORef)@@ -26,18 +29,20 @@ -- parameter. -- -- * This middleware only applies when the initial request method is POST.--- methodOverridePost :: Middleware methodOverridePost app req send = case (requestMethod req, lookup hContentType (requestHeaders req)) of- ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send- _ -> app req send+ ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send+ _ -> app req send setPost :: Request -> IO Request setPost req = do- body <- (mconcat . toChunks) `fmap` lazyRequestBody req- ref <- newIORef body- let rb = atomicModifyIORef ref $ \bs -> (mempty, bs)- case parseQuery body of- (("_method", Just newmethod):_) -> return $ req {requestBody = rb, requestMethod = newmethod}- _ -> return $ req {requestBody = rb}+ body <- (mconcat . toChunks) `fmap` lazyRequestBody req+ ref <- newIORef body+ let rb = atomicModifyIORef ref $ \bs -> (mempty, bs)+ req' = setRequestBodyChunks rb req+ case parseQuery body of+ (("_method", Just newmethod) : _) -> return req'{requestMethod = newmethod}+ _ -> return req'++{- HLint ignore setPost "Use tuple-section" -}
Network/Wai/Middleware/RealIp.hs view
@@ -1,11 +1,11 @@ -- | Infer the remote IP address using headers-module Network.Wai.Middleware.RealIp- ( realIp- , realIpHeader- , realIpTrusted- , defaultTrusted- , ipInRange- ) where+module Network.Wai.Middleware.RealIp (+ realIp,+ realIpHeader,+ realIpTrusted,+ defaultTrusted,+ ipInRange,+) where import qualified Data.ByteString.Char8 as B8 (split, unpack) import qualified Data.IP as IP@@ -48,26 +48,28 @@ -- -- @since 3.1.5 realIpTrusted :: HeaderName -> (IP.IP -> Bool) -> Middleware-realIpTrusted header isTrusted app req respond = app req' respond+realIpTrusted header isTrusted app req = app req' where req' = fromMaybe req $ do- (ip, port) <- IP.fromSockAddr (remoteHost req)- ip' <- if isTrusted ip- then findRealIp (requestHeaders req) header isTrusted- else Nothing- Just $ req { remoteHost = IP.toSockAddr (ip', port) }+ (ip, port) <- IP.fromSockAddr (remoteHost req)+ ip' <-+ if isTrusted ip+ then findRealIp (requestHeaders req) header isTrusted+ else Nothing+ Just $ req{remoteHost = IP.toSockAddr (ip', port)} -- | Standard private IP ranges. -- -- @since 3.1.5 defaultTrusted :: [IP.IPRange]-defaultTrusted = [ "127.0.0.0/8"- , "10.0.0.0/8"- , "172.16.0.0/12"- , "192.168.0.0/16"- , "::1/128"- , "fc00::/7"- ]+defaultTrusted =+ [ "127.0.0.0/8"+ , "10.0.0.0/8"+ , "172.16.0.0/12"+ , "192.168.0.0/16"+ , "::1/128"+ , "fc00::/7"+ ] -- | Check if the given IP address is in the given range. --@@ -81,14 +83,13 @@ ipInRange (IP.IPv4 ip) (IP.IPv6Range r) = IP.ipv4ToIPv6 ip `IP.isMatchedTo` r ipInRange _ _ = False - findRealIp :: RequestHeaders -> HeaderName -> (IP.IP -> Bool) -> Maybe IP.IP findRealIp reqHeaders header isTrusted = case (nonTrusted, ips) of- ([], xs) -> listToMaybe xs- (xs, _) -> listToMaybe $ reverse xs+ ([], xs) -> listToMaybe xs+ (xs, _) -> listToMaybe $ reverse xs where -- account for repeated headers- headerVals = [ v | (k, v) <- reqHeaders, k == header ]- ips = mapMaybe (readMaybe . B8.unpack) $ concatMap (B8.split ',') headerVals+ headerVals = [v | (k, v) <- reqHeaders, k == header]+ ips = concatMap (mapMaybe (readMaybe . B8.unpack) . B8.split ',') headerVals nonTrusted = filter (not . isTrusted) ips
Network/Wai/Middleware/RequestLogger.hs view
@@ -4,32 +4,33 @@ -- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should -- not use CPP. -- EDIT: Fixed this by adding two "zero-width spaces" in between the "*/*"-module Network.Wai.Middleware.RequestLogger- ( -- * Basic stdout logging- logStdout- , logStdoutDev- -- * Create more versions- , mkRequestLogger- , RequestLoggerSettings- , defaultRequestLoggerSettings- , outputFormat- , autoFlush- , destination- , OutputFormat (..)- , ApacheSettings- , defaultApacheSettings- , setApacheIPAddrSource- , setApacheRequestFilter- , setApacheUserGetter- , DetailedSettings (..)- , OutputFormatter- , OutputFormatterWithDetails- , OutputFormatterWithDetailsAndHeaders- , Destination (..)- , Callback- , IPAddrSource (..)- ) where+module Network.Wai.Middleware.RequestLogger (+ -- * Basic stdout logging+ logStdout,+ logStdoutDev, + -- * Create more versions+ mkRequestLogger,+ RequestLoggerSettings,+ defaultRequestLoggerSettings,+ outputFormat,+ autoFlush,+ destination,+ OutputFormat (..),+ ApacheSettings,+ defaultApacheSettings,+ setApacheIPAddrSource,+ setApacheRequestFilter,+ setApacheUserGetter,+ DetailedSettings (..),+ OutputFormatter,+ OutputFormatterWithDetails,+ OutputFormatterWithDetailsAndHeaders,+ Destination (..),+ Callback,+ IPAddrSource (..),+) where+ import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as BS@@ -46,12 +47,17 @@ 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 Network.Wai (+ Middleware,+ Request (..),+ RequestBodyLength (..),+ Response,+ getRequestBodyChunk,+ requestBodyLength,+ responseHeaders,+ responseStatus,+ setRequestBodyChunks,+ ) import Network.Wai.Internal (Response (..)) import Network.Wai.Logger import System.Console.ANSI@@ -61,24 +67,27 @@ import Network.Wai.Header (contentLength) import Network.Wai.Middleware.RequestLogger.Internal-import Network.Wai.Parse- ( Param- , File- , fileName- , getRequestBodyType- , lbsBackEnd- , sinkRequestBody- )+import Network.Wai.Parse (+ File,+ Param,+ fileName,+ getRequestBodyType,+ lbsBackEnd,+ sinkRequestBody,+ ) -- | The logging format. data OutputFormat- = Apache IPAddrSource- | ApacheWithSettings ApacheSettings -- ^ @since 3.1.8- | Detailed Bool -- ^ use colors?- | DetailedWithSettings DetailedSettings -- ^ @since 3.1.3- | CustomOutputFormat OutputFormatter- | CustomOutputFormatWithDetails OutputFormatterWithDetails- | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders+ = Apache IPAddrSource+ | -- | @since 3.1.8+ ApacheWithSettings ApacheSettings+ | -- | use colors?+ Detailed Bool+ | -- | @since 3.1.3+ DetailedWithSettings DetailedSettings+ | CustomOutputFormat OutputFormatter+ | CustomOutputFormatWithDetails OutputFormatterWithDetails+ | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders -- | Settings for the `ApacheWithSettings` `OutputFormat`. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards@@ -95,11 +104,12 @@ } defaultApacheSettings :: ApacheSettings-defaultApacheSettings = ApacheSettings- { apacheIPAddrSource = FromSocket- , apacheRequestFilter = \_ _ -> True- , apacheUserGetter = \_ -> Nothing- }+defaultApacheSettings =+ ApacheSettings+ { apacheIPAddrSource = FromSocket+ , apacheRequestFilter = \_ _ -> True+ , apacheUserGetter = const Nothing+ } -- | Where to take IP addresses for clients from. See 'IPAddrSource' for more information. --@@ -107,7 +117,7 @@ -- -- @since 3.1.8 setApacheIPAddrSource :: IPAddrSource -> ApacheSettings -> ApacheSettings-setApacheIPAddrSource x y = y { apacheIPAddrSource = x }+setApacheIPAddrSource x y = y{apacheIPAddrSource = x} -- | Function that allows you to filter which requests are logged, based on -- the request and response@@ -115,8 +125,9 @@ -- Default: log all requests -- -- @since 3.1.8-setApacheRequestFilter :: (Request -> Response -> Bool) -> ApacheSettings -> ApacheSettings-setApacheRequestFilter x y = y { apacheRequestFilter = x }+setApacheRequestFilter+ :: (Request -> Response -> Bool) -> ApacheSettings -> ApacheSettings+setApacheRequestFilter x y = y{apacheRequestFilter = x} -- | Function that allows you to get the current user from the request, which -- will then be added in the log.@@ -124,8 +135,9 @@ -- Default: return no user -- -- @since 3.1.8-setApacheUserGetter :: (Request -> Maybe BS.ByteString) -> ApacheSettings -> ApacheSettings-setApacheUserGetter x y = y { apacheUserGetter = x }+setApacheUserGetter+ :: (Request -> Maybe BS.ByteString) -> ApacheSettings -> ApacheSettings+setApacheUserGetter x y = y{apacheUserGetter = x} -- | Settings for the `Detailed` `OutputFormat`. --@@ -143,28 +155,30 @@ { useColors :: Bool , mModifyParams :: Maybe (Param -> Maybe Param) , mFilterRequests :: Maybe (Request -> Response -> Bool)- , mPrelogRequests :: Bool -- ^ @since 3.1.7+ , mPrelogRequests :: Bool+ -- ^ @since 3.1.7 } instance Default DetailedSettings where- def = DetailedSettings- { useColors = True- , mModifyParams = Nothing- , mFilterRequests = Nothing- , mPrelogRequests = False- }+ def =+ DetailedSettings+ { useColors = True+ , mModifyParams = Nothing+ , mFilterRequests = Nothing+ , mPrelogRequests = False+ } type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr -type OutputFormatterWithDetails- = ZonedDate- -> Request- -> Status- -> Maybe Integer- -> NominalDiffTime- -> [S8.ByteString]- -> B.Builder- -> LogStr+type OutputFormatterWithDetails =+ ZonedDate+ -> Request+ -> Status+ -> Maybe Integer+ -> NominalDiffTime+ -> [S8.ByteString]+ -> B.Builder+ -> LogStr -- | Same as @OutputFormatterWithDetails@ but with response headers included --@@ -173,20 +187,29 @@ -- header in your application and retrieve in the log formatter. -- -- @since 3.0.27-type OutputFormatterWithDetailsAndHeaders- = ZonedDate -- ^ When the log message was generated- -> Request -- ^ The WAI request- -> Status -- ^ HTTP status code- -> Maybe Integer -- ^ Response size- -> NominalDiffTime -- ^ Duration of the request- -> [S8.ByteString] -- ^ The request body- -> B.Builder -- ^ Raw response- -> [Header] -- ^ The response headers- -> LogStr+type OutputFormatterWithDetailsAndHeaders =+ ZonedDate+ -- ^ When the log message was generated+ -> Request+ -- ^ The WAI request+ -> Status+ -- ^ HTTP status code+ -> Maybe Integer+ -- ^ Response size+ -> NominalDiffTime+ -- ^ Duration of the request+ -> [S8.ByteString]+ -- ^ The request body+ -> B.Builder+ -- ^ Raw response+ -> [Header]+ -- ^ The response headers+ -> LogStr -data Destination = Handle Handle- | Logger LoggerSet- | Callback Callback+data Destination+ = Handle Handle+ | Logger LoggerSet+ | Callback Callback type Callback = LogStr -> IO () @@ -196,23 +219,23 @@ -- for the record type @RequestLoggerSettings@, so they can be used to -- modify settings values using record syntax. data RequestLoggerSettings = RequestLoggerSettings- {- -- | Default value: @Detailed@ @True@.- outputFormat :: OutputFormat- -- | Only applies when using the @Handle@ constructor for @destination@.- --- -- Default value: @True@.+ { outputFormat :: OutputFormat+ -- ^ Default value: @Detailed@ @True@. , autoFlush :: Bool- -- | Default: @Handle@ @stdout@.+ -- ^ Only applies when using the @Handle@ constructor for @destination@.+ --+ -- Default value: @True@. , destination :: Destination+ -- ^ Default: @Handle@ @stdout@. } defaultRequestLoggerSettings :: RequestLoggerSettings-defaultRequestLoggerSettings = RequestLoggerSettings- { outputFormat = Detailed True- , autoFlush = True- , destination = Handle stdout- }+defaultRequestLoggerSettings =+ RequestLoggerSettings+ { outputFormat = Detailed True+ , autoFlush = True+ , destination = Handle stdout+ } instance Default RequestLoggerSettings where def = defaultRequestLoggerSettings@@ -232,11 +255,16 @@ return $ apacheMiddleware (\_ _ -> True) apache ApacheWithSettings ApacheSettings{..} -> do getdate <- getDateGetter flusher- apache <- initLoggerUser (Just apacheUserGetter) apacheIPAddrSource (LogCallback callback flusher) getdate+ apache <-+ initLoggerUser+ (Just apacheUserGetter)+ apacheIPAddrSource+ (LogCallback callback flusher)+ getdate return $ apacheMiddleware apacheRequestFilter apache Detailed useColors ->- let settings = def { useColors = useColors}- in detailedMiddleware callbackAndFlush settings+ let settings = def{useColors = useColors}+ in detailedMiddleware callbackAndFlush settings DetailedWithSettings settings -> detailedMiddleware callbackAndFlush settings CustomOutputFormat formatter -> do@@ -247,12 +275,15 @@ return $ customMiddlewareWithDetails callbackAndFlush getdate formatter CustomOutputFormatWithDetailsAndHeaders formatter -> do getdate <- getDateGetter flusher- return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter+ return $+ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter -apacheMiddleware :: (Request -> Response -> Bool) -> ApacheLoggerActions -> Middleware+apacheMiddleware+ :: (Request -> Response -> Bool) -> ApacheLoggerActions -> Middleware apacheMiddleware applyRequestFilter ala app req sendResponse = app req $ \res -> do when (applyRequestFilter req res) $- apacheLogger ala req (responseStatus res) $ contentLength (responseHeaders res)+ apacheLogger ala req (responseStatus res) $+ contentLength (responseHeaders res) sendResponse res customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware@@ -262,47 +293,53 @@ liftIO $ cb $ formatter date req (responseStatus res) msize sendResponse res -customMiddlewareWithDetails :: Callback -> IO ZonedDate -> OutputFormatterWithDetails -> Middleware+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- let msize = contentLength (responseHeaders res)- builderIO <- newIORef $ B.byteString ""- res' <- recordChunks builderIO res- rspRcv <- sendResponse res'- _ <- liftIO . cb .- formatter date req' (responseStatus res') msize (t1 `diffUTCTime` t0) reqBody =<<- readIORef builderIO- return rspRcv+ (req', reqBody) <- getRequestBody req+ t0 <- getCurrentTime+ app req' $ \res -> do+ t1 <- getCurrentTime+ date <- liftIO getdate+ let msize = contentLength (responseHeaders res)+ builderIO <- newIORef $ B.byteString ""+ res' <- recordChunks builderIO res+ rspRcv <- sendResponse res'+ _ <-+ liftIO+ . cb+ . formatter date req' (responseStatus res') msize (t1 `diffUTCTime` t0) reqBody+ =<< readIORef builderIO+ return rspRcv -customMiddlewareWithDetailsAndHeaders :: Callback -> IO ZonedDate -> OutputFormatterWithDetailsAndHeaders -> Middleware+customMiddlewareWithDetailsAndHeaders+ :: Callback -> IO ZonedDate -> OutputFormatterWithDetailsAndHeaders -> Middleware customMiddlewareWithDetailsAndHeaders cb getdate formatter app req sendResponse = do- (req', reqBody) <- getRequestBody req- t0 <- getCurrentTime- app req' $ \res -> do- t1 <- getCurrentTime- date <- liftIO getdate- let msize = contentLength (responseHeaders res)- builderIO <- newIORef $ B.byteString ""- res' <- recordChunks builderIO res- rspRcv <- sendResponse res'- _ <- do- rawResponse <- readIORef builderIO- let status = responseStatus res'- duration = t1 `diffUTCTime` t0- resHeaders = responseHeaders res'- liftIO . cb $ formatter date req' status msize duration reqBody rawResponse resHeaders- return rspRcv+ (req', reqBody) <- getRequestBody req+ t0 <- getCurrentTime+ app req' $ \res -> do+ t1 <- getCurrentTime+ date <- liftIO getdate+ let msize = contentLength (responseHeaders res)+ builderIO <- newIORef $ B.byteString ""+ res' <- recordChunks builderIO res+ rspRcv <- sendResponse res'+ _ <- do+ rawResponse <- readIORef builderIO+ let status = responseStatus res'+ duration = t1 `diffUTCTime` t0+ resHeaders = responseHeaders res'+ liftIO . cb $+ formatter date req' status msize duration reqBody rawResponse resHeaders+ return rspRcv+ -- | Production request logger middleware. -- -- This uses the 'Apache' logging format, and takes IP addresses for clients from -- the socket (see 'IPAddrSource' for more information). It logs to 'stdout'. {-# NOINLINE logStdout #-} logStdout :: Middleware-logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket }+logStdout = unsafePerformIO $ mkRequestLogger def{outputFormat = Apache FromSocket} -- | Development request logger middleware. --@@ -333,16 +370,14 @@ -- > Accept: text/css,*/*;q=0.1 -- > Status: 304 Not Modified 0.010555s detailedMiddleware :: Callback -> DetailedSettings -> IO Middleware- -- NB: The */* in the comments above have "zero-width spaces" in them, so the -- CPP doesn't screw up everything. So don't copy those; they're technically wrong. detailedMiddleware cb settings = let (ansiColor, ansiMethod, ansiStatusCode) =- if useColors settings- then (ansiColor', ansiMethod', ansiStatusCode')- else (\_ t -> [t], (:[]), \_ t -> [t])-- in return $ detailedMiddleware' cb settings ansiColor ansiMethod ansiStatusCode+ if useColors settings+ then (ansiColor', ansiMethod', ansiStatusCode')+ else (\_ t -> [t], (: []), \_ t -> [t])+ in return $ detailedMiddleware' cb settings ansiColor ansiMethod ansiStatusCode ansiColor' :: Color -> BS.ByteString -> [BS.ByteString] ansiColor' color bs =@@ -354,114 +389,124 @@ -- | Tags http method with a unique color. ansiMethod' :: BS.ByteString -> [BS.ByteString] ansiMethod' m = case m of- "GET" -> ansiColor' Cyan m- "HEAD" -> ansiColor' Cyan m- "PUT" -> ansiColor' Green m- "POST" -> ansiColor' Yellow m+ "GET" -> ansiColor' Cyan m+ "HEAD" -> ansiColor' Cyan m+ "PUT" -> ansiColor' Green m+ "POST" -> ansiColor' Yellow m "DELETE" -> ansiColor' Red m- _ -> ansiColor' Magenta m+ _ -> ansiColor' Magenta m ansiStatusCode' :: BS.ByteString -> BS.ByteString -> [BS.ByteString] ansiStatusCode' c t = case S8.take 1 c of- "2" -> ansiColor' Green t- "3" -> ansiColor' Yellow t- "4" -> ansiColor' Red t- "5" -> ansiColor' Magenta t- _ -> ansiColor' Blue t+ "2" -> ansiColor' Green t+ "3" -> ansiColor' Yellow t+ "4" -> ansiColor' Red t+ "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)+ 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+ return r getRequestBody :: Request -> IO (Request, [S8.ByteString]) getRequestBody req = do- let loop front = do- bs <- getRequestBodyChunk 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)+ let loop front = do+ bs <- getRequestBodyChunk 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' = setRequestBodyChunks rbody req+ return (req', body) -detailedMiddleware' :: Callback- -> DetailedSettings- -> (Color -> BS.ByteString -> [BS.ByteString])- -> (BS.ByteString -> [BS.ByteString])- -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])- -> Middleware+{- HLint ignore getRequestBody "Use lambda-case" -}++detailedMiddleware'+ :: Callback+ -> DetailedSettings+ -> (Color -> BS.ByteString -> [BS.ByteString])+ -> (BS.ByteString -> [BS.ByteString])+ -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])+ -> Middleware detailedMiddleware' cb DetailedSettings{..} ansiColor ansiMethod ansiStatusCode app req sendResponse = do- (req', body) <-- -- second tuple item should not be necessary, but a test runner might mess it up- case (requestBodyLength req, contentLength (requestHeaders req)) of- -- log the request body if it is small- (KnownLength len, _) | len <= 2048 -> getRequestBody req- (_, Just len) | len <= 2048 -> getRequestBody req- _ -> return (req, [])+ (req', body) <-+ -- second tuple item should not be necessary, but a test runner might mess it up+ case (requestBodyLength req, contentLength (requestHeaders req)) of+ -- log the request body if it is small+ (KnownLength len, _) | len <= 2048 -> getRequestBody req+ (_, Just len) | len <= 2048 -> getRequestBody req+ _ -> return (req, []) - let reqbodylog _ = if null body || isJust mModifyParams- then [""]- else ansiColor White " Request Body: " <> body <> ["\n"]- reqbody = concatMap (either (const [""]) reqbodylog . decodeUtf8') body- postParams <- if requestMethod req `elem` ["GET", "HEAD"]- then return []- else do (unmodifiedPostParams, files) <- liftIO $ allPostParams body- let postParams =- case mModifyParams of- Just modifyParams -> mapMaybe modifyParams unmodifiedPostParams- Nothing -> unmodifiedPostParams- return $ collectPostParams (postParams, files)+ let reqbodylog _ =+ if null body || isJust mModifyParams+ then [""]+ else ansiColor White " Request Body: " <> body <> ["\n"]+ reqbody = concatMap (either (const [""]) reqbodylog . decodeUtf8') body+ postParams <-+ if requestMethod req `elem` ["GET", "HEAD"]+ then return []+ else do+ (unmodifiedPostParams, files) <- liftIO $ allPostParams body+ let postParams =+ case mModifyParams of+ Just modifyParams -> mapMaybe modifyParams unmodifiedPostParams+ Nothing -> unmodifiedPostParams+ return $ collectPostParams (postParams, files) - let getParams = map emptyGetParam $ queryString req- accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req- params = let par | not $ null postParams = [pack (show postParams)]- | not $ null getParams = [pack (show getParams)]- | otherwise = []- in if null par then [""] else ansiColor White " Params: " <> par <> ["\n"]+ let getParams = map emptyGetParam $ queryString req+ accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req+ params =+ let par+ | not $ null postParams = [pack (show postParams)]+ | not $ null getParams = [pack (show getParams)]+ | otherwise = []+ in if null par then [""] else ansiColor White " Params: " <> par <> ["\n"] - t0 <- getCurrentTime+ t0 <- getCurrentTime - -- Optionally prelog the request- when mPrelogRequests $- cb $ "PRELOGGING REQUEST: " <> mkRequestLog params reqbody accept+ -- Optionally prelog the request+ when mPrelogRequests $+ cb $+ "PRELOGGING REQUEST: " <> mkRequestLog params reqbody accept - app req' $ \rsp -> do- case mFilterRequests of- Just f | not $ f req' rsp -> pure ()- _ -> do- let isRaw =- case rsp of- ResponseRaw{} -> True- _ -> False- stCode = statusBS rsp- stMsg = msgBS rsp- t1 <- getCurrentTime+ app req' $ \rsp -> do+ case mFilterRequests of+ Just f | not $ f req' rsp -> pure ()+ _ -> do+ let isRaw =+ case rsp of+ ResponseRaw{} -> True+ _ -> False+ stCode = statusBS rsp+ stMsg = msgBS rsp+ t1 <- getCurrentTime - -- log the status of the response- cb $- mkRequestLog params reqbody accept- <> mkResponseLog isRaw stCode stMsg t1 t0+ -- log the status of the response+ cb $+ mkRequestLog params reqbody accept+ <> mkResponseLog isRaw stCode stMsg t1 t0 - sendResponse rsp+ sendResponse rsp where allPostParams body = case getRequestBodyType req of@@ -471,37 +516,44 @@ let rbody = atomicModifyIORef ichunks $ \chunks -> case chunks of [] -> ([], S8.empty)- x:y -> (y, x)+ x : y -> (y, x) sinkRequestBody lbsBackEnd rbt rbody - emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)- emptyGetParam (k, Just v) = (k,v)- emptyGetParam (k, Nothing) = (k,"")+ emptyGetParam+ :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)+ emptyGetParam (k, Just v) = (k, v)+ emptyGetParam (k, Nothing) = (k, "") collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]- collectPostParams (postParams, files) = postParams ++- map (\(k,v) -> (k, "FILE: " <> fileName v)) files+ 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))- <> " "- <> toLogStr (rawPathInfo req)- <> "\n"- <> foldMap toLogStr params- <> foldMap toLogStr reqbody- <> foldMap toLogStr (ansiColor White " Accept: ")- <> toLogStr accept- <> "\n"+ <> " "+ <> toLogStr (rawPathInfo req)+ <> "\n"+ <> foldMap toLogStr params+ <> foldMap toLogStr reqbody+ <> foldMap toLogStr (ansiColor White " Accept: ")+ <> toLogStr accept+ <> "\n" - mkResponseLog :: Bool -> S8.ByteString -> S8.ByteString -> UTCTime -> UTCTime -> LogStr+ mkResponseLog+ :: Bool -> S8.ByteString -> S8.ByteString -> UTCTime -> UTCTime -> LogStr mkResponseLog isRaw stCode stMsg t1 t0 =- if isRaw then "" else- foldMap toLogStr (ansiColor White " Status: ")- <> foldMap toLogStr (ansiStatusCode stCode (stCode <> " " <> stMsg))- <> " "- <> toLogStr (pack $ show $ diffUTCTime t1 t0)- <> "\n"+ if isRaw+ then ""+ else+ foldMap toLogStr (ansiColor White " Status: ")+ <> foldMap toLogStr (ansiStatusCode stCode (stCode <> " " <> stMsg))+ <> " "+ <> toLogStr (pack $ show $ diffUTCTime t1 t0)+ <> "\n"++{- HLint ignore detailedMiddleware' "Use lambda-case" -} statusBS :: Response -> BS.ByteString statusBS = pack . show . statusCode . responseStatus
Network/Wai/Middleware/RequestLogger/Internal.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE CPP #-}+ -- | A module for containing some CPPed code, due to: -- -- https://github.com/yesodweb/wai/issues/192-module Network.Wai.Middleware.RequestLogger.Internal- ( getDateGetter- , logToByteString- ) where+module Network.Wai.Middleware.RequestLogger.Internal (+ getDateGetter,+ logToByteString,+) where #if !MIN_VERSION_wai_logger(2, 2, 0) import Control.Concurrent (forkIO, threadDelay)@@ -18,8 +19,10 @@ logToByteString :: LogStr -> ByteString logToByteString = fromLogStr -getDateGetter :: IO () -- ^ flusher- -> IO (IO ByteString)+getDateGetter+ :: IO ()+ -- ^ flusher+ -> IO (IO ByteString) #if !MIN_VERSION_wai_logger(2, 2, 0) getDateGetter flusher = do (getter, updater) <- clockDateCacher
Network/Wai/Middleware/RequestLogger/JSON.hs view
@@ -1,12 +1,10 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} -module Network.Wai.Middleware.RequestLogger.JSON- ( formatAsJSON- , formatAsJSONWithHeaders-- , requestToJSON- ) where+module Network.Wai.Middleware.RequestLogger.JSON (+ formatAsJSON,+ formatAsJSONWithHeaders,+ requestToJSON,+) where import Data.Aeson import qualified Data.ByteString.Builder as BB (toLazyByteString)@@ -34,20 +32,23 @@ formatAsJSON :: OutputFormatterWithDetails formatAsJSON date req status responseSize duration reqBody response =- toLogStr (encode $- object- [ "request" .= requestToJSON req reqBody (Just duration)- , "response" .=- object- [ "status" .= statusCode status- , "size" .= responseSize- , "body" .=- if statusCode status >= 400- then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ response- else Nothing- ]- , "time" .= decodeUtf8With lenientDecode date- ]) <> "\n"+ toLogStr+ ( encode $+ object+ [ "request" .= requestToJSON req reqBody (Just duration)+ , "response"+ .= object+ [ "status" .= statusCode status+ , "size" .= responseSize+ , "body"+ .= if statusCode status >= 400+ then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ response+ else Nothing+ ]+ , "time" .= decodeUtf8With lenientDecode date+ ]+ )+ <> "\n" -- | Same as @formatAsJSON@ but with response headers included --@@ -58,20 +59,24 @@ -- @since 3.0.27 formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders formatAsJSONWithHeaders date req status resSize duration reqBody res resHeaders =- toLogStr (encode $- object- [ "request" .= requestToJSON req reqBody (Just duration)- , "response" .= object- [ "status" .= statusCode status- , "size" .= resSize- , "headers" .= responseHeadersToJSON resHeaders- , "body" .=- if statusCode status >= 400- then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ res- else Nothing- ]- , "time" .= decodeUtf8With lenientDecode date- ]) <> "\n"+ toLogStr+ ( encode $+ object+ [ "request" .= requestToJSON req reqBody (Just duration)+ , "response"+ .= object+ [ "status" .= statusCode status+ , "size" .= resSize+ , "headers" .= responseHeadersToJSON resHeaders+ , "body"+ .= if statusCode status >= 400+ then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ res+ else Nothing+ ]+ , "time" .= decodeUtf8With lenientDecode date+ ]+ )+ <> "\n" word32ToHostAddress :: Word32 -> Text word32ToHostAddress = T.intercalate "." . map (T.pack . show) . fromIPv4 . fromHostAddress@@ -103,62 +108,81 @@ -- without a major version bump. -- -- @since 3.1.4-requestToJSON :: Request -- ^ The WAI request- -> [S8.ByteString] -- ^ Chunked request body- -> Maybe NominalDiffTime -- ^ Optional request duration- -> Value+requestToJSON+ :: Request+ -- ^ The WAI request+ -> [S8.ByteString]+ -- ^ Chunked request body+ -> Maybe NominalDiffTime+ -- ^ Optional request duration+ -> Value requestToJSON req reqBody duration =- object $- [ "method" .= decodeUtf8With lenientDecode (requestMethod req)- , "path" .= decodeUtf8With lenientDecode (rawPathInfo req)- , "queryString" .= map queryItemToJSON (queryString req)- , "size" .= requestBodyLengthToJSON (requestBodyLength req)- , "body" .= decodeUtf8With lenientDecode (S8.concat reqBody)- , "remoteHost" .= sockToJSON (remoteHost req)- , "httpVersion" .= httpVersionToJSON (httpVersion req)- , "headers" .= requestHeadersToJSON (requestHeaders req)- ]- <>- maybeToList (("durationMs" .=) . readAsDouble . printf "%.2f" . rationalToDouble . (* 1000) . toRational <$> duration)+ object $+ [ "method" .= decodeUtf8With lenientDecode (requestMethod req)+ , "path" .= decodeUtf8With lenientDecode (rawPathInfo req)+ , "queryString" .= map queryItemToJSON (queryString req)+ , "size" .= requestBodyLengthToJSON (requestBodyLength req)+ , "body" .= decodeUtf8With lenientDecode (S8.concat reqBody)+ , "remoteHost" .= sockToJSON (remoteHost req)+ , "httpVersion" .= httpVersionToJSON (httpVersion req)+ , "headers" .= requestHeadersToJSON (requestHeaders req)+ ]+ <> maybeToList+ ( ("durationMs" .=)+ . readAsDouble+ . printf "%.2f"+ . rationalToDouble+ . (* 1000)+ . toRational+ <$> duration+ ) where rationalToDouble :: Rational -> Double rationalToDouble = fromRational sockToJSON :: SockAddr -> Value sockToJSON (SockAddrInet pn ha) =- object- [ "port" .= portToJSON pn- , "hostAddress" .= word32ToHostAddress ha- ]+ object+ [ "port" .= portToJSON pn+ , "hostAddress" .= word32ToHostAddress ha+ ] sockToJSON (SockAddrInet6 pn _ ha _) =- object- [ "port" .= portToJSON pn- , "hostAddress" .= ha- ]+ object+ [ "port" .= portToJSON pn+ , "hostAddress" .= ha+ ] sockToJSON (SockAddrUnix sock) =- object [ "unix" .= sock ]+ object ["unix" .= sock] #if !MIN_VERSION_network(3,0,0) sockToJSON (SockAddrCan i) = object [ "can" .= i ] #endif queryItemToJSON :: QueryItem -> Value-queryItemToJSON (name, mValue) = toJSON (decodeUtf8With lenientDecode name, fmap (decodeUtf8With lenientDecode) mValue)+queryItemToJSON (name, mValue) =+ toJSON+ (decodeUtf8With lenientDecode name, fmap (decodeUtf8With lenientDecode) mValue) requestHeadersToJSON :: RequestHeaders -> Value-requestHeadersToJSON = toJSON . map hToJ where- -- Redact cookies- hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text)- hToJ hd = headerToJSON hd+requestHeadersToJSON = toJSON . map hToJ+ where+ -- Redact cookies+ hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text)+ hToJ hd = headerToJSON hd responseHeadersToJSON :: [Header] -> Value-responseHeadersToJSON = toJSON . map hToJ where- -- Redact cookies- hToJ ("Set-Cookie", _) = toJSON ("Set-Cookie" :: Text, "-RDCT-" :: Text)- hToJ hd = headerToJSON hd+responseHeadersToJSON = toJSON . map hToJ+ where+ -- Redact cookies+ hToJ ("Set-Cookie", _) = toJSON ("Set-Cookie" :: Text, "-RDCT-" :: Text)+ hToJ hd = headerToJSON hd headerToJSON :: Header -> Value-headerToJSON (headerName, header) = toJSON (decodeUtf8With lenientDecode . original $ headerName, decodeUtf8With lenientDecode header)+headerToJSON (headerName, header) =+ toJSON+ ( decodeUtf8With lenientDecode . original $ headerName+ , decodeUtf8With lenientDecode header+ ) portToJSON :: PortNumber -> Value portToJSON = toJSON . toInteger
Network/Wai/Middleware/RequestSizeLimit.hs view
@@ -1,19 +1,21 @@ {-# 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, -- in which an attacker sends huge bodies to your server.-module Network.Wai.Middleware.RequestSizeLimit- (+module Network.Wai.Middleware.RequestSizeLimit ( -- * Middleware- requestSizeLimitMiddleware+ requestSizeLimitMiddleware,+ -- * Constructing 'RequestSizeLimitSettings'- , defaultRequestSizeLimitSettings+ defaultRequestSizeLimitSettings,+ -- * 'RequestSizeLimitSettings' and accessors- , RequestSizeLimitSettings- , setMaxLengthForRequest- , setOnLengthExceeded- ) where+ RequestSizeLimitSettings,+ setMaxLengthForRequest,+ setOnLengthExceeded,+) where import Control.Exception (catch, try) import qualified Data.ByteString.Lazy as BSL@@ -25,7 +27,11 @@ import Network.HTTP.Types.Status (requestEntityTooLarge413) import Network.Wai -import Network.Wai.Middleware.RequestSizeLimit.Internal (RequestSizeLimitSettings (..), setMaxLengthForRequest, setOnLengthExceeded)+import Network.Wai.Middleware.RequestSizeLimit.Internal (+ RequestSizeLimitSettings (..),+ setMaxLengthForRequest,+ setOnLengthExceeded,+ ) import Network.Wai.Request -- | Create a 'RequestSizeLimitSettings' with these settings:@@ -35,10 +41,11 @@ -- -- @since 3.1.1 defaultRequestSizeLimitSettings :: RequestSizeLimitSettings-defaultRequestSizeLimitSettings = RequestSizeLimitSettings- { maxLengthForRequest = \_req -> pure $ Just $ 2 * 1024 * 1024- , onLengthExceeded = \maxLen _app req sendResponse -> sendResponse (tooLargeResponse maxLen (requestBodyLength req))- }+defaultRequestSizeLimitSettings =+ RequestSizeLimitSettings+ { maxLengthForRequest = \_req -> pure $ Just $ 2 * 1024 * 1024+ , onLengthExceeded = \maxLen _app req sendResponse -> sendResponse (tooLargeResponse maxLen (requestBodyLength req))+ } -- | Middleware to limit request bodies to a certain size. --@@ -57,21 +64,23 @@ -- In the case of a known-length request, RequestSizeException will be thrown immediately Left (RequestSizeException _maxLen) -> handleLengthExceeded maxLen -- In the case of a chunked request (unknown length), RequestSizeException will be thrown during the processing of a body- Right newReq -> app newReq sendResponse `catch` \(RequestSizeException _maxLen) -> handleLengthExceeded maxLen-- where- handleLengthExceeded maxLen = onLengthExceeded settings maxLen app req sendResponse+ Right newReq ->+ app newReq sendResponse `catch` \(RequestSizeException _maxLen) -> handleLengthExceeded maxLen+ where+ handleLengthExceeded maxLen = onLengthExceeded settings maxLen app req sendResponse tooLargeResponse :: Word64 -> RequestBodyLength -> Response-tooLargeResponse maxLen bodyLen = responseLBS- requestEntityTooLarge413- [("Content-Type", "text/plain")]- (BSL.concat- [ "Request body too large to be processed. The maximum size is "- , LS8.pack (show maxLen)- , " bytes; your request body was "- , case bodyLen of- 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`."- ])+tooLargeResponse maxLen bodyLen =+ responseLBS+ requestEntityTooLarge413+ [("Content-Type", "text/plain")]+ ( BSL.concat+ [ "Request body too large to be processed. The maximum size is "+ , LS8.pack (show maxLen)+ , " bytes; your request body was "+ , case bodyLen of+ 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
@@ -1,9 +1,9 @@ -- | Internal constructors and helper functions. Note that no guarantees are given for stability of these interfaces.-module Network.Wai.Middleware.RequestSizeLimit.Internal- ( RequestSizeLimitSettings(..)- , setMaxLengthForRequest- , setOnLengthExceeded- ) where+module Network.Wai.Middleware.RequestSizeLimit.Internal (+ RequestSizeLimitSettings (..),+ setMaxLengthForRequest,+ setOnLengthExceeded,+) where import Data.Word (Word64) import Network.Wai (Middleware, Request)@@ -40,18 +40,24 @@ -- -- @since 3.1.1 data RequestSizeLimitSettings = RequestSizeLimitSettings- { maxLengthForRequest :: Request -> IO (Maybe Word64) -- ^ Function to determine the maximum request size in bytes for the request. Return 'Nothing' for no limit. Since 3.1.1- , onLengthExceeded :: Word64 -> Middleware -- ^ Callback function when maximum length is exceeded. The 'Word64' argument is the limit computed by 'maxLengthForRequest'. Since 3.1.1+ { maxLengthForRequest :: Request -> IO (Maybe Word64)+ -- ^ Function to determine the maximum request size in bytes for the request. Return 'Nothing' for no limit. Since 3.1.1+ , onLengthExceeded :: Word64 -> Middleware+ -- ^ Callback function when maximum length is exceeded. The 'Word64' argument is the limit computed by 'maxLengthForRequest'. Since 3.1.1 } -- | Function to determine the maximum request size in bytes for the request. Return 'Nothing' for no limit. -- -- @since 3.1.1-setMaxLengthForRequest :: (Request -> IO (Maybe Word64)) -> RequestSizeLimitSettings -> RequestSizeLimitSettings-setMaxLengthForRequest fn settings = settings { maxLengthForRequest = fn }+setMaxLengthForRequest+ :: (Request -> IO (Maybe Word64))+ -> RequestSizeLimitSettings+ -> RequestSizeLimitSettings+setMaxLengthForRequest fn settings = settings{maxLengthForRequest = fn} -- | Callback function when maximum length is exceeded. The 'Word64' argument is the limit computed by 'setMaxLengthForRequest'. -- -- @since 3.1.1-setOnLengthExceeded :: (Word64 -> Middleware) -> RequestSizeLimitSettings -> RequestSizeLimitSettings-setOnLengthExceeded fn settings = settings { onLengthExceeded = fn }+setOnLengthExceeded+ :: (Word64 -> Middleware) -> RequestSizeLimitSettings -> RequestSizeLimitSettings+setOnLengthExceeded fn settings = settings{onLengthExceeded = fn}
Network/Wai/Middleware/Rewrite.hs view
@@ -1,43 +1,38 @@-{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-}--module Network.Wai.Middleware.Rewrite- ( -- * How to use this module- -- $howto-- -- ** A note on semantics-- -- $semantics-- -- ** Paths and Queries-- -- $pathsandqueries- PathsAndQueries+{-# LANGUAGE TupleSections #-} - -- ** An example rewriting paths with queries+module Network.Wai.Middleware.Rewrite (+ -- * How to use this module+ -- $howto - -- $takeover+ -- ** A note on semantics+ -- $semantics - -- ** Upgrading from wai-extra ≤ 3.0.16.1+ -- ** Paths and Queries+ -- $pathsandqueries+ PathsAndQueries, - -- $upgrading+ -- ** An example rewriting paths with queries+ -- $takeover - -- * 'Middleware'+ -- ** Upgrading from wai-extra ≤ 3.0.16.1+ -- $upgrading - -- ** Recommended functions- , rewriteWithQueries- , rewritePureWithQueries- , rewriteRoot+ -- * 'Middleware' - -- ** Deprecated- , rewrite- , rewritePure+ -- ** Recommended functions+ rewriteWithQueries,+ rewritePureWithQueries,+ rewriteRoot, - -- * Operating on 'Request's+ -- ** Deprecated+ rewrite,+ rewritePure, - , rewriteRequest- , rewriteRequestPure- ) where+ -- * Operating on 'Request's+ rewriteRequest,+ rewriteRequestPure,+) where -- GHC ≤ 7.10 does not export Applicative functions from the prelude. #if __GLASGOW_HASKELL__ <= 710@@ -51,7 +46,6 @@ import Network.HTTP.Types as H import Network.Wai - -- $howto -- This module provides 'Middleware' to rewrite URL paths. It also provides -- functions that will convert a 'Request' to a modified 'Request'.@@ -202,7 +196,9 @@ -- upgrading as the upgraded functions no longer modify 'rawPathInfo'. --------------------------------------------------+ -- * Types+ -------------------------------------------------- -- | A tuple of the path sections as ['Text'] and query parameters as@@ -216,7 +212,9 @@ type PathsAndQueries = ([Text], H.Query) --------------------------------------------------+ -- * Rewriting 'Middleware'+ -------------------------------------------------- -- | Rewrite based on your own conversion function for paths only, to be@@ -225,14 +223,17 @@ -- For new code, use 'rewriteWithQueries' instead. rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware rewrite convert app req sendResponse = do- let convertIO = pathsOnly . curry $ liftIO . uncurry convert- newReq <- rewriteRequestRawM convertIO req- app newReq sendResponse-{-# WARNING rewrite [- "This modifies the 'rawPathInfo' field of a 'Request'."- , " This is not recommended behaviour; it is however how"- , " this function has worked in the past."- , " Use 'rewriteWithQueries' instead"] #-}+ let convertIO = pathsOnly . curry $ liftIO . uncurry convert+ newReq <- rewriteRequestRawM convertIO req+ app newReq sendResponse+{-# WARNING+ rewrite+ [ "This modifies the 'rawPathInfo' field of a 'Request'."+ , " This is not recommended behaviour; it is however how"+ , " this function has worked in the past."+ , " Use 'rewriteWithQueries' instead"+ ]+ #-} -- | Rewrite based on pure conversion function for paths only, to be -- supplied by users of this library.@@ -240,28 +241,33 @@ -- For new code, use 'rewritePureWithQueries' instead. rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware rewritePure convert app req =- let convertPure = pathsOnly . curry $ Identity . uncurry convert- newReq = runIdentity $ rewriteRequestRawM convertPure req- in app newReq-{-# WARNING rewritePure [- "This modifies the 'rawPathInfo' field of a 'Request'."- , " This is not recommended behaviour; it is however how"- , " this function has worked in the past."- , " Use 'rewritePureWithQueries' instead"] #-}+ let convertPure = pathsOnly . curry $ Identity . uncurry convert+ newReq = runIdentity $ rewriteRequestRawM convertPure req+ in app newReq+{-# WARNING+ rewritePure+ [ "This modifies the 'rawPathInfo' field of a 'Request'."+ , " This is not recommended behaviour; it is however how"+ , " this function has worked in the past."+ , " Use 'rewritePureWithQueries' instead"+ ]+ #-} -- | Rewrite based on your own conversion function for paths and queries. -- This function is to be supplied by users of this library, and operates -- in 'IO'.-rewriteWithQueries :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)- -> Middleware+rewriteWithQueries+ :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)+ -> Middleware rewriteWithQueries convert app req sendResponse = do- newReq <- rewriteRequestM convert req- app newReq sendResponse+ newReq <- rewriteRequestM convert req+ app newReq sendResponse -- | Rewrite based on pure conversion function for paths and queries. This -- function is to be supplied by users of this library.-rewritePureWithQueries :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)- -> Middleware+rewritePureWithQueries+ :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)+ -> Middleware rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req -- | Rewrite root requests (/) to a specified path@@ -280,60 +286,79 @@ onlyRoot paths _ = paths --------------------------------------------------+ -- * Modifying 'Request's directly+ -------------------------------------------------- -- | Modify a 'Request' using the supplied function in 'IO'. This is suitable for -- the reverse proxy example.-rewriteRequest :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)- -> Request -> IO Request+rewriteRequest+ :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)+ -> Request+ -> IO Request rewriteRequest convert req =- let convertIO = curry $ liftIO . uncurry convert- in rewriteRequestRawM convertIO req+ let convertIO = curry $ liftIO . uncurry convert+ in rewriteRequestRawM convertIO req -- | Modify a 'Request' using the pure supplied function. This is suitable for -- the reverse proxy example.-rewriteRequestPure :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)- -> Request -> Request+rewriteRequestPure+ :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)+ -> Request+ -> Request rewriteRequestPure convert req =- let convertPure = curry $ Identity . uncurry convert- in runIdentity $ rewriteRequestRawM convertPure req+ let convertPure = curry $ Identity . uncurry convert+ in runIdentity $ rewriteRequestRawM convertPure req --------------------------------------------------+ -- * Helper functions+ -------------------------------------------------- -- | This helper function factors out the common behaviour of rewriting requests.-rewriteRequestM :: (Applicative m, Monad m)- => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)- -> Request -> m Request+rewriteRequestM+ :: (Applicative m, Monad m)+ => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)+ -> Request+ -> m Request rewriteRequestM convert req = do- (pInfo, qByteStrings) <- curry convert (pathInfo req) (queryString req) (requestHeaders req)- pure req {pathInfo = pInfo, queryString = qByteStrings}+ (pInfo, qByteStrings) <-+ curry convert (pathInfo req) (queryString req) (requestHeaders req)+ pure req{pathInfo = pInfo, queryString = qByteStrings} -- | This helper function preserves the semantics of wai-extra ≤ 3.0, in -- which the rewrite functions modify the 'rawPathInfo' parameter. Note -- that this has not been extended to modify the 'rawQueryInfo' as -- modifying either of these values has been deprecated.-rewriteRequestRawM :: (Applicative m, Monad m)- => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)- -> Request -> m Request+rewriteRequestRawM+ :: (Applicative m, Monad m)+ => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)+ -> Request+ -> m Request rewriteRequestRawM convert req = do- newReq <- rewriteRequestM convert req- let rawPInfo = TE.encodeUtf8 . T.intercalate "/" . pathInfo $ newReq- pure newReq { rawPathInfo = rawPInfo }-{-# WARNING rewriteRequestRawM [- "This modifies the 'rawPathInfo' field of a 'Request'."- , " This is not recommended behaviour; it is however how"- , " this function has worked in the past."- , " Use 'rewriteRequestM' instead"] #-}+ newReq <- rewriteRequestM convert req+ let rawPInfo = TE.encodeUtf8 . T.intercalate "/" . pathInfo $ newReq+ pure newReq{rawPathInfo = rawPInfo}+{-# WARNING+ rewriteRequestRawM+ [ "This modifies the 'rawPathInfo' field of a 'Request'."+ , " This is not recommended behaviour; it is however how"+ , " this function has worked in the past."+ , " Use 'rewriteRequestM' instead"+ ]+ #-} -- | Produce a function that works on 'PathsAndQueries' from one working -- only on paths. This is not exported, as it is only needed to handle -- code written for versions ≤ 3.0 of the library; see the -- example above using 'Data.Bifunctor.first' to do something similar.-pathsOnly :: (Applicative m, Monad m)- => ([Text] -> H.RequestHeaders -> m [Text])- -> PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries+pathsOnly+ :: (Applicative m, Monad m)+ => ([Text] -> H.RequestHeaders -> m [Text])+ -> PathsAndQueries+ -> H.RequestHeaders+ -> m PathsAndQueries pathsOnly convert psAndQs headers = (,[]) <$> convert (fst psAndQs) headers {-# INLINE pathsOnly #-}
Network/Wai/Middleware/Routed.hs view
@@ -1,10 +1,10 @@ -- | -- -- Since 3.0.9-module Network.Wai.Middleware.Routed- ( routedMiddleware- , hostedMiddleware- ) where+module Network.Wai.Middleware.Routed (+ routedMiddleware,+ hostedMiddleware,+) where import Data.ByteString (ByteString) import Data.Text (Text)@@ -17,23 +17,30 @@ -- > let corsify = routedMiddleWare ("static" `elem`) addCorsHeaders -- -- Since 3.0.9-routedMiddleware :: ([Text] -> Bool) -- ^ Only use middleware if this pathInfo test returns True- -> Middleware -- ^ middleware to apply the path prefix guard to- -> Middleware -- ^ modified middleware+routedMiddleware+ :: ([Text] -> Bool)+ -- ^ Only use middleware if this pathInfo test returns True+ -> Middleware+ -- ^ middleware to apply the path prefix guard to+ -> Middleware+ -- ^ modified middleware routedMiddleware pathCheck middle app req- | pathCheck (pathInfo req) = middle app req- | otherwise = app req+ | pathCheck (pathInfo req) = middle app req+ | otherwise = app req -- | Only apply the middleware to certain hosts -- -- Since 3.0.9-hostedMiddleware :: ByteString -- ^ Domain the middleware applies to- -> Middleware -- ^ middleware to apply the path prefix guard to- -> Middleware -- ^ modified middleware+hostedMiddleware+ :: ByteString+ -- ^ Domain the middleware applies to+ -> Middleware+ -- ^ middleware to apply the path prefix guard to+ -> Middleware+ -- ^ modified middleware hostedMiddleware domain middle app req- | hasDomain domain req = middle app req- | otherwise = app req+ | hasDomain domain req = middle app req+ | otherwise = app req hasDomain :: ByteString -> Request -> Bool-hasDomain domain req = maybe False (== domain) mHost- where mHost = requestHeaderHost req+hasDomain domain req = Just domain == requestHeaderHost req
Network/Wai/Middleware/Select.hs view
@@ -1,4 +1,7 @@ ---------------------------------------------------------++---------------------------------------------------------+ -- | -- Module : Network.Wai.Middleware.Select -- Copyright : Michael Snoyman@@ -24,10 +27,8 @@ -- > $ healthCheck app -- -- @since 3.1.10--------------------------------------------------------------module Network.Wai.Middleware.Select- ( -- * Middleware selection+module Network.Wai.Middleware.Select (+ -- * Middleware selection MiddlewareSelection (..), selectMiddleware, @@ -36,7 +37,7 @@ selectMiddlewareOnRawPathInfo, selectMiddlewareExceptRawPathInfo, passthroughMiddleware,- )+) where import Control.Applicative ((<|>))@@ -45,31 +46,35 @@ import Network.Wai --------------------------------------------------+ -- * Middleware selection+ -------------------------------------------------- -- | Relevant Middleware for a given 'Request'. newtype MiddlewareSelection = MiddlewareSelection- { applySelectedMiddleware :: Request -> Maybe Middleware- }+ { applySelectedMiddleware :: Request -> Maybe Middleware+ } instance Semigroup MiddlewareSelection where- MiddlewareSelection f <> MiddlewareSelection g =- MiddlewareSelection $ \req -> f req <|> g req+ MiddlewareSelection f <> MiddlewareSelection g =+ MiddlewareSelection $ \req -> f req <|> g req instance Monoid MiddlewareSelection where- mempty = MiddlewareSelection $ const Nothing+ mempty = MiddlewareSelection $ const Nothing -- | Create the 'Middleware' dynamically applying 'MiddlewareSelection'. selectMiddleware :: MiddlewareSelection -> Middleware selectMiddleware selection app request respond =- mw app request respond+ mw app request respond where mw :: Middleware mw = fromMaybe passthroughMiddleware (applySelectedMiddleware selection request) --------------------------------------------------+ -- * Helpers+ -------------------------------------------------- passthroughMiddleware :: Middleware@@ -78,14 +83,15 @@ -- | Use the 'Middleware' when the predicate holds. selectMiddlewareOn :: (Request -> Bool) -> Middleware -> MiddlewareSelection selectMiddlewareOn doesApply mw = MiddlewareSelection $ \request ->- if doesApply request- then Just mw- else Nothing+ if doesApply request+ then Just mw+ else Nothing -- | Use the `Middleware` for the given 'rawPathInfo'. selectMiddlewareOnRawPathInfo :: ByteString -> Middleware -> MiddlewareSelection selectMiddlewareOnRawPathInfo path = selectMiddlewareOn ((== path) . rawPathInfo) -- | Use the `Middleware` for all 'rawPathInfo' except then given one.-selectMiddlewareExceptRawPathInfo :: ByteString -> Middleware -> MiddlewareSelection+selectMiddlewareExceptRawPathInfo+ :: ByteString -> Middleware -> MiddlewareSelection selectMiddlewareExceptRawPathInfo path = selectMiddlewareOn ((/= path) . rawPathInfo)
Network/Wai/Middleware/StreamFile.hs view
@@ -1,8 +1,7 @@ -- | -- -- Since 3.0.4-module Network.Wai.Middleware.StreamFile- (streamFile) where+module Network.Wai.Middleware.StreamFile (streamFile) where import qualified Data.ByteString.Char8 as S8 import Network.HTTP.Types (hContentLength)@@ -10,28 +9,28 @@ import Network.Wai.Internal import System.Directory (getFileSize) --- |Convert ResponseFile type responses into ResponseStream type+-- | Convert ResponseFile type responses into ResponseStream type ----- Checks the response type, and if it's a ResponseFile, converts it--- into a ResponseStream. Other response types are passed through--- unchanged.+-- Checks the response type, and if it's a ResponseFile, converts it+-- into a ResponseStream. Other response types are passed through+-- unchanged. ----- Converted responses get a Content-Length header.+-- Converted responses get a Content-Length header. ----- Streaming a file will bypass a sendfile system call, and may be--- useful to work around systems without working sendfile--- implementations.+-- Streaming a file will bypass a sendfile system call, and may be+-- useful to work around systems without working sendfile+-- implementations. ----- Since 3.0.4+-- Since 3.0.4 streamFile :: Middleware streamFile app env sendResponse = app env $ \res -> case res of- ResponseFile _ _ fp _ -> withBody sendBody+ ResponseFile _ _ fp _ -> withBody sendBody where (s, hs, withBody) = responseToStream res sendBody :: StreamingBody -> IO ResponseReceived sendBody body = do- len <- getFileSize fp- let hs' = (hContentLength, (S8.pack (show len))) : hs- sendResponse $ responseStream s hs' body- _ -> sendResponse res+ len <- getFileSize fp+ let hs' = (hContentLength, S8.pack (show len)) : hs+ sendResponse $ responseStream s hs' body+ _ -> sendResponse res
Network/Wai/Middleware/StripHeaders.hs view
@@ -7,26 +7,31 @@ -- When using this, care should be taken not to strip out headers that are -- required for correct operation of the client (eg Content-Type). -module Network.Wai.Middleware.StripHeaders- ( stripHeader- , stripHeaders- , stripHeaderIf- , stripHeadersIf- ) where+module Network.Wai.Middleware.StripHeaders (+ stripHeader,+ stripHeaders,+ stripHeaderIf,+ stripHeadersIf,+) where import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI-import Network.Wai (Middleware, Request, modifyResponse, mapResponseHeaders, ifRequest)+import Network.Wai (+ Middleware,+ Request,+ ifRequest,+ mapResponseHeaders,+ modifyResponse,+ ) import Network.Wai.Internal (Response) - stripHeader :: ByteString -> (Response -> Response)-stripHeader h = mapResponseHeaders (filter (\ hdr -> fst hdr /= CI.mk h))+stripHeader h = mapResponseHeaders (filter (\hdr -> fst hdr /= CI.mk h)) stripHeaders :: [ByteString] -> (Response -> Response) stripHeaders hs =- let hnames = map CI.mk hs- in mapResponseHeaders (filter (\ hdr -> fst hdr `notElem` hnames))+ let hnames = map CI.mk hs+ in mapResponseHeaders (filter (\hdr -> fst hdr `notElem` hnames)) -- | If the request satisifes the provided predicate, strip headers matching -- the provided header name.@@ -34,12 +39,12 @@ -- Since 3.0.8 stripHeaderIf :: ByteString -> (Request -> Bool) -> Middleware stripHeaderIf h rpred =- ifRequest rpred (modifyResponse $ stripHeader h)+ ifRequest rpred (modifyResponse $ stripHeader h) -- | If the request satisifes the provided predicate, strip all headers whose -- header name is in the list of provided header names. -- -- Since 3.0.8 stripHeadersIf :: [ByteString] -> (Request -> Bool) -> Middleware-stripHeadersIf hs rpred- = ifRequest rpred (modifyResponse $ stripHeaders hs)+stripHeadersIf hs rpred =+ ifRequest rpred (modifyResponse $ stripHeaders hs)
Network/Wai/Middleware/Timeout.hs view
@@ -1,9 +1,9 @@ -- | Timeout requests-module Network.Wai.Middleware.Timeout- ( timeout- , timeoutStatus- , timeoutAs- ) where+module Network.Wai.Middleware.Timeout (+ timeout,+ timeoutStatus,+ timeoutAs,+) where import Network.HTTP.Types (Status, status503) import Network.Wai
Network/Wai/Middleware/Vhost.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-}-module Network.Wai.Middleware.Vhost- ( vhost- , redirectWWW- , redirectTo- , redirectToLogged- ) where +module Network.Wai.Middleware.Vhost (+ vhost,+ redirectWWW,+ redirectTo,+ redirectToLogged,+) where import qualified Data.ByteString as BS #if __GLASGOW_HASKELL__ < 710@@ -20,23 +20,28 @@ vhost vhosts def req = case filter (\(b, _) -> b req) vhosts of [] -> def req- (_, app):_ -> app req+ (_, app) : _ -> app req redirectWWW :: Text -> Application -> Application -- W.MiddleWare redirectWWW home =- redirectIf home (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)+ redirectIf+ home+ (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders) redirectIf :: Text -> (Request -> Bool) -> Application -> Application redirectIf home cond app req sendResponse =- if cond req- then sendResponse $ redirectTo $ TE.encodeUtf8 home- else app req sendResponse+ if cond req+ then sendResponse $ redirectTo $ TE.encodeUtf8 home+ else app req sendResponse redirectTo :: BS.ByteString -> Response-redirectTo location = responseLBS H.status301- [ (H.hContentType, "text/plain") , (H.hLocation, location) ] "Redirect"+redirectTo location =+ responseLBS+ H.status301+ [(H.hContentType, "text/plain"), (H.hLocation, location)]+ "Redirect" redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response redirectToLogged logger loc = do- logger $ "redirecting to: " `mappend` TE.decodeUtf8 loc- return $ redirectTo loc+ logger $ "redirecting to: " `mappend` TE.decodeUtf8 loc+ return $ redirectTo loc
Network/Wai/Parse.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-}+{-# language DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-}+{-# language LambdaCase #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-}@@ -12,6 +14,7 @@ , getRequestBodyType , sinkRequestBody , sinkRequestBodyEx+ , RequestParseException(..) , BackEnd , lbsBackEnd , tempFileBackEnd@@ -58,6 +61,7 @@ import qualified Control.Exception as E import Control.Monad (guard, unless, when) import Control.Monad.Trans.Resource (InternalState, allocate, register, release, runInternalState)+import Data.Bifunctor (bimap) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L@@ -66,7 +70,8 @@ import Data.Int (Int64) import Data.List (sortBy) import Data.Maybe (catMaybes, fromMaybe)-import Data.Word (Word8)+import Data.Typeable+import Data.Word8 import Network.HTTP.Types (hContentType) import qualified Network.HTTP.Types as H import Network.Wai@@ -85,20 +90,20 @@ parseHttpAccept = map fst . sortBy (rcompare `on` snd) . map (addSpecificity . grabQ)- . S.split 44 -- comma+ . S.split _comma where rcompare :: (Double,Int) -> (Double,Int) -> Ordering rcompare = flip compare addSpecificity (s, q) = -- Prefer higher-specificity types- let semicolons = S.count 0x3B s- stars = S.count 0x2A s+ let semicolons = S.count _semicolon s+ stars = S.count _asterisk s in (s, (q, semicolons - stars)) grabQ s = -- Stripping all spaces may be too harsh. -- Maybe just strip either side of semicolon?- let (s', q) = S.breakSubstring ";q=" (S.filter (/=0x20) s) -- 0x20 is space- q' = S.takeWhile (/=0x3B) (S.drop 3 q) -- 0x3B is semicolon+ let (s', q) = S.breakSubstring ";q=" (S.filter (/= _space) s)+ q' = S.takeWhile (/= _semicolon) (S.drop 3 q) in (s', readQ q') readQ s = case reads $ S8.unpack s of (x, _):_ -> x@@ -332,26 +337,23 @@ -- @since 1.3.2 parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)]) parseContentType a = do- let (ctype, b) = S.break (== semicolon) a+ let (ctype, b) = S.break (== _semicolon) a attrs = goAttrs id $ S.drop 1 b in (ctype, attrs) where- semicolon = 59- equals = 61- space = 32- dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote+ dq s = if S.length s > 2 && S.head s == _quotedbl && S.last s == _quotedbl then S.tail $ S.init s else s goAttrs front bs | S.null bs = front [] | otherwise =- let (x, rest) = S.break (== semicolon) bs+ let (x, rest) = S.break (== _semicolon) bs in goAttrs (front . (goAttr x:)) $ S.drop 1 rest goAttr bs =- let (k, v') = S.break (== equals) bs+ let (k, v') = S.break (== _equal) bs v = S.drop 1 v' in (strip k, dq $ strip v)- strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)+ strip = S.dropWhile (== _space) . fst . S.breakEnd (/= _space) -- | Parse the body of an HTTP request. -- See parseRequestBodyEx for details.@@ -359,6 +361,8 @@ -- When dealing with untrusted data (as is usually the case when -- receiving input from the internet), it is recommended to -- use the 'parseRequestBodyEx' function instead.+--+-- since 3.1.15 : throws 'RequestParseException' if something goes wrong parseRequestBody :: BackEnd y -> Request -> IO ([Param], [File y])@@ -370,6 +374,8 @@ -- for all parameters, and a list of key,a pairs -- for filenames. The a depends on the used backend that -- is responsible for storing the received files.+--+-- since 3.1.15 : throws 'RequestParseException' if something goes wrong parseRequestBodyEx :: ParseRequestBodyOptions -> BackEnd y -> Request@@ -377,17 +383,20 @@ parseRequestBodyEx o s r = case getRequestBodyType r of Nothing -> return ([], [])- Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)+ Just rbt -> sinkRequestBodyEx o s rbt (getRequestBodyChunk r) +-- | since 3.1.15 : throws 'RequestParseException' if something goes wrong sinkRequestBody :: BackEnd y -> RequestBodyType -> IO S.ByteString -> IO ([Param], [File y]) sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions --- |+-- | Throws 'RequestParseException' if something goes wrong -- -- @since 3.0.16.0+--+-- since 3.1.15 : throws 'RequestParseException' if something goes wrong sinkRequestBodyEx :: ParseRequestBodyOptions -> BackEnd y -> RequestBodyType@@ -400,7 +409,7 @@ Left y' -> ((y':y, z), ()) Right z' -> ((y, z':z), ()) conduitRequestBodyEx o s r body add- (\(a, b) -> (reverse a, reverse b)) <$> readIORef ref+ bimap reverse reverse <$> readIORef ref conduitRequestBodyEx :: ParseRequestBodyOptions -> BackEnd y@@ -420,7 +429,7 @@ let newsize = size + S.length bs case prboMaxParmsSize o of Just maxSize -> when (newsize > maxSize) $- error "Maximum size of parameters exceeded"+ E.throwIO $ MaxParamSizeExceeded newsize Nothing -> return () loop newsize $ front . (bs:) bs <- loop 0 id@@ -448,7 +457,7 @@ close front = leftover src front >> return Nothing push front bs = do- let (x, y) = S.break (== 10) bs -- LF+ let (x, y) = S.break (== _lf) bs in if S.null y then go $ front `S.append` x else do@@ -460,10 +469,12 @@ Nothing -> return () return . Just $ killCR res +-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString] takeLines' lineLength maxLines source = reverse <$> takeLines'' [] lineLength maxLines source +-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong takeLines'' :: [S.ByteString] -> Maybe Int@@ -474,7 +485,7 @@ case maxLines of Just maxLines' -> when (length lines > maxLines') $- error "Too many lines in mime/multipart header"+ E.throwIO $ TooManyHeaderLines (length lines) Nothing -> return () res <- takeLine lineLength src case res of@@ -496,10 +507,12 @@ if S.null bs then f else return bs+{- HLint ignore readSource "Use tuple-section" -} leftover :: Source -> S.ByteString -> IO () leftover (Source _ ref) = writeIORef ref +-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong parsePiecesEx :: ParseRequestBodyOptions -> BackEnd y -> S.ByteString@@ -527,11 +540,11 @@ case prboKeyLength o of Just maxKeyLength -> when (S.length name > maxKeyLength) $- error "Filename is too long"+ E.throwIO $ FilenameTooLong name maxKeyLength Nothing -> return () case prboMaxNumFiles o of Just maxFiles -> when (numFiles >= maxFiles) $- error "Maximum number of files exceeded"+ E.throwIO $ MaxFileNumberExceeded numFiles Nothing -> return () let ct = fromMaybe "application/octet-stream" mct fi0 = FileInfo filename ct ()@@ -546,7 +559,7 @@ case prboKeyLength o of Just maxKeyLength -> when (S.length name > maxKeyLength) $- error "Parameter name is too long"+ E.throwIO $ ParamNameTooLong name maxKeyLength Nothing -> return () let seed = id let iter front bs = return $ front . (:) bs@@ -557,7 +570,7 @@ let newParmSize = parmSize + S.length name + S.length bs case prboMaxParmsSize o of Just maxParmSize -> when (newParmSize > maxParmSize) $- error "Maximum size of parameters exceeded"+ E.throwIO $ MaxParamSizeExceeded newParmSize Nothing -> return () add $ Left x' when wasFound $ loop (numParms + 1) numFiles@@ -572,10 +585,29 @@ contDisp = mk $ S8.pack "Content-Disposition" contType = mk $ S8.pack "Content-Type" parsePair s =- let (x, y) = breakDiscard 58 s -- colon- in (mk x, S.dropWhile (== 32) y) -- space+ let (x, y) = breakDiscard _colon s+ in (mk x, S.dropWhile (== _space) y) +-- | Things that could go wrong while parsing a 'Request'+--+-- @since 3.1.15+data RequestParseException = MaxParamSizeExceeded Int+ | ParamNameTooLong S.ByteString Int+ | MaxFileNumberExceeded Int+ | FilenameTooLong S.ByteString Int+ | TooManyHeaderLines Int+ deriving (Eq, Typeable)+instance E.Exception RequestParseException+instance Show RequestParseException where+ show = \case+ MaxParamSizeExceeded lmax -> unwords ["maximum parameter size exceeded:", show lmax]+ ParamNameTooLong s lmax -> unwords ["parameter name", S8.unpack s, "is too long:", show lmax]+ MaxFileNumberExceeded lmax -> unwords ["maximum number of files exceeded:", show lmax]+ FilenameTooLong fn lmax ->+ unwords ["file name", S8.unpack fn, "too long:", show lmax]+ TooManyHeaderLines nmax -> unwords ["Too many lines in mime/multipart header:", show nmax] + data Bound = FoundBound S.ByteString S.ByteString | NoBound | PartialBound@@ -693,22 +725,22 @@ return (b, seed) parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]-parseAttrs = map go . S.split 59 -- semicolon+parseAttrs = map go . S.split _semicolon where- tw = S.dropWhile (== 32) -- space- dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote+ tw = S.dropWhile (== _space)+ dq s = if S.length s > 2 && S.head s == _quotedbl && S.last s == _quotedbl then S.tail $ S.init s else s go s =- let (x, y) = breakDiscard 61 s -- equals sign+ let (x, y) = breakDiscard _equal s in (tw x, dq $ tw y) killCRLF :: S.ByteString -> S.ByteString killCRLF bs- | S.null bs || S.last bs /= 10 = bs -- line feed+ | S.null bs || S.last bs /= _lf = bs | otherwise = killCR $ S.init bs killCR :: S.ByteString -> S.ByteString killCR bs- | S.null bs || S.last bs /= 13 = bs -- carriage return+ | S.null bs || S.last bs /= _cr = bs | otherwise = S.init bs
Network/Wai/Request.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-}--- | Some helpers for interrogating a WAI 'Request'. -module Network.Wai.Request- ( appearsSecure- , guessApproot- , RequestSizeException(..)- , requestSizeCheck- ) where+-- | Some helpers for interrogating a WAI 'Request'.+module Network.Wai.Request (+ appearsSecure,+ guessApproot,+ RequestSizeException (..),+ requestSizeCheck,+) where import Control.Exception (Exception, throwIO) import Data.ByteString (ByteString)@@ -19,7 +19,6 @@ import Network.HTTP.Types (HeaderName) import Network.Wai - -- | Does this request appear to have been made over an SSL connection? -- -- This function first checks @'isSecure'@, but also checks for headers that may@@ -33,14 +32,16 @@ -- -- @since 3.0.7 appearsSecure :: Request -> Bool-appearsSecure request = isSecure request || any (uncurry matchHeader)- [ ("HTTPS" , (== "on"))- , ("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.- ]-+appearsSecure request =+ isSecure request+ || any+ (uncurry matchHeader)+ [ ("HTTPS", (== "on"))+ , ("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 matchHeader :: HeaderName -> (ByteString -> Bool) -> Bool matchHeader h f = maybe False f $ lookup h $ requestHeaders request@@ -54,8 +55,8 @@ -- @since 3.0.7 guessApproot :: Request -> ByteString guessApproot req =- (if appearsSecure req then "https://" else "http://") `S.append`- fromMaybe "localhost" (requestHeaderHost req)+ (if appearsSecure req then "https://" else "http://")+ `S.append` fromMaybe "localhost" (requestHeaderHost req) -- | see 'requestSizeCheck' --@@ -68,7 +69,9 @@ 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. --@@ -81,20 +84,19 @@ requestSizeCheck :: Word64 -> Request -> IO Request requestSizeCheck maxSize req = case requestBodyLength req of- KnownLength len ->+ KnownLength len -> if len > maxSize- then return $ req { requestBody = throwIO (RequestSizeException maxSize) }+ then return $ setRequestBodyChunks (throwIO $ RequestSizeException maxSize) req else return req- ChunkedBody -> do+ ChunkedBody -> do currentSize <- newIORef 0- return $ req- { requestBody = do- bs <- requestBody req+ let rbody = do+ bs <- getRequestBodyChunk req total <- atomicModifyIORef' currentSize $ \sz -> let nextSize = sz + fromIntegral (S.length bs)- in (nextSize, nextSize)+ in (nextSize, nextSize) if total > maxSize- then throwIO (RequestSizeException maxSize)- else return bs- }+ then throwIO (RequestSizeException maxSize)+ else return bs+ return $ setRequestBodyChunks rbody req
Network/Wai/Test.hs view
@@ -1,37 +1,40 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Network.Wai.Test- ( -- * Session- Session- , runSession- , withSession- -- * Client Cookies- , ClientCookies- , getClientCookies- , modifyClientCookies- , setClientCookie- , deleteClientCookie- -- * Requests- , request- , srequest- , SRequest (..)- , SResponse (..)- , defaultRequest- , setPath- , setRawPathInfo- -- * Assertions- , assertStatus- , assertContentType- , assertBody- , assertBodyContains- , assertHeader- , assertNoHeader- , assertClientCookieExists- , assertNoClientCookieExists- , assertClientCookieValue- ) where+{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Test (+ -- * Session+ Session,+ runSession,+ withSession,++ -- * Client Cookies+ ClientCookies,+ getClientCookies,+ modifyClientCookies,+ setClientCookie,+ deleteClientCookie,++ -- * Requests+ request,+ srequest,+ SRequest (..),+ SResponse (..),+ defaultRequest,+ setPath,+ setRawPathInfo,++ -- * Assertions+ assertStatus,+ assertContentType,+ assertBody,+ assertBodyContains,+ assertHeader,+ assertNoHeader,+ assertClientCookieExists,+ assertNoClientCookieExists,+ assertClientCookieValue,+) where+ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) import Data.Monoid (mempty, mappend)@@ -73,22 +76,22 @@ -- Since 3.0.6 modifyClientCookies :: (ClientCookies -> ClientCookies) -> Session () modifyClientCookies f =- lift (ST.modify (\cs -> cs { clientCookies = f $ clientCookies cs }))+ lift (ST.modify (\cs -> cs{clientCookies = f $ clientCookies cs})) -- | -- -- 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 =- modifyClientCookies . Map.delete+ modifyClientCookies . Map.delete -- | See also: 'runSessionWith'. runSession :: Session a -> Application -> IO a@@ -125,74 +128,80 @@ -- | Set whole path (request path + query string). setPath :: Request -> S8.ByteString -> Request-setPath req path = req {- pathInfo = segments- , rawPathInfo = L8.toStrict . toLazyByteString $ H.encodePathSegments segments- , queryString = query- , rawQueryString = H.renderQuery True query- }+setPath req path =+ req+ { pathInfo = segments+ , rawPathInfo = L8.toStrict . toLazyByteString $ H.encodePathSegments segments+ , queryString = query+ , rawQueryString = H.renderQuery True query+ } where (segments, query) = H.decodePath path setRawPathInfo :: Request -> S8.ByteString -> Request setRawPathInfo r rawPinfo = let pInfo = dropFrontSlash $ T.split (== '/') $ TE.decodeUtf8 rawPinfo- in r { rawPathInfo = rawPinfo, pathInfo = pInfo }+ in r{rawPathInfo = rawPinfo, pathInfo = pInfo} where- dropFrontSlash ("":"":[]) = [] -- homepage, a single slash- dropFrontSlash ("":path) = path+ dropFrontSlash ["", ""] = [] -- homepage, a single slash+ dropFrontSlash ("" : path) = path dropFrontSlash path = path addCookiesToRequest :: Request -> Session Request addCookiesToRequest req = do- oldClientCookies <- getClientCookies- let requestPath = "/" `T.append` T.intercalate "/" (pathInfo req)- currentUTCTime <- liftIO getCurrentTime- let cookiesForRequest =- Map.filter- (\c -> checkCookieTime currentUTCTime c- && checkCookiePath requestPath c)- oldClientCookies- let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)- | c <- map snd $ Map.toList cookiesForRequest- ]- let cookieValue = L8.toStrict . toLazyByteString $ Cookie.renderCookies cookiePairs- addCookieHeader rest- | null cookiePairs = rest- | otherwise = ("Cookie", cookieValue) : rest- return $ req { requestHeaders = addCookieHeader $ requestHeaders req }- where checkCookieTime t c =- case Cookie.setCookieExpires c of- Nothing -> True- Just t' -> t < t'- checkCookiePath p c =- case Cookie.setCookiePath c of- Nothing -> True- Just p' -> p' `S8.isPrefixOf` TE.encodeUtf8 p+ oldClientCookies <- getClientCookies+ let requestPath = "/" `T.append` T.intercalate "/" (pathInfo req)+ currentUTCTime <- liftIO getCurrentTime+ let cookiesForRequest =+ Map.filter+ ( \c ->+ checkCookieTime currentUTCTime c+ && checkCookiePath requestPath c+ )+ oldClientCookies+ let cookiePairs =+ [ (Cookie.setCookieName c, Cookie.setCookieValue c)+ | c <- map snd $ Map.toList cookiesForRequest+ ]+ let cookieValue = L8.toStrict . toLazyByteString $ Cookie.renderCookies cookiePairs+ addCookieHeader rest+ | null cookiePairs = rest+ | otherwise = ("Cookie", cookieValue) : rest+ return $ req{requestHeaders = addCookieHeader $ requestHeaders req}+ where+ checkCookieTime t c =+ case Cookie.setCookieExpires c of+ Nothing -> True+ Just t' -> t < t'+ checkCookiePath p c =+ case Cookie.setCookiePath c of+ Nothing -> True+ Just p' -> p' `S8.isPrefixOf` TE.encodeUtf8 p extractSetCookieFromSResponse :: SResponse -> Session SResponse extractSetCookieFromSResponse response = do- let setCookieHeaders =- filter (("Set-Cookie"==) . fst) $ simpleHeaders response- let newClientCookies = map (Cookie.parseSetCookie . snd) setCookieHeaders- modifyClientCookies- (Map.union- (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))- return response+ let setCookieHeaders =+ filter (("Set-Cookie" ==) . fst) $ simpleHeaders response+ let newClientCookies = map (Cookie.parseSetCookie . snd) setCookieHeaders+ modifyClientCookies+ ( Map.union+ (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies])+ )+ return response -- | Similar to 'request', but allows setting the request body as a plain -- 'L.ByteString'. srequest :: SRequest -> Session SResponse srequest (SRequest req bod) = do refChunks <- liftIO $ newIORef $ L.toChunks bod- request $- req- { requestBody = atomicModifyIORef refChunks $ \bss ->+ let rbody = atomicModifyIORef refChunks $ \bss -> case bss of [] -> ([], S.empty)- x:y -> (y, x)- }+ x : y -> (y, x)+ request $ setRequestBodyChunks rbody req +{- HLint ignore srequest "Use lambda-case" -}+ runResponse :: IORef SResponse -> Response -> IO ResponseReceived runResponse ref res = do refBuilder <- newIORef mempty@@ -220,112 +229,140 @@ assertContentType :: HasCallStack => ByteString -> SResponse -> Session () assertContentType ct SResponse{simpleHeaders = h} = case lookup "content-type" h of- Nothing -> assertString $ concat- [ "Expected content type "- , show ct- , ", but no content type provided"- ]- Just ct' -> assertBool (concat- [ "Expected content type "- , show ct- , ", but received "- , show ct'- ]) (go ct == go ct')+ Nothing ->+ assertString $+ concat+ [ "Expected content type "+ , show ct+ , ", but no content type provided"+ ]+ Just ct' ->+ assertBool+ ( concat+ [ "Expected content type "+ , show ct+ , ", but received "+ , show ct'+ ]+ )+ (go ct == go ct') where go = S8.takeWhile (/= ';') assertStatus :: HasCallStack => Int -> SResponse -> Session ()-assertStatus i SResponse{simpleStatus = s} = assertBool (concat- [ "Expected status code "- , show i- , ", but received "- , show sc- ]) $ i == sc+assertStatus i SResponse{simpleStatus = s} =+ assertBool+ ( concat+ [ "Expected status code "+ , show i+ , ", but received "+ , show sc+ ]+ )+ $ i == sc where sc = H.statusCode s assertBody :: HasCallStack => L.ByteString -> SResponse -> Session ()-assertBody lbs SResponse{simpleBody = lbs'} = assertBool (concat- [ "Expected response body "- , show $ L8.unpack lbs- , ", but received "- , show $ L8.unpack lbs'- ]) $ lbs == lbs'+assertBody lbs SResponse{simpleBody = lbs'} =+ assertBool+ ( concat+ [ "Expected response body "+ , show $ L8.unpack lbs+ , ", but received "+ , show $ L8.unpack lbs'+ ]+ )+ $ lbs == lbs' assertBodyContains :: HasCallStack => L.ByteString -> SResponse -> Session ()-assertBodyContains lbs SResponse{simpleBody = lbs'} = assertBool (concat- [ "Expected response body to contain "- , show $ L8.unpack lbs- , ", but received "- , show $ L8.unpack lbs'- ]) $ strict lbs `S.isInfixOf` strict lbs'+assertBodyContains lbs SResponse{simpleBody = lbs'} =+ assertBool+ ( concat+ [ "Expected response body to contain "+ , show $ L8.unpack lbs+ , ", but received "+ , show $ L8.unpack lbs'+ ]+ )+ $ strict lbs `S.isInfixOf` strict lbs' where strict = S.concat . L.toChunks -assertHeader :: HasCallStack => CI ByteString -> ByteString -> SResponse -> Session ()+assertHeader+ :: HasCallStack => CI ByteString -> ByteString -> SResponse -> Session () assertHeader header value SResponse{simpleHeaders = h} = case lookup header h of- Nothing -> assertString $ concat- [ "Expected header "- , show header- , " to be "- , show value- , ", but it was not present"- ]- Just value' -> assertBool (concat- [ "Expected header "- , show header- , " to be "- , show value- , ", but received "- , show value'- ]) (value == value')+ Nothing ->+ assertString $+ concat+ [ "Expected header "+ , show header+ , " to be "+ , show value+ , ", but it was not present"+ ]+ Just value' ->+ assertBool+ ( concat+ [ "Expected header "+ , show header+ , " to be "+ , show value+ , ", but received "+ , show value'+ ]+ )+ (value == value') assertNoHeader :: HasCallStack => CI ByteString -> SResponse -> Session () assertNoHeader header SResponse{simpleHeaders = h} = case lookup header h of Nothing -> return ()- Just s -> assertString $ concat- [ "Unexpected header "- , show header- , " containing "- , show s- ]+ Just s ->+ assertString $+ concat+ [ "Unexpected header "+ , show header+ , " containing "+ , show s+ ] -- | -- -- Since 3.0.6 assertClientCookieExists :: HasCallStack => String -> ByteString -> Session () assertClientCookieExists s cookieName = do- cookies <- getClientCookies- assertBool s $ Map.member cookieName cookies+ cookies <- getClientCookies+ assertBool s $ Map.member cookieName cookies -- | -- -- Since 3.0.6 assertNoClientCookieExists :: HasCallStack => String -> ByteString -> Session () assertNoClientCookieExists s cookieName = do- cookies <- getClientCookies- assertBool s $ not $ Map.member cookieName cookies+ cookies <- getClientCookies+ assertBool s $ not $ Map.member cookieName cookies -- | -- -- Since 3.0.6-assertClientCookieValue :: HasCallStack => String -> ByteString -> ByteString -> Session ()+assertClientCookieValue+ :: HasCallStack => String -> ByteString -> ByteString -> Session () assertClientCookieValue s cookieName cookieValue = do- cookies <- getClientCookies- case Map.lookup cookieName cookies of- Nothing ->- assertFailure (s ++ " (cookie does not exist)")- Just c ->- assertBool- (concat- [ s- , " (actual value "- , show $ Cookie.setCookieValue c- , " expected value "- , show cookieValue- , ")"- ]- )- (Cookie.setCookieValue c == cookieValue)+ cookies <- getClientCookies+ case Map.lookup cookieName cookies of+ Nothing ->+ assertFailure (s ++ " (cookie does not exist)")+ Just c ->+ assertBool+ ( concat+ [ s+ , " (actual value "+ , show $ Cookie.setCookieValue c+ , " expected value "+ , show cookieValue+ , ")"+ ]+ )+ (Cookie.setCookieValue c == cookieValue)
Network/Wai/UrlMap.hs view
@@ -1,22 +1,20 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{- | This module gives you a way to mount applications under sub-URIs.-For example: -> bugsApp, helpdeskApp, apiV1, apiV2, mainApp :: Application->-> myApp :: Application-> myApp = mapUrls $-> mount "bugs" bugsApp-> <|> mount "helpdesk" helpdeskApp-> <|> mount "api"-> ( mount "v1" apiV1-> <|> mount "v2" apiV2-> )-> <|> mountRoot mainApp---}+-- | This module gives you a way to mount applications under sub-URIs.+-- For example:+--+-- > bugsApp, helpdeskApp, apiV1, apiV2, mainApp :: Application+-- >+-- > myApp :: Application+-- > myApp = mapUrls $+-- > mount "bugs" bugsApp+-- > <|> mount "helpdesk" helpdeskApp+-- > <|> mount "api"+-- > ( mount "v1" apiV1+-- > <|> mount "v2" apiV2+-- > )+-- > <|> mountRoot mainApp module Network.Wai.UrlMap ( UrlMap', UrlMap,@@ -36,19 +34,22 @@ import Network.Wai (Application, Request (pathInfo, rawPathInfo), responseLBS) type Path = [Text]-newtype UrlMap' a = UrlMap' { unUrlMap :: [(Path, a)] }+newtype UrlMap' a = UrlMap' {unUrlMap :: [(Path, a)]} instance Functor UrlMap' where- fmap f (UrlMap' xs) = UrlMap' (fmap (\(p, a) -> (p, f a)) xs)+ fmap f (UrlMap' xs) = UrlMap' (fmap (fmap f) xs) instance Applicative UrlMap' where- pure x = UrlMap' [([], x)]- (UrlMap' xs) <*> (UrlMap' ys) = UrlMap' [ (p, f y) |- (p, y) <- ys,- f <- map snd xs ]+ pure x = UrlMap' [([], x)]+ (UrlMap' xs) <*> (UrlMap' ys) =+ UrlMap'+ [ (p, f y)+ | (p, y) <- ys+ , f <- map snd xs+ ] instance Alternative UrlMap' where- empty = UrlMap' empty+ empty = UrlMap' empty (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys) type UrlMap = UrlMap' Application@@ -62,21 +63,24 @@ -- | A convenience function like mount', but for mounting things under a single -- path segment. mount :: ToApplication a => Text -> a -> UrlMap-mount prefix thing = mount' [prefix] thing+mount prefix = mount' [prefix] -- | Mount something at the root. Use this for the last application in the -- block, to avoid 500 errors from none of the applications matching. mountRoot :: ToApplication a => a -> UrlMap mountRoot = mount' [] -try :: Eq a- => [a] -- ^ Path info of request- -> [([a], b)] -- ^ List of applications to match+try+ :: Eq a+ => [a]+ -- ^ Path info of request+ -> [([a], b)]+ -- ^ List of applications to match -> Maybe ([a], b)-try xs tuples = foldl go Nothing tuples- where- go (Just x) _ = Just x- go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)+try xs = foldl go Nothing+ where+ go (Just x) _ = Just x+ go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y) class ToApplication a where toApplication :: a -> Application@@ -88,16 +92,20 @@ toApplication urlMap req sendResponse = case try (pathInfo req) (unUrlMap urlMap) of Just (newPath, app) ->- app (req { pathInfo = newPath- , rawPathInfo = makeRaw newPath- }) sendResponse+ app+ ( req+ { pathInfo = newPath+ , rawPathInfo = makeRaw newPath+ }+ )+ sendResponse Nothing ->- sendResponse $ responseLBS- status404- [(hContentType, "text/plain")]- "Not found\n"-- where+ sendResponse $+ responseLBS+ status404+ [(hContentType, "text/plain")]+ "Not found\n"+ where makeRaw :: [Text] -> B.ByteString makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"
Network/Wai/Util.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-}+ -- | Some helpers functions.-module Network.Wai.Util- ( dropWhileEnd- , splitCommas- , trimWS- ) where+module Network.Wai.Util (+ dropWhileEnd,+ splitCommas,+ trimWS,+) where import qualified Data.ByteString as S import Data.Word8 (Word8, _comma, _space)
example/Main.hs view
@@ -1,26 +1,36 @@ {-# LANGUAGE OverloadedStrings #-}+ module Main where -import Data.ByteString.Builder (string8) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Chan import Control.Monad (forever)+import Data.ByteString.Builder (string8) import Data.Time.Clock.POSIX (getPOSIXTime) import Network.HTTP.Types (status200) import Network.Wai (Application, Middleware, pathInfo, responseFile)-import Network.Wai.EventSource (ServerEvent(..), eventSourceAppChan, eventSourceAppIO)+import Network.Wai.EventSource (+ ServerEvent (..),+ eventSourceAppChan,+ eventSourceAppIO,+ ) import Network.Wai.Handler.Warp (run) import Network.Wai.Middleware.AddHeaders (addHeaders)-import Network.Wai.Middleware.Gzip (gzip, def)-+import Network.Wai.Middleware.Gzip (def, gzip) app :: Chan ServerEvent -> Application app chan req respond = case pathInfo req of- [] -> respond $ responseFile status200 [("Content-Type", "text/html")] "example/index.html" Nothing- ["esold"] -> eventSourceAppChan chan req respond+ [] ->+ respond $+ responseFile+ status200+ [("Content-Type", "text/html")]+ "example/index.html"+ Nothing+ ["esold"] -> eventSourceAppChan chan req respond ["eschan"] -> eventSourceAppChan chan req respond- ["esio"] -> eventSourceAppIO eventIO req respond+ ["esio"] -> eventSourceAppIO eventIO req respond _ -> error "unexpected pathInfo" eventChan :: Chan ServerEvent -> IO ()@@ -33,30 +43,37 @@ eventIO = do threadDelay 1000000 time <- getPOSIXTime- return $ ServerEvent (Just $ string8 "io")- Nothing- [string8 . show $ time]+ return $+ ServerEvent+ (Just $ string8 "io")+ Nothing+ [string8 . show $ time] eventRaw :: (ServerEvent -> IO ()) -> IO () -> IO () eventRaw = handle (0 :: Int)- where- handle counter emit flush = do- threadDelay 1000000- _ <- emit $ ServerEvent (Just $ string8 "raw")- Nothing- [string8 . show $ counter]- _ <- flush- handle (counter + 1) emit flush+ where+ handle counter emit flush = do+ threadDelay 1000000+ _ <-+ emit $+ ServerEvent+ (Just $ string8 "raw")+ Nothing+ [string8 . show $ counter]+ _ <- flush+ handle (counter + 1) emit flush main :: IO () main = do chan <- newChan _ <- forkIO . eventChan $ chan run 8080 (gzip def $ headers $ app chan)- where- -- headers required for SSE to work through nginx- -- not required if using warp directly- headers :: Middleware- headers = addHeaders [ ("X-Accel-Buffering", "no")- , ("Cache-Control", "no-cache")- ]+ where+ -- headers required for SSE to work through nginx+ -- not required if using warp directly+ headers :: Middleware+ headers =+ addHeaders+ [ ("X-Accel-Buffering", "no")+ , ("Cache-Control", "no-cache")+ ]
test/Network/Wai/Middleware/ApprootSpec.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.ApprootSpec- ( main- , spec- ) where +module Network.Wai.Middleware.ApprootSpec (+ main,+ spec,+) where+ import Data.ByteString (ByteString) import Network.HTTP.Types (RequestHeaders, status200) import Network.Wai@@ -22,16 +23,23 @@ simpleHeaders resp `shouldBe` [("Approot", expected)] test "respects host header" "foobar" False [] "http://foobar" test "respects isSecure" "foobar" True [] "https://foobar"- test "respects SSL headers" "foobar" False- [("HTTP_X_FORWARDED_SSL", "on")] "https://foobar"+ test+ "respects SSL headers"+ "foobar"+ False+ [("HTTP_X_FORWARDED_SSL", "on")]+ "https://foobar" runApp :: ByteString -> Bool -> RequestHeaders -> IO SResponse-runApp host secure headers = runSession- (request defaultRequest- { requestHeaderHost = Just host- , isSecure = secure- , requestHeaders = headers- }) $ fromRequest app-+runApp host secure headers =+ runSession+ ( request+ defaultRequest+ { requestHeaderHost = Just host+ , isSecure = secure+ , requestHeaders = headers+ }+ )+ $ fromRequest app where app req respond = respond $ responseLBS status200 [("Approot", getApproot req)] ""
test/Network/Wai/Middleware/CombineHeadersSpec.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.CombineHeadersSpec- ( main- , spec- ) where +module Network.Wai.Middleware.CombineHeadersSpec (+ main,+ spec,+) where+ import Data.ByteString (ByteString) import Data.IORef (newIORef, readIORef, writeIORef) import Network.HTTP.Types (status200)@@ -11,7 +12,13 @@ import Network.Wai import Test.Hspec -import Network.Wai.Middleware.CombineHeaders (CombineSettings, combineHeaders, defaultCombineSettings, setRequestHeaders, setResponseHeaders)+import Network.Wai.Middleware.CombineHeaders (+ CombineSettings,+ combineHeaders,+ defaultCombineSettings,+ setRequestHeaders,+ setResponseHeaders,+ ) import Network.Wai.Test (SResponse (simpleHeaders), request, runSession) main :: IO ()@@ -26,18 +33,24 @@ testReqHdrs name a b = test name defaultCombineSettings a b [] [] testResHdrs name a b =- test name (setRequestHeaders False $ setResponseHeaders True defaultCombineSettings) [] [] a b+ test+ name+ (setRequestHeaders False $ setResponseHeaders True defaultCombineSettings)+ []+ []+ a+ b -- Request Headers testReqHdrs "should reorder alphabetically (request)"- [host , userAgent, acceptHtml]- [acceptHtml, host , userAgent ]+ [host, userAgent, acceptHtml]+ [acceptHtml, host, userAgent] -- Response Headers testResHdrs "should reorder alphabetically (response)"- [expires , location, contentTypeHtml]- [contentTypeHtml, expires , location ]+ [expires, location, contentTypeHtml]+ [contentTypeHtml, expires, location] -- Request Headers testReqHdrs@@ -48,58 +61,70 @@ testResHdrs -- Using the default header map, Cache-Control is a "combineable" header, "Set-Cookie" is not "combines Cache-Control (in order) and keeps Set-Cookie (in order)"- [ cacheControlPublic, setCookie "2", date, cacheControlMax, setCookie "1"]- [ cacheControlPublic `combineHdrs` cacheControlMax, date, setCookie "2", setCookie "1"]+ [cacheControlPublic, setCookie "2", date, cacheControlMax, setCookie "1"]+ [ cacheControlPublic `combineHdrs` cacheControlMax+ , date+ , setCookie "2"+ , setCookie "1"+ ] -- Request Headers testReqHdrs "KeepOnly works as expected (present | request)" -- "Alt-Svc" has (KeepOnly "clear")- [ date, altSvc "wrong", altSvc "clear", altSvc "wrong again", host ]- [ altSvc "clear", date, host ]+ [date, altSvc "wrong", altSvc "clear", altSvc "wrong again", host]+ [altSvc "clear", date, host] testReqHdrs "KeepOnly works as expected ( absent | request)" -- "Alt-Svc" has (KeepOnly "clear"), but will combine when there's no "clear" (AND keeps order)- [ date, altSvc "wrong", altSvc "not clear", altSvc "wrong again", host ]- [ altSvc "wrong, not clear, wrong again", date, host ]+ [date, altSvc "wrong", altSvc "not clear", altSvc "wrong again", host]+ [altSvc "wrong, not clear, wrong again", date, host] -- Response Headers testResHdrs "KeepOnly works as expected (present | response)" -- "If-None-Match" has (KeepOnly "*")- [ date, ifNoneMatch "wrong", ifNoneMatch "*", ifNoneMatch "wrong again", host ]- [ date, host, ifNoneMatch "*" ]+ [date, ifNoneMatch "wrong", ifNoneMatch "*", ifNoneMatch "wrong again", host]+ [date, host, ifNoneMatch "*"] testResHdrs "KeepOnly works as expected ( absent | response)" -- "If-None-Match" has (KeepOnly "*"), but will combine when there's no "*" (AND keeps order)- [ date, ifNoneMatch "wrong", ifNoneMatch "not *", ifNoneMatch "wrong again", host ]- [ date, host, ifNoneMatch "wrong, not *, wrong again" ]+ [ date+ , ifNoneMatch "wrong"+ , ifNoneMatch "not *"+ , ifNoneMatch "wrong again"+ , host+ ]+ [date, host, ifNoneMatch "wrong, not *, wrong again"] -- Request Headers testReqHdrs "Technically acceptable headers get combined correctly (request)"- [ ifNoneMatch "correct, ", ifNoneMatch "something else \t", ifNoneMatch "and more , "]- [ ifNoneMatch "correct, something else, and more" ]+ [ ifNoneMatch "correct, "+ , ifNoneMatch "something else \t"+ , ifNoneMatch "and more , "+ ]+ [ifNoneMatch "correct, something else, and more"] -- Response Headers testResHdrs "Technically acceptable headers get combined correctly (response)"- [ altSvc "correct\t, ", altSvc "something else", altSvc "and more, , "]- [ altSvc "correct, something else, and more" ]+ [altSvc "correct\t, ", altSvc "something else", altSvc "and more, , "]+ [altSvc "correct, something else, and more"] combineHdrs :: Header -> Header -> Header combineHdrs (hname, h1) (_, h2) = (hname, h1 <> ", " <> h2) -acceptHtml,- acceptJSON,- cacheControlMax,- cacheControlPublic,- contentTypeHtml,- date,- expires,- host,- location,- userAgent :: Header-+acceptHtml+ , acceptJSON+ , cacheControlMax+ , cacheControlPublic+ , contentTypeHtml+ , date+ , expires+ , host+ , location+ , userAgent+ :: Header acceptHtml = (hAccept, "text/html") acceptJSON = (hAccept, "application/json") altSvc :: ByteString -> Header@@ -117,18 +142,24 @@ setCookie val = (hSetCookie, val) userAgent = (hUserAgent, "curl/7.68.0") -runApp :: CombineSettings -> RequestHeaders -> ResponseHeaders -> IO (RequestHeaders, ResponseHeaders)+runApp+ :: CombineSettings+ -> RequestHeaders+ -> ResponseHeaders+ -> IO (RequestHeaders, ResponseHeaders) runApp settings reqHeaders resHeaders = do reqHdrs <- newIORef $ error "IORef not set"- sResponse <- runSession- session- $ combineHeaders settings $ app reqHdrs+ sResponse <-+ runSession+ session+ $ combineHeaders settings+ $ app reqHdrs finalReqHeaders <- readIORef reqHdrs pure (finalReqHeaders, simpleHeaders sResponse) where session = request- defaultRequest { requestHeaders = reqHeaders }+ defaultRequest{requestHeaders = reqHeaders} app hdrRef req respond = do writeIORef hdrRef $ requestHeaders req respond $ responseLBS status200 resHeaders ""
test/Network/Wai/Middleware/ForceSSLSpec.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.ForceSSLSpec- ( main- , spec- ) where +module Network.Wai.Middleware.ForceSSLSpec (+ main,+ spec,+) where import Control.Monad (forM_) import Data.ByteString (ByteString)@@ -28,7 +28,6 @@ hostSpec :: ByteString -> Spec hostSpec host = describe ("forceSSL on host " <> show host <> "") $ do- it "redirects non-https requests to https" $ do resp <- runApp host forceSSL defaultRequest @@ -36,28 +35,39 @@ simpleHeaders resp `shouldBe` [("Location", "https://" <> host)] it "redirects with 307 in the case of a non-GET request" $ do- resp <- runApp host forceSSL defaultRequest- { requestMethod = methodPost }+ resp <-+ runApp+ host+ forceSSL+ defaultRequest+ { requestMethod = methodPost+ } simpleStatus resp `shouldBe` status307 simpleHeaders resp `shouldBe` [("Location", "https://" <> host)] it "does not redirect already-secure requests" $ do- resp <- runApp host forceSSL defaultRequest { isSecure = True }+ resp <- runApp host forceSSL defaultRequest{isSecure = True} simpleStatus resp `shouldBe` status200 it "preserves the original host, path, and query string" $ do- resp <- runApp host forceSSL defaultRequest- { rawPathInfo = "/foo/bar"- , rawQueryString = "?baz=bat"- }+ resp <-+ runApp+ host+ forceSSL+ defaultRequest+ { rawPathInfo = "/foo/bar"+ , rawQueryString = "?baz=bat"+ } - simpleHeaders resp `shouldBe`- [("Location", "https://" <> host <> "/foo/bar?baz=bat")]+ simpleHeaders resp+ `shouldBe` [("Location", "https://" <> host <> "/foo/bar?baz=bat")] runApp :: ByteString -> Middleware -> Request -> IO SResponse-runApp host mw req = runSession- (request req { requestHeaderHost = Just host }) $ mw app+runApp host mw req =+ runSession+ (request req{requestHeaderHost = Just host})+ $ mw app where app _ respond = respond $ responseLBS status200 [] ""
test/Network/Wai/Middleware/RealIpSpec.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Middleware.RealIpSpec- ( spec- ) where+module Network.Wai.Middleware.RealIpSpec (+ spec,+) where import qualified Data.ByteString.Lazy.Char8 as B8 import qualified Data.IP as IP@@ -82,10 +82,13 @@ simpleBody resp1 `shouldBe` "10.0.0.1" simpleBody resp2 `shouldBe` "10.0.0.2" - runApp :: IP.IP -> RequestHeaders -> Middleware -> IO SResponse-runApp ip hs mw = runSession- (request defaultRequest { remoteHost = IP.toSockAddr (ip, 80), requestHeaders = hs }) $ mw app+runApp ip hs mw =+ runSession+ ( request+ defaultRequest{remoteHost = IP.toSockAddr (ip, 80), requestHeaders = hs}+ )+ $ mw app where app req respond = respond $ responseLBS status200 [] $ renderIp req renderIp = B8.pack . maybe "" (show . fst) . IP.fromSockAddr . remoteHost
test/Network/Wai/Middleware/RequestSizeLimitSpec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ module Network.Wai.Middleware.RequestSizeLimitSpec (main, spec) where import Control.Monad (replicateM)@@ -20,86 +21,121 @@ spec :: Spec spec = describe "RequestSizeLimitMiddleware" $ do- describe "Plain text response" $ do- runStrictBodyTests "returns 413 for request bodies > 10 bytes, when streaming the whole body" tenByteLimitSettings "1234567890a" isStatus413- runStrictBodyTests "returns 200 for request bodies <= 10 bytes, when streaming the whole body" tenByteLimitSettings "1234567890" isStatus200-- 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-- describe "Per-request sizes" $ do+ describe "Plain text response" $ do+ runStrictBodyTests+ "returns 413 for request bodies > 10 bytes, when streaming the whole body"+ tenByteLimitSettings+ "1234567890a"+ isStatus413+ runStrictBodyTests+ "returns 200 for request bodies <= 10 bytes, when streaming the whole body"+ tenByteLimitSettings+ "1234567890"+ isStatus200 - it "allows going over the limit, when the path has been whitelisted" $ do- let req = SRequest defaultRequest- { pathInfo = ["upload", "image"]- } "1234567890a"- settings =- setMaxLengthForRequest- (\req' -> if pathInfo req' == ["upload", "image"] then pure $ Just 20 else pure $ Just 10)- defaultRequestSizeLimitSettings- resp <- runStrictBodyApp settings req- isStatus200 resp+ 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 - describe "streaming chunked bodies" $ do- let streamingReq = defaultRequest- { isSecure = False- , requestBodyLength = ChunkedBody- , requestBody = return "a"- }- it "413s if the combined chunk size is > the size limit" $ do- resp <- runStreamingChunkApp 11 tenByteLimitSettings streamingReq- simpleStatus resp `shouldBe` status413- it "200s if the combined chunk size is <= the size limit" $ do- resp <- runStreamingChunkApp 10 tenByteLimitSettings streamingReq- simpleStatus resp `shouldBe` status200+ describe "Per-request sizes" $ do+ it "allows going over the limit, when the path has been whitelisted" $ do+ let req =+ SRequest+ defaultRequest+ { pathInfo = ["upload", "image"]+ }+ "1234567890a"+ settings =+ setMaxLengthForRequest+ ( \req' ->+ if pathInfo req' == ["upload", "image"] then pure $ Just 20 else pure $ Just 10+ )+ defaultRequestSizeLimitSettings+ resp <- runStrictBodyApp settings req+ isStatus200 resp + describe "streaming chunked bodies" $ do+ let streamingReq =+ setRequestBodyChunks+ (return "a")+ defaultRequest+ { isSecure = False+ , requestBodyLength = ChunkedBody+ }+ it "413s if the combined chunk size is > the size limit" $ do+ resp <- runStreamingChunkApp 11 tenByteLimitSettings streamingReq+ simpleStatus resp `shouldBe` status413+ it "200s if the combined chunk size is <= the size limit" $ do+ resp <- runStreamingChunkApp 10 tenByteLimitSettings streamingReq+ simpleStatus resp `shouldBe` status200 where tenByteLimitSettings =- setMaxLengthForRequest- (\_req -> pure $ Just 10)- defaultRequestSizeLimitSettings+ setMaxLengthForRequest+ (\_req -> pure $ Just 10)+ defaultRequestSizeLimitSettings tenByteLimitJSONSettings =- setOnLengthExceeded- (\_maxLen _app _req sendResponse -> sendResponse $ responseLBS status413 [("Content-Type", "application/json")] (encode $ object ["error" .= ("request size too large" :: Text)]))- tenByteLimitSettings+ setOnLengthExceeded+ ( \_maxLen _app _req sendResponse ->+ sendResponse $+ responseLBS+ status413+ [("Content-Type", "application/json")]+ (encode $ object ["error" .= ("request size too large" :: Text)])+ )+ tenByteLimitSettings isStatus413 = \sResp -> simpleStatus sResp `shouldBe` status413 isStatus200 = \sResp -> simpleStatus sResp `shouldBe` status200 isJSONContentType = \sResp -> simpleHeaders sResp `shouldBe` [("Content-Type", "application/json")] data LengthType = UseKnownLength | UseChunked- deriving (Show, Eq)+ deriving (Show, Eq) -runStrictBodyTests :: String -> RequestSizeLimitSettings -> ByteString -> (SResponse -> Expectation) -> Spec+runStrictBodyTests+ :: String+ -> RequestSizeLimitSettings+ -> ByteString+ -> (SResponse -> Expectation)+ -> Spec runStrictBodyTests name settings reqBody runExpectations = describe name $ do- it "chunked" $ do- let req = mkRequestWithBytestring reqBody UseChunked- resp <- runStrictBodyApp settings req+ it "chunked" $ do+ let req = mkRequestWithBytestring reqBody UseChunked+ resp <- runStrictBodyApp settings req - runExpectations resp- it "non-chunked" $ do- let req = mkRequestWithBytestring reqBody UseKnownLength- resp <- runStrictBodyApp settings req+ runExpectations resp+ it "non-chunked" $ do+ let req = mkRequestWithBytestring reqBody UseKnownLength+ resp <- runStrictBodyApp settings req - runExpectations resp+ runExpectations resp where mkRequestWithBytestring :: ByteString -> LengthType -> SRequest mkRequestWithBytestring body lengthType = SRequest adjustedRequest $- L.fromChunks $ map S.singleton $ S.unpack body+ 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- }+ 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 =@@ -107,14 +143,15 @@ requestSizeLimitMiddleware settings app where app req' respond = do- _body <- strictRequestBody req'- respond $ responseLBS status200 [] ""+ _body <- strictRequestBody req'+ respond $ responseLBS status200 [] "" -runStreamingChunkApp :: Int -> RequestSizeLimitSettings -> Request -> IO SResponse+runStreamingChunkApp+ :: Int -> RequestSizeLimitSettings -> Request -> IO SResponse runStreamingChunkApp times settings req = runSession (request req) $ requestSizeLimitMiddleware settings app where app req' respond = do- _chunks <- replicateM times (getRequestBodyChunk req')- respond $ responseLBS status200 [] ""+ _chunks <- replicateM times (getRequestBodyChunk req')+ respond $ responseLBS status200 [] ""
test/Network/Wai/Middleware/RoutedSpec.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.RoutedSpec- ( main- , spec- ) where +module Network.Wai.Middleware.RoutedSpec (+ main,+ spec,+) where+ import Data.ByteString (ByteString) import Data.String (IsString) import Network.HTTP.Types (hContentType, status200)@@ -11,42 +12,49 @@ import Network.Wai.Test import Test.Hspec -import Network.Wai.Middleware.Routed import Network.Wai.Middleware.ForceSSL (forceSSL)+import Network.Wai.Middleware.Routed main :: IO () main = hspec spec spec :: Spec spec = describe "forceSSL" $ do- it "routed middleware" $ do- let destination = "https://example.com/d/"- let routedSslJsonApp prefix = routedMiddleware (checkPrefix prefix) forceSSL jsonApp- checkPrefix p (p1:_) = p == p1- checkPrefix _ _ = False+ it "routed middleware" $ do+ let destination = "https://example.com/d/"+ let routedSslJsonApp prefix = routedMiddleware (checkPrefix prefix) forceSSL jsonApp+ checkPrefix p (p1 : _) = p == p1+ checkPrefix _ _ = False - flip runSession (routedSslJsonApp "r") $ do- res <- testDPath "http"- assertNoHeader location res- assertStatus 200 res- assertBody "{\"foo\":\"bar\"}" res+ flip runSession (routedSslJsonApp "r") $ do+ res <- testDPath "http"+ assertNoHeader location res+ assertStatus 200 res+ assertBody "{\"foo\":\"bar\"}" res - flip runSession (routedSslJsonApp "d") $ do- res2 <- testDPath "http"- assertHeader location destination res2- assertStatus 301 res2+ flip runSession (routedSslJsonApp "d") $ do+ res2 <- testDPath "http"+ assertHeader location destination res2+ assertStatus 301 res2 jsonApp :: Application-jsonApp _req cps = cps $ responseLBS status200- [(hContentType, "application/json")]- "{\"foo\":\"bar\"}"+jsonApp _req cps =+ cps $+ responseLBS+ status200+ [(hContentType, "application/json")]+ "{\"foo\":\"bar\"}" testDPath :: ByteString -> Session SResponse testDPath proto =- request $ flip setRawPathInfo "/d/" defaultRequest- { requestHeaders = [("X-Forwarded-Proto", proto)]- , requestHeaderHost = Just "example.com"- }+ request $+ flip+ setRawPathInfo+ "/d/"+ defaultRequest+ { requestHeaders = [("X-Forwarded-Proto", proto)]+ , requestHeaderHost = Just "example.com"+ } location :: IsString ci => ci location = "Location"
test/Network/Wai/Middleware/SelectSpec.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Middleware.SelectSpec- ( main,+module Network.Wai.Middleware.SelectSpec (+ main, spec,- )+) where import Data.ByteString (ByteString)@@ -22,34 +22,52 @@ spec :: Spec spec = describe "Select" $ do- it "With empty select should passthrough" $- runApp (selectMiddleware mempty) "/" `shouldReturn` status200- it "With other path select should passthrough" $- runApp (selectMiddleware $ selectOverride "/_" status401) "/" `shouldReturn` status200- it "With path select should hit override" $- runApp (selectMiddleware $ selectOverride "/_" status401) "/_" `shouldReturn` status401- it "With twice path select should hit first override" $- runApp (selectMiddleware $ selectOverride "/_" status401 <> selectOverride "/_" status500) "/_"- `shouldReturn` status401- it "With two paths select should hit first matching (first)" $- runApp (selectMiddleware $ selectOverride "/_" status401 <> selectOverride "/-" status500) "/_"- `shouldReturn` status401- it "With two paths select should hit first matching (last)" $- runApp (selectMiddleware $ selectOverride "/_" status401 <> selectOverride "/-" status500) "/-"- `shouldReturn` status500- it "With other two paths select should passthrough" $- runApp (selectMiddleware $ selectOverride "/_" status401 <> selectOverride "/-" status500) "/"- `shouldReturn` status200- it "With mempty then the path select should hit the pass" $- runApp (selectMiddleware $ mempty <> selectOverride "/-" status500) "/-"- `shouldReturn` status500+ it "With empty select should passthrough" $+ runApp (selectMiddleware mempty) "/" `shouldReturn` status200+ it "With other path select should passthrough" $+ runApp (selectMiddleware $ selectOverride "/_" status401) "/"+ `shouldReturn` status200+ it "With path select should hit override" $+ runApp (selectMiddleware $ selectOverride "/_" status401) "/_"+ `shouldReturn` status401+ it "With twice path select should hit first override" $+ runApp+ ( selectMiddleware $+ selectOverride "/_" status401 <> selectOverride "/_" status500+ )+ "/_"+ `shouldReturn` status401+ it "With two paths select should hit first matching (first)" $+ runApp+ ( selectMiddleware $+ selectOverride "/_" status401 <> selectOverride "/-" status500+ )+ "/_"+ `shouldReturn` status401+ it "With two paths select should hit first matching (last)" $+ runApp+ ( selectMiddleware $+ selectOverride "/_" status401 <> selectOverride "/-" status500+ )+ "/-"+ `shouldReturn` status500+ it "With other two paths select should passthrough" $+ runApp+ ( selectMiddleware $+ selectOverride "/_" status401 <> selectOverride "/-" status500+ )+ "/"+ `shouldReturn` status200+ it "With mempty then the path select should hit the pass" $+ runApp (selectMiddleware $ mempty <> selectOverride "/-" status500) "/-"+ `shouldReturn` status500 runApp :: Middleware -> ByteString -> IO Status runApp mw path =- fmap simpleStatus $- runSession- (request $ defaultRequest {rawPathInfo = path})- $ mw app+ fmap simpleStatus+ $ runSession+ (request $ defaultRequest{rawPathInfo = path})+ $ mw app app :: Application app = constApp status200
test/Network/Wai/Middleware/StripHeadersSpec.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.StripHeadersSpec- ( main- , spec- ) where +module Network.Wai.Middleware.StripHeadersSpec (+ main,+ spec,+) where+ import Control.Arrow (first) import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI@@ -19,11 +20,9 @@ import Network.Wai.Middleware.AddHeaders (addHeaders) import Network.Wai.Middleware.StripHeaders (stripHeaderIf, stripHeadersIf) - main :: IO () main = hspec spec - spec :: Spec spec = describe "stripHeader" $ do let host = "example.com"@@ -31,29 +30,45 @@ it "strips a specific header" $ do resp1 <- runApp host (addHeaders testHeaders) defaultRequest- resp2 <- runApp host (stripHeaderIf "Foo" (const False) . addHeaders testHeaders) defaultRequest- resp3 <- runApp host (stripHeaderIf "Foo" (const True) . addHeaders testHeaders) defaultRequest+ resp2 <-+ runApp+ host+ (stripHeaderIf "Foo" (const False) . addHeaders testHeaders)+ defaultRequest+ resp3 <-+ runApp+ host+ (stripHeaderIf "Foo" (const True) . addHeaders testHeaders)+ defaultRequest simpleHeaders resp1 `shouldBe` ciTestHeaders simpleHeaders resp2 `shouldBe` ciTestHeaders- simpleHeaders resp3 `shouldBe` tail ciTestHeaders+ simpleHeaders resp3 `shouldBe` drop 1 ciTestHeaders it "strips specific set of headers" $ do resp1 <- runApp host (addHeaders testHeaders) defaultRequest- resp2 <- runApp host (stripHeadersIf ["Bar", "Foo"] (const False) . addHeaders testHeaders) defaultRequest- resp3 <- runApp host (stripHeadersIf ["Bar", "Foo"] (const True) . addHeaders testHeaders) defaultRequest+ resp2 <-+ runApp+ host+ (stripHeadersIf ["Bar", "Foo"] (const False) . addHeaders testHeaders)+ defaultRequest+ resp3 <-+ runApp+ host+ (stripHeadersIf ["Bar", "Foo"] (const True) . addHeaders testHeaders)+ defaultRequest simpleHeaders resp1 `shouldBe` ciTestHeaders simpleHeaders resp2 `shouldBe` ciTestHeaders simpleHeaders resp3 `shouldBe` [last ciTestHeaders] - testHeaders :: [(ByteString, ByteString)] testHeaders = [("Foo", "fooey"), ("Bar", "barbican"), ("Baz", "bazooka")] - runApp :: ByteString -> Middleware -> Request -> IO SResponse-runApp host mw req = runSession- (request req { requestHeaderHost = Just $ host <> ":80" }) $ mw app+runApp host mw req =+ runSession+ (request req{requestHeaderHost = Just $ host <> ":80"})+ $ mw app where app _ respond = respond $ responseLBS status200 [] ""
test/Network/Wai/Middleware/TimeoutSpec.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.TimeoutSpec- ( spec- ) where++module Network.Wai.Middleware.TimeoutSpec (+ spec,+) where import Control.Concurrent (threadDelay) import Network.HTTP.Types (status200, status503, status504)
test/Network/Wai/ParseSpec.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+ module Network.Wai.ParseSpec (main, spec) where #if __GLASGOW_HASKELL__ < 804@@ -12,8 +13,13 @@ import qualified Data.IORef as I import qualified Data.Text as TS import qualified Data.Text.Encoding as TE-import Network.Wai (Request (requestBody, requestHeaders), defaultRequest)-import Network.Wai.Handler.Warp (InvalidRequest(..))+import Data.Word8 (_e)+import Network.Wai (+ Request (requestHeaders),+ defaultRequest,+ setRequestBodyChunks,+ )+import Network.Wai.Handler.Warp (InvalidRequest (..)) import System.IO (IOMode (ReadMode), withFile) import Test.HUnit (Assertion, (@=?), (@?=)) import Test.Hspec@@ -29,15 +35,24 @@ spec = do describe "parseContentType" $ do let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z)- mapM_ go+ mapM_+ go [ ("text/plain", "text/plain", []) , ("text/plain; charset=UTF-8 ", "text/plain", [("charset", "UTF-8")])- , ("text/plain; charset=UTF-8 ; boundary = foo", "text/plain", [("charset", "UTF-8"), ("boundary", "foo")])- , ("text/plain; charset=UTF-8 ; boundary = \"quoted\"", "text/plain", [("charset", "UTF-8"), ("boundary", "quoted")])+ ,+ ( "text/plain; charset=UTF-8 ; boundary = foo"+ , "text/plain"+ , [("charset", "UTF-8"), ("boundary", "foo")]+ )+ ,+ ( "text/plain; charset=UTF-8 ; boundary = \"quoted\""+ , "text/plain"+ , [("charset", "UTF-8"), ("boundary", "quoted")]+ ) ] it "parseHttpAccept" caseParseHttpAccept describe "parseRequestBody" $ do- caseParseRequestBody+ caseParseRequestBody it "multipart with plus" caseMultipartPlus it "multipart with multiple attributes" caseMultipartAttrs it "urlencoded with plus" caseUrlEncPlus@@ -47,163 +62,186 @@ caseParseHttpAccept :: Assertion caseParseHttpAccept = do- let input = "text/plain; q=0.5, text/html;charset=utf-8, text/*;q=0.8;ext=blah, text/x-dvi; q=0.8, text/x-c"+ let input =+ "text/plain; q=0.5, text/html;charset=utf-8, text/*;q=0.8;ext=blah, text/x-dvi; q=0.8, text/x-c" expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"] expected @=? parseHttpAccept input -parseRequestBody' :: BackEnd file- -> SRequest- -> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo file)])+parseRequestBody'+ :: BackEnd file+ -> SRequest+ -> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo file)]) parseRequestBody' sink (SRequest req bod) = case getRequestBodyType req of Nothing -> return ([], []) Just rbt -> do ref <- I.newIORef $ L.toChunks bod let rb = I.atomicModifyIORef ref $ \chunks ->- case chunks of- [] -> ([], S.empty)- x:y -> (y, x)+ case chunks of+ [] -> ([], S.empty)+ x : y -> (y, x) sinkRequestBody sink rbt rb caseParseRequestBody :: Spec caseParseRequestBody = do- it "parsing post x-www-form-urlencoded" $ do- let content1 = "foo=bar&baz=bin"- let ctype1 = "application/x-www-form-urlencoded"- result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1- result1 `shouldBe` ([("foo", "bar"), ("baz", "bin")], [])-- let ctype2 = "multipart/form-data; boundary=AaB03x"- let expectedsmap2 =- [ ("title", "A File")- , ("summary", "This is my file\nfile test")- ]- let textPlain = "text/plain; charset=iso-8859-1"- let expectedfile2 =- [("document", FileInfo "b.txt" textPlain "This is a file.\nIt has two lines.")]- let expected2 = (expectedsmap2, expectedfile2)-- it "parsing post multipart/form-data" $ do- result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2- result2 `shouldBe` expected2+ it "parsing post x-www-form-urlencoded" $ do+ let content1 = "foo=bar&baz=bin"+ let ctype1 = "application/x-www-form-urlencoded"+ result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1+ result1 `shouldBe` ([("foo", "bar"), ("baz", "bin")], []) - it "parsing post multipart/form-data 2" $ do- result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2- result2' `shouldBe` expected2+ let ctype2 = "multipart/form-data; boundary=AaB03x"+ let expectedsmap2 =+ [ ("title", "A File")+ , ("summary", "This is my file\nfile test")+ ]+ let textPlain = "text/plain; charset=iso-8859-1"+ let expectedfile2 =+ [("document", FileInfo "b.txt" textPlain "This is a file.\nIt has two lines.")]+ let expected2 = (expectedsmap2, expectedfile2) + it "parsing post multipart/form-data" $ do+ result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2+ result2 `shouldBe` expected2 - let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"- let expectedsmap3 = []- let expectedfile3 = [("yaml", FileInfo "README" "application/octet-stream" "Photo blog using Hack.\n")]- let expected3 = (expectedsmap3, expectedfile3)+ it "parsing post multipart/form-data 2" $ do+ result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2+ result2' `shouldBe` expected2 - let def = defaultParseRequestBodyOptions- it "parsing actual post multipart/form-data" $ do- result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3- result3 `shouldBe` expected3+ let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"+ let expectedsmap3 = []+ let expectedfile3 =+ [+ ( "yaml"+ , FileInfo "README" "application/octet-stream" "Photo blog using Hack.\n"+ )+ ]+ let expected3 = (expectedsmap3, expectedfile3) - it "parsing actual post multipart/form-data 2" $ do- result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3- result3' `shouldBe` expected3+ let def = defaultParseRequestBodyOptions+ it "parsing actual post multipart/form-data" $ do+ result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3+ result3 `shouldBe` expected3 - it "parsing with memory limit" $ do- SRequest req4 _bod4 <- toRequest'' ctype3 content3- result4' <- parseRequestBodyEx ( setMaxRequestNumFiles 1 $ setMaxRequestKeyLength 14 def ) lbsBackEnd req4- result4' `shouldBe` expected3+ it "parsing actual post multipart/form-data 2" $ do+ result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3+ result3' `shouldBe` expected3 - it "exceeding number of files" $ do- SRequest req4 _bod4 <- toRequest'' ctype3 content3- (parseRequestBodyEx ( setMaxRequestNumFiles 0 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall+ it "parsing with memory limit" $ do+ SRequest req4 _bod4 <- toRequest'' ctype3 content3+ result4' <-+ parseRequestBodyEx+ (setMaxRequestNumFiles 1 $ setMaxRequestKeyLength 14 def)+ lbsBackEnd+ req4+ result4' `shouldBe` expected3 - it "exceeding parameter length" $ do- SRequest req4 _bod4 <- toRequest'' ctype3 content3- (parseRequestBodyEx ( setMaxRequestKeyLength 2 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall+ it "exceeding number of files" $ do+ SRequest req4 _bod4 <- toRequest'' ctype3 content3+ (parseRequestBodyEx (setMaxRequestNumFiles 0 def) lbsBackEnd req4)+ `shouldThrow` anyException - it "exceeding file size" $ do- SRequest req4 _bod4 <- toRequest'' ctype3 content3- (parseRequestBodyEx ( setMaxRequestFileSize 2 def ) lbsBackEnd req4)- `shouldThrow` (== PayloadTooLarge)+ it "exceeding parameter length" $ do+ SRequest req4 _bod4 <- toRequest'' ctype3 content3+ (parseRequestBodyEx (setMaxRequestKeyLength 2 def) lbsBackEnd req4)+ `shouldThrow` anyException - it "exceeding total file size" $ do- SRequest req4 _bod4 <- toRequest'' ctype3 content3- (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req4)- `shouldThrow` (== PayloadTooLarge)- SRequest req5 _bod5 <- toRequest'' ctype3 content5- (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req5)- `shouldThrow` (== PayloadTooLarge)+ it "exceeding file size" $ do+ SRequest req4 _bod4 <- toRequest'' ctype3 content3+ (parseRequestBodyEx (setMaxRequestFileSize 2 def) lbsBackEnd req4)+ `shouldThrow` (== PayloadTooLarge) - it "exceeding max parm value size" $ do- SRequest req4 _bod4 <- toRequest'' ctype2 content2- (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req4)- `shouldThrow` (== PayloadTooLarge)+ it "exceeding total file size" $ do+ SRequest req4 _bod4 <- toRequest'' ctype3 content3+ (parseRequestBodyEx (setMaxRequestFilesSize 20 def) lbsBackEnd req4)+ `shouldThrow` (== PayloadTooLarge)+ SRequest req5 _bod5 <- toRequest'' ctype3 content5+ (parseRequestBodyEx (setMaxRequestFilesSize 20 def) lbsBackEnd req5)+ `shouldThrow` (== PayloadTooLarge) - it "exceeding max header lines" $ do- SRequest req4 _bod4 <- toRequest'' ctype2 content2- (parseRequestBodyEx ( setMaxHeaderLines 1 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall+ it "exceeding max parm value size" $ do+ SRequest req4 _bod4 <- toRequest'' ctype2 content2+ (parseRequestBodyEx (setMaxRequestParmsSize 10 def) lbsBackEnd req4)+ `shouldThrow` (== PayloadTooLarge) - it "exceeding header line size" $ do- SRequest req4 _bod4 <- toRequest'' ctype3 content4- (parseRequestBodyEx ( setMaxHeaderLineLength 8190 def ) lbsBackEnd req4)- `shouldThrow` (== RequestHeaderFieldsTooLarge)+ it "exceeding max header lines" $ do+ SRequest req4 _bod4 <- toRequest'' ctype2 content2+ (parseRequestBodyEx (setMaxHeaderLines 1 def) lbsBackEnd req4)+ `shouldThrow` anyException - it "Testing parseRequestBodyEx with application/x-www-form-urlencoded" $ do- let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"- let ctype = "application/x-www-form-urlencoded"- SRequest req _bod <- toRequest'' ctype content- result <- parseRequestBodyEx def lbsBackEnd req- result `shouldBe` ([( "thisisalongparameterkey"- , "andthisbeanevenlongerparametervaluehelloworldhowareyou" )], [])+ it "exceeding header line size" $ do+ SRequest req4 _bod4 <- toRequest'' ctype3 content4+ (parseRequestBodyEx (setMaxHeaderLineLength 8190 def) lbsBackEnd req4)+ `shouldThrow` (== RequestHeaderFieldsTooLarge) - it "exceeding max parm value size with x-www-form-urlencoded mimetype" $ do- let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"- let ctype = "application/x-www-form-urlencoded"- SRequest req _bod <- toRequest'' ctype content- (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req) `shouldThrow` anyErrorCall+ it "Testing parseRequestBodyEx with application/x-www-form-urlencoded" $ do+ let content =+ "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"+ let ctype = "application/x-www-form-urlencoded"+ SRequest req _bod <- toRequest'' ctype content+ result <- parseRequestBodyEx def lbsBackEnd req+ result+ `shouldBe` (+ [+ ( "thisisalongparameterkey"+ , "andthisbeanevenlongerparametervaluehelloworldhowareyou"+ )+ ]+ , []+ ) + it "exceeding max parm value size with x-www-form-urlencoded mimetype" $ do+ let content =+ "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"+ let ctype = "application/x-www-form-urlencoded"+ SRequest req _bod <- toRequest'' ctype content+ (parseRequestBodyEx (setMaxRequestParmsSize 10 def) lbsBackEnd req)+ `shouldThrow` anyException where content2 =- "--AaB03x\n"- <> "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n"- <> "Content-Type: text/plain; charset=iso-8859-1\n\n"- <> "This is a file.\n"- <> "It has two lines.\n"- <> "--AaB03x\n"- <> "Content-Disposition: form-data; name=\"title\"\n"- <> "Content-Type: text/plain; charset=iso-8859-1\n\n"- <> "A File\n"- <> "--AaB03x\n"- <> "Content-Disposition: form-data; name=\"summary\"\n"- <> "Content-Type: text/plain; charset=iso-8859-1\n\n"- <> "This is my file\n"- <> "file test\n"- <> "--AaB03x--"+ "--AaB03x\n"+ <> "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n"+ <> "Content-Type: text/plain; charset=iso-8859-1\n\n"+ <> "This is a file.\n"+ <> "It has two lines.\n"+ <> "--AaB03x\n"+ <> "Content-Disposition: form-data; name=\"title\"\n"+ <> "Content-Type: text/plain; charset=iso-8859-1\n\n"+ <> "A File\n"+ <> "--AaB03x\n"+ <> "Content-Disposition: form-data; name=\"summary\"\n"+ <> "Content-Type: text/plain; charset=iso-8859-1\n\n"+ <> "This is my file\n"+ <> "file test\n"+ <> "--AaB03x--" content3 =- "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"- <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\n"- <> "Content-Type: application/octet-stream\r\n\r\n"- <> "Photo blog using Hack.\n\r\n"- <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"+ "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"+ <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\n"+ <> "Content-Type: application/octet-stream\r\n\r\n"+ <> "Photo blog using Hack.\n\r\n"+ <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n" content4 =- "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"- <> "Content-Disposition: form-data; name=\"alb\"; filename=\"README\"\r\n"- <> "Content-Type: application/octet-stream\r\n\r\n"- <> "Photo blog using Hack.\r\n\r\n"- <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"- <> "Content-Disposition: form-data; name=\"bla\"; filename=\"riedmi"- <> S8.replicate 8190 'e' <> "\"\r\n"- <> "Content-Type: application/octet-stream\r\n\r\n"- <> "Photo blog using Hack.\r\n\r\n"- <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"+ "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"+ <> "Content-Disposition: form-data; name=\"alb\"; filename=\"README\"\r\n"+ <> "Content-Type: application/octet-stream\r\n\r\n"+ <> "Photo blog using Hack.\r\n\r\n"+ <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"+ <> "Content-Disposition: form-data; name=\"bla\"; filename=\"riedmi"+ <> S.replicate 8190 _e+ <> "\"\r\n"+ <> "Content-Type: application/octet-stream\r\n\r\n"+ <> "Photo blog using Hack.\r\n\r\n"+ <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n" content5 =- "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"- <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\n"- <> "Content-Type: application/octet-stream\r\n\r\n"- <> "Photo blog using Hack.\n\r\n"- <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"- <> "Content-Disposition: form-data; name=\"yaml2\"; filename=\"MEADRE\"\r\n"- <> "Content-Type: application/octet-stream\r\n\r\n"- <> "Photo blog using Hack.\n\r\n"- <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"+ "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"+ <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\n"+ <> "Content-Type: application/octet-stream\r\n\r\n"+ <> "Photo blog using Hack.\n\r\n"+ <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"+ <> "Content-Disposition: form-data; name=\"yaml2\"; filename=\"MEADRE\"\r\n"+ <> "Content-Type: application/octet-stream\r\n\r\n"+ <> "Photo blog using Hack.\n\r\n"+ <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n" caseMultipartPlus :: Assertion caseMultipartPlus = do@@ -211,11 +249,11 @@ result @?= ([("email", "has+plus")], []) where content =- "--AaB03x\n" <>- "Content-Disposition: form-data; name=\"email\"\n" <>- "Content-Type: text/plain; charset=iso-8859-1\n\n" <>- "has+plus\n" <>- "--AaB03x--"+ "--AaB03x\n"+ <> "Content-Disposition: form-data; name=\"email\"\n"+ <> "Content-Type: text/plain; charset=iso-8859-1\n\n"+ <> "has+plus\n"+ <> "--AaB03x--" ctype = "multipart/form-data; boundary=AaB03x" caseMultipartAttrs :: Assertion@@ -224,17 +262,17 @@ result @?= ([("email", "has+plus")], []) where content =- "--AaB03x\n" <>- "Content-Disposition: form-data; name=\"email\"\n" <>- "Content-Type: text/plain; charset=iso-8859-1\n\n" <>- "has+plus\n" <>- "--AaB03x--"+ "--AaB03x\n"+ <> "Content-Disposition: form-data; name=\"email\"\n"+ <> "Content-Type: text/plain; charset=iso-8859-1\n\n"+ <> "has+plus\n"+ <> "--AaB03x--" ctype = "multipart/form-data; charset=UTF-8; boundary=AaB03x" caseUrlEncPlus :: Assertion caseUrlEncPlus = do result <- runResourceT $ withInternalState $ \state ->- parseRequestBody' (tempFileBackEnd state) $ toRequest ctype content+ parseRequestBody' (tempFileBackEnd state) $ toRequest ctype content result @?= ([("email", "has+plus")], []) where content = "email=has%2Bplus"@@ -252,8 +290,14 @@ , ("REQUEST_URI", "http://192.168.1.115:3000/") , ("REQUEST_METHOD", "POST") , ("HTTP_CONNECTION", "Keep-Alive")- , ("HTTP_COOKIE", "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD")- , ("HTTP_USER_AGENT", "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)")+ ,+ ( "HTTP_COOKIE"+ , "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD"+ )+ ,+ ( "HTTP_USER_AGENT"+ , "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)"+ ) , ("HTTP_HOST", "192.168.1.115:3000") , ("HTTP_ACCEPT", "*, */*") , ("HTTP_VERSION", "HTTP/1.1")@@ -262,9 +306,10 @@ headers | includeLength = ("content-length", "12098") : headers' | otherwise = headers'- let request' = defaultRequest- { requestHeaders = headers- }+ let request' =+ defaultRequest+ { requestHeaders = headers+ } (params, files) <- case getRequestBodyType request' of Nothing -> return ([], [])@@ -276,17 +321,25 @@ length files @?= 1 toRequest' :: S8.ByteString -> S8.ByteString -> SRequest-toRequest' ctype content = SRequest defaultRequest- { requestHeaders = [("Content-Type", ctype)]- } (L.fromChunks $ map S.singleton $ S.unpack content)+toRequest' ctype content =+ SRequest+ defaultRequest+ { requestHeaders = [("Content-Type", ctype)]+ }+ (L.fromChunks $ map S.singleton $ S.unpack content) toRequest'' :: S8.ByteString -> S8.ByteString -> IO SRequest-toRequest'' ctype content = mkRB content >>= \b -> return $ SRequest defaultRequest- { requestHeaders = [("Content-Type", ctype)], requestBody = b- } (L.fromChunks $ map S.singleton $ S.unpack content)+toRequest'' ctype content =+ mkRB content >>= \b -> do+ let req =+ setRequestBodyChunks+ b+ defaultRequest{requestHeaders = [("Content-Type", ctype)]}+ return $ SRequest req (L.fromChunks $ map S.singleton $ S.unpack content) mkRB :: S8.ByteString -> IO (IO S8.ByteString) mkRB content = do r <- I.newIORef content return $- I.atomicModifyIORef r $ \a -> (S8.empty, a)+ I.atomicModifyIORef r $+ \a -> (S8.empty, a)
test/Network/Wai/RequestSpec.hs view
@@ -1,15 +1,21 @@ {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.RequestSpec- ( main- , spec- ) where +module Network.Wai.RequestSpec (+ main,+ spec,+) where import Control.Exception (try) import Control.Monad (forever) import Data.ByteString (ByteString) import Network.HTTP.Types (HeaderName)-import Network.Wai (Request (..), RequestBodyLength (..), defaultRequest)+import Network.Wai (+ Request (..),+ RequestBodyLength (..),+ defaultRequest,+ getRequestBodyChunk,+ setRequestBodyChunks,+ ) import Network.Wai.Request import Test.Hspec @@ -21,46 +27,51 @@ describe "requestSizeCheck" $ do it "too large content length should throw RequestSizeException" $ do let limit = 1024- largeRequest = defaultRequest- { isSecure = False- , requestBodyLength = KnownLength (limit + 1)- , requestBody = return "repeat this chunk"- }+ largeRequest =+ setRequestBodyChunks+ (return "repeat this chunk")+ defaultRequest+ { isSecure = False+ , requestBodyLength = KnownLength (limit + 1)+ } checkedRequest <- requestSizeCheck limit largeRequest- body <- try (requestBody checkedRequest)+ body <- try (getRequestBodyChunk checkedRequest) case body of Left (RequestSizeException l) -> l `shouldBe` limit- Right _ -> expectationFailure "request size check failed"+ Right _ -> expectationFailure "request size check failed" it "too many chunks should throw RequestSizeException" $ do let limit = 1024- largeRequest = defaultRequest- { isSecure = False- , requestBodyLength = ChunkedBody- , requestBody = return "repeat this chunk"- }+ largeRequest =+ setRequestBodyChunks+ (return "repeat this chunk")+ defaultRequest+ { isSecure = False+ , requestBodyLength = ChunkedBody+ } checkedRequest <- requestSizeCheck limit largeRequest- body <- try (forever $ requestBody checkedRequest)+ body <- try (forever $ getRequestBodyChunk checkedRequest) case body of Left (RequestSizeException l) -> l `shouldBe` limit- Right _ -> expectationFailure "request size check failed"+ Right _ -> expectationFailure "request size check failed" describe "appearsSecure" $ do- let insecureRequest = defaultRequest- { isSecure = False- , requestHeaders =- [ ("HTTPS", "off")- , ("HTTP_X_FORWARDED_SSL", "off")- , ("HTTP_X_FORWARDED_SCHEME", "http")- , ("HTTP_X_FORWARDED_PROTO", "http,xyz")- ]- }+ let insecureRequest =+ defaultRequest+ { isSecure = False+ , requestHeaders =+ [ ("HTTPS", "off")+ , ("HTTP_X_FORWARDED_SSL", "off")+ , ("HTTP_X_FORWARDED_SCHEME", "http")+ , ("HTTP_X_FORWARDED_PROTO", "http,xyz")+ ]+ } it "returns False for an insecure request" $ insecureRequest `shouldSatisfy` not . appearsSecure it "checks if the Request is actually secure" $ do- let req = insecureRequest { isSecure = True }+ let req = insecureRequest{isSecure = True} req `shouldSatisfy` appearsSecure @@ -85,8 +96,9 @@ req `shouldSatisfy` appearsSecure addHeader :: HeaderName -> ByteString -> Request -> Request-addHeader name value req = req- { requestHeaders = (name, value) : otherHeaders }-+addHeader name value req =+ req+ { requestHeaders = (name, value) : otherHeaders+ } where otherHeaders = filter ((/= name) . fst) $ requestHeaders req
test/Network/Wai/TestSpec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ module Network.Wai.TestSpec (main, spec) where import Control.Monad (void)@@ -24,194 +25,215 @@ spec :: Spec spec = do- describe "setPath" $ do-- let req = setPath defaultRequest "/foo/bar/baz?foo=23&bar=42&baz"-- it "sets pathInfo" $ do- pathInfo req `shouldBe` ["foo", "bar", "baz"]-- it "utf8 path" $- pathInfo (setPath defaultRequest "/foo/%D7%A9%D7%9C%D7%95%D7%9D/bar") `shouldBe`- ["foo", "שלום", "bar"]+ describe "setPath" $ do+ let req = setPath defaultRequest "/foo/bar/baz?foo=23&bar=42&baz" - it "sets rawPathInfo" $ do- rawPathInfo req `shouldBe` "/foo/bar/baz"+ it "sets pathInfo" $ do+ pathInfo req `shouldBe` ["foo", "bar", "baz"] - it "sets queryString" $ do- queryString req `shouldBe` [("foo", Just "23"), ("bar", Just "42"), ("baz", Nothing)]+ it "utf8 path" $+ pathInfo (setPath defaultRequest "/foo/%D7%A9%D7%9C%D7%95%D7%9D/bar")+ `shouldBe` ["foo", "שלום", "bar"] - it "sets rawQueryString" $ do- rawQueryString req `shouldBe` "?foo=23&bar=42&baz"+ it "sets rawPathInfo" $ do+ rawPathInfo req `shouldBe` "/foo/bar/baz" - context "when path has no query string" $ do- it "sets rawQueryString to empty string" $ do- rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` ""+ it "sets queryString" $ do+ queryString req+ `shouldBe` [("foo", Just "23"), ("bar", Just "42"), ("baz", Nothing)] - describe "srequest" $ do+ it "sets rawQueryString" $ do+ rawQueryString req `shouldBe` "?foo=23&bar=42&baz" - let echoApp req respond = do- reqBody <- L8.fromStrict <$> getRequestBodyChunk req- let reqHeaders = requestHeaders req- respond $- responseLBS- status200- reqHeaders- reqBody+ context "when path has no query string" $ do+ it "sets rawQueryString to empty string" $ do+ rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` "" - it "returns the response body of an echo app" $ do- sresp <- flip runSession echoApp $- srequest $ SRequest defaultRequest "request body"- simpleBody sresp `shouldBe` "request body"+ describe "srequest" $ do+ let echoApp req respond = do+ reqBody <- L8.fromStrict <$> getRequestBodyChunk req+ let reqHeaders = requestHeaders req+ respond $+ responseLBS+ status200+ reqHeaders+ reqBody - describe "request" $ do+ it "returns the response body of an echo app" $ do+ sresp <-+ flip runSession echoApp $+ srequest $+ SRequest defaultRequest "request body"+ simpleBody sresp `shouldBe` "request body" - let echoApp req respond = do- reqBody <- L8.fromStrict <$> getRequestBodyChunk req- let reqHeaders = requestHeaders req- respond $- responseLBS- status200- reqHeaders- reqBody+ describe "request" $ do+ let echoApp req respond = do+ reqBody <- L8.fromStrict <$> getRequestBodyChunk req+ let reqHeaders = requestHeaders req+ respond $+ responseLBS+ status200+ reqHeaders+ reqBody - it "returns the status code of an echo app on default request" $ do- sresp <- runSession (request defaultRequest) echoApp- simpleStatus sresp `shouldBe` status200+ it "returns the status code of an echo app on default request" $ do+ sresp <- runSession (request defaultRequest) echoApp+ simpleStatus sresp `shouldBe` status200 - it "returns the response body of an echo app" $ do- bodyRef <- IORef.newIORef "request body"- let getBodyChunk = IORef.atomicModifyIORef bodyRef $ \leftover -> ("", leftover)- sresp <- flip runSession echoApp $- request $- defaultRequest- { requestBody = getBodyChunk- }- simpleBody sresp `shouldBe` "request body"+ it "returns the response body of an echo app" $ do+ bodyRef <- IORef.newIORef "request body"+ let getBodyChunk = IORef.atomicModifyIORef bodyRef $ \leftover -> ("", leftover)+ sresp <-+ flip runSession echoApp $+ request $+ setRequestBodyChunks getBodyChunk defaultRequest+ simpleBody sresp `shouldBe` "request body" - it "returns the response headers of an echo app" $ do- sresp <- flip runSession echoApp $- request $- defaultRequest- { requestHeaders = [("foo", "bar")]- }- simpleHeaders sresp `shouldBe` [("foo", "bar")]+ it "returns the response headers of an echo app" $ do+ sresp <-+ flip runSession echoApp $+ request $+ defaultRequest+ { requestHeaders = [("foo", "bar")]+ }+ simpleHeaders sresp `shouldBe` [("foo", "bar")] - let cookieApp req respond =- case pathInfo req of- ["set", name, val] ->- respond $- responseLBS- status200- [( "Set-Cookie"- , toByteString $ Cookie.renderSetCookie $- Cookie.def { Cookie.setCookieName = TE.encodeUtf8 name- , Cookie.setCookieValue = TE.encodeUtf8 val- }- )- ]- "set_cookie_body"- ["delete", name] ->- respond $- responseLBS- status200- [( "Set-Cookie"- , toByteString $ Cookie.renderSetCookie $- Cookie.def { Cookie.setCookieName =- TE.encodeUtf8 name- , Cookie.setCookieExpires =- Just $ UTCTime (fromGregorian 1970 1 1) 0- }- )- ]- "set_cookie_body"- _ ->- respond $- responseLBS- status200- []- ( L8.pack- $ show- $ map snd- $ filter ((=="Cookie") . fst)- $ requestHeaders req- )+ let cookieApp req respond =+ case pathInfo req of+ ["set", name, val] ->+ respond $+ responseLBS+ status200+ [+ ( "Set-Cookie"+ , toByteString $+ Cookie.renderSetCookie $+ Cookie.def+ { Cookie.setCookieName = TE.encodeUtf8 name+ , Cookie.setCookieValue = TE.encodeUtf8 val+ }+ )+ ]+ "set_cookie_body"+ ["delete", name] ->+ respond $+ responseLBS+ status200+ [+ ( "Set-Cookie"+ , toByteString $+ Cookie.renderSetCookie $+ Cookie.def+ { Cookie.setCookieName =+ TE.encodeUtf8 name+ , Cookie.setCookieExpires =+ Just $ UTCTime (fromGregorian 1970 1 1) 0+ }+ )+ ]+ "set_cookie_body"+ _ ->+ respond $+ responseLBS+ status200+ []+ ( L8.pack $+ show $+ map snd $+ filter ((== "Cookie") . fst) $+ requestHeaders req+ ) - it "sends a Cookie header with correct value after receiving a Set-Cookie header" $ do- sresp <- flip runSession cookieApp $ do- void $ request $- setPath defaultRequest "/set/cookie_name/cookie_value"- request $- setPath defaultRequest "/get"- simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]"+ it+ "sends a Cookie header with correct value after receiving a Set-Cookie header" $ do+ sresp <- flip runSession cookieApp $ do+ void $+ request $+ setPath defaultRequest "/set/cookie_name/cookie_value"+ request $+ setPath defaultRequest "/get"+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" - it "sends a Cookie header with updated value after receiving a Set-Cookie header update" $ do- sresp <- flip runSession cookieApp $ do- void $ request $- setPath defaultRequest "/set/cookie_name/cookie_value"- void $ request $- setPath defaultRequest "/set/cookie_name/cookie_value2"- request $- setPath defaultRequest "/get"- simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]"+ it+ "sends a Cookie header with updated value after receiving a Set-Cookie header update" $ do+ sresp <- flip runSession cookieApp $ do+ void $+ request $+ setPath defaultRequest "/set/cookie_name/cookie_value"+ void $+ request $+ setPath defaultRequest "/set/cookie_name/cookie_value2"+ request $+ setPath defaultRequest "/get"+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]" - it "handles multiple cookies" $ do- sresp <- flip runSession cookieApp $ do- void $ request $- setPath defaultRequest "/set/cookie_name/cookie_value"- void $ request $- setPath defaultRequest "/set/cookie_name2/cookie_value2"- request $- setPath defaultRequest "/get"- simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value;cookie_name2=cookie_value2\"]"+ it "handles multiple cookies" $ do+ sresp <- flip runSession cookieApp $ do+ void $+ request $+ setPath defaultRequest "/set/cookie_name/cookie_value"+ void $+ request $+ setPath defaultRequest "/set/cookie_name2/cookie_value2"+ request $+ setPath defaultRequest "/get"+ simpleBody sresp+ `shouldBe` "[\"cookie_name=cookie_value;cookie_name2=cookie_value2\"]" - it "removes a deleted cookie" $ do- sresp <- flip runSession cookieApp $ do- void $ request $- setPath defaultRequest "/set/cookie_name/cookie_value"- void $ request $- setPath defaultRequest "/set/cookie_name2/cookie_value2"- void $ request $- setPath defaultRequest "/delete/cookie_name2"- request $- setPath defaultRequest "/get"- simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]"+ it "removes a deleted cookie" $ do+ sresp <- flip runSession cookieApp $ do+ void $+ request $+ setPath defaultRequest "/set/cookie_name/cookie_value"+ void $+ request $+ setPath defaultRequest "/set/cookie_name2/cookie_value2"+ void $+ request $+ setPath defaultRequest "/delete/cookie_name2"+ request $+ setPath defaultRequest "/get"+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" - it "sends a cookie set with setClientCookie to server" $ do- sresp <- flip runSession cookieApp $ do- setClientCookie- (Cookie.def { Cookie.setCookieName = "cookie_name"- , Cookie.setCookieValue = "cookie_value"- }- )- request $- setPath defaultRequest "/get"- simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]"+ it "sends a cookie set with setClientCookie to server" $ do+ sresp <- flip runSession cookieApp $ do+ setClientCookie+ ( Cookie.def+ { Cookie.setCookieName = "cookie_name"+ , Cookie.setCookieValue = "cookie_value"+ }+ )+ request $+ setPath defaultRequest "/get"+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" - it "sends a cookie updated with setClientCookie to server" $ do- sresp <- flip runSession cookieApp $ do- setClientCookie- (Cookie.def { Cookie.setCookieName = "cookie_name"- , Cookie.setCookieValue = "cookie_value"- }- )- setClientCookie- (Cookie.def { Cookie.setCookieName = "cookie_name"- , Cookie.setCookieValue = "cookie_value2"- }- )- request $- setPath defaultRequest "/get"- simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]"+ it "sends a cookie updated with setClientCookie to server" $ do+ sresp <- flip runSession cookieApp $ do+ setClientCookie+ ( Cookie.def+ { Cookie.setCookieName = "cookie_name"+ , Cookie.setCookieValue = "cookie_value"+ }+ )+ setClientCookie+ ( Cookie.def+ { Cookie.setCookieName = "cookie_name"+ , Cookie.setCookieValue = "cookie_value2"+ }+ )+ request $+ setPath defaultRequest "/get"+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]" - it "does not send a cookie deleted with deleteClientCookie to server" $ do- sresp <- flip runSession cookieApp $ do- setClientCookie- (Cookie.def { Cookie.setCookieName = "cookie_name"- , Cookie.setCookieValue = "cookie_value"- }- )- deleteClientCookie "cookie_name"- request $- setPath defaultRequest "/get"- simpleBody sresp `shouldBe` "[]"+ it "does not send a cookie deleted with deleteClientCookie to server" $ do+ sresp <- flip runSession cookieApp $ do+ setClientCookie+ ( Cookie.def+ { Cookie.setCookieName = "cookie_name"+ , Cookie.setCookieValue = "cookie_value"+ }+ )+ deleteClientCookie "cookie_name"+ request $+ setPath defaultRequest "/get"+ simpleBody sresp `shouldBe` "[]"
test/WaiExtraSpec.hs view
@@ -184,7 +184,7 @@ "test" gzipAppWithHeaders :: ResponseHeaders -> Application-gzipAppWithHeaders hdrs = gzipApp' $ mapResponseHeaders $ (hdrs ++)+gzipAppWithHeaders hdrs = gzipApp' $ mapResponseHeaders (hdrs ++) gzipFileApp :: GzipSettings -> Application gzipFileApp = flip gzipFileApp' id@@ -529,13 +529,13 @@ where params = [("foo", "bar"), ("baz", "bin")] -- the time cannot be known, so match around it- postOutput = (T.pack $ "POST /\n Params: " ++ (show params), "s\n")+ postOutput = (T.pack $ "POST /\n Params: " ++ show params, "s\n") getOutput params' = ("GET /location\n Params: " <> T.pack (show params') <> "\n Accept: \n Status: 200 OK 0", "s\n") debugApp (beginning, ending) req send = do iactual <- I.newIORef mempty middleware <- mkRequestLogger def- { destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs)+ { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs) , outputFormat = Detailed False } res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send
test/sample.hs view
@@ -5,22 +5,29 @@ import Data.Text () import Network.HTTP.Types import Network.Wai+import Network.Wai.Handler.Warp import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Jsonp-import Network.Wai.Handler.Warp app :: Application app request = return $ case pathInfo request of- [] -> responseLBS status200 []- $ fromChunks $ flip map [1..10000] $ \i -> pack $ concat- [ "<p>Just this same paragraph again. "- , show (i :: Int)- , "</p>"- ]+ [] -> responseLBS status200 [] $+ fromChunks $+ flip map [1 .. 10000] $ \i ->+ pack $+ concat+ [ "<p>Just this same paragraph again. "+ , show (i :: Int)+ , "</p>"+ ] ["test.html"] -> ResponseFile status200 [] "test.html" Nothing- ["json"] -> ResponseFile status200 [(hContentType, "application/json")]- "json" Nothing- _ -> ResponseFile status404 [] "../LICENSE" Nothing+ ["json"] ->+ ResponseFile+ status200+ [(hContentType, "application/json")]+ "json"+ Nothing+ _ -> ResponseFile status404 [] "../LICENSE" Nothing main :: IO () main = run 3000 $ gzip def $ jsonp app
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 3.1.13.0+Version: 3.1.14 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality:@@ -103,7 +103,7 @@ Library Build-Depends: base >= 4.12 && < 5 , aeson- , ansi-terminal+ , ansi-terminal >= 0.4 , base64-bytestring , bytestring >= 0.10.4 , call-stack@@ -123,7 +123,7 @@ , time >= 1.1.4 , transformers >= 0.2.2 , vault- , wai >= 3.0.3.0 && < 3.3+ , wai >= 3.2.4 && < 3.3 , wai-logger >= 2.3.7 , warp >= 3.3.22 , word8@@ -229,6 +229,7 @@ , wai-extra , wai , warp+ , word8 , zlib ghc-options: -Wall default-language: Haskell2010