diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Network/Wai/EventSource.hs b/Network/Wai/EventSource.hs --- a/Network/Wai/EventSource.hs +++ b/Network/Wai/EventSource.hs @@ -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_" -} diff --git a/Network/Wai/EventSource/EventStream.hs b/Network/Wai/EventSource/EventStream.hs --- a/Network/Wai/EventSource/EventStream.hs +++ b/Network/Wai/EventSource/EventStream.hs @@ -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') diff --git a/Network/Wai/Handler/CGI.hs b/Network/Wai/Handler/CGI.hs --- a/Network/Wai/Handler/CGI.hs +++ b/Network/Wai/Handler/CGI.hs @@ -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" ] diff --git a/Network/Wai/Handler/SCGI.hs b/Network/Wai/Handler/SCGI.hs --- a/Network/Wai/Handler/SCGI.hs +++ b/Network/Wai/Handler/SCGI.hs @@ -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 diff --git a/Network/Wai/Header.hs b/Network/Wai/Header.hs --- a/Network/Wai/Header.hs +++ b/Network/Wai/Header.hs @@ -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 diff --git a/Network/Wai/Middleware/AcceptOverride.hs b/Network/Wai/Middleware/AcceptOverride.hs --- a/Network/Wai/Middleware/AcceptOverride.hs +++ b/Network/Wai/Middleware/AcceptOverride.hs @@ -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 + } diff --git a/Network/Wai/Middleware/AddHeaders.hs b/Network/Wai/Middleware/AddHeaders.hs --- a/Network/Wai/Middleware/AddHeaders.hs +++ b/Network/Wai/Middleware/AddHeaders.hs @@ -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 diff --git a/Network/Wai/Middleware/Approot.hs b/Network/Wai/Middleware/Approot.hs --- a/Network/Wai/Middleware/Approot.hs +++ b/Network/Wai/Middleware/Approot.hs @@ -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"@. diff --git a/Network/Wai/Middleware/Autohead.hs b/Network/Wai/Middleware/Autohead.hs --- a/Network/Wai/Middleware/Autohead.hs +++ b/Network/Wai/Middleware/Autohead.hs @@ -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 diff --git a/Network/Wai/Middleware/CleanPath.hs b/Network/Wai/Middleware/CleanPath.hs --- a/Network/Wai/Middleware/CleanPath.hs +++ b/Network/Wai/Middleware/CleanPath.hs @@ -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 diff --git a/Network/Wai/Middleware/CombineHeaders.hs b/Network/Wai/Middleware/CombineHeaders.hs --- a/Network/Wai/Middleware/CombineHeaders.hs +++ b/Network/Wai/Middleware/CombineHeaders.hs @@ -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) + ] diff --git a/Network/Wai/Middleware/ForceDomain.hs b/Network/Wai/Middleware/ForceDomain.hs --- a/Network/Wai/Middleware/ForceDomain.hs +++ b/Network/Wai/Middleware/ForceDomain.hs @@ -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 diff --git a/Network/Wai/Middleware/ForceSSL.hs b/Network/Wai/Middleware/ForceSSL.hs --- a/Network/Wai/Middleware/ForceSSL.hs +++ b/Network/Wai/Middleware/ForceSSL.hs @@ -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 diff --git a/Network/Wai/Middleware/Gzip.hs b/Network/Wai/Middleware/Gzip.hs --- a/Network/Wai/Middleware/Gzip.hs +++ b/Network/Wai/Middleware/Gzip.hs @@ -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 diff --git a/Network/Wai/Middleware/HealthCheckEndpoint.hs b/Network/Wai/Middleware/HealthCheckEndpoint.hs --- a/Network/Wai/Middleware/HealthCheckEndpoint.hs +++ b/Network/Wai/Middleware/HealthCheckEndpoint.hs @@ -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 diff --git a/Network/Wai/Middleware/HttpAuth.hs b/Network/Wai/Middleware/HttpAuth.hs --- a/Network/Wai/Middleware/HttpAuth.hs +++ b/Network/Wai/Middleware/HttpAuth.hs @@ -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 diff --git a/Network/Wai/Middleware/Jsonp.hs b/Network/Wai/Middleware/Jsonp.hs --- a/Network/Wai/Middleware/Jsonp.hs +++ b/Network/Wai/Middleware/Jsonp.hs @@ -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 diff --git a/Network/Wai/Middleware/MethodOverride.hs b/Network/Wai/Middleware/MethodOverride.hs --- a/Network/Wai/Middleware/MethodOverride.hs +++ b/Network/Wai/Middleware/MethodOverride.hs @@ -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 diff --git a/Network/Wai/Middleware/MethodOverridePost.hs b/Network/Wai/Middleware/MethodOverridePost.hs --- a/Network/Wai/Middleware/MethodOverridePost.hs +++ b/Network/Wai/Middleware/MethodOverridePost.hs @@ -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" -} diff --git a/Network/Wai/Middleware/RealIp.hs b/Network/Wai/Middleware/RealIp.hs --- a/Network/Wai/Middleware/RealIp.hs +++ b/Network/Wai/Middleware/RealIp.hs @@ -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 diff --git a/Network/Wai/Middleware/RequestLogger.hs b/Network/Wai/Middleware/RequestLogger.hs --- a/Network/Wai/Middleware/RequestLogger.hs +++ b/Network/Wai/Middleware/RequestLogger.hs @@ -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 diff --git a/Network/Wai/Middleware/RequestLogger/Internal.hs b/Network/Wai/Middleware/RequestLogger/Internal.hs --- a/Network/Wai/Middleware/RequestLogger/Internal.hs +++ b/Network/Wai/Middleware/RequestLogger/Internal.hs @@ -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 diff --git a/Network/Wai/Middleware/RequestLogger/JSON.hs b/Network/Wai/Middleware/RequestLogger/JSON.hs --- a/Network/Wai/Middleware/RequestLogger/JSON.hs +++ b/Network/Wai/Middleware/RequestLogger/JSON.hs @@ -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 diff --git a/Network/Wai/Middleware/RequestSizeLimit.hs b/Network/Wai/Middleware/RequestSizeLimit.hs --- a/Network/Wai/Middleware/RequestSizeLimit.hs +++ b/Network/Wai/Middleware/RequestSizeLimit.hs @@ -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`." + ] + ) diff --git a/Network/Wai/Middleware/RequestSizeLimit/Internal.hs b/Network/Wai/Middleware/RequestSizeLimit/Internal.hs --- a/Network/Wai/Middleware/RequestSizeLimit/Internal.hs +++ b/Network/Wai/Middleware/RequestSizeLimit/Internal.hs @@ -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} diff --git a/Network/Wai/Middleware/Rewrite.hs b/Network/Wai/Middleware/Rewrite.hs --- a/Network/Wai/Middleware/Rewrite.hs +++ b/Network/Wai/Middleware/Rewrite.hs @@ -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 #-} diff --git a/Network/Wai/Middleware/Routed.hs b/Network/Wai/Middleware/Routed.hs --- a/Network/Wai/Middleware/Routed.hs +++ b/Network/Wai/Middleware/Routed.hs @@ -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 diff --git a/Network/Wai/Middleware/Select.hs b/Network/Wai/Middleware/Select.hs --- a/Network/Wai/Middleware/Select.hs +++ b/Network/Wai/Middleware/Select.hs @@ -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) diff --git a/Network/Wai/Middleware/StreamFile.hs b/Network/Wai/Middleware/StreamFile.hs --- a/Network/Wai/Middleware/StreamFile.hs +++ b/Network/Wai/Middleware/StreamFile.hs @@ -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 diff --git a/Network/Wai/Middleware/StripHeaders.hs b/Network/Wai/Middleware/StripHeaders.hs --- a/Network/Wai/Middleware/StripHeaders.hs +++ b/Network/Wai/Middleware/StripHeaders.hs @@ -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) diff --git a/Network/Wai/Middleware/Timeout.hs b/Network/Wai/Middleware/Timeout.hs --- a/Network/Wai/Middleware/Timeout.hs +++ b/Network/Wai/Middleware/Timeout.hs @@ -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 diff --git a/Network/Wai/Middleware/Vhost.hs b/Network/Wai/Middleware/Vhost.hs --- a/Network/Wai/Middleware/Vhost.hs +++ b/Network/Wai/Middleware/Vhost.hs @@ -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 diff --git a/Network/Wai/Parse.hs b/Network/Wai/Parse.hs --- a/Network/Wai/Parse.hs +++ b/Network/Wai/Parse.hs @@ -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 diff --git a/Network/Wai/Request.hs b/Network/Wai/Request.hs --- a/Network/Wai/Request.hs +++ b/Network/Wai/Request.hs @@ -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 diff --git a/Network/Wai/Test.hs b/Network/Wai/Test.hs --- a/Network/Wai/Test.hs +++ b/Network/Wai/Test.hs @@ -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) diff --git a/Network/Wai/UrlMap.hs b/Network/Wai/UrlMap.hs --- a/Network/Wai/UrlMap.hs +++ b/Network/Wai/UrlMap.hs @@ -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 "/" diff --git a/Network/Wai/Util.hs b/Network/Wai/Util.hs --- a/Network/Wai/Util.hs +++ b/Network/Wai/Util.hs @@ -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) diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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") + ] diff --git a/test/Network/Wai/Middleware/ApprootSpec.hs b/test/Network/Wai/Middleware/ApprootSpec.hs --- a/test/Network/Wai/Middleware/ApprootSpec.hs +++ b/test/Network/Wai/Middleware/ApprootSpec.hs @@ -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)] "" diff --git a/test/Network/Wai/Middleware/CombineHeadersSpec.hs b/test/Network/Wai/Middleware/CombineHeadersSpec.hs --- a/test/Network/Wai/Middleware/CombineHeadersSpec.hs +++ b/test/Network/Wai/Middleware/CombineHeadersSpec.hs @@ -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 "" diff --git a/test/Network/Wai/Middleware/ForceSSLSpec.hs b/test/Network/Wai/Middleware/ForceSSLSpec.hs --- a/test/Network/Wai/Middleware/ForceSSLSpec.hs +++ b/test/Network/Wai/Middleware/ForceSSLSpec.hs @@ -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 [] "" diff --git a/test/Network/Wai/Middleware/RealIpSpec.hs b/test/Network/Wai/Middleware/RealIpSpec.hs --- a/test/Network/Wai/Middleware/RealIpSpec.hs +++ b/test/Network/Wai/Middleware/RealIpSpec.hs @@ -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 diff --git a/test/Network/Wai/Middleware/RequestSizeLimitSpec.hs b/test/Network/Wai/Middleware/RequestSizeLimitSpec.hs --- a/test/Network/Wai/Middleware/RequestSizeLimitSpec.hs +++ b/test/Network/Wai/Middleware/RequestSizeLimitSpec.hs @@ -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 [] "" diff --git a/test/Network/Wai/Middleware/RoutedSpec.hs b/test/Network/Wai/Middleware/RoutedSpec.hs --- a/test/Network/Wai/Middleware/RoutedSpec.hs +++ b/test/Network/Wai/Middleware/RoutedSpec.hs @@ -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" diff --git a/test/Network/Wai/Middleware/SelectSpec.hs b/test/Network/Wai/Middleware/SelectSpec.hs --- a/test/Network/Wai/Middleware/SelectSpec.hs +++ b/test/Network/Wai/Middleware/SelectSpec.hs @@ -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 diff --git a/test/Network/Wai/Middleware/StripHeadersSpec.hs b/test/Network/Wai/Middleware/StripHeadersSpec.hs --- a/test/Network/Wai/Middleware/StripHeadersSpec.hs +++ b/test/Network/Wai/Middleware/StripHeadersSpec.hs @@ -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 [] "" diff --git a/test/Network/Wai/Middleware/TimeoutSpec.hs b/test/Network/Wai/Middleware/TimeoutSpec.hs --- a/test/Network/Wai/Middleware/TimeoutSpec.hs +++ b/test/Network/Wai/Middleware/TimeoutSpec.hs @@ -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) diff --git a/test/Network/Wai/ParseSpec.hs b/test/Network/Wai/ParseSpec.hs --- a/test/Network/Wai/ParseSpec.hs +++ b/test/Network/Wai/ParseSpec.hs @@ -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) diff --git a/test/Network/Wai/RequestSpec.hs b/test/Network/Wai/RequestSpec.hs --- a/test/Network/Wai/RequestSpec.hs +++ b/test/Network/Wai/RequestSpec.hs @@ -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 diff --git a/test/Network/Wai/TestSpec.hs b/test/Network/Wai/TestSpec.hs --- a/test/Network/Wai/TestSpec.hs +++ b/test/Network/Wai/TestSpec.hs @@ -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` "[]" diff --git a/test/WaiExtraSpec.hs b/test/WaiExtraSpec.hs --- a/test/WaiExtraSpec.hs +++ b/test/WaiExtraSpec.hs @@ -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 diff --git a/test/sample.hs b/test/sample.hs --- a/test/sample.hs +++ b/test/sample.hs @@ -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 - [ "

Just this same paragraph again. " - , show (i :: Int) - , "

" - ] + [] -> responseLBS status200 [] $ + fromChunks $ + flip map [1 .. 10000] $ \i -> + pack $ + concat + [ "

Just this same paragraph again. " + , show (i :: Int) + , "

" + ] ["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 diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -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