wai-extra 3.0.32 → 3.1.18
raw patch · 60 files changed
Files
- ChangeLog.md +107/−1
- Network/Wai/EventSource.hs +34/−31
- Network/Wai/EventSource/EventStream.hs +38/−45
- Network/Wai/Handler/CGI.hs +94/−81
- Network/Wai/Handler/SCGI.hs +35/−25
- Network/Wai/Header.hs +61/−5
- Network/Wai/Middleware/AcceptOverride.hs +27/−14
- Network/Wai/Middleware/AddHeaders.hs +9/−11
- Network/Wai/Middleware/Approot.hs +34/−28
- Network/Wai/Middleware/Autohead.hs +8/−3
- Network/Wai/Middleware/CleanPath.hs +25/−21
- Network/Wai/Middleware/CombineHeaders.hs +302/−0
- Network/Wai/Middleware/ForceDomain.hs +20/−15
- Network/Wai/Middleware/ForceSSL.hs +12/−10
- Network/Wai/Middleware/Gzip.hs +363/−160
- Network/Wai/Middleware/HealthCheckEndpoint.hs +38/−0
- Network/Wai/Middleware/HttpAuth.hs +71/−54
- Network/Wai/Middleware/Jsonp.hs +34/−26
- Network/Wai/Middleware/Local.hs +15/−16
- Network/Wai/Middleware/MethodOverride.hs +5/−5
- Network/Wai/Middleware/MethodOverridePost.hs +23/−19
- Network/Wai/Middleware/RealIp.hs +95/−0
- Network/Wai/Middleware/RequestLogger.hs +443/−201
- Network/Wai/Middleware/RequestLogger/Internal.hs +11/−7
- Network/Wai/Middleware/RequestLogger/JSON.hs +129/−71
- Network/Wai/Middleware/RequestSizeLimit.hs +86/−0
- Network/Wai/Middleware/RequestSizeLimit/Internal.hs +63/−0
- Network/Wai/Middleware/Rewrite.hs +112/−87
- Network/Wai/Middleware/Routed.hs +24/−17
- Network/Wai/Middleware/Select.hs +97/−0
- Network/Wai/Middleware/StreamFile.hs +18/−25
- Network/Wai/Middleware/StripHeaders.hs +21/−16
- Network/Wai/Middleware/Timeout.hs +5/−5
- Network/Wai/Middleware/ValidateHeaders.hs +138/−0
- Network/Wai/Middleware/Vhost.hs +24/−14
- Network/Wai/Parse.hs +390/−268
- Network/Wai/Request.hs +37/−36
- Network/Wai/Test.hs +219/−184
- Network/Wai/Test/Internal.hs +4/−4
- Network/Wai/UrlMap.hs +62/−45
- Network/Wai/Util.hs +27/−0
- example/Main.hs +45/−28
- test/Network/Wai/Middleware/ApprootSpec.hs +26/−18
- test/Network/Wai/Middleware/CombineHeadersSpec.hs +165/−0
- test/Network/Wai/Middleware/ForceSSLSpec.hs +33/−20
- test/Network/Wai/Middleware/RealIpSpec.hs +94/−0
- test/Network/Wai/Middleware/RequestSizeLimitSpec.hs +157/−0
- test/Network/Wai/Middleware/RoutedSpec.hs +38/−31
- test/Network/Wai/Middleware/SelectSpec.hs +82/−0
- test/Network/Wai/Middleware/StripHeadersSpec.hs +37/−21
- test/Network/Wai/Middleware/TimeoutSpec.hs +5/−5
- test/Network/Wai/Middleware/ValidateHeadersSpec.hs +59/−0
- test/Network/Wai/ParseSpec.hs +239/−166
- test/Network/Wai/RequestSpec.hs +47/−36
- test/Network/Wai/TestSpec.hs +206/−192
- test/WaiExtraSpec.hs +594/−208
- test/json.gz +1/−0
- test/noprecompress +1/−0
- test/sample.hs +18/−11
- wai-extra.cabal +89/−57
ChangeLog.md view
@@ -1,5 +1,111 @@ # Changelog for wai-extra +## 3.1.18++* Fixed handling of quoted strings and semicolons in `parseRequestBodyEx` [#1038](https://github.com/yesodweb/wai/pull/1038).+ In particular, multipart form data containing filenames with semicolons and `\` escaped characters+ are now parsed correctly.+* Added instances `Foldable` and `Traversable` for `UrlMap'` [#992](https://github.com/yesodweb/wai/pull/992)++## 3.1.17++* Started deprecation of `data-default` [#1011](https://github.com/yesodweb/wai/pull/1011)+ * All `Default` instances have comments that these will be removed in a future major version.+ * `def` exported from `Network.Wai.Middleware.Gzip` now has a deprecation warning+ * All uses of `def` have been replaced with explicit `default{TYPE_NAME}` values.+* Some additional documentation++## 3.1.16++* Substituted `data-default-class` for `data-default` [#1010](https://github.com/yesodweb/wai/pull/1010)++## 3.1.15++* Added `validateHeadersMiddleware` for validating response headers set by the application [#990](https://github.com/yesodweb/wai/pull/990).++## 3.1.14++* Request parsing throws an exception rather than `error`ing [#972](https://github.com/yesodweb/wai/pull/972):+ * 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`.+* `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)++## 3.1.12.1++* Include test/{json.gz,noprecompress} as extra-source-files [#887](https://github.com/yesodweb/wai/pull/887)++## 3.1.12++* Added gzip caching based on `ETag` [#885](https://github.com/yesodweb/wai/pull/885):++## 3.1.11++* Overhaul to `Network.Wai.Middleware.Gzip` [#880](https://github.com/yesodweb/wai/pull/880):+ * Don't fail if quality value parameters are present in the `Accept-Encoding` header+ * Add `Accept-Encoding` to the `Vary` response header, instead of overriding it+ * Add setting parameter to decide the compression threshold (`gzipSizeThreshold`)+ * Always skip compression on a `206 Partial Content` response+ * Only catch `IOException`s and `ZlibException`s when using `GzipCacheFolder`+ * Added documentation on the usage of `gzip` and its decision-making.++## 3.1.10.1++* Added documentation to `Accept Override` `Middleware` [#884](https://github.com/yesodweb/wai/pull/884)++## 3.1.10++* Fixed import linting mistake introduced in `3.1.9` ([#875)](https://github.com/yesodweb/wai/pull/875)) where `Network.Wai.Handler.CGI` wouldn't compile on Windows. [#881](https://github.com/yesodweb/wai/pull/880)+* Added `Select` to choose between `Middleware`s [#878](https://github.com/yesodweb/wai/pull/878)++## 3.1.9++* Cleanup and linting of most of `wai-extra` and refactoring the `gzip` middleware to keep it more DRY and to skip compression earlier if possible [#875](https://github.com/yesodweb/wai/pull/875)+* Added `HealthCheckEndpoint` `Middleware`s for health check [#877](https://github.com/yesodweb/wai/pull/877)++## 3.1.8++* Added an `ApacheWithSettings` output format for `RequestLogger` that allows request filtering similar to `DetailedWithSettings` and logging of the current user via wai-logger's `initLoggerUser` [#866](https://github.com/yesodweb/wai/pull/866)++## 3.1.7++* Added new `mPrelogRequests` option to `DetailedSettings` [#857](https://github.com/yesodweb/wai/pull/857)++## 3.1.6++* Remove unused dependencies [#837](https://github.com/yesodweb/wai/pull/837)++## 3.1.5++* `Network.Wai.Middleware.RealIp`: Add a new middleware to infer the remote IP address from headers [#834](https://github.com/yesodweb/wai/pull/834)++## 3.1.4.1++* `Network.Wai.Middleware.Gzip`: Add `Vary: Accept-Encoding` header to responses [#829](https://github.com/yesodweb/wai/pull/829)++## 3.1.4++* Export `Network.Wai.Middleware.RequestLogger.JSON.requestToJSON` [#827](https://github.com/yesodweb/wai/pull/827)++## 3.1.3++* Add a `DetailedWithSettings` output format for `RequestLogger` that allows to hide requests and modify query parameters [#826](https://github.com/yesodweb/wai/pull/826)++## 3.1.2++* Remove an extraneous dot from the error message for `defaultRequestSizeLimitSettings`++## 3.1.1++* `Network.Wai.Middleware.RequestSizeLimit`: Add a new middleware to reject request bodies above a certain size. [#818](https://github.com/yesodweb/wai/pull/818/files)++## 3.1.0++* `Network.Wai.Test`: Add support for source locations to assertion primitives [#817](https://github.com/yesodweb/wai/pull/817)+ ## 3.0.32 * Undo previous two release, restore code from 3.0.29.2@@ -10,7 +116,7 @@ ## 3.0.30 -* `Network.Wai.Test`: Add support source locations to assertion primitives [#812](https://github.com/yesodweb/wai/pull/812)+* `Network.Wai.Test`: Add support for source locations to assertion primitives [#812](https://github.com/yesodweb/wai/pull/812) ## 3.0.29.2
Network/Wai/EventSource.hs view
@@ -1,25 +1,24 @@-{-|- 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(..),+ ServerEvent (..), eventSourceAppChan, eventSourceAppIO,- eventStreamAppRaw- ) where+ eventStreamAppRaw,+) where -import Data.Function (fix)-import Control.Concurrent.Chan (Chan, dupChan, readChan)-import Control.Monad.IO.Class (liftIO)-import Network.HTTP.Types (status200, hContentType)-import Network.Wai (Application, responseStream)+import Control.Concurrent.Chan (Chan, dupChan, readChan)+import Control.Monad.IO.Class (liftIO)+import Data.Function (fix)+import Network.HTTP.Types (hContentType, status200)+import Network.Wai (Application, responseStream) import Network.Wai.EventSource.EventStream @@ -34,28 +33,32 @@ -- the given IO action. eventSourceAppIO :: IO ServerEvent -> Application eventSourceAppIO src _ sendResponse =- sendResponse $ responseStream- status200- [(hContentType, "text/event-stream")]+ sendResponse+ $ responseStream+ status200+ [(hContentType, "text/event-stream")] $ \sendChunk flush -> do flush fix $ \loop -> do se <- src case eventToBuilder se of Nothing -> return ()- Just b -> sendChunk b >> flush >> loop+ Just b -> sendChunk b >> flush >> loop -- | Make a new WAI EventSource application with a handler that emits events. -- -- @since 3.0.28-eventStreamAppRaw :: ((ServerEvent -> IO()) -> IO () -> IO ()) -> Application+eventStreamAppRaw :: ((ServerEvent -> IO ()) -> IO () -> IO ()) -> Application eventStreamAppRaw handler _ sendResponse =- sendResponse $ responseStream- status200- [(hContentType, "text/event-stream")]+ sendResponse+ $ responseStream+ status200+ [(hContentType, "text/event-stream")] $ \sendChunk flush -> handler (sendEvent sendChunk) flush- where- sendEvent sendChunk event =- case eventToBuilder event of- Nothing -> return ()- Just b -> sendChunk b+ where+ sendEvent sendChunk event =+ case eventToBuilder event of+ Nothing -> return ()+ Just b -> sendChunk b++{- HLint ignore eventStreamAppRaw "Use forM_" -}
Network/Wai/EventSource/EventStream.hs view
@@ -1,76 +1,69 @@ {-# 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- ) where+ ServerEvent (..),+ eventToBuilder,+) where import Data.ByteString.Builder #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif+import Data.Word8 (_colon, _lf) -{-|- Type representing a communication over an event stream. This can be an- actual event, a comment, a modification to the retry timer, or a special- "close" event indicating the server should close the connection.--}+-- |+-- Type representing a communication over an event stream. This can be an+-- actual event, a comment, a modification to the retry timer, or a special+-- "close" event indicating the server should close the connection. data ServerEvent- = ServerEvent {- eventName :: Maybe Builder,- eventId :: Maybe Builder,- eventData :: [Builder]+ = ServerEvent+ { eventName :: Maybe Builder+ , eventId :: Maybe Builder+ , eventData :: [Builder] }- | CommentEvent {- eventComment :: Builder+ | CommentEvent+ { eventComment :: Builder }- | RetryEvent {- eventRetry :: Int+ | RetryEvent+ { eventRetry :: Int } | CloseEvent --{-|- Newline as a Builder.--}+-- |+-- Newline as a Builder. nl :: Builder-nl = char7 '\n'-+nl = word8 _lf -{-|- Field names as Builder--}+-- |+-- Field names as Builder nameField, idField, dataField, retryField, commentField :: Builder nameField = string7 "event:" idField = string7 "id:" dataField = string7 "data:" retryField = string7 "retry:"-commentField = char7 ':'-+commentField = word8 _colon -{-|- Wraps the text as a labeled field of an event stream.--}+-- |+-- Wraps the text as a labeled field of an event stream. field :: Builder -> Builder -> Builder field l b = l `mappend` b `mappend` nl --{-|- Converts a 'ServerEvent' to its wire representation as specified by the- @text/event-stream@ content type.--}+-- |+-- Converts a 'ServerEvent' to its wire representation as specified by the+-- @text/event-stream@ content type. eventToBuilder :: ServerEvent -> Maybe Builder eventToBuilder (CommentEvent txt) = Just $ field commentField txt-eventToBuilder (RetryEvent n) = Just $ field retryField (string8 . show $ n)-eventToBuilder (CloseEvent) = Nothing-eventToBuilder (ServerEvent n i d)= Just $- (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl+eventToBuilder (RetryEvent n) = Just $ field retryField (string8 . show $ n)+eventToBuilder CloseEvent = Nothing+eventToBuilder (ServerEvent n i d) =+ Just $+ name n (evid i $ mconcat (map (field dataField) d)) `mappend` nl where- name Nothing = id+ name Nothing = id name (Just n') = mappend (field nameField n')- evid Nothing = id- evid (Just i') = mappend (field idField i')+ evid Nothing = id+ evid (Just i') = mappend (field idField i')
Network/Wai/Handler/CGI.hs view
@@ -1,38 +1,40 @@-{-# LANGUAGE RankNTypes, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+ -- | Backend for Common Gateway Interface. Almost all users should use the -- 'run' function.-module Network.Wai.Handler.CGI- ( run- , runSendfile- , runGeneric- , requestBodyFunc- ) where+module Network.Wai.Handler.CGI (+ run,+ runSendfile,+ runGeneric,+ requestBodyFunc,+) where -import Network.Wai-import Network.Wai.Internal-import Network.Socket (getAddrInfo, addrAddress)-import Data.IORef-import Data.Maybe (fromMaybe)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy as L import Control.Arrow ((***))-import Data.Char (toLower)-import qualified System.IO-import qualified Data.String as String-import Data.ByteString.Builder (byteString, toLazyByteString, char7, string8)+import Control.Monad (unless, void)+import Data.ByteString.Builder (byteString, string8, toLazyByteString, word8) import Data.ByteString.Builder.Extra (flush)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Internal (defaultChunkSize)-import System.IO (Handle)-import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength)-import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI+import Data.Char (toLower)+import Data.Function (fix)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat, mempty, mappend) #endif- import qualified Data.Streaming.ByteString.Builder as Builder-import Data.Function (fix)-import Control.Monad (unless, void)+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)+import Network.Wai+import Network.Wai.Internal+import System.IO (Handle)+import qualified System.IO #if WINDOWS import System.Environment (getEnvironment)@@ -45,9 +47,9 @@ safeRead :: Read a => a -> String -> a safeRead d s =- case reads s of- ((x, _):_) -> x- [] -> d+ case reads s of+ ((x, _) : _) -> x+ [] -> d lookup' :: String -> [(String, String)] -> String lookup' key pairs = fromMaybe "" $ lookup key pairs@@ -63,8 +65,11 @@ -- | Some web servers provide an optimization for sending files via a sendfile -- system call via a special header. To use this feature, provide that header -- name here.-runSendfile :: B.ByteString -- ^ sendfile header- -> Application -> IO ()+runSendfile+ :: B.ByteString+ -- ^ sendfile header+ -> Application+ -> IO () runSendfile sf app = do vars <- getEnvironment let input = requestBodyHandle System.IO.stdin@@ -75,12 +80,16 @@ -- use the same code as CGI. Most users will not need this function, and can -- stick with 'run' or 'runSendfile'. runGeneric- :: [(String, String)] -- ^ all variables- -> (Int -> IO (IO B.ByteString)) -- ^ responseBody of input- -> (B.ByteString -> IO ()) -- ^ destination for output- -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?- -> Application- -> IO ()+ :: [(String, String)]+ -- ^ all variables+ -> (Int -> IO (IO B.ByteString))+ -- ^ responseBody of input+ -> (B.ByteString -> IO ())+ -- ^ destination for output+ -> Maybe B.ByteString+ -- ^ does the server support the X-Sendfile header?+ -> Application+ -> IO () runGeneric vars inputH outputH xsendfile app = do let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars pinfo = lookup' "PATH_INFO" vars@@ -89,10 +98,7 @@ remoteHost' = case lookup "REMOTE_ADDR" vars of Just x -> x- Nothing ->- case lookup "REMOTE_HOST" vars of- Just x -> x- Nothing -> ""+ Nothing -> lookup' "REMOTE_HOST" vars isSecure' = case map toLower $ lookup' "SERVER_PROTOCOL" vars of "https" -> True@@ -101,29 +107,30 @@ requestBody' <- inputH contentLength let addr = case addrs of- a:_ -> addrAddress a+ 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+ , requestHeaderReferer = lookup "referer" reqHeaders+ , requestHeaderUserAgent = lookup "user-agent" reqHeaders #endif- }+ } void $ app env $ \res -> case (xsendfile, res) of (Just sf, ResponseFile s hs fp Nothing) -> do@@ -140,31 +147,36 @@ 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 where headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))- status (Status i m) = (byteString "Status", mconcat- [ string8 $ show i- , char7 ' '- , byteString m- ])+ status (Status i m) =+ ( byteString "Status"+ , mconcat+ [ string8 $ show i+ , word8 _space+ , byteString m+ ]+ ) header' (x, y) = (byteString $ CI.original x, byteString y)- header (x, y) = mconcat- [ x- , byteString ": "- , y- , char7 '\n'- ]- sfBuilder s hs sf fp = mconcat- [ headers s hs- , header $ (byteString sf, string8 fp)- , char7 '\n'- , byteString sf- , byteString " not supported"- ]+ header (x, y) =+ mconcat+ [ x+ , byteString ": "+ , y+ , word8 _lf+ ]+ sfBuilder s hs sf fp =+ mconcat+ [ headers s hs+ , header (byteString sf, string8 fp)+ , word8 _lf+ , byteString sf+ , byteString " not supported"+ ] fixHeaders h = case lookup hContentType h of Nothing -> (hContentType, "text/html; charset=utf-8") : h@@ -176,11 +188,11 @@ cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name" cleanupVarName s = case s of- 'H':'T':'T':'P':'_':a:as -> String.fromString $ a : helper' as+ 'H' : 'T' : 'T' : 'P' : '_' : a : as -> String.fromString $ a : helper' as _ -> String.fromString s -- FIXME remove? where- helper' ('_':x:rest) = '-' : x : helper' rest- helper' (x:rest) = toLower x : helper' rest+ helper' ('_' : x : rest) = '-' : x : helper' rest+ helper' (x : rest) = toLower x : helper' rest helper' [] = [] requestBodyHandle :: Handle -> Int -> IO (IO B.ByteString)@@ -188,7 +200,8 @@ bs <- B.hGet h i return $ if B.null bs then Nothing else Just bs -requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString)+requestBodyFunc+ :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString) requestBodyFunc get count0 = do ref <- newIORef count0 return $ do
Network/Wai/Handler/SCGI.hs view
@@ -1,20 +1,23 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}-module Network.Wai.Handler.SCGI- ( run- , runSendfile- ) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-} -import Network.Wai-import Network.Wai.Handler.CGI (runGeneric, requestBodyFunc)-import Foreign.Ptr-import Foreign.Marshal.Alloc-import Foreign.C+module Network.Wai.Handler.SCGI (+ run,+ runSendfile,+) where+ import Data.ByteString (ByteString) import qualified Data.ByteString as S-import qualified Data.ByteString.Unsafe as S import qualified Data.ByteString.Char8 as S8-import Data.IORef import Data.ByteString.Lazy.Internal (defaultChunkSize)+import qualified Data.ByteString.Unsafe as S+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe, listToMaybe)+import Foreign.C (CChar, CInt (..))+import Foreign.Marshal.Alloc (free, mallocBytes)+import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Network.Wai (Application)+import Network.Wai.Handler.CGI (requestBodyFunc, runGeneric) run :: Application -> IO () run app = runOne Nothing app >> run app@@ -26,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 ()@@ -48,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 @@ -60,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@@ -72,10 +82,10 @@ where readLen l = do bs <- readByteString socket 1- let [c] = S8.unpack bs- if c == ':'- then return l- else readLen $ l * 10 + (fromEnum c - fromEnum '0')+ case S8.unpack bs of+ [':'] -> return l+ [c] -> readLen $ l * 10 + (fromEnum c - fromEnum '0')+ _ -> error "Network.Wai.Handler.SCGI.readNetstring: should never happen" readByteString :: CInt -> Int -> IO S.ByteString readByteString socket len = do
Network/Wai/Header.hs view
@@ -1,12 +1,20 @@ -- | Some helpers for dealing with WAI 'Header's.--module Network.Wai.Header- ( contentLength- ) where+module Network.Wai.Header (+ contentLength,+ parseQValueList,+ replaceHeader,+) where +import Control.Monad (guard)+import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8+import Data.ByteString.Internal (w2c)+import Data.Word8 (_0, _1, _period, _semicolon, _space) import Network.HTTP.Types as H+import Text.Read (readMaybe) +import Network.Wai.Util (dropWhileEnd, splitCommas)+ -- | More useful for a response. A Wai Request already has a requestBodyLength contentLength :: [(HeaderName, S8.ByteString)] -> Maybe Integer contentLength hdrs = lookup H.hContentLength hdrs >>= readInt@@ -14,5 +22,53 @@ readInt :: S8.ByteString -> Maybe Integer readInt bs = case S8.readInteger bs of- Just (i, rest) | S8.null 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]+replaceHeader name val old =+ (name, val) : filter ((/= name) . fst) old++-- | Only to be used on header's values which support quality value syntax+--+-- A few things to keep in mind when using this function:+-- * The resulting 'Int' will be anywhere from 1000 to 0 ("1" = 1000, "0.6" = 600, "0.025" = 25)+-- * The absence of a Q value will result in 'Just 1000'+-- * A bad parse of the Q value will result in a 'Nothing', e.g.+-- * Q value has more than 3 digits behind the dot+-- * Q value is missing+-- * Q value is higher than 1+-- * Q value is not a number+parseQValueList :: S8.ByteString -> [(S8.ByteString, Maybe Int)]+parseQValueList = fmap go . splitCommas+ where+ go = checkQ . S.break (== _semicolon)+ checkQ :: (S.ByteString, S.ByteString) -> (S.ByteString, Maybe Int)+ checkQ (val, "") = (val, Just 1000)+ 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+ )+ where+ parseQval qVal = do+ q <- S.stripPrefix "q=" qVal+ (i, rest) <- S.uncons q+ guard $+ i `elem` [_0, _1]+ && S.length rest <= 4+ case S.uncons rest of+ Nothing+ -- q = "0" or "1"+ | i == _0 -> Just 0+ | i == _1 -> Just 1000+ | otherwise -> Nothing+ Just (dot, trail)+ | dot == _period && not (i == _1 && S.any (/= _0) trail) -> do+ let len = S.length trail+ extraZeroes = replicate (3 - len) '0'+ guard $ len > 0+ readMaybe $ w2c i : S8.unpack trail ++ extraZeroes+ | otherwise -> Nothing
Network/Wai/Middleware/AcceptOverride.hs view
@@ -1,11 +1,29 @@-module Network.Wai.Middleware.AcceptOverride- ( acceptOverride- ) where+module Network.Wai.Middleware.AcceptOverride (+ -- $howto+ acceptOverride,+) where -import Network.Wai import Control.Monad (join)-import Data.ByteString (ByteString)+import Network.Wai +import Network.Wai.Header (replaceHeader)++-- $howto+-- This 'Middleware' provides a way for the request itself to+-- tell the server to override the \"Accept\" header by looking+-- for the \"_accept\" query parameter in the query string and+-- inserting or replacing the \"Accept\" header with that string.+--+-- For example:+--+-- @+-- ?_accept=SomeValue+-- @+--+-- This will result in \"Accept: SomeValue\" being set in the+-- request as a header, and all other previous \"Accept\" headers+-- will be removed from the request.+ acceptOverride :: Middleware acceptOverride app req = app req'@@ -13,12 +31,7 @@ req' = case join $ lookup "_accept" $ queryString req of Nothing -> req- Just a -> req { requestHeaders = changeVal "Accept" a $ requestHeaders req}--changeVal :: Eq a- => a- -> ByteString- -> [(a, ByteString)]- -> [(a, ByteString)]-changeVal key val old = (key, val)- : filter (\(k, _) -> k /= key) old+ Just a ->+ req+ { requestHeaders = replaceHeader "Accept" a $ requestHeaders req+ }
Network/Wai/Middleware/AddHeaders.hs view
@@ -1,24 +1,22 @@ -- | -- -- Since 3.0.3-module Network.Wai.Middleware.AddHeaders- ( addHeaders- ) where--import Network.HTTP.Types (Header)-import Network.Wai (Middleware, modifyResponse, mapResponseHeaders)-import Network.Wai.Internal (Response(..))-import Data.ByteString (ByteString)+module Network.Wai.Middleware.AddHeaders (+ addHeaders,+) where -import qualified Data.CaseInsensitive as CI import Control.Arrow (first)+import Data.ByteString (ByteString)+import qualified Data.CaseInsensitive as CI+import Network.HTTP.Types (Header)+import Network.Wai (Middleware, mapResponseHeaders, modifyResponse)+import Network.Wai.Internal (Response (..)) addHeaders :: [(ByteString, ByteString)] -> Middleware -- ^ Prepend a list of headers without any checks -- -- Since 3.0.3- addHeaders h = modifyResponse $ addHeaders' (map (first CI.mk) h) addHeaders' :: [Header] -> Response -> Response-addHeaders' h = mapResponseHeaders (\hs -> h ++ hs)+addHeaders' h = mapResponseHeaders (h ++)
Network/Wai/Middleware/Approot.hs view
@@ -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,30 +14,33 @@ -- @/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, -import Control.Exception (Exception, throw)-import Data.ByteString (ByteString)+ -- * 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-import Data.Maybe (fromMaybe)-import Data.Typeable (Typeable)-import qualified Data.Vault.Lazy as V-import Network.Wai (Request, vault, Middleware)-import Network.Wai.Request (guessApproot)-import System.Environment (getEnvironment)-import System.IO.Unsafe (unsafePerformIO)+import Data.Maybe (fromMaybe)+import Data.Typeable (Typeable)+import qualified Data.Vault.Lazy as V+import Network.Wai (Middleware, Request, vault)+import System.Environment (lookupEnv)+import System.IO.Unsafe (unsafePerformIO) +import Network.Wai.Request (guessApproot)+ approotKey :: V.Key ByteString approotKey = unsafePerformIO V.newKey {-# NOINLINE approotKey #-}@@ -47,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"@.@@ -69,10 +75,10 @@ -- Since 3.0.7 envFallbackNamed :: String -> IO Middleware envFallbackNamed name = do- env <- getEnvironment- case lookup name env of- Just s -> return $ hardcoded $ S8.pack s- Nothing -> return fromRequest+ approot <- lookupEnv name+ pure $ case approot of+ Just s -> hardcoded $ S8.pack s+ Nothing -> fromRequest -- | Hard-code the given value as the approot. --
Network/Wai/Middleware/Autohead.hs view
@@ -1,17 +1,22 @@ {-# LANGUAGE CPP #-}+ -- | Automatically produce responses to HEAD requests based on the underlying -- applications GET response. module Network.Wai.Middleware.Autohead (autohead) where -import Network.Wai #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) #endif+import Network.Wai (+ Middleware,+ requestMethod,+ responseBuilder,+ responseToStream,+ ) autohead :: Middleware autohead app req sendResponse- | requestMethod req == "HEAD" = app req { requestMethod = "GET" } $ \res -> do+ | requestMethod req == "HEAD" = app req{requestMethod = "GET"} $ \res -> do let (s, hs, _) = responseToStream res sendResponse $ responseBuilder s hs mempty | otherwise = app req sendResponse-
Network/Wai/Middleware/CleanPath.hs view
@@ -1,32 +1,36 @@ {-# LANGUAGE CPP #-}-module Network.Wai.Middleware.CleanPath- ( cleanPath- ) where -import Network.Wai+module Network.Wai.Middleware.CleanPath (+ cleanPath,+) where+ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L-import Network.HTTP.Types (status301, hLocation)-import Data.Text (Text) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat) #endif+import Data.Text (Text)+import Network.HTTP.Types (hLocation, status301)+import Network.Wai (Application, pathInfo, rawQueryString, responseLBS) -cleanPath :: ([Text] -> Either B.ByteString [Text])- -> B.ByteString- -> ([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- Left p -> sendResponse- $ responseLBS 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+ Left p ->+ sendResponse $+ responseLBS+ 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
+ Network/Wai/Middleware/CombineHeaders.hs view
@@ -0,0 +1,302 @@+{-# 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,++ -- * Adjusting the settings+ setHeader,+ removeHeader,+ setHeaderMap,+ regular,+ keepOnly,+ setRequestHeaders,+ setResponseHeaders,+) where++import qualified Data.ByteString as B+import qualified Data.List as L (foldl', reverse)+import qualified Data.Map.Strict as M+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, mapResponseHeaders, requestHeaders)+import Network.Wai.Util (dropWhileEnd)++-- | The mapping of 'HeaderName' to 'HandleType'+type HeaderMap = M.Map HeaderName HandleType++-- | These settings define which headers should be combined,+-- if the combining should happen on incoming (request) headers+-- and if it should happen on outgoing (response) headers.+--+-- Any header you put in the header map *will* be used to+-- combine those headers with commas. There's no check to see+-- if it is a header that allows comma-separated lists, so if+-- you want to combine custom headers, go ahead.+--+-- (You can check the documentation of 'defaultCombineSettings'+-- to see which standard headers are specified to be able to be+-- combined)+--+-- @since 3.1.13.0+data CombineSettings = CombineSettings+ { combineHeaderMap :: HeaderMap+ -- ^ Which headers should be combined? And how? (cf. 'HandleType')+ , combineRequestHeaders :: Bool+ -- ^ Should request headers be combined?+ , combineResponseHeaders :: Bool+ -- ^ Should response headers be combined?+ }+ deriving (Eq, Show)++-- | Settings that combine request headers,+-- but don't touch response headers.+--+-- All types of headers that /can/ be combined+-- (as defined in the spec) /will/ be combined.+--+-- To be exact, this is the list:+--+-- * Accept+-- * Accept-CH+-- * Accept-Charset+-- * Accept-Encoding+-- * Accept-Language+-- * Accept-Post+-- * Access-Control-Allow-Headers+-- * Access-Control-Allow-Methods+-- * Access-Control-Expose-Headers+-- * Access-Control-Request-Headers+-- * Allow+-- * Alt-Svc @(KeepOnly \"clear\"")@+-- * Cache-Control+-- * Clear-Site-Data @(KeepOnly \"*\")@+-- * Connection+-- * Content-Encoding+-- * Content-Language+-- * Digest+-- * If-Match+-- * If-None-Match @(KeepOnly \"*\")@+-- * Link+-- * Permissions-Policy+-- * TE+-- * Timing-Allow-Origin @(KeepOnly \"*\")@+-- * Trailer+-- * Transfer-Encoding+-- * Upgrade+-- * Via+-- * Vary @(KeepOnly \"*\")@+-- * Want-Digest+--+-- N.B. Any header name that has \"KeepOnly\" after it+-- will be combined like normal, unless one of the values+-- is the one mentioned (\"*\" most of the time), then+-- that value is used and all others are dropped.+--+-- @since 3.1.13.0+defaultCombineSettings :: CombineSettings+defaultCombineSettings =+ CombineSettings+ { combineHeaderMap = defaultHeaderMap+ , combineRequestHeaders = True+ , combineResponseHeaders = False+ }++-- | Override the 'HeaderMap' of the 'CombineSettings'+-- (default: 'defaultHeaderMap')+--+-- @since 3.1.13.0+setHeaderMap :: HeaderMap -> CombineSettings -> CombineSettings+setHeaderMap mp set = set{combineHeaderMap = mp}++-- | Set whether the combining of headers should be applied to+-- the incoming request headers. (default: True)+--+-- @since 3.1.13.0+setRequestHeaders :: Bool -> CombineSettings -> CombineSettings+setRequestHeaders b set = set{combineRequestHeaders = b}++-- | Set whether the combining of headers should be applied to+-- the outgoing response headers. (default: False)+--+-- @since 3.1.13.0+setResponseHeaders :: Bool -> CombineSettings -> CombineSettings+setResponseHeaders b set = set{combineResponseHeaders = b}++-- | Convenience function to add a header to the header map or,+-- if it is already in the map, to change the 'HandleType'.+--+-- @since 3.1.13.0+setHeader :: HeaderName -> HandleType -> CombineSettings -> CombineSettings+setHeader name typ 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+ }++-- | This middleware will reorganize the incoming and/or outgoing+-- headers in such a way that it combines any duplicates of+-- headers that, on their own, can normally have more than one+-- value, and any other headers will stay untouched.+--+-- This middleware WILL change the global order of headers+-- (they will be put in alphabetical order), but keep the+-- order of the same type of header. I.e. if there are 3+-- \"Set-Cookie\" headers, the first one will still be first,+-- the second one will still be second, etc. But now they are+-- guaranteed to be next to each other.+--+-- N.B. This 'Middleware' assumes the headers it combines+-- are correctly formatted. If one of the to-be-combined+-- headers is malformed, the new combined header will also+-- (probably) be malformed.+--+-- @since 3.1.13.0+combineHeaders :: CombineSettings -> Middleware+combineHeaders CombineSettings{..} app req resFunc =+ app newReq $ resFunc . adjustRes+ where+ newReq+ | combineRequestHeaders = req{requestHeaders = mkNewHeaders oldHeaders}+ | otherwise = req+ oldHeaders = requestHeaders req+ adjustRes+ | combineResponseHeaders = mapResponseHeaders mkNewHeaders+ | otherwise = id+ mkNewHeaders =+ M.foldrWithKey' finishHeaders [] . L.foldl' go mempty+ 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)++-- | Unpack 'HeaderHandling' back into 'Header's again+finishHeaders+ :: HeaderName -> HeaderHandling -> RequestHeaders -> RequestHeaders+finishHeaders name (shouldCombine, xs) hdrs =+ case shouldCombine of+ Just typ -> (name, combinedHeader typ) : hdrs+ Nothing ->+ -- Yes, this reverses the headers, but they+ -- were already reversed by 'checkHeader'+ L.foldl' (\acc el -> (name, el) : acc) hdrs xs+ where+ combinedHeader Regular = combineHdrs xs+ combinedHeader (KeepOnly val)+ | val `elem` xs = val+ | otherwise = combineHdrs xs+ -- headers were reversed, so do 'reverse' before combining+ combineHdrs = B.intercalate ", " . fmap clean . L.reverse+ clean = dropWhileEnd $ \w -> w == _comma || w == _space || w == _tab++type HeaderHandling = (Maybe HandleType, [B.ByteString])++-- | Both will concatenate with @,@ (commas), but 'KeepOnly' will drop all+-- values except the given one if present (e.g. in case of wildcards/special values)+--+-- For example: If there are multiple @"Clear-Site-Data"@ headers, but one of+-- them is the wildcard @\"*\"@ value, using @'KeepOnly' "*"@ will cause all+-- others to be dropped and only the wildcard value to remain.+-- (The @\"*\"@ wildcard in this case means /ALL site data/ should be cleared,+-- so no need to include more)+--+-- @since 3.1.13.0+data HandleType+ = Regular+ | KeepOnly B.ByteString+ deriving (Eq, Show)++-- | Use the regular strategy when combining headers.+-- (i.e. merge into one header and separate values with commas)+--+-- @since 3.1.13.0+regular :: HandleType+regular = Regular++-- | Use the regular strategy when combining headers,+-- but if the exact supplied 'ByteString' is encountered+-- then discard all other values and only keep that value.+--+-- e.g. @keepOnly "*"@ will drop all other encountered values+--+-- @since 3.1.13.0+keepOnly :: B.ByteString -> HandleType+keepOnly = KeepOnly++-- | The default collection of HTTP headers that can be combined+-- in case there are multiples in one request or response.+--+-- See the documentation of 'defaultCombineSettings' for the exact list.+--+-- @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"++ (H.hIfMatch, Regular)+ , (H.hIfNoneMatch, KeepOnly "*") -- wildcard? (if any is "*", only keep that one)+ , ("Link", Regular)+ , ("Permissions-Policy", Regular)+ , (H.hTE, Regular)+ , ("Timing-Allow-Origin", KeepOnly "*") -- wildcard? (if any is "*", only keep that one)+ , (H.hTrailer, Regular)+ , (H.hTransferEncoding, Regular)+ , (H.hUpgrade, Regular)+ , (H.hVia, Regular)+ , (H.hVary, KeepOnly "*") -- wildcard? (if any is "*", only keep that one)+ , ("Want-Digest", Regular)+ ]
Network/Wai/Middleware/ForceDomain.hs view
@@ -1,15 +1,21 @@+{-# LANGUAGE CPP #-}+ -- | -- -- @since 3.0.14 module Network.Wai.Middleware.ForceDomain where import Data.ByteString (ByteString)-import Data.Monoid ((<>), mempty)+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (mempty)+#endif+#endif import Network.HTTP.Types (hLocation, methodGet, status301, status307)-import Prelude+import Network.Wai (Middleware, Request (..), responseBuilder) -import Network.Wai-import Network.Wai.Request+import Network.Wai.Request (appearsSecure) -- | Force a domain by redirecting. -- The `checkDomain` function takes the current domain and checks whether it is correct.@@ -23,16 +29,15 @@ app req sendResponse Just domain -> sendResponse $ redirectResponse domain-- where- -- From: Network.Wai.Middleware.ForceSSL- redirectResponse domain =- responseBuilder status [(hLocation, location domain)] mempty+ where+ -- From: Network.Wai.Middleware.ForceSSL+ redirectResponse domain =+ responseBuilder status [(hLocation, location domain)] mempty - location h =- let p = if appearsSecure req then "https://" else "http://" in- p <> h <> rawPathInfo req <> rawQueryString req+ location h =+ let p = if appearsSecure req then "https://" else "http://"+ in p <> h <> rawPathInfo req <> rawQueryString req - status- | requestMethod req == methodGet = status301- | otherwise = status307+ status+ | requestMethod req == methodGet = status301+ | otherwise = status307
Network/Wai/Middleware/ForceSSL.hs view
@@ -1,22 +1,24 @@ {-# LANGUAGE CPP #-}+ -- | Redirect non-SSL requests to https -- -- Since 3.0.7-module Network.Wai.Middleware.ForceSSL- ( forceSSL- ) where--import Network.Wai-import Network.Wai.Request+module Network.Wai.Middleware.ForceSSL (+ forceSSL,+) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) import Data.Monoid (mempty) #endif-+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>))+#endif import Network.HTTP.Types (hLocation, methodGet, status301, status307)+import Network.Wai (Middleware, Request (..), Response, responseBuilder) +import Network.Wai.Request (appearsSecure)+ -- | For requests that don't appear secure, redirect to https -- -- Since 3.0.7@@ -24,12 +26,12 @@ forceSSL app req sendResponse = case (appearsSecure req, redirectResponse req) of (False, Just resp) -> sendResponse resp- _ -> app req sendResponse+ _ -> app req sendResponse redirectResponse :: Request -> Maybe Response redirectResponse req = do- host <- requestHeaderHost req- return $ responseBuilder status [(hLocation, location host)] mempty+ host <- requestHeaderHost req+ return $ responseBuilder status [(hLocation, location host)] mempty where location h = "https://" <> h <> rawPathInfo req <> rawQueryString req status
Network/Wai/Middleware/Gzip.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} ---------------------------------------------------------++---------------------------------------------------------+ -- | -- Module : Network.Wai.Middleware.Gzip -- Copyright : Michael Snoyman@@ -10,64 +12,217 @@ -- Portability : portable -- -- Automatic gzip compression of responses.--------------------------------------------------------------module Network.Wai.Middleware.Gzip- ( gzip- , GzipSettings- , gzipFiles- , GzipFiles (..)- , gzipCheckMime- , def- , defaultCheckMime- ) where+module Network.Wai.Middleware.Gzip (+ -- * How to use this module+ -- $howto -import Network.Wai-import Data.Maybe (fromMaybe, isJust)-import qualified Data.ByteString.Char8 as S8+ -- ** The Middleware+ -- $gzip+ gzip,++ -- ** The Settings+ -- $settings+ GzipSettings,+ defaultGzipSettings,+ gzipFiles,+ gzipCheckMime,+ gzipSizeThreshold,++ -- ** How to handle file responses+ GzipFiles (..),++ -- ** Miscellaneous+ -- $miscellaneous+ defaultCheckMime,+ def,+) where++import Control.Exception (+ IOException,+ SomeException,+ fromException,+ throwIO,+ try,+ )+import Control.Monad (unless) import qualified Data.ByteString as S-import Data.Default.Class-import Network.HTTP.Types ( Status, Header, hContentEncoding, hUserAgent- , hContentType, hContentLength)-import System.Directory (doesFileExist, createDirectoryIfMissing) import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Builder.Extra as Blaze (flush)-import Control.Exception (try, SomeException)+import qualified Data.ByteString.Char8 as S8+import Data.ByteString.Lazy.Internal (defaultChunkSize)+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)+import qualified Data.Default as Default (Default (..))+import Data.Function (fix)+import Data.Maybe (isJust) import qualified Data.Set as Set-import Network.Wai.Header-import Network.Wai.Internal import qualified Data.Streaming.ByteString.Builder as B import qualified Data.Streaming.Zlib as Z-import Control.Monad (unless)-import Data.Function (fix)-import Control.Exception (throwIO)+import Data.Word8 as W8 (toLower, _semicolon)+import Network.HTTP.Types (+ Header,+ Status (statusCode),+ hContentEncoding,+ hContentLength,+ hContentType,+ hUserAgent,+ )+import Network.HTTP.Types.Header (hAcceptEncoding, hETag, hVary)+import Network.Wai+import Network.Wai.Internal (Response (..))+import System.Directory (createDirectoryIfMissing, doesFileExist) import qualified System.IO as IO-import Data.ByteString.Lazy.Internal (defaultChunkSize)-import Data.Word8 (_semicolon) +import Network.Wai.Header (contentLength, parseQValueList, replaceHeader)+import Network.Wai.Util (splitCommas, trimWS)++-- $howto+--+-- This 'Middleware' adds @gzip encoding@ to an application.+-- Its use is pretty straightforward, but it's good to know+-- how and when it decides to encode the response body.+--+-- A few things to keep in mind when using this middleware:+--+-- * It is advised to put any 'Middleware's that change the+-- response behind this one, because it bases a lot of its+-- decisions on the returned response.+-- * Enabling compression may counteract zero-copy response+-- optimizations on some platforms.+-- * This middleware is applied to every response by default.+-- If it should only encode certain paths,+-- "Network.Wai.Middleware.Routed" might be helpful.++-- $gzip+--+-- There are a good amount of requirements that should be+-- fulfilled before a response will actually be @gzip encoded@+-- by this 'Middleware', so here's a short summary.+--+-- Request requirements:+--+-- * The request needs to accept \"gzip\" in the \"Accept-Encoding\" header.+-- * Requests from Internet Explorer 6 will not be encoded.+-- (i.e. if the request's \"User-Agent\" header contains \"MSIE 6\")+--+-- Response requirements:+--+-- * The response isn't already encoded. (i.e. shouldn't already+-- have a \"Content-Encoding\" header)+-- * The response isn't a @206 Partial Content@ (partial content+-- should never be compressed)+-- * If the response contains a \"Content-Length\" header, it+-- should be larger than the 'gzipSizeThreshold'.+-- * The \"Content-Type\" response header's value should+-- 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, use 'defaultGzipSettings'.+-- The default settings don't compress file responses, only builder and stream+-- responses, and only if the response passes the MIME and length checks. (cf.+-- 'defaultCheckMime' and 'gzipSizeThreshold')+--+-- To customize your own settings, use 'defaultGzipSettings' and set the+-- fields you would like to change as follows:+--+-- @+-- myGzipSettings :: 'GzipSettings'+-- myGzipSettings =+-- 'defaultGzipSettings'+-- { 'gzipFiles' = 'GzipCompress'+-- , 'gzipCheckMime' = myMimeCheckFunction+-- , 'gzipSizeThreshold' = 860+-- }+-- @+ data GzipSettings = GzipSettings { 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+ -- ^ 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. data GzipFiles- = GzipIgnore -- ^ Do not compress file responses.- | GzipCompress -- ^ Compress files. Note that this may counteract- -- zero-copy response optimizations on some- -- platforms.- | GzipCacheFolder FilePath -- ^ Compress files, caching them in- -- some directory.- | GzipPreCompressed GzipFiles -- ^ If we use compression then try to use the filename with ".gz"- -- appended to it, if the file is missing then try next action- --- -- @since 3.0.17+ = -- | Do not compress file ('ResponseFile') responses.+ -- Any 'ResponseBuilder' or 'ResponseStream' might still be compressed.+ GzipIgnore+ | -- | Compress files. Note that this may counteract+ -- zero-copy response optimizations on some platforms.+ GzipCompress+ | -- | Compress files, caching the compressed version in the given directory.+ GzipCacheFolder FilePath+ | -- | Takes the ETag response header into consideration when caching+ -- files in the given folder. If there's no ETag header,+ -- this setting is equivalent to 'GzipCacheFolder'.+ --+ -- N.B. Make sure the 'gzip' middleware is applied before+ -- any 'Middleware' that will set the ETag header.+ --+ -- @since 3.1.12+ GzipCacheETag FilePath+ | -- | If we use compression then try to use the filename with \".gz\"+ -- appended to it. If the file is missing then try next action.+ --+ -- @since 3.0.17+ GzipPreCompressed GzipFiles deriving (Show, Eq, Read) --- | Use default MIME settings; /do not/ compress files.-instance Default GzipSettings where- def = GzipSettings GzipIgnore defaultCheckMime+-- $miscellaneous+--+-- 'defaultCheckMime' is exported in case anyone wants to use it in+-- defining their own 'gzipCheckMime' function.+-- 'def' has been re-exported for convenience sake, but its use is now+-- heavily discouraged. Please use the explicit 'defaultGzipSettings'. +-- | DO NOT USE THIS INSTANCE!+-- Please use 'defaultGzipSettings'.+--+-- This instance will be removed in a future major version.+instance Default.Default GzipSettings where+ def = defaultGzipSettings++-- | Deprecated synonym for the 'defaultGzipSettings'.+def :: GzipSettings+def = defaultGzipSettings+{-# Deprecated def "Please use 'defaultGzipSettings'. 'def' and the Default instance will be removed in a future major update." #-}++-- | 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@.@@ -76,142 +231,196 @@ 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.------ Analyzes the \"Accept-Encoding\" header from the client to determine--- if gzip is supported.------ File responses will be compressed according to the 'GzipFiles' setting.------ Will only be applied based on the 'gzipCheckMime' setting. For default--- behavior, see 'defaultCheckMime'. gzip :: GzipSettings -> Middleware-gzip set app env sendResponse = app env $ \res ->- case res of- ResponseRaw{} -> sendResponse res- ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res- _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) && (bigEnough res)- then- let runAction x = case x of- (ResponseFile s hs file Nothing, GzipPreCompressed nextAction) ->- let- compressedVersion = file ++ ".gz"- in- doesFileExist compressedVersion >>= \y ->- if y- then (sendResponse $ ResponseFile s (fixHeaders hs) compressedVersion Nothing)- else (runAction (ResponseFile s hs file Nothing, nextAction))- (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->- case lookup hContentType hs of- Just m- | gzipCheckMime set m -> compressFile s hs file cache sendResponse- _ -> sendResponse res- (ResponseFile {}, GzipIgnore) -> sendResponse res- _ -> compressE set res sendResponse- in runAction (res, gzipFiles set)- else sendResponse res+gzip set app req sendResponse'+ | skipCompress = app req sendResponse+ | otherwise = app req . checkCompress $ \res ->+ let runAction x = case x of+ (ResponseRaw{}, _) -> sendResponse res+ -- Always skip if 'GzipIgnore'+ (ResponseFile{}, GzipIgnore) -> sendResponse res+ -- If there's a compressed version of the file, we send that.+ (ResponseFile s hs file Nothing, GzipPreCompressed nextAction) ->+ let compressedVersion = file ++ ".gz"+ in doesFileExist compressedVersion >>= \y ->+ if y+ then sendResponse $ ResponseFile s (fixHeaders hs) compressedVersion Nothing+ else runAction (ResponseFile s hs file Nothing, nextAction)+ -- Skip if it's not a MIME type we want to compress+ _ | not $ isCorrectMime (responseHeaders res) -> sendResponse res+ -- Use static caching logic+ (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->+ compressFile s hs file Nothing cache sendResponse+ -- Use static caching logic with "ETag" signatures+ (ResponseFile s hs file Nothing, GzipCacheETag cache) ->+ let mETag = lookup hETag hs+ in compressFile s hs file mETag cache sendResponse+ -- Use streaming logic+ _ -> compressE res sendResponse+ in runAction (res, gzipFiles set) where- enc = fromMaybe [] $ (splitCommas . S8.unpack)- `fmap` lookup "Accept-Encoding" (requestHeaders env)- ua = fromMaybe "" $ lookup hUserAgent $ requestHeaders env- isMSIE6 = "MSIE 6" `S.isInfixOf` ua- isEncoded res = isJust $ lookup hContentEncoding $ responseHeaders res+ isCorrectMime =+ maybe False (gzipCheckMime set) . lookup hContentType+ sendResponse = sendResponse' . mapResponseHeaders mAddVary+ 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.+ mAddVary [] = [(hVary, acceptEncoding)]+ mAddVary (h@(nm, val) : hs)+ | nm == hVary =+ let vals = splitCommas val+ 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)+ in newH : hs+ | otherwise = h : mAddVary hs - bigEnough rsp = case contentLength (responseHeaders rsp) of- Nothing -> True -- This could be a streaming case- Just len -> len >= minimumLength+ -- Can we skip from just looking at the 'Request'?+ skipCompress =+ not acceptsGZipEncoding || isMSIE6+ where+ reqHdrs = requestHeaders req+ acceptsGZipEncoding =+ maybe False (any isGzip . parseQValueList) $ hAcceptEncoding `lookup` reqHdrs+ isGzip (bs, q) =+ -- We skip if 'q' = Nothing, because it is malformed,+ -- or if it is 0, because that is an explicit "DO NOT USE GZIP"+ bs == "gzip" && maybe False (/= 0) q+ isMSIE6 =+ maybe False ("MSIE 6" `S.isInfixOf`) $ hUserAgent `lookup` reqHdrs - -- For a small enough response, gzipping will actually increase the size- -- Potentially for anything less than 860 bytes gzipping could be a net loss- -- The actual number is application specific though and may need to be adjusted- -- http://webmasters.stackexchange.com/questions/31750/what-is-recommended-minimum-object-size-for-gzip-performance-benefits- minimumLength = 860+ -- Can we skip just by looking at the current 'Response'?+ checkCompress+ :: (Response -> IO ResponseReceived) -> Response -> IO ResponseReceived+ checkCompress continue res =+ if isEncodedAlready || isPartial || tooSmall+ then sendResponse res+ else continue res+ where+ resHdrs = responseHeaders res+ -- Partial content should NEVER be compressed.+ isPartial = statusCode (responseStatus res) == 206+ isEncodedAlready = isJust $ hContentEncoding `lookup` resHdrs+ tooSmall =+ maybe+ False -- This could be a streaming case+ (< gzipSizeThreshold set)+ $ contentLength resHdrs -compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a-compressFile s hs file cache sendResponse = do+-- For a small enough response, gzipping will actually increase the size+-- Potentially for anything less than 860 bytes gzipping could be a net loss+-- The actual number is application specific though and may need to be adjusted+-- http://webmasters.stackexchange.com/questions/31750/what-is-recommended-minimum-object-size-for-gzip-performance-benefits+minimumLength :: Integer+minimumLength = 860++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 then onSucc 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- either onErr (const onSucc) (x :: Either SomeException ()) -- FIXME bad! don't catch all exceptions like that!+ 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+ reportError err =+ IO.hPutStrLn IO.stderr $+ "Network.Wai.Middleware.Gzip: compression failed: " <> err+ onErr e+ -- Catching IOExceptions for file system / hardware oopsies+ | Just ioe <- fromException e = do+ reportError $ show (ioe :: IOException)+ sendResponse $ responseFile s hs file Nothing+ -- Catching ZlibExceptions for compression oopsies+ | Just zlibe <- fromException e = do+ reportError $ show (zlibe :: Z.ZlibException)+ sendResponse $ responseFile s hs file Nothing+ | otherwise = throwIO e - onErr _ = sendResponse $ responseFile s hs file Nothing -- FIXME log the error message+ -- If there's an ETag, use it as the suffix of the cached file.+ eTag = maybe "" (map safe . S8.unpack . trimWS) mETag+ tmpfile = cache ++ '/' : map safe file ++ eTag - tmpfile = cache ++ '/' : map safe file 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 :: GzipSettings- -> Response- -> (Response -> IO a)- -> IO a-compressE set res sendResponse =- case lookup hContentType hs of- Just m | gzipCheckMime set m ->- let hs' = fixHeaders hs- in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do- (blazeRecv, _) <- B.newBuilderRecv B.defaultStrategy- deflate <- Z.initDeflate 1 (Z.WindowBits 31)- let sendBuilder builder = do- popper <- blazeRecv builder- fix $ \loop -> do- bs <- popper- unless (S.null bs) $ do- sendBS bs- loop- sendBS bs = Z.feedDeflate deflate bs >>= deflatePopper- flushBuilder = do- sendBuilder Blaze.flush- deflatePopper $ Z.flushDeflate deflate- flush- deflatePopper popper = fix $ \loop -> do- result <- popper- case result of- Z.PRDone -> return ()- Z.PRNext bs' -> do- sendChunk $ byteString bs'- loop- Z.PRError e -> throwIO e-- body sendBuilder flushBuilder+compressE+ :: Response+ -> (Response -> IO ResponseReceived)+ -> IO ResponseReceived+compressE res sendResponse =+ wb $ \body -> sendResponse $+ responseStream s (fixHeaders hs) $ \sendChunk flush -> do+ (blazeRecv, _) <- B.newBuilderRecv B.defaultStrategy+ deflate <- Z.initDeflate 1 (Z.WindowBits 31)+ let sendBuilder builder = do+ popper <- blazeRecv builder+ fix $ \loop -> do+ bs <- popper+ unless (S.null bs) $ do+ sendBS bs+ loop+ sendBS bs = Z.feedDeflate deflate bs >>= deflatePopper+ flushBuilder = do sendBuilder Blaze.flush- deflatePopper $ Z.finishDeflate deflate- _ -> sendResponse res+ deflatePopper $ Z.flushDeflate deflate+ flush+ deflatePopper popper = fix $ \loop -> do+ result <- popper+ case result of+ Z.PRDone -> return ()+ Z.PRNext bs' -> do+ sendChunk $ byteString bs'+ loop+ Z.PRError e -> throwIO e++ body sendBuilder flushBuilder+ sendBuilder Blaze.flush+ deflatePopper $ Z.finishDeflate deflate where (s, hs, wb) = responseToStream res @@ -219,12 +428,6 @@ -- different length after gzip compression. fixHeaders :: [Header] -> [Header] fixHeaders =- ((hContentEncoding, "gzip") :) . filter notLength+ replaceHeader hContentEncoding "gzip" . filter notLength where notLength (x, _) = x /= hContentLength--splitCommas :: String -> [String]-splitCommas [] = []-splitCommas x =- let (y, z) = break (== ',') x- in y : splitCommas (dropWhile (== ' ') $ drop 1 z)
+ Network/Wai/Middleware/HealthCheckEndpoint.hs view
@@ -0,0 +1,38 @@+---------------------------------------------------------++---------------------------------------------------------++-- |+-- Module : Network.Wai.Middleware.HealthCheckEndpoint+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Add empty endpoint (for Health check tests)+module Network.Wai.Middleware.HealthCheckEndpoint (+ healthCheck,+ voidEndpoint,+)+where++import Data.ByteString (ByteString)+import Network.HTTP.Types (status200)+import Network.Wai++-- | Add empty endpoint (for Health check tests) called \"/_healthz\"+--+-- @since 3.1.9+healthCheck :: Middleware+healthCheck = voidEndpoint "/_healthz"++-- | Add empty endpoint+--+-- @since 3.1.9+voidEndpoint :: ByteString -> Middleware+voidEndpoint endpointPath router request respond =+ if rawPathInfo request == endpointPath+ then respond $ responseLBS status200 mempty "-"+ else router request respond
Network/Wai/Middleware/HttpAuth.hs view
@@ -1,55 +1,66 @@-{-# LANGUAGE RecordWildCards, TupleSections, CPP #-}+{-# 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 import Data.ByteString (ByteString)+import qualified Data.ByteString as S import Data.ByteString.Base64 (decodeLenient) import Data.String (IsString (..))-import Data.Word8 (isSpace, _colon, toLower)-import Network.HTTP.Types (status401, hContentType, hAuthorization)-import Network.Wai--import qualified Data.ByteString as S-+import Data.Word8 (isSpace, toLower, _colon)+import Network.HTTP.Types (hAuthorization, hContentType, status401)+import Network.Wai (+ Application,+ Middleware,+ Request (requestHeaders),+ responseLBS,+ ) -- | Check if a given username and password is valid.-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@@ -57,8 +68,8 @@ else authOnNoAuth authRealm req sendResponse where check =- case (lookup hAuthorization $ requestHeaders req)- >>= extractBasicAuth of+ case lookup hAuthorization (requestHeaders req)+ >>= extractBasicAuth of Nothing -> return False Just (username, password) -> checkCreds req username password @@ -89,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@@ -111,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@@ -127,6 +144,6 @@ extractBearerAuth :: ByteString -> Maybe ByteString extractBearerAuth bs = let (x, y) = S.break isSpace bs- in if S.map toLower x == "bearer"- then Just $ S.dropWhile isSpace y- else Nothing+ in if S.map toLower x == "bearer"+ then Just $ S.dropWhile isSpace y+ else Nothing
Network/Wai/Middleware/Jsonp.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE RankNTypes, CPP #-}+{-# LANGUAGE CPP #-}+ ---------------------------------------------------------++---------------------------------------------------------+ -- | -- Module : Network.Wai.Middleware.Jsonp -- Copyright : Michael Snoyman@@ -10,23 +14,21 @@ -- Portability : portable -- -- Automatic wrapping of JSON responses to convert into JSONP.------------------------------------------------------------- module Network.Wai.Middleware.Jsonp (jsonp) where -import Network.Wai-import Network.Wai.Internal+import Control.Monad (join) import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B8-import Data.ByteString.Builder.Extra (byteStringCopy)+import qualified Data.ByteString as S import Data.ByteString.Builder (char7)+import Data.ByteString.Builder.Extra (byteStringCopy)+import qualified Data.ByteString.Char8 as B8+import Data.Maybe (fromMaybe) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mappend) #endif-import Control.Monad (join)-import Data.Maybe (fromMaybe)-import qualified Data.ByteString as S import Network.HTTP.Types (hAccept, hContentType)+import Network.Wai+import Network.Wai.Internal -- | Wrap json responses in a jsonp callback. --@@ -46,10 +48,13 @@ let env' = case callback of Nothing -> env- Just _ -> env- { requestHeaders = changeVal hAccept- "application/json"- $ requestHeaders env+ Just _ ->+ env+ { requestHeaders =+ changeVal+ hAccept+ "application/json"+ $ requestHeaders env } app env' $ \res -> case callback of@@ -59,11 +64,12 @@ go c r@(ResponseBuilder s hs b) = sendResponse $ case checkJSON hs of Nothing -> r- Just hs' -> responseBuilder s hs' $- byteStringCopy c- `mappend` char7 '('- `mappend` b- `mappend` char7 ')'+ Just hs' ->+ responseBuilder s hs' $+ byteStringCopy c+ `mappend` char7 '('+ `mappend` b+ `mappend` char7 ')' go c r = case checkJSON hs of Just hs' -> addCallback c s hs' wb@@ -85,10 +91,12 @@ _ <- body sendChunk flush sendChunk $ char7 ')' -changeVal :: Eq a- => a- -> ByteString- -> [(a, ByteString)]- -> [(a, ByteString)]-changeVal key val old = (key, val)- : filter (\(k, _) -> k /= key) old+changeVal+ :: Eq a+ => a+ -> ByteString+ -> [(a, ByteString)]+ -> [(a, ByteString)]+changeVal key val old =+ (key, val)+ : filter (\(k, _) -> k /= key) old
Network/Wai/Middleware/Local.hs view
@@ -1,26 +1,25 @@ {-# LANGUAGE CPP #-}+ -- | Only allow local connections.----module Network.Wai.Middleware.Local- ( local- ) where+module Network.Wai.Middleware.Local (+ local,+) where -import Network.Wai (Middleware,remoteHost, Response)-import Network.Socket (SockAddr(..))+import Network.Socket (SockAddr (..))+import Network.Wai (Middleware, Response, remoteHost) --- | This middleware rejects non-local connections with a specific response. +-- | This middleware rejects non-local connections with a specific response. -- It is useful when supporting web-based local applications, which would -- typically want to reject external connections.- local :: Response -> Middleware local resp f r k = case remoteHost r of- SockAddrInet _ h | h == fromIntegral home- -> f r k+ SockAddrInet _ h+ | h == fromIntegral home ->+ f r k #if !defined(mingw32_HOST_OS) && !defined(_WIN32)- SockAddrUnix _ -> f r k+ SockAddrUnix _ -> f r k #endif- _ -> k $ resp- where- home :: Integer- home = 127 + (256 * 256 * 256) * 1-+ _ -> k resp+ where+ home :: Integer+ home = 127 + (256 * 256 * 256)
Network/Wai/Middleware/MethodOverride.hs view
@@ -1,9 +1,9 @@-module Network.Wai.Middleware.MethodOverride- ( methodOverride- ) where+module Network.Wai.Middleware.MethodOverride (+ methodOverride,+) where -import Network.Wai import Control.Monad (join)+import Network.Wai (Middleware, queryString, requestMethod) -- | Overriding of HTTP request method via `_method` query string parameter. --@@ -16,5 +16,5 @@ where req' = case (requestMethod req, join $ lookup "_method" $ queryString req) of- ("POST", Just m) -> req { requestMethod = m }+ ("POST", Just m) -> req{requestMethod = m} _ -> req
Network/Wai/Middleware/MethodOverridePost.hs view
@@ -1,21 +1,23 @@ {-# LANGUAGE CPP #-}+ -----------------------------------------------------------------++-----------------------------------------------------------------+ -- | Module : Network.Wai.Middleware.MethodOverridePost -- -- Changes the request-method via first post-parameter _method.-------------------------------------------------------------------module Network.Wai.Middleware.MethodOverridePost- ( methodOverridePost- ) where--import Network.Wai-import Network.HTTP.Types (parseQuery, hContentType)+module Network.Wai.Middleware.MethodOverridePost (+ methodOverridePost,+) where +import Data.ByteString.Lazy (toChunks)+import Data.IORef (atomicModifyIORef, newIORef) #if __GLASGOW_HASKELL__ < 710-import Data.Monoid (mconcat, mempty)+import Data.Monoid (mconcat, mempty) #endif-import Data.IORef-import Data.ByteString.Lazy (toChunks)+import Network.HTTP.Types (hContentType, parseQuery)+import Network.Wai -- | Allows overriding of the HTTP request method via the _method post string parameter. --@@ -27,18 +29,20 @@ -- parameter. -- -- * This middleware only applies when the initial request method is POST.--- methodOverridePost :: Middleware methodOverridePost app req send = case (requestMethod req, lookup hContentType (requestHeaders req)) of- ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send- _ -> app req send+ ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send+ _ -> app req send setPost :: Request -> IO Request setPost req = do- body <- (mconcat . toChunks) `fmap` lazyRequestBody req- ref <- newIORef body- let rb = atomicModifyIORef ref $ \bs -> (mempty, bs)- case parseQuery body of- (("_method", Just newmethod):_) -> return $ req {requestBody = rb, requestMethod = newmethod}- _ -> return $ req {requestBody = rb}+ body <- (mconcat . toChunks) `fmap` lazyRequestBody req+ ref <- newIORef body+ let rb = atomicModifyIORef ref $ \bs -> (mempty, bs)+ req' = setRequestBodyChunks rb req+ case parseQuery body of+ (("_method", Just newmethod) : _) -> return req'{requestMethod = newmethod}+ _ -> return req'++{- HLint ignore setPost "Use tuple-section" -}
+ Network/Wai/Middleware/RealIp.hs view
@@ -0,0 +1,95 @@+-- | Infer the remote IP address using headers+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+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Network.HTTP.Types (HeaderName, RequestHeaders)+import Network.Wai (Middleware, remoteHost, requestHeaders)+import Text.Read (readMaybe)++-- | Infer the remote IP address from the @X-Forwarded-For@ header,+-- trusting requests from any private IP address. See 'realIpHeader' and+-- 'realIpTrusted' for more information and options.+--+-- @since 3.1.5+realIp :: Middleware+realIp = realIpHeader "X-Forwarded-For"++-- | Infer the remote IP address using the given header, trusting+-- requests from any private IP address. See 'realIpTrusted' for more+-- information and options.+--+-- @since 3.1.5+realIpHeader :: HeaderName -> Middleware+realIpHeader header =+ realIpTrusted header $ \ip -> any (ipInRange ip) defaultTrusted++-- | Infer the remote IP address using the given header, but only if the+-- request came from an IP that is trusted by the provided predicate.+--+-- The last non-trusted address is used to replace the 'remoteHost' in+-- the 'Request', unless all present IP addresses are trusted, in which+-- case the first address is used. Invalid IP addresses are ignored, and+-- the remoteHost value remains unaltered if no valid IP addresses are+-- found.+--+-- Examples:+--+-- @ realIpTrusted "X-Forwarded-For" $ flip ipInRange "10.0.0.0/8" @+--+-- @ realIpTrusted "X-Real-Ip" $ \\ip -> any (ipInRange ip) defaultTrusted @+--+-- @since 3.1.5+realIpTrusted :: HeaderName -> (IP.IP -> Bool) -> Middleware+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)}++-- | 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"+ ]++-- | Check if the given IP address is in the given range.+--+-- IPv4 addresses can be checked against IPv6 ranges, but testing an+-- IPv6 address against an IPv4 range is always 'False'.+--+-- @since 3.1.5+ipInRange :: IP.IP -> IP.IPRange -> Bool+ipInRange (IP.IPv4 ip) (IP.IPv4Range r) = ip `IP.isMatchedTo` r+ipInRange (IP.IPv6 ip) (IP.IPv6Range r) = ip `IP.isMatchedTo` r+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+ where+ -- account for repeated headers+ headerVals = [v | (k, v) <- reqHeaders, k == header]+ ips = concatMap (mapMaybe (readMaybe . B8.unpack) . B8.split ',') headerVals+ nonTrusted = filter (not . isTrusted) ips
Network/Wai/Middleware/RequestLogger.hs view
@@ -1,73 +1,203 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}+ -- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should -- not use CPP.-module Network.Wai.Middleware.RequestLogger- ( -- * Basic stdout logging- logStdout- , logStdoutDev- -- * Create more versions- , mkRequestLogger- , RequestLoggerSettings- , outputFormat- , autoFlush- , destination- , OutputFormat (..)- , OutputFormatter- , OutputFormatterWithDetails- , OutputFormatterWithDetailsAndHeaders- , Destination (..)- , Callback- , IPAddrSource (..)- ) where+-- EDIT: Fixed this by adding two "zero-width spaces" in between the "*/*"+module Network.Wai.Middleware.RequestLogger (+ -- * Basic stdout logging+ logStdout,+ logStdoutDev, -import System.IO (Handle, hFlush, stdout)-import qualified Data.ByteString.Builder as B (Builder, byteString)-import qualified Data.ByteString as BS-import Data.ByteString.Char8 (pack)+ -- * Create more versions+ mkRequestLogger,+ -- ** Settings type+ RequestLoggerSettings,+ defaultRequestLoggerSettings,+ -- *** Settings fields+ outputFormat,+ autoFlush,+ destination,+ -- ** More settings+ OutputFormat (..),+ ApacheSettings,+ defaultApacheSettings,+ setApacheIPAddrSource,+ setApacheRequestFilter,+ setApacheUserGetter,+ DetailedSettings (..),+ defaultDetailedSettings,+ OutputFormatter,+ OutputFormatterWithDetails,+ OutputFormatterWithDetailsAndHeaders,+ Destination (..),+ Callback,+ IPAddrSource (..),+) where+ import Control.Monad (when) import Control.Monad.IO.Class (liftIO)-import Network.Wai- ( Request(..), requestBodyLength, RequestBodyLength(..)- , Middleware- , Response, responseStatus, responseHeaders- )-import System.Log.FastLogger-import Network.HTTP.Types as H-import Data.Maybe (fromMaybe)-import Data.Monoid (mconcat, (<>))-import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)-import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File- , getRequestBodyType)-import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as B (Builder, byteString)+import Data.ByteString.Char8 (pack) import qualified Data.ByteString.Char8 as S8-import System.Console.ANSI+import qualified Data.ByteString.Lazy as LBS+import Data.Default (Default (def)) import Data.IORef-import System.IO.Unsafe+import Data.Maybe (fromMaybe, isJust, mapMaybe)+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#endif+import Data.Text.Encoding (decodeUtf8')+import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)+import Network.HTTP.Types as H+import Network.Wai (+ Middleware,+ Request (..),+ RequestBodyLength (..),+ Response,+ getRequestBodyChunk,+ requestBodyLength,+ responseHeaders,+ responseStatus,+ setRequestBodyChunks,+ ) import Network.Wai.Internal (Response (..))-import Data.Default.Class (Default (def)) import Network.Wai.Logger-import Network.Wai.Middleware.RequestLogger.Internal+import System.Console.ANSI+import System.IO (Handle, hFlush, stdout)+import System.IO.Unsafe (unsafePerformIO)+import System.Log.FastLogger+ import Network.Wai.Header (contentLength)-import Data.Text.Encoding (decodeUtf8')+import Network.Wai.Middleware.RequestLogger.Internal+import Network.Wai.Parse (+ File,+ Param,+ fileName,+ getRequestBodyType,+ lbsBackEnd,+ sinkRequestBody,+ ) +-- | The logging format.+--+-- @since 1.3.0 data OutputFormat- = Apache IPAddrSource- | Detailed Bool -- ^ use colors?- | 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+-- compatibility. In order to create an 'ApacheSettings' value, use 'defaultApacheSettings'+-- and the various \'setApache\' functions to modify individual fields. For example:+--+-- > setApacheIPAddrSource FromHeader defaultApacheSettings+--+-- @since 3.1.8+data ApacheSettings = ApacheSettings+ { apacheIPAddrSource :: IPAddrSource+ , apacheUserGetter :: Request -> Maybe BS.ByteString+ , apacheRequestFilter :: Request -> Response -> Bool+ }++defaultApacheSettings :: ApacheSettings+defaultApacheSettings =+ ApacheSettings+ { apacheIPAddrSource = FromSocket+ , apacheRequestFilter = \_ _ -> True+ , apacheUserGetter = const Nothing+ }++-- | Where to take IP addresses for clients from. See 'IPAddrSource' for more information.+--+-- Default value: FromSocket+--+-- @since 3.1.8+setApacheIPAddrSource :: IPAddrSource -> ApacheSettings -> ApacheSettings+setApacheIPAddrSource x y = y{apacheIPAddrSource = x}++-- | Function that allows you to filter which requests are logged, based on+-- the request and response+--+-- Default: log all requests+--+-- @since 3.1.8+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.+--+-- Default: return no user+--+-- @since 3.1.8+setApacheUserGetter+ :: (Request -> Maybe BS.ByteString) -> ApacheSettings -> ApacheSettings+setApacheUserGetter x y = y{apacheUserGetter = x}++-- | Settings for the `Detailed` `OutputFormat`.+--+-- `mModifyParams` allows you to pass a function to hide confidential+-- information (such as passwords) from the logs. If result is `Nothing`, then+-- the parameter is hidden. For example:+-- > myformat = Detailed True (Just hidePasswords)+-- > where hidePasswords p@(k,v) = if k = "password" then (k, "***REDACTED***") else p+--+-- `mFilterRequests` allows you to filter which requests are logged, based on+-- the request and response.+--+-- @since 3.1.3+data DetailedSettings = DetailedSettings+ { useColors :: Bool+ , mModifyParams :: Maybe (Param -> Maybe Param)+ , mFilterRequests :: Maybe (Request -> Response -> Bool)+ , mPrelogRequests :: Bool+ -- ^ @since 3.1.7+ }++-- | DO NOT USE THIS INSTANCE!+-- Please use 'defaultDetailedSettings'+--+-- This instance will be removed in a future major version.+instance Default DetailedSettings where+ def = defaultDetailedSettings++-- | Default 'DetailedSettings'+--+-- Uses colors, but doesn't modify nor filter anything.+-- Also doesn't prelog requests.+--+-- @since 3.1.16+defaultDetailedSettings :: DetailedSettings+defaultDetailedSettings =+ 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 --@@ -76,47 +206,89 @@ -- 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+-- | Where to send the logs to.+--+-- @since 1.3.0+data Destination+ = Handle Handle+ | Logger LoggerSet+ | Callback Callback ++-- | When using a callback as a destination.+--+-- @since 1.3.0 type Callback = LogStr -> IO () --- | @RequestLoggerSettings@ is an instance of Default. See <https://hackage.haskell.org/package/data-default Data.Default> for more information.+-- | Settings for the request logger. --+-- Sets what which format,+-- -- @outputFormat@, @autoFlush@, and @destination@ are record fields -- for the record type @RequestLoggerSettings@, so they can be used to -- modify settings values using record syntax.+--+-- @since 1.3.0 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@.+ --+ -- @since 1.3.0 , autoFlush :: Bool- -- | Default: @Handle@ @stdout@.+ -- ^ Only applies when using the 'Handle' constructor for 'destination'.+ --+ -- Default value: @True@.+ --+ -- @since 1.3.0 , destination :: Destination+ -- ^ Default: @Handle stdout@.+ --+ -- @since 1.3.0 } -instance Default RequestLoggerSettings where- def = RequestLoggerSettings+-- | Default 'RequestLoggerSettings'.+--+-- Use this to create 'RequestLoggerSettings', and use the+-- accompanying fields to edit these settings.+--+-- @since 3.1.8+defaultRequestLoggerSettings :: RequestLoggerSettings+defaultRequestLoggerSettings =+ RequestLoggerSettings { outputFormat = Detailed True , autoFlush = True , destination = Handle stdout } +-- | DO NOT USE THIS INSTANCE!+-- Please use 'defaultRequestLoggerSettings' instead.+--+-- This instance will be removed in a future major release.+instance Default RequestLoggerSettings where+ def = defaultRequestLoggerSettings++-- | Create the 'Middleware' using the given 'RequestLoggerSettings'+--+-- @since 1.3.0 mkRequestLogger :: RequestLoggerSettings -> IO Middleware mkRequestLogger RequestLoggerSettings{..} = do let (callback, flusher) =@@ -129,8 +301,21 @@ Apache ipsrc -> do getdate <- getDateGetter flusher apache <- initLogger ipsrc (LogCallback callback flusher) getdate- return $ apacheMiddleware apache- Detailed useColors -> detailedMiddleware callbackAndFlush useColors+ return $ apacheMiddleware (\_ _ -> True) apache+ ApacheWithSettings ApacheSettings{..} -> do+ getdate <- getDateGetter flusher+ apache <-+ initLoggerUser+ (Just apacheUserGetter)+ apacheIPAddrSource+ (LogCallback callback flusher)+ getdate+ return $ apacheMiddleware apacheRequestFilter apache+ Detailed useColors ->+ let settings = defaultDetailedSettings{useColors = useColors}+ in detailedMiddleware callbackAndFlush settings+ DetailedWithSettings settings ->+ detailedMiddleware callbackAndFlush settings CustomOutputFormat formatter -> do getDate <- getDateGetter flusher return $ customMiddleware callbackAndFlush getDate formatter@@ -139,12 +324,15 @@ return $ customMiddlewareWithDetails callbackAndFlush getdate formatter CustomOutputFormatWithDetailsAndHeaders formatter -> do getdate <- getDateGetter flusher- return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter+ return $+ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter -apacheMiddleware :: ApacheLoggerActions -> Middleware-apacheMiddleware ala app req sendResponse = app req $ \res -> do- let msize = contentLength (responseHeaders res)- apacheLogger ala req (responseStatus res) msize+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) sendResponse res customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware@@ -154,54 +342,62 @@ 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 defaultRequestLoggerSettings{outputFormat = Apache FromSocket} -- | Development request logger middleware. -- -- This uses the 'Detailed' 'True' logging format and logs to 'stdout'. {-# NOINLINE logStdoutDev #-} logStdoutDev :: Middleware-logStdoutDev = unsafePerformIO $ mkRequestLogger def+logStdoutDev = unsafePerformIO $ mkRequestLogger defaultRequestLoggerSettings -- | Prints a message using the given callback function for each request. -- This is not for serious production use- it is inefficient.@@ -217,22 +413,22 @@ -- Example ouput: -- -- > GET search--- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8+-- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8 -- > Status: 200 OK 0.010555s -- > -- > GET static/css/normalize.css -- > Params: [("LXwioiBG","")]--- > Accept: text/css,*/*;q=0.1+-- > Accept: text/css,*/*;q=0.1 -- > Status: 304 Not Modified 0.010555s--detailedMiddleware :: Callback -> Bool -> IO Middleware-detailedMiddleware cb useColors =+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- then (ansiColor', ansiMethod', ansiStatusCode')- else (\_ t -> [t], (:[]), \_ t -> [t])-- in return $ detailedMiddleware' cb 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 =@@ -244,102 +440,122 @@ -- | 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 <- requestBody req- if S8.null bs- then return $ front []- else loop $ front . (bs:)- body <- loop id- -- logging the body here consumes it, so fill it back up- -- obviously not efficient, but this is the development logger- --- -- Note: previously, we simply used CL.sourceList. However,- -- that meant that you could read the request body in twice.- -- While that in itself is not a problem, the issue is that,- -- in production, you wouldn't be able to do this, and- -- therefore some bugs wouldn't show up during testing. This- -- implementation ensures that each chunk is only returned- -- once.- ichunks <- newIORef body- let rbody = atomicModifyIORef ichunks $ \chunks ->- case chunks of- [] -> ([], S8.empty)- x:y -> (y, x)- let req' = req { requestBody = rbody }- return (req', body)+ 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- -> (Color -> BS.ByteString -> [BS.ByteString])- -> (BS.ByteString -> [BS.ByteString])- -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])- -> Middleware-detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do+{- 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+ (_, Just len) | len <= 2048 -> getRequestBody req _ -> return (req, []) - let reqbodylog _ = if null body then [""] else ansiColor White " Request Body: " <> body <> ["\n"]+ 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 postParams <- liftIO $ allPostParams body- return $ collectPostParams postParams+ 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"]+ 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++ -- Optionally prelog the request+ when mPrelogRequests $+ cb $+ "PRELOGGING REQUEST: " <> mkRequestLog params reqbody accept+ app req' $ \rsp -> do- let isRaw =- case rsp of- ResponseRaw{} -> True- _ -> False- stCode = statusBS rsp- stMsg = msgBS rsp- t1 <- getCurrentTime+ 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 $ mconcat $ map toLogStr $- ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++- params ++ reqbody ++- ansiColor White " Accept: " ++ [accept, "\n"] ++- if isRaw then [] else- ansiColor White " Status: " ++- ansiStatusCode stCode (stCode <> " " <> stMsg) ++- [" ", pack $ show $ diffUTCTime t1 t0, "\n"]+ -- log the status of the response+ cb $+ mkRequestLog params reqbody accept+ <> mkResponseLog isRaw stCode stMsg t1 t0 sendResponse rsp where@@ -351,18 +567,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" + 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"++{- HLint ignore detailedMiddleware' "Use lambda-case" -} statusBS :: Response -> BS.ByteString statusBS = pack . show . statusCode . responseStatus
Network/Wai/Middleware/RequestLogger/Internal.hs view
@@ -1,24 +1,28 @@ {-# LANGUAGE CPP #-}+ -- | A module for containing some CPPed code, due to: -- -- https://github.com/yesodweb/wai/issues/192-module Network.Wai.Middleware.RequestLogger.Internal- ( module Network.Wai.Middleware.RequestLogger.Internal- ) where+module Network.Wai.Middleware.RequestLogger.Internal (+ getDateGetter,+ logToByteString,+) where -import Data.ByteString (ByteString)-import Network.Wai.Logger (clockDateCacher) #if !MIN_VERSION_wai_logger(2, 2, 0) import Control.Concurrent (forkIO, threadDelay) import Control.Monad (forever) #endif+import Data.ByteString (ByteString)+import Network.Wai.Logger (clockDateCacher) import System.Log.FastLogger (LogStr, fromLogStr) logToByteString :: LogStr -> ByteString logToByteString = fromLogStr -getDateGetter :: IO () -- ^ flusher- -> IO (IO ByteString)+getDateGetter+ :: IO ()+ -- ^ flusher+ -> IO (IO ByteString) #if !MIN_VERSION_wai_logger(2, 2, 0) getDateGetter flusher = do (getter, updater) <- clockDateCacher
Network/Wai/Middleware/RequestLogger/JSON.hs view
@@ -1,47 +1,54 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} -module Network.Wai.Middleware.RequestLogger.JSON- ( formatAsJSON- , formatAsJSONWithHeaders- ) where+module Network.Wai.Middleware.RequestLogger.JSON (+ formatAsJSON,+ formatAsJSONWithHeaders,+ requestToJSON,+) where +import Data.Aeson import qualified Data.ByteString.Builder as BB (toLazyByteString)+import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Lazy (toStrict)-import Data.Aeson import Data.CaseInsensitive (original)+import Data.IP (fromHostAddress, fromIPv4)+import Data.Maybe (maybeToList)+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>))-import qualified Data.ByteString.Char8 as S8-import Data.IP-import qualified Data.Text as T+#endif import Data.Text (Text)+import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Time (NominalDiffTime) import Data.Word (Word32) import Network.HTTP.Types as H-import Network.Socket (SockAddr (..), PortNumber)+import Network.Socket (PortNumber, SockAddr (..)) import Network.Wai-import Network.Wai.Middleware.RequestLogger import System.Log.FastLogger (toLogStr) import Text.Printf (printf) +import Network.Wai.Middleware.RequestLogger+ formatAsJSON :: OutputFormatterWithDetails formatAsJSON date req status responseSize duration reqBody response =- toLogStr (encode $- object- [ "request" .= requestToJSON duration req reqBody- , "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 --@@ -52,20 +59,24 @@ -- @since 3.0.27 formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders formatAsJSONWithHeaders date req status resSize duration reqBody res resHeaders =- toLogStr (encode $- object- [ "request" .= requestToJSON duration req reqBody- , "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@@ -73,58 +84,105 @@ readAsDouble :: String -> Double readAsDouble = read -requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value-requestToJSON duration req reqBody =- object- [ "method" .= decodeUtf8With lenientDecode (requestMethod req)- , "path" .= decodeUtf8With lenientDecode (rawPathInfo req)- , "queryString" .= map queryItemToJSON (queryString req)- , "durationMs" .= (readAsDouble . printf "%.2f" . rationalToDouble $ toRational duration * 1000)- , "size" .= requestBodyLengthToJSON (requestBodyLength req)- , "body" .= decodeUtf8With lenientDecode (S8.concat reqBody)- , "remoteHost" .= sockToJSON (remoteHost req)- , "httpVersion" .= httpVersionToJSON (httpVersion req)- , "headers" .= requestHeadersToJSON (requestHeaders req)- ]+-- | Get the JSON representation for a request+--+-- This representation is identical to that used in 'formatAsJSON' for the+-- request. It includes:+--+-- [@method@]:+-- [@path@]:+-- [@queryString@]:+-- [@size@]: The size of the body, as defined in the request. This may differ+-- from the size of the data passed in the second argument.+-- [@body@]: The body, concatenated directly from the chunks passed in+-- [@remoteHost@]:+-- [@httpVersion@]:+-- [@headers@]:+--+-- If a @'Just' duration@ is passed in, then additionally the JSON includes:+--+-- [@durationMs@] The duration, formatted in milliseconds, to 2 decimal+-- places+--+-- This representation is not an API, and may change at any time (within reason)+-- 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 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+ ) where rationalToDouble :: Rational -> Double rationalToDouble = fromRational sockToJSON :: SockAddr -> Value sockToJSON (SockAddrInet pn ha) =- object- [ "port" .= portToJSON pn- , "hostAddress" .= word32ToHostAddress ha- ]+ object+ [ "port" .= portToJSON pn+ , "hostAddress" .= word32ToHostAddress ha+ ] sockToJSON (SockAddrInet6 pn _ ha _) =- object- [ "port" .= portToJSON pn- , "hostAddress" .= ha- ]+ object+ [ "port" .= portToJSON pn+ , "hostAddress" .= ha+ ] sockToJSON (SockAddrUnix sock) =- object [ "unix" .= sock ]+ object ["unix" .= sock] #if !MIN_VERSION_network(3,0,0) sockToJSON (SockAddrCan i) = object [ "can" .= i ] #endif queryItemToJSON :: QueryItem -> Value-queryItemToJSON (name, mValue) = toJSON (decodeUtf8With lenientDecode name, fmap (decodeUtf8With lenientDecode) mValue)+queryItemToJSON (name, mValue) =+ toJSON+ (decodeUtf8With lenientDecode name, fmap (decodeUtf8With lenientDecode) mValue) requestHeadersToJSON :: RequestHeaders -> Value-requestHeadersToJSON = toJSON . map hToJ where- -- Redact cookies- hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text)- hToJ hd = headerToJSON hd+requestHeadersToJSON = toJSON . map hToJ+ where+ -- Redact cookies+ hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text)+ hToJ hd = headerToJSON hd responseHeadersToJSON :: [Header] -> Value-responseHeadersToJSON = toJSON . map hToJ where- -- Redact cookies- hToJ ("Set-Cookie", _) = toJSON ("Set-Cookie" :: Text, "-RDCT-" :: Text)- hToJ hd = headerToJSON hd+responseHeadersToJSON = toJSON . map hToJ+ where+ -- Redact cookies+ hToJ ("Set-Cookie", _) = toJSON ("Set-Cookie" :: Text, "-RDCT-" :: Text)+ hToJ hd = headerToJSON hd headerToJSON :: Header -> Value-headerToJSON (headerName, header) = toJSON (decodeUtf8With lenientDecode . original $ headerName, decodeUtf8With lenientDecode header)+headerToJSON (headerName, header) =+ toJSON+ ( decodeUtf8With lenientDecode . original $ headerName+ , decodeUtf8With lenientDecode header+ ) portToJSON :: PortNumber -> Value portToJSON = toJSON . toInteger
+ Network/Wai/Middleware/RequestSizeLimit.hs view
@@ -0,0 +1,86 @@+{-# 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 (+ -- * Middleware+ requestSizeLimitMiddleware,++ -- * Constructing 'RequestSizeLimitSettings'+ defaultRequestSizeLimitSettings,++ -- * 'RequestSizeLimitSettings' and accessors+ RequestSizeLimitSettings,+ setMaxLengthForRequest,+ setOnLengthExceeded,+) where++import Control.Exception (catch, try)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as LS8+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#endif+import Data.Word (Word64)+import Network.HTTP.Types.Status (requestEntityTooLarge413)+import Network.Wai++import Network.Wai.Middleware.RequestSizeLimit.Internal (+ RequestSizeLimitSettings (..),+ setMaxLengthForRequest,+ setOnLengthExceeded,+ )+import Network.Wai.Request++-- | Create a 'RequestSizeLimitSettings' with these settings:+--+-- * 2MB size limit for all requests+-- * When the limit is exceeded, return a plain text response describing the error, with a 413 status code.+--+-- @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))+ }++-- | Middleware to limit request bodies to a certain size.+--+-- This uses 'requestSizeCheck' under the hood; see that function for details.+--+-- @since 3.1.1+requestSizeLimitMiddleware :: RequestSizeLimitSettings -> Middleware+requestSizeLimitMiddleware settings app req sendResponse = do+ maybeMaxLen <- maxLengthForRequest settings req++ case maybeMaxLen of+ Nothing -> app req sendResponse+ Just maxLen -> do+ eitherSizeExceptionOrNewReq <- try (requestSizeCheck maxLen req)+ case eitherSizeExceptionOrNewReq of+ -- 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++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`."+ ]+ )
+ Network/Wai/Middleware/RequestSizeLimit/Internal.hs view
@@ -0,0 +1,63 @@+-- | 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++import Data.Word (Word64)+import Network.Wai (Middleware, Request)++-- | Settings to configure 'requestSizeLimitMiddleware'.+--+-- This type (but not the constructor, or record fields) is exported from "Network.Wai.Middleware.RequestSizeLimit".+-- Since the constructor isn't exported, create a default value with 'defaultRequestSizeLimitSettings' first,+-- then set the values using 'setMaxLengthForRequest' and 'setOnLengthExceeded' (See the examples below).+--+-- If you need to access the constructor directly, it's exported from "Network.Wai.Middleware.RequestSizeLimit.Internal".+--+-- ==== __Examples__+--+-- ===== Conditionally setting the limit based on the request+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Network.Wai+-- > import Network.Wai.Middleware.RequestSizeLimit+-- >+-- > let megabyte = 1024 * 1024+-- > let sizeForReq req = if pathInfo req == ["upload", "image"] then pure $ Just $ megabyte * 20 else pure $ Just $ megabyte * 2+-- > let finalSettings = setMaxLengthForRequest sizeForReq defaultRequestSizeLimitSettings+--+-- ===== JSON response+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Network.Wai+-- > import Network.Wai.Middleware.RequestSizeLimit+-- > import Network.HTTP.Types.Status (requestEntityTooLarge413)+-- > import Data.Aeson+-- > import Data.Text (Text)+-- >+-- > let jsonResponse = \_maxLen _app _req sendResponse -> sendResponse $ responseLBS requestEntityTooLarge413 [("Content-Type", "application/json")] (encode $ object ["error" .= ("request size too large" :: Text)])+-- > let finalSettings = setOnLengthExceeded jsonResponse defaultRequestSizeLimitSettings+--+-- @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+ }++-- | 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}++-- | 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}
Network/Wai/Middleware/Rewrite.hs view
@@ -1,56 +1,50 @@-{-# 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-- -- ** An example rewriting paths with queries+{-# LANGUAGE TupleSections #-} - -- $takeover+module Network.Wai.Middleware.Rewrite (+ -- * How to use this module+ -- $howto - -- ** Upgrading from wai-extra ≤ 3.0.16.1+ -- ** A note on semantics+ -- $semantics - -- $upgrading+ -- ** Paths and Queries+ -- $pathsandqueries+ PathsAndQueries, - -- * 'Middleware'+ -- ** An example rewriting paths with queries+ -- $takeover - -- ** Recommended functions- , rewriteWithQueries- , rewritePureWithQueries- , rewriteRoot+ -- ** Upgrading from wai-extra ≤ 3.0.16.1+ -- $upgrading - -- ** Deprecated- , rewrite- , rewritePure+ -- * 'Middleware' - -- * Operating on 'Request's+ -- ** Recommended functions+ rewriteWithQueries,+ rewritePureWithQueries,+ rewriteRoot, - , rewriteRequest- , rewriteRequestPure- ) where+ -- ** Deprecated+ rewrite,+ rewritePure, -import Network.Wai-import Control.Monad.IO.Class (liftIO)-import Data.Text (Text)-import Data.Functor.Identity (Identity(..))-import qualified Data.Text.Encoding as TE-import qualified Data.Text as T-import Network.HTTP.Types as H+ -- * Operating on 'Request's+ rewriteRequest,+ rewriteRequestPure,+) where -- GHC ≤ 7.10 does not export Applicative functions from the prelude. #if __GLASGOW_HASKELL__ <= 710 import Control.Applicative #endif+import Control.Monad.IO.Class (liftIO)+import Data.Functor.Identity (Identity (..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types as H+import Network.Wai -- $howto -- This module provides 'Middleware' to rewrite URL paths. It also provides@@ -202,7 +196,9 @@ -- upgrading as the upgraded functions no longer modify 'rawPathInfo'. --------------------------------------------------+ -- * Types+ -------------------------------------------------- -- | A tuple of the path sections as ['Text'] and query parameters as@@ -216,7 +212,9 @@ type PathsAndQueries = ([Text], H.Query) --------------------------------------------------+ -- * Rewriting 'Middleware'+ -------------------------------------------------- -- | Rewrite based on your own conversion function for paths only, to be@@ -225,14 +223,17 @@ -- For new code, use 'rewriteWithQueries' instead. rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware rewrite convert app req sendResponse = do- let convertIO = pathsOnly . curry $ liftIO . uncurry convert- newReq <- rewriteRequestRawM convertIO req- app newReq sendResponse-{-# WARNING rewrite [- "This modifies the 'rawPathInfo' field of a 'Request'."- , " This is not recommended behaviour; it is however how"- , " this function has worked in the past."- , " Use 'rewriteWithQueries' instead"] #-}+ let convertIO = pathsOnly . curry $ liftIO . uncurry convert+ newReq <- rewriteRequestRawM convertIO req+ app newReq sendResponse+{-# WARNING+ rewrite+ [ "This modifies the 'rawPathInfo' field of a 'Request'."+ , " This is not recommended behaviour; it is however how"+ , " this function has worked in the past."+ , " Use 'rewriteWithQueries' instead"+ ]+ #-} -- | Rewrite based on pure conversion function for paths only, to be -- supplied by users of this library.@@ -240,28 +241,33 @@ -- For new code, use 'rewritePureWithQueries' instead. rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware rewritePure convert app req =- let convertPure = pathsOnly . curry $ Identity . uncurry convert- newReq = runIdentity $ rewriteRequestRawM convertPure req- in app newReq-{-# WARNING rewritePure [- "This modifies the 'rawPathInfo' field of a 'Request'."- , " This is not recommended behaviour; it is however how"- , " this function has worked in the past."- , " Use 'rewritePureWithQueries' instead"] #-}+ let convertPure = pathsOnly . curry $ Identity . uncurry convert+ newReq = runIdentity $ rewriteRequestRawM convertPure req+ in app newReq+{-# WARNING+ rewritePure+ [ "This modifies the 'rawPathInfo' field of a 'Request'."+ , " This is not recommended behaviour; it is however how"+ , " this function has worked in the past."+ , " Use 'rewritePureWithQueries' instead"+ ]+ #-} -- | Rewrite based on your own conversion function for paths and queries. -- This function is to be supplied by users of this library, and operates -- in 'IO'.-rewriteWithQueries :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)- -> Middleware+rewriteWithQueries+ :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)+ -> Middleware rewriteWithQueries convert app req sendResponse = do- newReq <- rewriteRequestM convert req- app newReq sendResponse+ newReq <- rewriteRequestM convert req+ app newReq sendResponse -- | Rewrite based on pure conversion function for paths and queries. This -- function is to be supplied by users of this library.-rewritePureWithQueries :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)- -> Middleware+rewritePureWithQueries+ :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)+ -> Middleware rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req -- | Rewrite root requests (/) to a specified path@@ -280,60 +286,79 @@ onlyRoot paths _ = paths --------------------------------------------------+ -- * Modifying 'Request's directly+ -------------------------------------------------- -- | Modify a 'Request' using the supplied function in 'IO'. This is suitable for -- the reverse proxy example.-rewriteRequest :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)- -> Request -> IO Request+rewriteRequest+ :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)+ -> Request+ -> IO Request rewriteRequest convert req =- let convertIO = curry $ liftIO . uncurry convert- in rewriteRequestRawM convertIO req+ let convertIO = curry $ liftIO . uncurry convert+ in rewriteRequestRawM convertIO req -- | Modify a 'Request' using the pure supplied function. This is suitable for -- the reverse proxy example.-rewriteRequestPure :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)- -> Request -> Request+rewriteRequestPure+ :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)+ -> Request+ -> Request rewriteRequestPure convert req =- let convertPure = curry $ Identity . uncurry convert- in runIdentity $ rewriteRequestRawM convertPure req+ let convertPure = curry $ Identity . uncurry convert+ in runIdentity $ rewriteRequestRawM convertPure req --------------------------------------------------+ -- * Helper functions+ -------------------------------------------------- -- | This helper function factors out the common behaviour of rewriting requests.-rewriteRequestM :: (Applicative m, Monad m)- => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)- -> Request -> m Request+rewriteRequestM+ :: (Applicative m, Monad m)+ => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)+ -> Request+ -> m Request rewriteRequestM convert req = do- (pInfo, qByteStrings) <- curry convert (pathInfo req) (queryString req) (requestHeaders req)- pure req {pathInfo = pInfo, queryString = qByteStrings}+ (pInfo, qByteStrings) <-+ curry convert (pathInfo req) (queryString req) (requestHeaders req)+ pure req{pathInfo = pInfo, queryString = qByteStrings} -- | This helper function preserves the semantics of wai-extra ≤ 3.0, in -- which the rewrite functions modify the 'rawPathInfo' parameter. Note -- that this has not been extended to modify the 'rawQueryInfo' as -- modifying either of these values has been deprecated.-rewriteRequestRawM :: (Applicative m, Monad m)- => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)- -> Request -> m Request+rewriteRequestRawM+ :: (Applicative m, Monad m)+ => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)+ -> Request+ -> m Request rewriteRequestRawM convert req = do- newReq <- rewriteRequestM convert req- let rawPInfo = TE.encodeUtf8 . T.intercalate "/" . pathInfo $ newReq- pure newReq { rawPathInfo = rawPInfo }-{-# WARNING rewriteRequestRawM [- "This modifies the 'rawPathInfo' field of a 'Request'."- , " This is not recommended behaviour; it is however how"- , " this function has worked in the past."- , " Use 'rewriteRequestM' instead"] #-}+ newReq <- rewriteRequestM convert req+ let rawPInfo = TE.encodeUtf8 . T.intercalate "/" . pathInfo $ newReq+ pure newReq{rawPathInfo = rawPInfo}+{-# WARNING+ rewriteRequestRawM+ [ "This modifies the 'rawPathInfo' field of a 'Request'."+ , " This is not recommended behaviour; it is however how"+ , " this function has worked in the past."+ , " Use 'rewriteRequestM' instead"+ ]+ #-} -- | Produce a function that works on 'PathsAndQueries' from one working -- only on paths. This is not exported, as it is only needed to handle -- code written for versions ≤ 3.0 of the library; see the -- example above using 'Data.Bifunctor.first' to do something similar.-pathsOnly :: (Applicative m, Monad m)- => ([Text] -> H.RequestHeaders -> m [Text])- -> PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries+pathsOnly+ :: (Applicative m, Monad m)+ => ([Text] -> H.RequestHeaders -> m [Text])+ -> PathsAndQueries+ -> H.RequestHeaders+ -> m PathsAndQueries pathsOnly convert psAndQs headers = (,[]) <$> convert (fst psAndQs) headers {-# INLINE pathsOnly #-}
Network/Wai/Middleware/Routed.hs view
@@ -1,14 +1,14 @@ -- | -- -- Since 3.0.9-module Network.Wai.Middleware.Routed- ( routedMiddleware- , hostedMiddleware- ) where+module Network.Wai.Middleware.Routed (+ routedMiddleware,+ hostedMiddleware,+) where -import Network.Wai import Data.ByteString (ByteString) import Data.Text (Text)+import Network.Wai -- | Apply a middleware based on a test of pathInfo --@@ -17,23 +17,30 @@ -- > let corsify = routedMiddleWare ("static" `elem`) addCorsHeaders -- -- Since 3.0.9-routedMiddleware :: ([Text] -> Bool) -- ^ Only use middleware if this pathInfo test returns True- -> Middleware -- ^ middleware to apply the path prefix guard to- -> Middleware -- ^ modified middleware+routedMiddleware+ :: ([Text] -> Bool)+ -- ^ Only use middleware if this pathInfo test returns True+ -> Middleware+ -- ^ middleware to apply the path prefix guard to+ -> Middleware+ -- ^ modified middleware routedMiddleware pathCheck middle app req- | pathCheck (pathInfo req) = middle app req- | otherwise = app req+ | pathCheck (pathInfo req) = middle app req+ | otherwise = app req -- | Only apply the middleware to certain hosts -- -- Since 3.0.9-hostedMiddleware :: ByteString -- ^ Domain the middleware applies to- -> Middleware -- ^ middleware to apply the path prefix guard to- -> Middleware -- ^ modified middleware+hostedMiddleware+ :: ByteString+ -- ^ Domain the middleware applies to+ -> Middleware+ -- ^ middleware to apply the path prefix guard to+ -> Middleware+ -- ^ modified middleware hostedMiddleware domain middle app req- | hasDomain domain req = middle app req- | otherwise = app req+ | hasDomain domain req = middle app req+ | otherwise = app req hasDomain :: ByteString -> Request -> Bool-hasDomain domain req = maybe False (== domain) mHost- where mHost = requestHeaderHost req+hasDomain domain req = Just domain == requestHeaderHost req
+ Network/Wai/Middleware/Select.hs view
@@ -0,0 +1,97 @@+---------------------------------------------------------++---------------------------------------------------------++-- |+-- Module : Network.Wai.Middleware.Select+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Dynamically choose between Middlewares+--+-- It's useful when you want some 'Middleware's applied selectively.+--+-- Example: do not log health check calls:+--+-- > import Network.Wai+-- > import Network.Wai.Middleware.HealthCheckEndpoint+-- > import Network.Wai.Middleware.RequestLogger+-- >+-- > app' :: Application+-- > app' =+-- > selectMiddleware (selectMiddlewareExceptRawPathInfo "/_healthz" logStdout)+-- > $ healthCheck app+--+-- @since 3.1.10+module Network.Wai.Middleware.Select (+ -- * Middleware selection+ MiddlewareSelection (..),+ selectMiddleware,++ -- * Helpers+ selectMiddlewareOn,+ selectMiddlewareOnRawPathInfo,+ selectMiddlewareExceptRawPathInfo,+ passthroughMiddleware,+)+where++import Control.Applicative ((<|>))+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import Network.Wai++--------------------------------------------------++-- * Middleware selection++--------------------------------------------------++-- | Relevant Middleware for a given 'Request'.+newtype MiddlewareSelection = MiddlewareSelection+ { applySelectedMiddleware :: Request -> Maybe Middleware+ }++instance Semigroup MiddlewareSelection where+ MiddlewareSelection f <> MiddlewareSelection g =+ MiddlewareSelection $ \req -> f req <|> g req++instance Monoid MiddlewareSelection where+ mempty = MiddlewareSelection $ const Nothing++-- | Create the 'Middleware' dynamically applying 'MiddlewareSelection'.+selectMiddleware :: MiddlewareSelection -> Middleware+selectMiddleware selection app request respond =+ mw app request respond+ where+ mw :: Middleware+ mw = fromMaybe passthroughMiddleware (applySelectedMiddleware selection request)++--------------------------------------------------++-- * Helpers++--------------------------------------------------++passthroughMiddleware :: Middleware+passthroughMiddleware = id++-- | 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++-- | 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 path = selectMiddlewareOn ((/= path) . rawPathInfo)
Network/Wai/Middleware/StreamFile.hs view
@@ -1,43 +1,36 @@ -- | -- -- Since 3.0.4-module Network.Wai.Middleware.StreamFile- (streamFile) where+module Network.Wai.Middleware.StreamFile (streamFile) where -import Network.Wai (responseStream)-import Network.Wai.Internal-import Network.Wai (Middleware, responseToStream) import qualified Data.ByteString.Char8 as S8-import System.PosixCompat (getFileStatus, fileSize, FileOffset) import Network.HTTP.Types (hContentLength)+import Network.Wai (Middleware, responseStream, responseToStream)+import Network.Wai.Internal+import System.Directory (getFileSize) --- |Convert ResponseFile type responses into ResponseStream type+-- | 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--getFileSize :: FilePath -> IO FileOffset-getFileSize path = do- stat <- getFileStatus path- return (fileSize stat)+ len <- getFileSize fp+ let hs' = (hContentLength, S8.pack (show len)) : hs+ sendResponse $ responseStream s hs' body+ _ -> sendResponse res
Network/Wai/Middleware/StripHeaders.hs view
@@ -7,26 +7,31 @@ -- When using this, care should be taken not to strip out headers that are -- required for correct operation of the client (eg Content-Type). -module Network.Wai.Middleware.StripHeaders- ( stripHeader- , stripHeaders- , stripHeaderIf- , stripHeadersIf- ) where--import Network.Wai (Middleware, Request, modifyResponse, mapResponseHeaders, ifRequest)-import Network.Wai.Internal (Response)-import Data.ByteString (ByteString)+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,+ ifRequest,+ mapResponseHeaders,+ modifyResponse,+ )+import Network.Wai.Internal (Response) stripHeader :: ByteString -> (Response -> Response)-stripHeader h = mapResponseHeaders (filter (\ hdr -> fst hdr /= CI.mk h))+stripHeader h = mapResponseHeaders (filter (\hdr -> fst hdr /= CI.mk h)) stripHeaders :: [ByteString] -> (Response -> Response) stripHeaders hs =- let hnames = map CI.mk hs- in mapResponseHeaders (filter (\ hdr -> fst hdr `notElem` hnames))+ let hnames = map CI.mk hs+ in mapResponseHeaders (filter (\hdr -> fst hdr `notElem` hnames)) -- | If the request satisifes the provided predicate, strip headers matching -- the provided header name.@@ -34,12 +39,12 @@ -- Since 3.0.8 stripHeaderIf :: ByteString -> (Request -> Bool) -> Middleware stripHeaderIf h rpred =- ifRequest rpred (modifyResponse $ stripHeader h)+ ifRequest rpred (modifyResponse $ stripHeader h) -- | If the request satisifes the provided predicate, strip all headers whose -- header name is in the list of provided header names. -- -- Since 3.0.8 stripHeadersIf :: [ByteString] -> (Request -> Bool) -> Middleware-stripHeadersIf hs rpred- = ifRequest rpred (modifyResponse $ stripHeaders hs)+stripHeadersIf hs rpred =+ ifRequest rpred (modifyResponse $ stripHeaders hs)
Network/Wai/Middleware/Timeout.hs view
@@ -1,9 +1,9 @@ -- | Timeout requests-module Network.Wai.Middleware.Timeout- ( timeout- , timeoutStatus- , timeoutAs- ) where+module Network.Wai.Middleware.Timeout (+ timeout,+ timeoutStatus,+ timeoutAs,+) where import Network.HTTP.Types (Status, status503) import Network.Wai
+ Network/Wai/Middleware/ValidateHeaders.hs view
@@ -0,0 +1,138 @@+-- | This module provides a middleware to validate response headers.+-- [RFC 9110](https://www.rfc-editor.org/rfc/rfc9110.html#section-5) constrains the allowed octets in header names and values:+--+-- * Header names are [tokens](https://www.rfc-editor.org/rfc/rfc9110#section-5.6.2), i.e. visible ASCII characters (octets 33 to 126 inclusive) except delimiters.+-- * Header values should be limited to visible ASCII characters, the whitespace characters space and horizontal tab and octets 128 to 255. Headers values may not have trailing whitespace (see [RFC 9110 Section 5.5](https://www.rfc-editor.org/rfc/rfc9110.html#section-5.5)). Folding is not allowed.+--+-- 'validateHeadersMiddleware' enforces these constraints for response headers by responding with a 500 Internal Server Error when an offending character is present. This is meant to catch programmer errors early on and reduce attack surface.+module Network.Wai.Middleware.ValidateHeaders+ ( -- * Middleware+ validateHeadersMiddleware+ -- * Settings+ , ValidateHeadersSettings (..)+ , defaultValidateHeadersSettings+ -- * Types+ , InvalidHeader (..)+ , InvalidHeaderReason (..)+ ) where++import Data.CaseInsensitive (original)+import Data.Char (chr)+import Data.Word (Word8)+import Network.HTTP.Types (Header, ResponseHeaders, internalServerError500)+import Network.Wai (Middleware, Response, responseHeaders, responseLBS)+import Text.Printf (printf)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL++-- | Middleware to validate response headers.+--+-- @since 3.1.15+validateHeadersMiddleware :: ValidateHeadersSettings -> Middleware+validateHeadersMiddleware settings app req respond =+ app req respond'+ where+ respond' response = case getInvalidHeader $ responseHeaders response of+ Just invalidHeader -> onInvalidHeader settings invalidHeader app req respond+ Nothing -> respond response++-- | Configuration for 'validateHeadersMiddleware'.+--+-- @since 3.1.15+data ValidateHeadersSettings = ValidateHeadersSettings+ { -- | Called when an invalid header is present.+ onInvalidHeader :: InvalidHeader -> Middleware+ }++-- | Default configuration for 'validateHeadersMiddleware'.+-- Checks that each header meets the requirements listed at the top of this module: Allowed octets for name and value and no trailing whitespace in the value.+--+-- @since 3.1.15+defaultValidateHeadersSettings :: ValidateHeadersSettings+defaultValidateHeadersSettings = ValidateHeadersSettings+ { onInvalidHeader = \invalidHeader _app _req respond -> respond $ invalidHeaderResponse invalidHeader+ }++-- | Description of an invalid header.+--+-- @since 3.1.15+data InvalidHeader = InvalidHeader Header InvalidHeaderReason++-- | Reasons a header might be invalid.+--+-- @since 3.1.15+data InvalidHeaderReason+ -- | Header name contains an invalid octet.+ = InvalidOctetInHeaderName Word8+ -- | Header value contains an invalid octet.+ | InvalidOctetInHeaderValue Word8+ -- | Header value contains trailing whitespace.+ | TrailingWhitespaceInHeaderValue++-- Internal stuff.+-- 'getInvalidHeader' returns an appropriate 'InvalidHeader' for a given header if applicable.+-- 'invalidHeaderResponse' creates a 'Response' for a given 'InvalidHeader'.++getInvalidHeader :: ResponseHeaders -> Maybe InvalidHeader+getInvalidHeader = firstJust . map go+ where+ firstJust :: [Maybe a] -> Maybe a+ firstJust [] = Nothing+ firstJust (Just x : _) = Just x+ firstJust (_ : xs) = firstJust xs++ go :: Header -> Maybe InvalidHeader+ go header@(name, value) = InvalidHeader header <$> firstJust+ [ InvalidOctetInHeaderName <$> BS.find (not . isValidHeaderNameOctet) (original name)+ , InvalidOctetInHeaderValue <$> BS.find (not . isValidHeaderValueOctet) value+ , if hasTrailingWhitespace value then Just TrailingWhitespaceInHeaderValue else Nothing+ ]++isValidHeaderNameOctet :: Word8 -> Bool+isValidHeaderNameOctet octet =+ isVisibleASCII octet && not (isDelimiter octet)++isValidHeaderValueOctet :: Word8 -> Bool+isValidHeaderValueOctet octet =+ isVisibleASCII octet || isWhitespace octet || isObsText octet++isVisibleASCII :: Word8 -> Bool+isVisibleASCII octet = octet >= 33 && octet <= 126++isDelimiter :: Word8 -> Bool+isDelimiter octet = chr (fromIntegral octet) `elem` ("\"(),/:;<=>?@[\\]{}" :: String)++-- Whitespace characters are only horizontal tab and space here.+isWhitespace :: Word8 -> Bool+isWhitespace octet = octet == 0x9 || octet == 0x20++isObsText :: Word8 -> Bool+isObsText octet = octet >= 0x80++hasTrailingWhitespace :: BS.ByteString -> Bool+hasTrailingWhitespace bs+ | BS.length bs == 0 = False+ | otherwise = isWhitespace (BS.index bs 0) || isWhitespace (BS.index bs $ BS.length bs - 1)++invalidHeaderResponse :: InvalidHeader -> Response+invalidHeaderResponse (InvalidHeader (headerName, headerValue) reason) =+ responseLBS internalServerError500 [("Content-Type", "text/plain")] $ BSL.concat+ [ "Invalid response header found:\n"+ , "In header '"+ , BSL.fromStrict $ original headerName+ , "' with value '"+ , BSL.fromStrict headerValue+ , "': "+ , showReason reason+ , "\nYou are seeing this error message because validateHeadersMiddleware is enabled."+ ]+ where+ showReason (InvalidOctetInHeaderName octet) = "Name contains invalid octet " <> showOctet octet+ showReason (InvalidOctetInHeaderValue octet) = "Value contains invalid octet " <> showOctet octet+ showReason TrailingWhitespaceInHeaderValue = "Value contains trailing whitespace."++ showOctet octet+ | isVisibleASCII octet = BSL.fromStrict $ BS8.pack $ printf "'%c' (0x%02X)" (chr $ fromIntegral octet) octet+ | otherwise = BSL.fromStrict $ BS8.pack $ printf "0x%02X" octet
Network/Wai/Middleware/Vhost.hs view
@@ -1,37 +1,47 @@ {-# LANGUAGE CPP #-}- module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where -import Network.Wai+module Network.Wai.Middleware.Vhost (+ vhost,+ redirectWWW,+ redirectTo,+ redirectToLogged,+) where -import Network.HTTP.Types as H-import qualified Data.Text.Encoding as TE-import Data.Text (Text) import qualified Data.ByteString as BS #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mappend) #endif+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types as H+import Network.Wai vhost :: [(Request -> Bool, Application)] -> Application -> Application vhost vhosts def req = case filter (\(b, _) -> b req) vhosts of [] -> def req- (_, app):_ -> app req+ (_, app) : _ -> app req redirectWWW :: Text -> Application -> Application -- W.MiddleWare redirectWWW home =- redirectIf home (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)+ redirectIf+ home+ (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders) redirectIf :: Text -> (Request -> Bool) -> Application -> Application redirectIf home cond app req sendResponse =- if cond req- then sendResponse $ redirectTo $ TE.encodeUtf8 home- else app req sendResponse+ if cond req+ then sendResponse $ redirectTo $ TE.encodeUtf8 home+ else app req sendResponse redirectTo :: BS.ByteString -> Response-redirectTo location = responseLBS H.status301- [ (H.hContentType, "text/plain") , (H.hLocation, location) ] "Redirect"+redirectTo location =+ responseLBS+ H.status301+ [(H.hContentType, "text/plain"), (H.hLocation, location)]+ "Redirect" redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response redirectToLogged logger loc = do- logger $ "redirecting to: " `mappend` TE.decodeUtf8 loc- return $ redirectTo loc+ logger $ "redirecting to: " `mappend` TE.decodeUtf8 loc+ return $ redirectTo loc
Network/Wai/Parse.hs view
@@ -1,78 +1,91 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-}--- | Some helpers for parsing data out of a raw WAI 'Request'.+{-# LANGUAGE TypeFamilies #-} -module Network.Wai.Parse- ( parseHttpAccept- , parseRequestBody- , RequestBodyType (..)- , getRequestBodyType- , sinkRequestBody- , sinkRequestBodyEx- , BackEnd- , lbsBackEnd- , tempFileBackEnd- , tempFileBackEndOpts- , Param- , File- , FileInfo (..)- , parseContentType- , ParseRequestBodyOptions- , defaultParseRequestBodyOptions- , noLimitParseRequestBodyOptions- , parseRequestBodyEx- , setMaxRequestKeyLength- , clearMaxRequestKeyLength- , setMaxRequestNumFiles- , clearMaxRequestNumFiles- , setMaxRequestFileSize- , clearMaxRequestFileSize- , setMaxRequestFilesSize- , clearMaxRequestFilesSize- , setMaxRequestParmsSize- , clearMaxRequestParmsSize- , setMaxHeaderLines- , clearMaxHeaderLines- , setMaxHeaderLineLength- , clearMaxHeaderLineLength+-- | Some helpers for parsing data out of a raw WAI 'Request'.+module Network.Wai.Parse (+ parseHttpAccept,+ parseRequestBody,+ RequestBodyType (..),+ getRequestBodyType,+ sinkRequestBody,+ sinkRequestBodyEx,+ RequestParseException (..),+ BackEnd,+ lbsBackEnd,+ tempFileBackEnd,+ tempFileBackEndOpts,+ Param,+ File,+ FileInfo (..),+ parseContentType,+ ParseRequestBodyOptions,+ defaultParseRequestBodyOptions,+ noLimitParseRequestBodyOptions,+ parseRequestBodyEx,+ setMaxRequestKeyLength,+ clearMaxRequestKeyLength,+ setMaxRequestNumFiles,+ clearMaxRequestNumFiles,+ setMaxRequestFileSize,+ clearMaxRequestFileSize,+ setMaxRequestFilesSize,+ clearMaxRequestFilesSize,+ setMaxRequestParmsSize,+ clearMaxRequestParmsSize,+ setMaxHeaderLines,+ clearMaxHeaderLines,+ setMaxHeaderLineLength,+ clearMaxHeaderLineLength, #if TEST- , Bound (..)- , findBound- , sinkTillBound- , killCR- , killCRLF- , takeLine+ Bound (..),+ findBound,+ sinkTillBound,+ killCR,+ killCRLF,+ takeLine, #endif- ) where+) where +import Prelude hiding (lines)++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif+import Control.Exception (catchJust) import qualified Control.Exception as E+import Control.Monad (guard, unless, when)+import Control.Monad.Trans.Resource (+ InternalState,+ allocate,+ register,+ release,+ runInternalState,+ )+import Data.Bifunctor (bimap) import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8-import Data.Word (Word8)+import qualified Data.ByteString.Lazy as L+import Data.CaseInsensitive (mk)+import Data.Function (fix, on)+import Data.IORef import Data.Int (Int64)-import Data.Maybe (catMaybes, fromMaybe) import Data.List (sortBy)-import Data.Function (on, fix)-import System.Directory (removeFile, getTemporaryDirectory)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Typeable+import Data.Word8+import Network.HTTP.Types (hContentType)+import qualified Network.HTTP.Types as H+import Network.Wai+import Network.Wai.Handler.Warp (InvalidRequest (..))+import System.Directory (getTemporaryDirectory, removeFile) import System.IO (hClose, openBinaryTempFile) import System.IO.Error (isDoesNotExistError)-import Network.Wai-import qualified Network.HTTP.Types as H-import Control.Applicative ((<$>))-import Control.Exception (catchJust)-import Control.Monad (when, unless, guard)-import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)-import Data.IORef-import Network.HTTP.Types (hContentType)-import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )-import Data.CaseInsensitive (mk) -import Prelude hiding (lines)- breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s = let (x, y) = S.break (== w) s@@ -80,30 +93,32 @@ -- | Parse the HTTP accept string to determine supported content types. parseHttpAccept :: S.ByteString -> [S.ByteString]-parseHttpAccept = map fst- . sortBy (rcompare `on` snd)- . map (addSpecificity . grabQ)- . S.split 44 -- comma+parseHttpAccept =+ map fst+ . sortBy (rcompare `on` snd)+ . map (addSpecificity . grabQ)+ . S.split _comma where- rcompare :: (Double,Int) -> (Double,Int) -> Ordering+ 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- in (s, (q, semicolons - stars))+ 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- _ -> 1.0+ (x, _) : _ -> x+ _ -> 1.0 -- | Store uploaded files in memory-lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString+lbsBackEnd+ :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString lbsBackEnd _ _ popper = loop id where@@ -111,26 +126,31 @@ bs <- popper if S.null bs then return $ L.fromChunks $ front []- else loop $ front . (bs:)+ else loop $ front . (bs :) -- | Save uploaded files on disk as temporary files -- -- Note: starting with version 2.0, removal of temp files is registered with -- the provided @InternalState@. It is the responsibility of the caller to -- ensure that this @InternalState@ gets cleaned up.-tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath+tempFileBackEnd+ :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf" -- | Same as 'tempFileBackEnd', but use configurable temp folders and patterns.-tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory- -> String -- ^ filename pattern- -> InternalState- -> ignored1- -> ignored2- -> IO S.ByteString- -> IO FilePath+tempFileBackEndOpts+ :: IO FilePath+ -- ^ get temporary directory+ -> String+ -- ^ filename pattern+ -> InternalState+ -> ignored1+ -> ignored2+ -> IO S.ByteString+ -> IO FilePath tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do- (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)+ (key, (fp, h)) <-+ flip runInternalState internalState $ allocate it (hClose . snd) _ <- runInternalState (register $ removeFileQuiet fp) internalState fix $ \loop -> do bs <- popper@@ -139,117 +159,126 @@ loop release key return fp- where- it = do- tempDir <- getTmpDir- openBinaryTempFile tempDir pattrn- removeFileQuiet fp = catchJust (guard . isDoesNotExistError)- (removeFile fp)- (const $ return ())+ where+ it = do+ tempDir <- getTmpDir+ openBinaryTempFile tempDir pattrn+ removeFileQuiet fp =+ catchJust+ (guard . isDoesNotExistError)+ (removeFile fp)+ (const $ return ()) -- | A data structure that describes the behavior of -- the parseRequestBodyEx function. -- -- @since 3.0.16.0 data ParseRequestBodyOptions = ParseRequestBodyOptions- { -- | The maximum length of a filename- prboKeyLength :: Maybe Int- , -- | The maximum number of files.- prboMaxNumFiles :: Maybe Int- , -- | The maximum filesize per file.- prboMaxFileSize :: Maybe Int64- , -- | The maximum total filesize.- prboMaxFilesSize :: Maybe Int64- , -- | The maximum size of the sum of all parameters- prboMaxParmsSize :: Maybe Int- , -- | The maximum header lines per mime/multipart entry- prboMaxHeaderLines :: Maybe Int- , -- | The maximum header line length per mime/multipart entry- prboMaxHeaderLineLength :: Maybe Int }+ { prboKeyLength :: Maybe Int+ -- ^ The maximum length of a filename+ , prboMaxNumFiles :: Maybe Int+ -- ^ The maximum number of files.+ , prboMaxFileSize :: Maybe Int64+ -- ^ The maximum filesize per file.+ , prboMaxFilesSize :: Maybe Int64+ -- ^ The maximum total filesize.+ , prboMaxParmsSize :: Maybe Int+ -- ^ The maximum size of the sum of all parameters+ , prboMaxHeaderLines :: Maybe Int+ -- ^ The maximum header lines per mime/multipart entry+ , prboMaxHeaderLineLength :: Maybe Int+ -- ^ The maximum header line length per mime/multipart entry+ } -- | Set the maximum length of a filename. -- -- @since 3.0.16.0-setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions-setMaxRequestKeyLength l p = p { prboKeyLength=Just l }+setMaxRequestKeyLength+ :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions+setMaxRequestKeyLength l p = p{prboKeyLength = Just l} -- | Do not limit the length of filenames. -- -- @since 3.0.16.0 clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions-clearMaxRequestKeyLength p = p { prboKeyLength=Nothing }+clearMaxRequestKeyLength p = p{prboKeyLength = Nothing} -- | Set the maximum number of files per request. -- -- @since 3.0.16.0-setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions-setMaxRequestNumFiles l p = p { prboMaxNumFiles=Just l }+setMaxRequestNumFiles+ :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions+setMaxRequestNumFiles l p = p{prboMaxNumFiles = Just l} -- | Do not limit the maximum number of files per request. -- -- @since 3.0.16.0 clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions-clearMaxRequestNumFiles p = p { prboMaxNumFiles=Nothing }+clearMaxRequestNumFiles p = p{prboMaxNumFiles = Nothing} -- | Set the maximum filesize per file (in bytes). -- -- @since 3.0.16.0-setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions-setMaxRequestFileSize l p = p { prboMaxFileSize=Just l }+setMaxRequestFileSize+ :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions+setMaxRequestFileSize l p = p{prboMaxFileSize = Just l} -- | Do not limit the maximum filesize per file. -- -- @since 3.0.16.0 clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions-clearMaxRequestFileSize p = p { prboMaxFileSize=Nothing }+clearMaxRequestFileSize p = p{prboMaxFileSize = Nothing} -- | Set the maximum size of all files per request. -- -- @since 3.0.16.0-setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions-setMaxRequestFilesSize l p = p { prboMaxFilesSize=Just l }+setMaxRequestFilesSize+ :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions+setMaxRequestFilesSize l p = p{prboMaxFilesSize = Just l} -- | Do not limit the maximum size of all files per request. -- -- @since 3.0.16.0 clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions-clearMaxRequestFilesSize p = p { prboMaxFilesSize=Nothing }+clearMaxRequestFilesSize p = p{prboMaxFilesSize = Nothing} -- | Set the maximum size of the sum of all parameters. -- -- @since 3.0.16.0-setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions-setMaxRequestParmsSize l p = p { prboMaxParmsSize=Just l }+setMaxRequestParmsSize+ :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions+setMaxRequestParmsSize l p = p{prboMaxParmsSize = Just l} -- | Do not limit the maximum size of the sum of all parameters. -- -- @since 3.0.16.0 clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions-clearMaxRequestParmsSize p = p { prboMaxParmsSize=Nothing }+clearMaxRequestParmsSize p = p{prboMaxParmsSize = Nothing} -- | Set the maximum header lines per mime/multipart entry. -- -- @since 3.0.16.0 setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions-setMaxHeaderLines l p = p { prboMaxHeaderLines=Just l }+setMaxHeaderLines l p = p{prboMaxHeaderLines = Just l} -- | Do not limit the maximum header lines per mime/multipart entry. -- -- @since 3.0.16.0-clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions-clearMaxHeaderLines p = p { prboMaxHeaderLines=Nothing }+clearMaxHeaderLines :: ParseRequestBodyOptions -> ParseRequestBodyOptions+clearMaxHeaderLines p = p{prboMaxHeaderLines = Nothing} -- | Set the maximum header line length per mime/multipart entry. -- -- @since 3.0.16.0-setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions-setMaxHeaderLineLength l p = p { prboMaxHeaderLineLength=Just l }+setMaxHeaderLineLength+ :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions+setMaxHeaderLineLength l p = p{prboMaxHeaderLineLength = Just l} -- | Do not limit the maximum header lines per mime/multipart entry. -- -- @since 3.0.16.0 clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions-clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing }+clearMaxHeaderLineLength p = p{prboMaxHeaderLineLength = Nothing} -- | A reasonable default set of parsing options. -- Maximum key/filename length: 32 bytes;@@ -262,27 +291,31 @@ -- -- @since 3.0.16.0 defaultParseRequestBodyOptions :: ParseRequestBodyOptions-defaultParseRequestBodyOptions = ParseRequestBodyOptions- { prboKeyLength=Just 32- , prboMaxNumFiles=Just 10- , prboMaxFileSize=Nothing- , prboMaxFilesSize=Nothing- , prboMaxParmsSize=Just 65336- , prboMaxHeaderLines=Just 32- , prboMaxHeaderLineLength=Just 8190 }+defaultParseRequestBodyOptions =+ ParseRequestBodyOptions+ { prboKeyLength = Just 32+ , prboMaxNumFiles = Just 10+ , prboMaxFileSize = Nothing+ , prboMaxFilesSize = Nothing+ , prboMaxParmsSize = Just 65336+ , prboMaxHeaderLines = Just 32+ , prboMaxHeaderLineLength = Just 8190+ } -- | Do not impose any memory limits. -- -- @since 3.0.21.0 noLimitParseRequestBodyOptions :: ParseRequestBodyOptions-noLimitParseRequestBodyOptions = ParseRequestBodyOptions- { prboKeyLength=Nothing- , prboMaxNumFiles=Nothing- , prboMaxFileSize=Nothing- , prboMaxFilesSize=Nothing- , prboMaxParmsSize=Nothing- , prboMaxHeaderLines=Nothing- , prboMaxHeaderLineLength=Nothing }+noLimitParseRequestBodyOptions =+ ParseRequestBodyOptions+ { prboKeyLength = Nothing+ , prboMaxNumFiles = Nothing+ , prboMaxFileSize = Nothing+ , prboMaxFilesSize = Nothing+ , prboMaxParmsSize = Nothing+ , prboMaxHeaderLines = Nothing+ , prboMaxHeaderLineLength = Nothing+ } -- | Information on an uploaded file. data FileInfo c = FileInfo@@ -300,10 +333,12 @@ -- | A file uploading backend. Takes the parameter name, file name, and a -- stream of data.-type BackEnd a = S.ByteString -- ^ parameter name- -> FileInfo ()- -> IO S.ByteString- -> IO a+type BackEnd a =+ S.ByteString+ -- ^ parameter name+ -> FileInfo ()+ -> IO S.ByteString+ -> IO a -- | The mimetype of the http body. -- Depending on whether just parameters or parameters and files@@ -328,28 +363,27 @@ -- content type and a list of pairs of attributes. -- -- @since 1.3.2-parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])+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- then S.tail $ S.init s- else s+ 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- in goAttrs (front . (goAttr x:)) $ S.drop 1 rest+ 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.@@ -357,9 +391,12 @@ -- 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.-parseRequestBody :: BackEnd y- -> Request- -> IO ([Param], [File y])+--+-- since 3.1.15 : throws 'RequestParseException' if something goes wrong+parseRequestBody+ :: BackEnd y+ -> Request+ -> IO ([Param], [File y]) parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions -- | Parse the body of an HTTP request, limit resource usage.@@ -368,44 +405,53 @@ -- 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.-parseRequestBodyEx :: ParseRequestBodyOptions- -> BackEnd y- -> Request- -> IO ([Param], [File y])+--+-- since 3.1.15 : throws 'RequestParseException' if something goes wrong+parseRequestBodyEx+ :: ParseRequestBodyOptions+ -> BackEnd y+ -> Request+ -> IO ([Param], [File y]) 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) -sinkRequestBody :: BackEnd y- -> RequestBodyType- -> IO S.ByteString- -> IO ([Param], [File y])+-- | 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-sinkRequestBodyEx :: ParseRequestBodyOptions- -> BackEnd y- -> RequestBodyType- -> IO S.ByteString- -> IO ([Param], [File y])+--+-- since 3.1.15 : throws 'RequestParseException' if something goes wrong+sinkRequestBodyEx+ :: ParseRequestBodyOptions+ -> BackEnd y+ -> RequestBodyType+ -> IO S.ByteString+ -> IO ([Param], [File y]) sinkRequestBodyEx o s r body = do ref <- newIORef ([], []) let add x = atomicModifyIORef ref $ \(y, z) -> case x of- Left y' -> ((y':y, z), ())- Right z' -> ((y, z':z), ())+ 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- -> RequestBodyType- -> IO S.ByteString- -> (Either Param (File y) -> IO ())- -> IO ()+conduitRequestBodyEx+ :: ParseRequestBodyOptions+ -> BackEnd y+ -> RequestBodyType+ -> IO S.ByteString+ -> (Either Param (File y) -> IO ())+ -> IO () conduitRequestBodyEx o _ UrlEncoded rbody add = do -- NOTE: in general, url-encoded data will be in a single chunk. -- Therefore, I'm optimizing for the usual case by sticking with@@ -417,16 +463,17 @@ else do let newsize = size + S.length bs case prboMaxParmsSize o of- Just maxSize -> when (newsize > maxSize) $- error "Maximum size of parameters exceeded"+ Just maxSize ->+ when (newsize > maxSize) $+ E.throwIO $+ MaxParamSizeExceeded newsize Nothing -> return ()- loop newsize $ front . (bs:)+ loop newsize $ front . (bs :) bs <- loop 0 id mapM_ (add . Left) $ H.parseSimpleQuery bs conduitRequestBodyEx o backend (Multipart bound) rbody add = parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody add - -- | Take one header or subheader line. -- Since: 3.0.26 -- Throw 431 if headers too large.@@ -437,9 +484,9 @@ go front = do bs <- readSource src case maxlen of- Just maxlen' -> when (S.length front > maxlen') $- E.throwIO $ ConnectionError (UnknownErrorCode 431)- "Request Header Fields Too Large"+ Just maxlen' ->+ when (S.length front > maxlen') $+ E.throwIO RequestHeaderFieldsTooLarge Nothing -> return () if S.null bs then close front@@ -447,23 +494,25 @@ 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 when (S.length y > 1) $ leftover src $ S.drop 1 y let res = front `S.append` x case maxlen of- Just maxlen' -> when (S.length res > maxlen') $- E.throwIO $ ConnectionError (UnknownErrorCode 431)- "Request Header Fields Too Large"+ Just maxlen' ->+ when (S.length res > maxlen') $+ E.throwIO RequestHeaderFieldsTooLarge Nothing -> return ()- return $ Just $ killCR $ res+ 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,14 +523,15 @@ 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 Nothing -> return lines Just l | S.null l -> return lines- | otherwise -> takeLines'' (l:lines) lineLength maxLines src+ | otherwise -> takeLines'' (l : lines) lineLength maxLines src data Source = Source (IO S.ByteString) (IORef S.ByteString) @@ -497,29 +547,36 @@ then f else return bs +{- HLint ignore readSource "Use tuple-section" -}+ leftover :: Source -> S.ByteString -> IO ()-leftover (Source _ ref) bs = writeIORef ref bs+leftover (Source _ ref) = writeIORef ref -parsePiecesEx :: ParseRequestBodyOptions- -> BackEnd y- -> S.ByteString- -> IO S.ByteString- -> (Either Param (File y) -> IO ())- -> IO ()+-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong+parsePiecesEx+ :: ParseRequestBodyOptions+ -> BackEnd y+ -> S.ByteString+ -> IO S.ByteString+ -> (Either Param (File y) -> IO ())+ -> IO () parsePiecesEx o sink bound rbody add = mkSource rbody >>= loop 0 0 0 0 where loop :: Int -> Int -> Int -> Int64 -> Source -> IO () loop numParms numFiles parmSize filesSize src = do _boundLine <- takeLine (prboMaxHeaderLineLength o) src- res' <- takeLines' (prboMaxHeaderLineLength o)- (prboMaxHeaderLines o) src+ res' <-+ takeLines'+ (prboMaxHeaderLineLength o)+ (prboMaxHeaderLines o)+ src unless (null res') $ do let ls' = map parsePair res' let x = do cd <- lookup contDisp ls' let ct = lookup contType ls'- let attrs = parseAttrs cd+ let attrs = parseContentDispositionAttrs cd name <- lookup "name" attrs return (ct, name, lookup "filename" attrs) case x of@@ -527,41 +584,60 @@ 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"+ Just maxFiles ->+ when (numFiles >= maxFiles) $+ E.throwIO $+ MaxFileNumberExceeded numFiles Nothing -> return () let ct = fromMaybe "application/octet-stream" mct fi0 = FileInfo filename ct ()- fs = catMaybes [ prboMaxFileSize o- , subtract filesSize <$> prboMaxFilesSize o ]- mfs = if fs == [] then Nothing else Just $ minimum fs+ fs =+ catMaybes+ [ prboMaxFileSize o+ , subtract filesSize <$> prboMaxFilesSize o+ ]+ mfs = if null fs then Nothing else Just $ minimum fs ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs let newFilesSize = filesSize + fileSize- add $ Right (name, fi0 { fileContent = y })+ add $ Right (name, fi0{fileContent = y}) when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src Just (_ct, name, Nothing) -> do 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- ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src- (fromIntegral <$> prboMaxParmsSize o)+ ((wasFound, _fileSize), front) <-+ sinkTillBound+ bound+ iter+ seed+ src+ (fromIntegral <$> prboMaxParmsSize o) let bs = S.concat $ front [] let x' = (name, bs) let newParmSize = parmSize + S.length name + S.length bs case prboMaxParmsSize o of- Just maxParmSize -> when (newParmSize > maxParmSize) $- error "Maximum size of parameters exceeded"+ Just maxParmSize ->+ when (newParmSize > maxParmSize) $+ E.throwIO $+ MaxParamSizeExceeded newParmSize Nothing -> return () add $ Left x'- when wasFound $ loop (numParms + 1) numFiles- newParmSize filesSize src+ when wasFound $+ loop+ (numParms + 1)+ numFiles+ newParmSize+ filesSize+ src _ -> do -- ignore this part let seed = ()@@ -572,27 +648,48 @@ 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) -data Bound = FoundBound S.ByteString S.ByteString- | NoBound- | PartialBound+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 deriving (Eq, Show) findBound :: S.ByteString -> S.ByteString -> Bound findBound b bs = handleBreak $ S.breakSubstring b bs where handleBreak (h, t)- | S.null t = go [lowBound..S.length bs - 1]+ | S.null t = go [lowBound .. S.length bs - 1] | otherwise = FoundBound h $ S.drop (S.length b) t lowBound = max 0 $ S.length bs - S.length b go [] = NoBound- go (i:is)- | mismatch [0..S.length b - 1] [i..S.length bs - 1] = go is+ go (i : is)+ | mismatch [0 .. S.length b - 1] [i .. S.length bs - 1] = go is | otherwise = let endI = i + S.length b in if endI > S.length bs@@ -600,29 +697,34 @@ else FoundBound (S.take i bs) (S.drop endI bs) mismatch [] _ = False mismatch _ [] = False- mismatch (x:xs) (y:ys)+ mismatch (x : xs) (y : ys) | S.index b x == S.index bs y = mismatch xs ys | otherwise = True -sinkTillBound' :: S.ByteString- -> S.ByteString- -> FileInfo ()- -> BackEnd y- -> Source- -> Maybe Int64- -> IO ((Bool, Int64), y)+sinkTillBound'+ :: S.ByteString+ -> S.ByteString+ -> FileInfo ()+ -> BackEnd y+ -> Source+ -> Maybe Int64+ -> IO ((Bool, Int64), y) sinkTillBound' bound name fi sink src max' = do (next, final) <- wrapTillBound bound src max' y <- sink name fi next b <- final return (b, y) -data WTB = WTBWorking (S.ByteString -> S.ByteString)- | WTBDone Bool-wrapTillBound :: S.ByteString -- ^ bound- -> Source- -> Maybe Int64- -> IO (IO S.ByteString, IO (Bool, Int64)) -- ^ Bool indicates if the bound was found+data WTB+ = WTBWorking (S.ByteString -> S.ByteString)+ | WTBDone Bool+wrapTillBound+ :: S.ByteString+ -- ^ bound+ -> Source+ -> Maybe Int64+ -> IO (IO S.ByteString, IO (Bool, Int64))+ -- ^ Bool indicates if the bound was found wrapTillBound bound src max' = do ref <- newIORef $ WTBWorking id sref <- newIORef (0 :: Int64)@@ -642,12 +744,11 @@ WTBDone _ -> return S.empty WTBWorking front -> do bs <- readSource src- cur <- atomicModifyIORef' sref $ \ cur ->+ cur <- atomicModifyIORef' sref $ \cur -> let new = cur + fromIntegral (S.length bs) in (new, new) case max' of- Just max'' | cur > max'' ->- E.throwIO $ ConnectionError (UnknownErrorCode 413) "Payload Too Large"- _ -> return ()+ Just max'' | cur > max'' -> E.throwIO PayloadTooLarge+ _ -> return () if S.null bs then do writeIORef ref $ WTBDone False@@ -664,9 +765,10 @@ NoBound -> do -- don't emit newlines, in case it's part of a bound let (toEmit, front') =- if not (S8.null bs) && S8.last bs `elem` ['\r','\n']- then let (x, y) = S.splitAt (S.length bs - 2) bs- in (x, S.append y)+ if not (S8.null bs) && S8.last bs `elem` ['\r', '\n']+ then+ let (x, y) = S.splitAt (S.length bs - 2) bs+ in (x, S.append y) else (bs, id) writeIORef ref $ WTBWorking front' if S.null toEmit@@ -676,12 +778,13 @@ writeIORef ref $ WTBWorking $ S.append bs go ref sref -sinkTillBound :: S.ByteString- -> (x -> S.ByteString -> IO x)- -> x- -> Source- -> Maybe Int64- -> IO ((Bool, Int64), x)+sinkTillBound+ :: S.ByteString+ -> (x -> S.ByteString -> IO x)+ -> x+ -> Source+ -> Maybe Int64+ -> IO ((Bool, Int64), x) sinkTillBound bound iter seed0 src max' = do (next, final) <- wrapTillBound bound src max' let loop seed = do@@ -693,23 +796,42 @@ b <- final return (b, seed) -parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]-parseAttrs = map go . S.split 59 -- semicolon- where- tw = S.dropWhile (== 32) -- space- dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote- then S.tail $ S.init s- else s- go s =- let (x, y) = breakDiscard 61 s -- equals sign- in (tw x, dq $ tw y)+parseContentDispositionAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]+parseContentDispositionAttrs = parseTokenValues+ where+ nonTokenChars = [_semicolon, _equal]+ dropSpace = S.dropWhile (== _space)+ parseTokenValues input | S.null input = []+ parseTokenValues input =+ let (token, rest) = parseToken $ dropSpace input+ in case S.uncons rest of+ Just (c, rest')+ | c == _equal -> + let (value, rest'') = parseValue rest'+ in (token, value) : parseTokenValues (S.drop 1 rest'')+ | otherwise -> (token, S.empty) : parseTokenValues rest'+ Nothing -> (token, S.empty) : parseTokenValues S.empty+ parseToken = S.break (`elem` nonTokenChars)+ parseValue input =+ case S.uncons $ dropSpace input of+ Just (c, rest) | c == _quotedbl -> parseQuotedString [] rest+ _ -> S.break (`elem` nonTokenChars) $ dropSpace input+ parseQuotedString acc input =+ let (prefix, rest) = S.break (`elem` [_quotedbl, _backslash]) input+ in case S.uncons rest of+ Just (c, rest')+ | c == _quotedbl -> (S.concat $ reverse (prefix:acc), rest')+ | c == _backslash ->+ let (slashed, postSlash) = S.splitAt 1 rest'+ in parseQuotedString (slashed:prefix:acc) postSlash+ _ -> (S.concat $ reverse (prefix:acc), rest) killCRLF :: S.ByteString -> S.ByteString killCRLF bs- | S.null bs || S.last bs /= 10 = bs -- line feed+ | S.null bs || S.last bs /= _lf = bs | otherwise = killCR $ S.init bs killCR :: S.ByteString -> S.ByteString killCR bs- | S.null bs || S.last bs /= 13 = bs -- carriage return+ | S.null bs || S.last bs /= _cr = bs | otherwise = S.init bs
Network/Wai/Request.hs view
@@ -1,25 +1,23 @@ {-# 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)-import Data.Maybe (fromMaybe)-import Network.HTTP.Types (HeaderName)-import Network.Wai- import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C-import Control.Exception (Exception, throwIO)+import Data.IORef (atomicModifyIORef', newIORef)+import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) import Data.Word (Word64)-import Data.IORef (atomicModifyIORef', newIORef)-+import Network.HTTP.Types (HeaderName)+import Network.Wai -- | Does this request appear to have been made over an SSL connection? --@@ -34,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@@ -55,13 +55,13 @@ -- @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' -- -- @since 3.0.15-data RequestSizeException+newtype RequestSizeException = RequestSizeException Word64 deriving (Eq, Ord, Typeable) @@ -69,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. --@@ -82,20 +84,19 @@ requestSizeCheck :: Word64 -> Request -> IO Request requestSizeCheck maxSize req = case requestBodyLength req of- KnownLength len ->+ KnownLength len -> if len > maxSize- then return $ req { requestBody = throwIO (RequestSizeException maxSize) }+ then return $ setRequestBodyChunks (throwIO $ RequestSizeException maxSize) req else return req- ChunkedBody -> do+ ChunkedBody -> do currentSize <- newIORef 0- return $ req- { requestBody = do- bs <- requestBody req+ let rbody = do+ bs <- getRequestBodyChunk req total <- atomicModifyIORef' currentSize $ \sz -> let nextSize = sz + fromIntegral (S.length bs)- in (nextSize, nextSize)+ in (nextSize, nextSize) if total > maxSize- then throwIO (RequestSizeException maxSize)- else return bs- }+ then throwIO (RequestSizeException maxSize)+ else return bs+ return $ setRequestBodyChunks rbody req
Network/Wai/Test.hs view
@@ -1,67 +1,69 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Network.Wai.Test- ( -- * Session- Session- , runSession- -- * 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- , WaiTestFailure (..)- ) 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) #endif -import Network.Wai-import Network.Wai.Internal (ResponseReceived (ResponseReceived))-import Network.Wai.Test.Internal+import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask, runReaderT) import qualified Control.Monad.Trans.State as ST-import Control.Monad.Trans.Reader (runReaderT, ask)-import Control.Monad (unless)-import Control.DeepSeq (deepseq)-import Control.Exception (throwIO, Exception)-import Data.Typeable (Typeable)-import qualified Data.Map as Map-import qualified Web.Cookie as Cookie import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString as S import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Network.HTTP.Types as H+import Data.CallStack (HasCallStack) import Data.CaseInsensitive (CI)-import qualified Data.ByteString as S+import Data.IORef+import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.Encoding as TE-import Data.IORef import Data.Time.Clock (getCurrentTime)+import qualified Network.HTTP.Types as H+import Network.Wai+import Network.Wai.Internal (ResponseReceived (ResponseReceived))+import Network.Wai.Test.Internal+import qualified Test.HUnit as HUnit+import qualified Web.Cookie as Cookie -- | --@@ -74,28 +76,31 @@ -- 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 cookieName =- modifyClientCookies- (Map.delete cookieName)+deleteClientCookie =+ modifyClientCookies . Map.delete -- | See also: 'runSessionWith'. runSession :: Session a -> Application -> IO a runSession session app = ST.evalStateT (runReaderT session app) initState +-- | Synonym for 'flip runSession'+withSession :: Application -> Session a -> IO a+withSession = flip runSession+ data SRequest = SRequest { simpleRequest :: Request , simpleRequestBody :: L.ByteString@@ -123,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@@ -206,128 +217,152 @@ where (s, h, withBody) = responseToStream res -assertBool :: String -> Bool -> Session ()+assertBool :: HasCallStack => String -> Bool -> Session () assertBool s b = unless b $ assertFailure s -assertString :: String -> Session ()+assertString :: HasCallStack => String -> Session () assertString s = unless (null s) $ assertFailure s -assertFailure :: String -> Session ()-assertFailure msg = msg `deepseq` liftIO (throwIO (WaiTestFailure msg))--data WaiTestFailure = WaiTestFailure String- deriving (Show, Eq, Typeable)-instance Exception WaiTestFailure+assertFailure :: HasCallStack => String -> Session ()+assertFailure = liftIO . HUnit.assertFailure -assertContentType :: ByteString -> SResponse -> Session ()+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 :: Int -> SResponse -> Session ()-assertStatus i SResponse{simpleStatus = s} = assertBool (concat- [ "Expected status code "- , show i- , ", but received "- , show sc- ]) $ i == sc+assertStatus :: HasCallStack => Int -> SResponse -> Session ()+assertStatus i SResponse{simpleStatus = s} =+ assertBool+ ( concat+ [ "Expected status code "+ , show i+ , ", but received "+ , show sc+ ]+ )+ $ i == sc where sc = H.statusCode s -assertBody :: 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 :: 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' -assertBodyContains :: 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 :: 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' where strict = S.concat . L.toChunks -assertHeader :: 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 :: CI ByteString -> SResponse -> Session ()+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 :: String -> ByteString -> Session ()+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 :: String -> ByteString -> Session ()+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 :: String -> ByteString -> ByteString -> Session ()+assertClientCookieValue+ :: HasCallStack => String -> ByteString -> ByteString -> Session () assertClientCookieValue s cookieName cookieValue = do- cookies <- getClientCookies- case Map.lookup cookieName cookies of- Nothing ->- assertFailure (s ++ " (cookie does not exist)")- Just c ->- assertBool- (concat- [ s- , " (actual value "- , show $ Cookie.setCookieValue c- , " expected value "- , show cookieValue- , ")"- ]- )- (Cookie.setCookieValue c == cookieValue)+ cookies <- getClientCookies+ case Map.lookup cookieName cookies of+ Nothing ->+ assertFailure (s ++ " (cookie does not exist)")+ Just c ->+ assertBool+ ( concat+ [ s+ , " (actual value "+ , show $ Cookie.setCookieValue c+ , " expected value "+ , show cookieValue+ , ")"+ ]+ )+ (Cookie.setCookieValue c == cookieValue)
Network/Wai/Test/Internal.hs view
@@ -1,12 +1,12 @@ module Network.Wai.Test.Internal where -import Network.Wai-import qualified Control.Monad.Trans.State as ST import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import qualified Control.Monad.Trans.State as ST+import Data.ByteString (ByteString) import Data.Map (Map) import qualified Data.Map as Map+import Network.Wai (Application) import qualified Web.Cookie as Cookie-import Data.ByteString (ByteString) type Session = ReaderT Application (ST.StateT ClientState IO) @@ -15,7 +15,7 @@ -- Since 3.0.6 type ClientCookies = Map ByteString Cookie.SetCookie -data ClientState = ClientState+newtype ClientState = ClientState { clientCookies :: ClientCookies }
Network/Wai/UrlMap.hs view
@@ -1,55 +1,65 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-}-{- | 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+{-# LANGUAGE FlexibleInstances #-} --}+-- | 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, mount', mount, mountRoot,- mapUrls+ mapUrls, ) where import Control.Applicative-import Data.List+import qualified Data.ByteString as B+import Data.List (stripPrefix) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Data.ByteString as B-import Network.HTTP.Types-import Network.Wai+import Network.HTTP.Types (hContentType, status404)+import Network.Wai (Application, Request (pathInfo, rawPathInfo), responseLBS) type Path = [Text]-newtype UrlMap' a = UrlMap' { unUrlMap :: [(Path, a)] }+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) +-- | @since 3.1.18+instance Foldable UrlMap' where+ foldr f z (UrlMap' xs) = foldr (f . snd) z xs++-- | @since 3.1.18+instance Traversable UrlMap' where+ traverse f (UrlMap' xs) = UrlMap' <$> traverse (traverse f) xs+ type UrlMap = UrlMap' Application -- | Mount an application under a given path. The ToApplication typeclass gives@@ -61,21 +71,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@@ -87,16 +100,20 @@ toApplication urlMap req sendResponse = case try (pathInfo req) (unUrlMap urlMap) of Just (newPath, app) ->- app (req { pathInfo = newPath- , rawPathInfo = makeRaw newPath- }) sendResponse+ app+ ( req+ { pathInfo = newPath+ , rawPathInfo = makeRaw newPath+ }+ )+ sendResponse Nothing ->- sendResponse $ responseLBS- status404- [(hContentType, "text/plain")]- "Not found\n"-- where+ sendResponse $+ responseLBS+ status404+ [(hContentType, "text/plain")]+ "Not found\n"+ where makeRaw :: [Text] -> B.ByteString makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"
+ Network/Wai/Util.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}++-- | Some helpers functions.+module Network.Wai.Util (+ dropWhileEnd,+ splitCommas,+ trimWS,+) where++import qualified Data.ByteString as S+import Data.Word8 (Word8, _comma, _space)++-- | Used to split a header value which is a comma separated list+splitCommas :: S.ByteString -> [S.ByteString]+splitCommas = map trimWS . S.split _comma++-- Trim whitespace+trimWS :: S.ByteString -> S.ByteString+trimWS = dropWhileEnd (== _space) . S.dropWhile (== _space)++-- | Dropping all 'Word8's from the end that satisfy the predicate.+dropWhileEnd :: (Word8 -> Bool) -> S.ByteString -> S.ByteString+#if MIN_VERSION_bytestring(0,10,12)+dropWhileEnd = S.dropWhileEnd+#else+dropWhileEnd p = fst . S.spanEnd p+#endif
example/Main.hs view
@@ -1,26 +1,36 @@ {-# LANGUAGE OverloadedStrings #-}+ module Main where -import Data.ByteString.Builder (string8) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Chan-import Control.Monad+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 (defaultGzipSettings, 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- where- handle counter emit flush = do- threadDelay 1000000- _ <- emit $ ServerEvent (Just $ string8 "raw")- Nothing- [string8 . show $ counter]- _ <- flush- handle (counter + 1) emit flush+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 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")- ]+ run 8080 (gzip defaultGzipSettings $ 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")+ ]
test/Network/Wai/Middleware/ApprootSpec.hs view
@@ -1,17 +1,18 @@ {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.ApprootSpec- ( main- , spec- ) where -import Test.Hspec+module Network.Wai.Middleware.ApprootSpec (+ main,+ spec,+) where -import Network.Wai.Middleware.Approot-import Network.Wai.Test-import Network.Wai-import Network.HTTP.Types import Data.ByteString (ByteString)+import Network.HTTP.Types (RequestHeaders, status200)+import Network.Wai+import Test.Hspec +import Network.Wai.Middleware.Approot (fromRequest, getApproot)+import Network.Wai.Test (SResponse (simpleHeaders), request, runSession)+ main :: IO () main = hspec spec @@ -22,16 +23,23 @@ simpleHeaders resp `shouldBe` [("Approot", expected)] test "respects host header" "foobar" False [] "http://foobar" test "respects isSecure" "foobar" True [] "https://foobar"- test "respects SSL headers" "foobar" False- [("HTTP_X_FORWARDED_SSL", "on")] "https://foobar"+ test+ "respects SSL headers"+ "foobar"+ False+ [("HTTP_X_FORWARDED_SSL", "on")]+ "https://foobar" runApp :: ByteString -> Bool -> RequestHeaders -> IO SResponse-runApp host secure headers = runSession- (request defaultRequest- { requestHeaderHost = Just host- , isSecure = secure- , requestHeaders = headers- }) $ fromRequest app-+runApp host secure headers =+ runSession+ ( request+ defaultRequest+ { requestHeaderHost = Just host+ , isSecure = secure+ , requestHeaders = headers+ }+ )+ $ fromRequest app where app req respond = respond $ responseLBS status200 [("Approot", getApproot req)] ""
+ test/Network/Wai/Middleware/CombineHeadersSpec.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.CombineHeadersSpec (+ main,+ spec,+) where++import Data.ByteString (ByteString)+import Data.IORef (newIORef, readIORef, writeIORef)+import Network.HTTP.Types (status200)+import Network.HTTP.Types.Header+import Network.Wai+import Test.Hspec++import Network.Wai.Middleware.CombineHeaders (+ CombineSettings,+ combineHeaders,+ defaultCombineSettings,+ setRequestHeaders,+ setResponseHeaders,+ )+import Network.Wai.Test (SResponse (simpleHeaders), request, runSession)++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ let test name settings reqHeaders expectedReqHeaders resHeaders expectedResHeaders = it name $ do+ (reqHdrs, resHdrs) <- runApp settings reqHeaders resHeaders+ reqHdrs `shouldBe` expectedReqHeaders+ resHdrs `shouldBe` expectedResHeaders+ testReqHdrs name a b =+ test name defaultCombineSettings a b [] []+ testResHdrs name a b =+ test+ name+ (setRequestHeaders False $ setResponseHeaders True defaultCombineSettings)+ []+ []+ a+ b++ -- Request Headers+ testReqHdrs+ "should reorder alphabetically (request)"+ [host, userAgent, acceptHtml]+ [acceptHtml, host, userAgent]+ -- Response Headers+ testResHdrs+ "should reorder alphabetically (response)"+ [expires, location, contentTypeHtml]+ [contentTypeHtml, expires, location]++ -- Request Headers+ testReqHdrs+ "combines Accept (in order)"+ [userAgent, acceptHtml, host, acceptJSON]+ [acceptHtml `combineHdrs` acceptJSON, host, userAgent]+ -- Response Headers+ 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"+ ]++ -- 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]+ 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]++ -- 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 "*"]+ 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"]++ -- 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"]+ -- 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"]++combineHdrs :: Header -> Header -> Header+combineHdrs (hname, h1) (_, h2) = (hname, h1 <> ", " <> h2)++acceptHtml+ , acceptJSON+ , cacheControlMax+ , cacheControlPublic+ , contentTypeHtml+ , date+ , expires+ , host+ , location+ , userAgent+ :: Header+acceptHtml = (hAccept, "text/html")+acceptJSON = (hAccept, "application/json")+altSvc :: ByteString -> Header+altSvc x = ("Alt-Svc", x)+cacheControlPublic = (hCacheControl, "public")+cacheControlMax = (hCacheControl, "public")+contentTypeHtml = (hContentType, "text/html")+date = (hDate, "Mon, 19 Aug 2022 18:18:31 GMT")+expires = (hExpires, "Mon, 19 Sep 2022 18:18:31 GMT")+host = (hHost, "google.com")+ifNoneMatch :: ByteString -> Header+ifNoneMatch x = (hIfNoneMatch, x)+location = (hLocation, "http://www.google.com/")+setCookie :: ByteString -> Header+setCookie val = (hSetCookie, val)+userAgent = (hUserAgent, "curl/7.68.0")++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+ finalReqHeaders <- readIORef reqHdrs+ pure (finalReqHeaders, simpleHeaders sResponse)+ where+ session =+ request+ defaultRequest{requestHeaders = reqHeaders}+ app hdrRef req respond = do+ writeIORef hdrRef $ requestHeaders req+ respond $ responseLBS status200 resHeaders ""
test/Network/Wai/Middleware/ForceSSLSpec.hs view
@@ -1,18 +1,21 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.ForceSSLSpec- ( main- , spec- ) where -import Test.Hspec--import Network.Wai.Middleware.ForceSSL+module Network.Wai.Middleware.ForceSSLSpec (+ main,+ spec,+) where -import Control.Monad+import Control.Monad (forM_) import Data.ByteString (ByteString)+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>))+#endif import Network.HTTP.Types (methodPost, status200, status301, status307) import Network.Wai+import Test.Hspec++import Network.Wai.Middleware.ForceSSL (forceSSL) import Network.Wai.Test main :: IO ()@@ -25,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 @@ -33,28 +35,39 @@ simpleHeaders resp `shouldBe` [("Location", "https://" <> host)] it "redirects with 307 in the case of a non-GET request" $ do- resp <- runApp host forceSSL defaultRequest- { requestMethod = methodPost }+ resp <-+ runApp+ host+ forceSSL+ defaultRequest+ { requestMethod = methodPost+ } simpleStatus resp `shouldBe` status307 simpleHeaders resp `shouldBe` [("Location", "https://" <> host)] it "does not redirect already-secure requests" $ do- resp <- runApp host forceSSL defaultRequest { isSecure = True }+ resp <- runApp host forceSSL defaultRequest{isSecure = True} simpleStatus resp `shouldBe` status200 it "preserves the original host, path, and query string" $ do- resp <- runApp host forceSSL defaultRequest- { rawPathInfo = "/foo/bar"- , rawQueryString = "?baz=bat"- }+ resp <-+ runApp+ host+ forceSSL+ defaultRequest+ { rawPathInfo = "/foo/bar"+ , rawQueryString = "?baz=bat"+ } - simpleHeaders resp `shouldBe`- [("Location", "https://" <> host <> "/foo/bar?baz=bat")]+ simpleHeaders resp+ `shouldBe` [("Location", "https://" <> host <> "/foo/bar?baz=bat")] runApp :: ByteString -> Middleware -> Request -> IO SResponse-runApp host mw req = runSession- (request req { requestHeaderHost = Just host }) $ mw app+runApp host mw req =+ runSession+ (request req{requestHeaderHost = Just host})+ $ mw app where app _ respond = respond $ responseLBS status200 [] ""
+ test/Network/Wai/Middleware/RealIpSpec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.RealIpSpec (+ spec,+) where++import qualified Data.ByteString.Lazy.Char8 as B8+import qualified Data.IP as IP+import Network.HTTP.Types (RequestHeaders, status200)+import Network.Wai+import Test.Hspec++import Network.Wai.Middleware.RealIp+import Network.Wai.Test++spec :: Spec+spec = do+ describe "realIp" $ do+ it "does nothing when header is missing" $ do+ resp <- runApp "127.0.0.1" [] realIp+ simpleBody resp `shouldBe` "127.0.0.1"++ it "uses X-Forwarded-For when present" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1")]+ resp <- runApp "127.0.0.1" headers realIp+ simpleBody resp `shouldBe` "1.1.1.1"++ it "ignores X-Forwarded-For from non-trusted ip" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1")]+ resp <- runApp "1.2.3.4" headers realIp+ simpleBody resp `shouldBe` "1.2.3.4"++ it "ignores trusted ip addresses in X-Forwarded-For" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1, 10.0.0.1")]+ resp <- runApp "127.0.0.1" headers realIp+ simpleBody resp `shouldBe` "1.1.1.1"++ it "ignores invalid ip addresses" $ do+ let headers1 = [("X-Forwarded-For", "1.1.1")]+ resp1 <- runApp "127.0.0.1" headers1 realIp+ let headers2 = [("X-Forwarded-For", "1.1.1.1,foo")]+ resp2 <- runApp "127.0.0.1" headers2 realIp++ simpleBody resp1 `shouldBe` "127.0.0.1"+ simpleBody resp2 `shouldBe` "1.1.1.1"++ it "takes the last non-trusted address" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1, 2.2.2.2, 10.0.0.1")]+ resp <- runApp "127.0.0.1" headers realIp+ simpleBody resp `shouldBe` "2.2.2.2"++ it "takes the first address when all are trusted" $ do+ let headers = [("X-Forwarded-For", "192.168.0.1, 10.0.0.2, 10.0.0.1")]+ resp <- runApp "127.0.0.1" headers realIp+ simpleBody resp `shouldBe` "192.168.0.1"++ it "handles repeated headers" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1"), ("X-Forwarded-For", "2.2.2.2")]+ resp <- runApp "127.0.0.1" headers realIp+ simpleBody resp `shouldBe` "2.2.2.2"++ it "handles ipv6 addresses" $ do+ let headers = [("X-Forwarded-For", "2001:db8::ff00:42:8329,10.0.0.1")]+ resp <- runApp "::1" headers realIp+ simpleBody resp `shouldBe` "2001:db8::ff00:42:8329"++ describe "realIpHeader" $ do+ it "uses specified header" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1"), ("X-Real-Ip", "2.2.2.2")]+ resp <- runApp "127.0.0.1" headers $ realIpHeader "X-Real-Ip"+ simpleBody resp `shouldBe` "2.2.2.2"++ describe "realIpTrusted" $ do+ it "uses provided trusted predicate" $ do+ let headers = [("X-Forwarded-For", "10.0.0.1, 1.1.1.1")]+ isTrusted1 ip = any (ipInRange ip) ["127.0.0.1/32", "1.1.1.1/32"]+ isTrusted2 = flip ipInRange "1.1.1.1/32"++ resp1 <- runApp "127.0.0.1" headers $ realIpTrusted "X-Forwarded-For" isTrusted1+ resp2 <- runApp "10.0.0.2" headers $ realIpTrusted "X-Forwarded-For" isTrusted2++ 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+ where+ app req respond = respond $ responseLBS status200 [] $ renderIp req+ renderIp = B8.pack . maybe "" (show . fst) . IP.fromSockAddr . remoteHost
+ test/Network/Wai/Middleware/RequestSizeLimitSpec.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.RequestSizeLimitSpec (main, spec) where++import Control.Monad (replicateM)+import Data.Aeson (encode, object, (.=))+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import Data.Text (Text)+import Network.HTTP.Types (hContentLength, status200, status413)+import Network.Wai+import Test.Hspec++import Network.Wai.Middleware.RequestSizeLimit+import Network.Wai.Test++main :: IO ()+main = hspec spec++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+ 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+ tenByteLimitJSONSettings =+ 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)++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++ runExpectations resp+ it "non-chunked" $ do+ let req = mkRequestWithBytestring reqBody UseKnownLength+ resp <- runStrictBodyApp settings req++ runExpectations resp+ where+ mkRequestWithBytestring :: ByteString -> LengthType -> SRequest+ mkRequestWithBytestring body lengthType =+ SRequest adjustedRequest $+ L.fromChunks $+ map S.singleton $+ S.unpack body+ where+ adjustedRequest =+ defaultRequest+ { requestHeaders =+ [ (hContentLength, S8.pack $ show $ S.length body)+ | lengthType == UseKnownLength+ ]+ , requestMethod = "POST"+ , requestBodyLength =+ if lengthType == UseKnownLength+ then KnownLength $ fromIntegral $ S.length body+ else ChunkedBody+ }++runStrictBodyApp :: RequestSizeLimitSettings -> SRequest -> IO SResponse+runStrictBodyApp settings req =+ runSession (srequest req) $+ requestSizeLimitMiddleware settings app+ where+ app req' respond = do+ _body <- strictRequestBody req'+ respond $ responseLBS status200 [] ""++runStreamingChunkApp+ :: Int -> RequestSizeLimitSettings -> Request -> IO SResponse+runStreamingChunkApp times settings req =+ runSession (request req) $+ requestSizeLimitMiddleware settings app+ where+ app req' respond = do+ _chunks <- replicateM times (getRequestBodyChunk req')+ respond $ responseLBS status200 [] ""
test/Network/Wai/Middleware/RoutedSpec.hs view
@@ -1,53 +1,60 @@ {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.RoutedSpec- ( main- , spec- ) where -import Test.Hspec--import Network.Wai.Middleware.Routed-import Network.Wai.Middleware.ForceSSL (forceSSL)+module Network.Wai.Middleware.RoutedSpec (+ main,+ spec,+) where +import Data.ByteString (ByteString)+import Data.String (IsString) import Network.HTTP.Types (hContentType, status200) import Network.Wai import Network.Wai.Test-import Data.ByteString (ByteString)-import Data.String (IsString)+import Test.Hspec +import Network.Wai.Middleware.ForceSSL (forceSSL)+import Network.Wai.Middleware.Routed+ main :: IO () main = hspec spec spec :: Spec spec = describe "forceSSL" $ do- it "routed middleware" $ do- let destination = "https://example.com/d/"- let routedSslJsonApp prefix = routedMiddleware (checkPrefix prefix) forceSSL jsonApp- checkPrefix p (p1:_) = p == p1- checkPrefix _ _ = False+ it "routed middleware" $ do+ let destination = "https://example.com/d/"+ let routedSslJsonApp prefix = routedMiddleware (checkPrefix prefix) forceSSL jsonApp+ checkPrefix p (p1 : _) = p == p1+ checkPrefix _ _ = False - flip runSession (routedSslJsonApp "r") $ do- res <- testDPath "http"- assertNoHeader location res- assertStatus 200 res- assertBody "{\"foo\":\"bar\"}" res+ flip runSession (routedSslJsonApp "r") $ do+ res <- testDPath "http"+ assertNoHeader location res+ assertStatus 200 res+ assertBody "{\"foo\":\"bar\"}" res - flip runSession (routedSslJsonApp "d") $ do- res2 <- testDPath "http"- assertHeader location destination res2- assertStatus 301 res2+ flip runSession (routedSslJsonApp "d") $ do+ res2 <- testDPath "http"+ assertHeader location destination res2+ assertStatus 301 res2 jsonApp :: Application-jsonApp _req cps = cps $ responseLBS status200- [(hContentType, "application/json")]- "{\"foo\":\"bar\"}"+jsonApp _req cps =+ cps $+ responseLBS+ status200+ [(hContentType, "application/json")]+ "{\"foo\":\"bar\"}" testDPath :: ByteString -> Session SResponse testDPath proto =- request $ flip setRawPathInfo "/d/" defaultRequest- { requestHeaders = [("X-Forwarded-Proto", proto)]- , requestHeaderHost = Just "example.com"- }+ request $+ flip+ setRawPathInfo+ "/d/"+ defaultRequest+ { requestHeaders = [("X-Forwarded-Proto", proto)]+ , requestHeaderHost = Just "example.com"+ } location :: IsString ci => ci location = "Location"
+ test/Network/Wai/Middleware/SelectSpec.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.SelectSpec (+ main,+ spec,+)+where++import Data.ByteString (ByteString)+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#endif+import Network.HTTP.Types (Status, status200, status401, status500)+import Network.Wai+import Network.Wai.Middleware.Select+import Network.Wai.Test (SResponse (simpleStatus), request, runSession)+import Test.Hspec++main :: IO ()+main = hspec spec++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++runApp :: Middleware -> ByteString -> IO Status+runApp mw path =+ fmap simpleStatus+ $ runSession+ (request $ defaultRequest{rawPathInfo = path})+ $ mw app++app :: Application+app = constApp status200++constApp :: Status -> Application+constApp status _ respond = respond $ responseLBS status [] ""++overrideMiddleware :: Application -> Middleware+overrideMiddleware = const++selectOverride :: ByteString -> Status -> MiddlewareSelection+selectOverride path status = selectMiddlewareOnRawPathInfo path $ overrideMiddleware $ constApp status
test/Network/Wai/Middleware/StripHeadersSpec.hs view
@@ -1,28 +1,28 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.StripHeadersSpec- ( main- , spec- ) where -import Test.Hspec--import Network.Wai.Middleware.AddHeaders-import Network.Wai.Middleware.StripHeaders+module Network.Wai.Middleware.StripHeadersSpec (+ main,+ spec,+) where import Control.Arrow (first) import Data.ByteString (ByteString)+import qualified Data.CaseInsensitive as CI+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>))+#endif import Network.HTTP.Types (status200) import Network.Wai-import Network.Wai.Test--import qualified Data.CaseInsensitive as CI+import Network.Wai.Test (SResponse (simpleHeaders), request, runSession)+import Test.Hspec +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"@@ -30,29 +30,45 @@ it "strips a specific header" $ do resp1 <- runApp host (addHeaders testHeaders) defaultRequest- resp2 <- runApp host (stripHeaderIf "Foo" (const False) . addHeaders testHeaders) defaultRequest- resp3 <- runApp host (stripHeaderIf "Foo" (const True) . addHeaders testHeaders) defaultRequest+ resp2 <-+ runApp+ host+ (stripHeaderIf "Foo" (const False) . addHeaders testHeaders)+ defaultRequest+ resp3 <-+ runApp+ host+ (stripHeaderIf "Foo" (const True) . addHeaders testHeaders)+ defaultRequest simpleHeaders resp1 `shouldBe` ciTestHeaders simpleHeaders resp2 `shouldBe` ciTestHeaders- simpleHeaders resp3 `shouldBe` tail ciTestHeaders+ simpleHeaders resp3 `shouldBe` drop 1 ciTestHeaders it "strips specific set of headers" $ do resp1 <- runApp host (addHeaders testHeaders) defaultRequest- resp2 <- runApp host (stripHeadersIf ["Bar", "Foo"] (const False) . addHeaders testHeaders) defaultRequest- resp3 <- runApp host (stripHeadersIf ["Bar", "Foo"] (const True) . addHeaders testHeaders) defaultRequest+ resp2 <-+ runApp+ host+ (stripHeadersIf ["Bar", "Foo"] (const False) . addHeaders testHeaders)+ defaultRequest+ resp3 <-+ runApp+ host+ (stripHeadersIf ["Bar", "Foo"] (const True) . addHeaders testHeaders)+ defaultRequest simpleHeaders resp1 `shouldBe` ciTestHeaders simpleHeaders resp2 `shouldBe` ciTestHeaders simpleHeaders resp3 `shouldBe` [last ciTestHeaders] - testHeaders :: [(ByteString, ByteString)] testHeaders = [("Foo", "fooey"), ("Bar", "barbican"), ("Baz", "bazooka")] - runApp :: ByteString -> Middleware -> Request -> IO SResponse-runApp host mw req = runSession- (request req { requestHeaderHost = Just $ host <> ":80" }) $ mw app+runApp host mw req =+ runSession+ (request req{requestHeaderHost = Just $ host <> ":80"})+ $ mw app where app _ respond = respond $ responseLBS status200 [] ""
test/Network/Wai/Middleware/TimeoutSpec.hs view
@@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Middleware.TimeoutSpec- ( spec- ) where--import Test.Hspec+module Network.Wai.Middleware.TimeoutSpec (+ spec,+) where import Control.Concurrent (threadDelay) import Network.HTTP.Types (status200, status503, status504) import Network.Wai+import Test.Hspec+ import Network.Wai.Middleware.Timeout import Network.Wai.Test
+ test/Network/Wai/Middleware/ValidateHeadersSpec.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ValidateHeadersSpec (spec) where++import Network.HTTP.Types (ResponseHeaders, status200)+import Network.Wai (Application, defaultRequest, responseLBS)+import Test.Hspec (Spec, describe, it)++import Network.Wai.Middleware.ValidateHeaders (validateHeadersMiddleware, defaultValidateHeadersSettings)+import Network.Wai.Test (Session, assertStatus, request, withSession)++spec :: Spec+spec = do+ describe "validateHeadersMiddleware" $ do+ it "allows token characters in header names" $ withHeadersApp [("token!#$%&'*+-.^_`|~123", "bar")] $ do+ assertStatus 200 =<< request defaultRequest++ it "does not allow colons in header names" $ withHeadersApp [("broken:header", "foo")] $ do+ assertStatus 500 =<< request defaultRequest++ it "does not allow whitespace in header names" $ do+ withHeadersApp [("white space", "foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("white\nspace", "foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("white\rspace", "foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("white\tspace", "foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("ehite\vspace", "foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("white\fspace", "foo")] $ assertStatus 500 =<< request defaultRequest++ it "allows visible ASCII, space and horizontal tab in header values" $ do+ withHeadersApp [("MyHeader", "the quick brown\tfox jumped over the lazy dog!")] $ do+ assertStatus 200 =<< request defaultRequest++ it "allows octets beyond 0x80 in headers values" $ do+ -- Just an example+ withHeadersApp [("MyHeader", "verr\252ckt")] $ do+ assertStatus 200 =<< request defaultRequest++ it "does not allow other whitespace in header values" $ do+ withHeadersApp [("MyHeader", "white\nspace")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("MyHeader", "white\rspace")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("MyHeader", "white\vspace")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("MyHeader", "white\fspace")] $ assertStatus 500 =<< request defaultRequest++ it "does not allow control characters in header values" $ do+ -- Just examples again+ withHeadersApp [("MyHeader", "control character \0")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("MyHeader", "control character \27")] $ assertStatus 500 =<< request defaultRequest++ it "does not allow trailing whitespace in header values" $ do+ withHeadersApp [("MyHeader", " foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("MyHeader", "foo ")] $ assertStatus 500 =<< request defaultRequest++withHeadersApp :: ResponseHeaders -> Session a -> IO a+withHeadersApp headers session =+ withSession (validateHeadersMiddleware defaultValidateHeadersSettings $ headersApp headers) session++headersApp :: ResponseHeaders -> Application+headersApp headers _ respond =+ respond $ responseLBS status200 headers ""
test/Network/Wai/ParseSpec.hs view
@@ -1,24 +1,32 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.ParseSpec (main, spec) where -import Test.Hspec-import Test.HUnit+module Network.Wai.ParseSpec (main, spec) where -import System.IO-import Data.Monoid-import qualified Data.IORef as I+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid+#endif+import Control.Monad.Trans.Resource (runResourceT, withInternalState) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L+import qualified Data.IORef as I import qualified Data.Text as TS import qualified Data.Text.Encoding as TE-import Control.Monad.Trans.Resource (withInternalState, runResourceT)-import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )+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 -import Network.Wai-import Network.Wai.Test-import Network.Wai.Parse-import WaiExtraSpec (toRequest)+import Network.Wai.Parse+import Network.Wai.Test (SRequest (SRequest))+import WaiExtraSpec (toRequest) main :: IO () main = hspec spec@@ -27,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@@ -45,167 +62,208 @@ 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 multipart/form-data 2" $ 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")], []) - 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)+ 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) - let unknownErrorException c (ConnectionError (UnknownErrorCode code) _) = c == code- unknownErrorException _ _ = False+ it "parsing post multipart/form-data" $ do+ result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2+ result2 `shouldBe` expected2 + 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` unknownErrorException 413+ 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` unknownErrorException 413- SRequest req5 _bod5 <- toRequest'' ctype3 content5- (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req5)- `shouldThrow` unknownErrorException 413+ 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` unknownErrorException 413+ 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` unknownErrorException 431+ 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+ it "parsing filename with semi-colon" $ do+ SRequest req _bod <- toRequest'' ctype3 content6+ let expected = ([], [("yaml", FileInfo "semi; colon;" "application/octet-stream" "Photo blog using Hack.\n")])+ body <- parseRequestBodyEx def lbsBackEnd req+ body `shouldBe` expected+ it "parsing filename with semi-colon" $ do+ SRequest req _bod <- toRequest'' ctype3 content7+ let expected = ([], [("yaml", FileInfo "this will be dropped, !only this will be returned" "application/octet-stream" "Photo blog using Hack.\n")])+ body <- parseRequestBodyEx def lbsBackEnd req+ body `shouldBe` expected 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"+ content6 =+ "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"+ <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"semi; colon;\"\r\n"+ <> "Content-Type: application/octet-stream\r\n\r\n"+ <> "Photo blog using Hack.\n\r\n"+ <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"+ content7 =+ "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"+ <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"this will be dropped, \\!only this will be returned\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@@ -213,11 +271,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@@ -226,17 +284,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"@@ -254,8 +312,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")@@ -264,9 +328,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 ([], [])@@ -278,17 +343,25 @@ length files @?= 1 toRequest' :: S8.ByteString -> S8.ByteString -> SRequest-toRequest' ctype content = SRequest defaultRequest- { requestHeaders = [("Content-Type", ctype)]- } (L.fromChunks $ map S.singleton $ S.unpack content)+toRequest' ctype content =+ SRequest+ defaultRequest+ { requestHeaders = [("Content-Type", ctype)]+ }+ (L.fromChunks $ map S.singleton $ S.unpack content) toRequest'' :: S8.ByteString -> S8.ByteString -> IO SRequest-toRequest'' ctype content = mkRB content >>= \b -> return $ SRequest defaultRequest- { requestHeaders = [("Content-Type", ctype)], requestBody = b- } (L.fromChunks $ map S.singleton $ S.unpack content)+toRequest'' ctype content =+ mkRB content >>= \b -> do+ let req =+ setRequestBodyChunks+ b+ defaultRequest{requestHeaders = [("Content-Type", ctype)]}+ return $ SRequest req (L.fromChunks $ map S.singleton $ S.unpack content) mkRB :: S8.ByteString -> IO (IO S8.ByteString) mkRB content = do r <- I.newIORef content return $- I.atomicModifyIORef r $ \a -> (S8.empty, a)+ I.atomicModifyIORef r $+ \a -> (S8.empty, a)
test/Network/Wai/RequestSpec.hs view
@@ -1,18 +1,23 @@ {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.RequestSpec- ( main- , spec- ) where -import Test.Hspec+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(..), defaultRequest, RequestBodyLength(..))-+import Network.Wai (+ Request (..),+ RequestBodyLength (..),+ defaultRequest,+ getRequestBodyChunk,+ setRequestBodyChunks,+ ) import Network.Wai.Request-import Control.Exception (try)-import Control.Monad (forever)+import Test.Hspec main :: IO () main = hspec spec@@ -22,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 @@ -86,8 +96,9 @@ req `shouldSatisfy` appearsSecure addHeader :: HeaderName -> ByteString -> Request -> Request-addHeader name value req = req- { requestHeaders = (name, value) : otherHeaders }-+addHeader name value req =+ req+ { requestHeaders = (name, value) : otherHeaders+ } where otherHeaders = filter ((/= name) . fst) $ requestHeaders req
test/Network/Wai/TestSpec.hs view
@@ -1,28 +1,22 @@ {-# LANGUAGE OverloadedStrings #-}-module Network.Wai.TestSpec (main, spec) where -import Control.Monad (void)+module Network.Wai.TestSpec (main, spec) where +import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, toLazyByteString)+import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.IORef as IORef- import qualified Data.Text.Encoding as TE--import Data.Time.Calendar (fromGregorian)-import Data.Time.Clock (UTCTime(..))--import Test.Hspec--import Network.Wai-import Network.Wai.Test--import Network.HTTP.Types (status200)--import qualified Data.ByteString.Lazy.Char8 as L8-import Data.ByteString.Builder (Builder, toLazyByteString)-import Data.ByteString (ByteString)-+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (..))+import Network.HTTP.Types (status200)+import Network.Wai+import Test.Hspec import qualified Web.Cookie as Cookie +import Network.Wai.Test+ main :: IO () main = hspec spec @@ -31,197 +25,217 @@ 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"]-- it "sets rawPathInfo" $ do- rawPathInfo req `shouldBe` "/foo/bar/baz"-- it "sets queryString" $ do- queryString req `shouldBe` [("foo", Just "23"), ("bar", Just "42"), ("baz", Nothing)]-- it "sets rawQueryString" $ do- rawQueryString req `shouldBe` "?foo=23&bar=42&baz"+ describe "setPath" $ do+ let req = setPath defaultRequest "/foo/bar/baz?foo=23&bar=42&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 pathInfo" $ do+ pathInfo req `shouldBe` ["foo", "bar", "baz"] - describe "srequest" $ do+ it "utf8 path" $+ pathInfo (setPath defaultRequest "/foo/%D7%A9%D7%9C%D7%95%D7%9D/bar")+ `shouldBe` ["foo", "שלום", "bar"] - let echoApp req respond = do- reqBody <- L8.fromStrict <$> getRequestBodyChunk req- let reqHeaders = requestHeaders req- respond $- responseLBS- status200- reqHeaders- reqBody+ it "sets rawPathInfo" $ do+ rawPathInfo req `shouldBe` "/foo/bar/baz" - it "returns the response body of an echo app" $ do- sresp <- flip runSession echoApp $- srequest $ SRequest defaultRequest "request body"- simpleBody sresp `shouldBe` "request body"+ it "sets queryString" $ do+ queryString req+ `shouldBe` [("foo", Just "23"), ("bar", Just "42"), ("baz", Nothing)] - describe "request" $ 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 status code of an echo app on default request" $ do- sresp <- runSession (request defaultRequest) echoApp- simpleStatus sresp `shouldBe` status200+ describe "srequest" $ do+ let echoApp req respond = do+ reqBody <- L8.fromStrict <$> getRequestBodyChunk req+ let reqHeaders = requestHeaders req+ respond $+ responseLBS+ status200+ reqHeaders+ reqBody - 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+ sresp <-+ flip runSession echoApp $+ srequest $+ SRequest defaultRequest "request body"+ 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")]+ describe "request" $ do+ let echoApp req respond = do+ reqBody <- L8.fromStrict <$> getRequestBodyChunk req+ let reqHeaders = requestHeaders req+ respond $+ responseLBS+ status200+ reqHeaders+ reqBody - 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 "returns the status code of an echo app on default request" $ do+ sresp <- runSession (request defaultRequest) echoApp+ simpleStatus sresp `shouldBe` status200 - 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 "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 "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 "returns the response headers of an echo app" $ do+ sresp <-+ flip runSession echoApp $+ request $+ defaultRequest+ { requestHeaders = [("foo", "bar")]+ }+ simpleHeaders sresp `shouldBe` [("foo", "bar")] - 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\"]"+ let cookieApp req respond =+ case pathInfo req of+ ["set", name, val] ->+ respond $+ responseLBS+ status200+ [+ ( "Set-Cookie"+ , toByteString $+ Cookie.renderSetCookie $+ Cookie.defaultSetCookie+ { Cookie.setCookieName = TE.encodeUtf8 name+ , Cookie.setCookieValue = TE.encodeUtf8 val+ }+ )+ ]+ "set_cookie_body"+ ["delete", name] ->+ respond $+ responseLBS+ status200+ [+ ( "Set-Cookie"+ , toByteString $+ Cookie.renderSetCookie $+ Cookie.defaultSetCookie+ { 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 "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 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 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 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 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 "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 "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 "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.defaultSetCookie+ { 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.defaultSetCookie+ { Cookie.setCookieName = "cookie_name"+ , Cookie.setCookieValue = "cookie_value"+ }+ )+ setClientCookie+ ( Cookie.defaultSetCookie+ { 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.defaultSetCookie+ { Cookie.setCookieName = "cookie_name"+ , Cookie.setCookieValue = "cookie_value"+ }+ )+ deleteClientCookie "cookie_name"+ request $+ setPath defaultRequest "/get"+ simpleBody sresp `shouldBe` "[]"
test/WaiExtraSpec.hs view
@@ -1,79 +1,108 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-module WaiExtraSpec (spec, toRequest) where -import Test.Hspec-import Test.HUnit hiding (Test)-#if MIN_VERSION_base(4,8,0)-import Data.Monoid ((<>))-#else-import Data.Monoid (mempty, mappend, (<>))-#endif+module WaiExtraSpec (spec, toRequest) where -import Network.Wai-import Network.Wai.Test-import Network.Wai.UrlMap+import Codec.Compression.GZip (decompress)+import Control.Applicative ((<|>))+import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L-import qualified Data.Text.Lazy as T+import qualified Data.IORef as I+import Data.Maybe (fromMaybe)+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (mempty, mappend)+#endif+#endif import qualified Data.Text as TS import qualified Data.Text.Encoding as TE-import Control.Applicative+import qualified Data.Text.Lazy as T+import Network.HTTP.Types (+ Header,+ RequestHeaders,+ ResponseHeaders,+ hContentEncoding,+ hContentLength,+ hContentType,+ partialContent206,+ status200,+ )+import Network.HTTP.Types.Header (hAcceptEncoding, hVary)+import Network.Wai+import System.Directory (listDirectory)+import System.IO.Temp (withSystemTempDirectory)+import System.Log.FastLogger (fromLogStr)+import Test.HUnit (Assertion, assertBool, assertEqual, (@?=))+import Test.Hspec -import Network.Wai.Middleware.Jsonp-import Network.Wai.Middleware.Gzip-import Network.Wai.Middleware.Vhost-import Network.Wai.Middleware.Autohead-import Network.Wai.Middleware.MethodOverride-import Network.Wai.Middleware.MethodOverridePost-import Network.Wai.Middleware.AcceptOverride+import Network.Wai.Header (parseQValueList)+import Network.Wai.Middleware.AcceptOverride (acceptOverride)+import Network.Wai.Middleware.Autohead (autohead)+import Network.Wai.Middleware.Gzip (+ GzipFiles (..),+ GzipSettings (..),+ defaultGzipSettings,+ defaultCheckMime,+ gzip,+ )+import Network.Wai.Middleware.Jsonp (jsonp)+import Network.Wai.Middleware.MethodOverride (methodOverride)+import Network.Wai.Middleware.MethodOverridePost (methodOverridePost) import Network.Wai.Middleware.RequestLogger-import Codec.Compression.GZip (decompress)-import Network.Wai.Middleware.StreamFile--import Control.Monad.IO.Class (liftIO)-import Data.Maybe (fromMaybe)-import Network.HTTP.Types (status200)-import System.Log.FastLogger--import qualified Data.IORef as I+import Network.Wai.Middleware.StreamFile (streamFile)+import Network.Wai.Middleware.Vhost (vhost)+import Network.Wai.Test+import Network.Wai.UrlMap (mapUrls, mount, mountRoot) spec :: Spec spec = do- describe "Network.Wai.UrlMap" $ do- mapM_ (uncurry it) casesUrlMap+ describe "Network.Wai.UrlMap" $ do+ mapM_ (uncurry it) casesUrlMap - describe "Network.Wai" $ do- {-- , it "findBound" caseFindBound- , it "sinkTillBound" caseSinkTillBound- , it "killCR" caseKillCR- , it "killCRLF" caseKillCRLF- , it "takeLine" caseTakeLine- -}- it "jsonp" caseJsonp- it "gzip" caseGzip- it "gzip not for MSIE" caseGzipMSIE- it "gzip bypass when precompressed" caseGzipBypassPre- it "defaultCheckMime" caseDefaultCheckMime- it "vhost" caseVhost- it "autohead" caseAutohead- it "method override" caseMethodOverride- it "method override post" caseMethodOverridePost- it "accept override" caseAcceptOverride- it "debug request body" caseDebugRequestBody- it "stream file" caseStreamFile- it "stream LBS" caseStreamLBS+ describe "Network.Wai" $ do+ {-+ , it "findBound" caseFindBound+ , it "sinkTillBound" caseSinkTillBound+ , it "killCR" caseKillCR+ , it "killCRLF" caseKillCRLF+ , it "takeLine" caseTakeLine+ -}+ it "jsonp" caseJsonp+ describe "gzip" $ do+ it "gzip" caseGzip+ it "more gzip" caseGzip2+ it "gzip not on partial content" caseGzipPartial+ it "gzip removes length header" caseGzipLength+ it "gzip not for MSIE" caseGzipMSIE+ it "gzip bypass when precompressed" caseGzipBypassPre+ it "defaultCheckMime" caseDefaultCheckMime+ it "gzip checking of files" caseGzipFiles+ it "vhost" caseVhost+ it "autohead" caseAutohead+ it "method override" caseMethodOverride+ it "method override post" caseMethodOverridePost+ it "accept override" caseAcceptOverride+ it "debug request body" caseDebugRequestBody+ it "stream file" caseStreamFile+ it "stream LBS" caseStreamLBS+ it "can modify POST params before logging" caseModifyPostParamsInLogs+ it "can filter requests in logs" caseFilterRequestsInLogs+ it "can parse Q values" caseQValues toRequest :: S8.ByteString -> S8.ByteString -> SRequest-toRequest ctype content = SRequest defaultRequest- { requestHeaders = [("Content-Type", ctype)]- , requestMethod = "POST"- , rawPathInfo = "/"- , rawQueryString = ""- , queryString = []- } (L.fromChunks [content])+toRequest ctype content =+ SRequest+ defaultRequest+ { requestHeaders = [("Content-Type", ctype)]+ , requestMethod = "POST"+ , rawPathInfo = "/"+ , rawQueryString = ""+ , queryString = []+ }+ (L.fromChunks [content]) {- caseFindBound :: Assertion@@ -127,28 +156,36 @@ -} jsonpApp :: Application-jsonpApp = jsonp $ \_ f -> f $ responseLBS- status200- [("Content-Type", "application/json")]- "{\"foo\":\"bar\"}"+jsonpApp = jsonp $ \_ f ->+ f $+ responseLBS+ status200+ [("Content-Type", "application/json")]+ "{\"foo\":\"bar\"}" caseJsonp :: Assertion-caseJsonp = flip runSession jsonpApp $ do- sres1 <- request defaultRequest+caseJsonp = withSession jsonpApp $ do+ sres1 <-+ request+ defaultRequest { queryString = [("callback", Just "test")] , requestHeaders = [("Accept", "text/javascript")] } assertContentType "text/javascript" sres1 assertBody "test({\"foo\":\"bar\"})" sres1 - sres2 <- request defaultRequest+ sres2 <-+ request+ defaultRequest { queryString = [("call_back", Just "test")] , requestHeaders = [("Accept", "text/javascript")] } assertContentType "application/json" sres2 assertBody "{\"foo\":\"bar\"}" sres2 - sres3 <- request defaultRequest+ sres3 <-+ request+ defaultRequest { queryString = [("callback", Just "test")] , requestHeaders = [("Accept", "text/html")] }@@ -156,32 +193,221 @@ assertBody "{\"foo\":\"bar\"}" sres3 gzipApp :: Application-gzipApp = gzip def $ \_ f -> f $ responseLBS status200- [("Content-Type", "text/plain")]- "test"+gzipApp = gzipApp' id --- Lie a little and don't compress the body. This way we test--- that the compression is skipped based on the presence of--- the Content-Encoding header.-gzipPrecompressedApp :: Application-gzipPrecompressedApp = gzip def $ \_ f -> f $ responseLBS status200- [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")]- "test"+gzipApp' :: (Response -> Response) -> Application+gzipApp' changeRes =+ gzip defaultGzipSettings $ \_ f ->+ f . changeRes $+ responseLBS+ status200+ [("Content-Type", "text/plain")]+ "test" -caseGzip :: Assertion-caseGzip = flip runSession gzipApp $ do- sres1 <- request defaultRequest- { requestHeaders = [("Accept-Encoding", "gzip")]+gzipAppWithHeaders :: ResponseHeaders -> Application+gzipAppWithHeaders hdrs = gzipApp' $ mapResponseHeaders (hdrs ++)++gzipFileApp :: GzipSettings -> Application+gzipFileApp = flip gzipFileApp' id++gzipJSONFile, gzipNoPreCompressFile :: FilePath+gzipJSONFile = "test/json"+gzipNoPreCompressFile = "test/noprecompress"++gzipJSONBody, gzipNocompressBody :: L.ByteString+#if WINDOWS+gzipJSONBody = "{\"data\":\"this is some data\"}\r\n"+gzipNocompressBody = "noprecompress\r\n"+#else+gzipJSONBody = "{\"data\":\"this is some data\"}\n"+gzipNocompressBody = "noprecompress\n"+#endif++-- | Use 'changeRes' to make r+gzipFileApp' :: GzipSettings -> (Response -> Response) -> Application+gzipFileApp' set changeRes =+ gzip set $ \_ f ->+ f . changeRes $+ responseFile status200 [(hContentType, "application/json")] gzipJSONFile Nothing++acceptGzip :: Header+acceptGzip = (hAcceptEncoding, "gzip")++doesEncodeGzip :: RequestHeaders -> Session SResponse+doesEncodeGzip = doesEncodeGzip' "test"++doesEncodeGzipJSON :: RequestHeaders -> Session SResponse+doesEncodeGzipJSON = doesEncodeGzip' gzipJSONBody++doesEncodeGzipNoPreCompress :: RequestHeaders -> Session SResponse+doesEncodeGzipNoPreCompress = doesEncodeGzip' gzipNocompressBody++doesEncodeGzip' :: L.ByteString -> RequestHeaders -> Session SResponse+doesEncodeGzip' body hdrs = do+ sres <-+ request+ defaultRequest+ { requestHeaders = hdrs }- assertHeader "Content-Encoding" "gzip" sres1- liftIO $ decompress (simpleBody sres1) @?= "test"+ assertHeader hContentEncoding "gzip" sres+ assertHeader hVary "Accept-Encoding" sres+ liftIO $ decompress (simpleBody sres) @?= body+ pure sres - sres2 <- request defaultRequest- { requestHeaders = []+doesNotEncodeGzip :: RequestHeaders -> Session SResponse+doesNotEncodeGzip = doesNotEncodeGzip' "test"++doesNotEncodeGzipJSON :: RequestHeaders -> Session SResponse+doesNotEncodeGzipJSON = doesNotEncodeGzip' gzipJSONBody++doesNotEncodeGzipNoPreCompress :: RequestHeaders -> Session SResponse+doesNotEncodeGzipNoPreCompress = doesNotEncodeGzip' gzipNocompressBody++doesNotEncodeGzip' :: L.ByteString -> RequestHeaders -> Session SResponse+doesNotEncodeGzip' body hdrs = do+ sres <-+ request+ defaultRequest+ { requestHeaders = hdrs }- assertNoHeader "Content-Encoding" sres2- assertBody "test" sres2+ assertNoHeader hContentEncoding sres+ assertHeader hVary "Accept-Encoding" sres+ assertBody body sres+ pure sres +caseGzip :: Assertion+caseGzip = do+ withSession gzipApp $ do+ _ <- doesEncodeGzip [acceptGzip]+ _ <- doesNotEncodeGzip []+ _ <- doesEncodeGzip [(hAcceptEncoding, "compress , gzip ; q=0.8")]+ pure ()++ withSession (gzipAppWithHeaders [(hContentLength, "200")]) $ do+ sres4 <- doesNotEncodeGzip [acceptGzip]+ assertHeader hContentLength "200" sres4++caseGzipLength :: Assertion+caseGzipLength = do+ withSession (gzipAppWithHeaders [(hContentLength, "4000")]) $ do+ sres <- doesEncodeGzip [acceptGzip]+ assertNoHeader hContentLength sres++caseGzipPartial :: Assertion+caseGzipPartial =+ withSession partialApp $ do+ _ <- doesNotEncodeGzip [acceptGzip]+ pure ()+ where+ partialApp = gzipApp' $ mapResponseStatus $ const partialContent206++-- | Checking that it doesn't compress when already compressed AND+-- doesn't replace already set "Vary" header.+caseGzip2 :: Assertion+caseGzip2 =+ withSession gzipVariantApp $ do+ sres1 <-+ request+ defaultRequest+ { requestHeaders = [(hAcceptEncoding, "compress, gzip")]+ }+ assertHeader hContentEncoding "compress" sres1+ assertHeader hVary "Accept-Encoding, foobar" sres1+ where+ gzipVariantApp =+ gzipAppWithHeaders+ [ ("Content-Encoding", "compress")+ , ("Vary", "foobar")+ ]++-- | Testing of the GzipSettings's 'GzipFiles' setting+-- with 'ResponseFile' responses.+caseGzipFiles :: Assertion+caseGzipFiles = do+ -- Default GzipSettings ignore compressing files+ withSession (gzipFileApp defaultGzipSettings) $ do+ _ <- doesNotEncodeGzipJSON [acceptGzip]+ _ <- doesNotEncodeGzipJSON []+ pure ()++ -- Just compresses the file+ withSession (gzipFileApp defaultGzipSettings{gzipFiles = GzipCompress}) $ do+ _ <- doesEncodeGzipJSON [acceptGzip]+ _ <- doesNotEncodeGzipJSON []+ pure ()++ -- Checks for a "filename.gz" file in the same folder+ withSession (gzipFileApp defaultGzipSettings{gzipFiles = GzipPreCompressed GzipIgnore}) $ do+ sres <-+ request+ defaultRequest+ { requestHeaders = [acceptGzip]+ }+ assertHeader hContentEncoding "gzip" sres+ assertHeader hVary "Accept-Encoding" sres+ -- json.gz has body "test\n"+ assertBody+#if WINDOWS+ "test\r\n"+#else+ "test\n"+#endif+ sres++ _ <- doesNotEncodeGzipJSON []+ pure ()++ -- If no "filename.gz" file is in the same folder, just ignore+ withSession (noPreCompressApp $ GzipPreCompressed GzipIgnore) $ do+ _ <- doesNotEncodeGzipNoPreCompress [acceptGzip]+ _ <- doesNotEncodeGzipNoPreCompress []+ pure ()++ -- If no "filename.gz" file is in the same folder, just compress+ withSession (noPreCompressApp $ GzipPreCompressed GzipCompress) $ do+ _ <- doesEncodeGzipNoPreCompress [acceptGzip]+ _ <- doesNotEncodeGzipNoPreCompress []+ pure ()++ -- Using a caching directory+ withSystemTempDirectory "gziptest" $ \path -> do+ let checkTempDir n s = do+ fs <- listDirectory path+ assertBool s $ length fs == n+ checkTempDir 0 "temp directory should be empty"+ -- Respond with "test/json" file+ withSession (gzipFileApp defaultGzipSettings{gzipFiles = GzipCacheFolder path}) $ do+ _ <- doesEncodeGzipJSON [acceptGzip]+ liftIO $ checkTempDir 1 "should have one file"+ _ <- doesEncodeGzipJSON [acceptGzip]+ liftIO $ checkTempDir 1 "should still have only one file"+ _ <- doesNotEncodeGzipJSON []+ liftIO $ checkTempDir 1 "should not have done anything"++ -- Respond with "test/noprecompress" file+ withSession (noPreCompressApp $ GzipCacheFolder path) $ do+ _ <- doesEncodeGzipNoPreCompress [acceptGzip]+ liftIO $ checkTempDir 2 "should now have 2 files"+ _ <- doesEncodeGzipNoPreCompress [acceptGzip]+ liftIO $ checkTempDir 2 "should still only have 2 files"+ _ <- doesNotEncodeGzipNoPreCompress []+ liftIO $ checkTempDir 2 "again should not have done anything"++ -- try "test/json" again, just to make sure it isn't a weird Session bug+ withSession (gzipFileApp defaultGzipSettings{gzipFiles = GzipCacheFolder path}) $ do+ _ <- doesEncodeGzipJSON [acceptGzip]+ liftIO $ checkTempDir 2 "just to make sure it isn't a fluke"+ where+ noPreCompressApp set =+ gzipFileApp'+ defaultGzipSettings{gzipFiles = set}+ $ const+ $ responseFile+ status200+ [(hContentType, "text/plain")]+ gzipNoPreCompressFile+ Nothing+ caseDefaultCheckMime :: Assertion caseDefaultCheckMime = do let go x y = (x, defaultCheckMime x) `shouldBe` (x, y)@@ -193,81 +419,105 @@ go "application/json; charset=utf-8" True caseGzipMSIE :: Assertion-caseGzipMSIE = flip runSession gzipApp $ do- sres1 <- request defaultRequest- { requestHeaders =- [ ("Accept-Encoding", "gzip")- , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")- ]- }- assertNoHeader "Content-Encoding" sres1- liftIO $ simpleBody sres1 @?= "test"+caseGzipMSIE = withSession gzipApp $ do+ sres1 <-+ doesNotEncodeGzip+ [ acceptGzip+ , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")+ ]+ assertHeader "Vary" "Accept-Encoding" sres1 caseGzipBypassPre :: Assertion-caseGzipBypassPre = flip runSession gzipPrecompressedApp $ do- sres1 <- request defaultRequest- { requestHeaders = [("Accept-Encoding", "gzip")]- }- assertHeader "Content-Encoding" "gzip" sres1- assertBody "test" sres1 -- the body is not actually compressed+caseGzipBypassPre =+ -- Lie a little and don't compress the body. This way we test+ -- that the compression is skipped based on the presence of+ -- the Content-Encoding header.+ withSession (gzipAppWithHeaders [(hContentEncoding, "gzip")]) $ do+ sres1 <- request defaultRequest{requestHeaders = [acceptGzip]}+ assertHeader "Content-Encoding" "gzip" sres1+ assertHeader "Vary" "Accept-Encoding" sres1+ assertBody "test" sres1 -- the body is not actually compressed vhostApp1, vhostApp2, vhostApp :: Application vhostApp1 _ f = f $ responseLBS status200 [] "app1" vhostApp2 _ f = f $ responseLBS status200 [] "app2"-vhostApp = vhost- [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1)- ]- vhostApp2+vhostApp =+ vhost+ [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1)+ ]+ vhostApp2 caseVhost :: Assertion-caseVhost = flip runSession vhostApp $ do- sres1 <- request defaultRequest+caseVhost = withSession vhostApp $ do+ sres1 <-+ request+ defaultRequest { requestHeaders = [("Host", "foo.com")] } assertBody "app1" sres1 - sres2 <- request defaultRequest+ sres2 <-+ request+ defaultRequest { requestHeaders = [("Host", "bar.com")] } assertBody "app2" sres2 autoheadApp :: Application-autoheadApp = autohead $ \_ f -> f $ responseLBS status200- [("Foo", "Bar")] "body"+autoheadApp = autohead $ \_ f ->+ f $+ responseLBS+ status200+ [("Foo", "Bar")]+ "body" caseAutohead :: Assertion-caseAutohead = flip runSession autoheadApp $ do- sres1 <- request defaultRequest+caseAutohead = withSession autoheadApp $ do+ sres1 <-+ request+ defaultRequest { requestMethod = "GET" } assertHeader "Foo" "Bar" sres1 assertBody "body" sres1 - sres2 <- request defaultRequest+ sres2 <-+ request+ defaultRequest { requestMethod = "HEAD" } assertHeader "Foo" "Bar" sres2 assertBody "" sres2 moApp :: Application-moApp = methodOverride $ \req f -> f $ responseLBS status200- [("Method", requestMethod req)] ""+moApp = methodOverride $ \req f ->+ f $+ responseLBS+ status200+ [("Method", requestMethod req)]+ "" caseMethodOverride :: Assertion-caseMethodOverride = flip runSession moApp $ do- sres1 <- request defaultRequest+caseMethodOverride = withSession moApp $ do+ sres1 <-+ request+ defaultRequest { requestMethod = "GET" , queryString = [] } assertHeader "Method" "GET" sres1 - sres2 <- request defaultRequest+ sres2 <-+ request+ defaultRequest { requestMethod = "POST" , queryString = [] } assertHeader "Method" "POST" sres2 - sres3 <- request defaultRequest+ sres3 <-+ request+ defaultRequest { requestMethod = "POST" , queryString = [("_method", Just "PUT")] }@@ -277,47 +527,62 @@ mopApp = methodOverridePost $ \req f -> f $ responseLBS status200 [("Method", requestMethod req)] "" caseMethodOverridePost :: Assertion-caseMethodOverridePost = flip runSession mopApp $ do-+caseMethodOverridePost = withSession mopApp $ do -- Get Request are unmodified- sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"- s = simpleRequest r- m = s { requestMethod = "GET" }- b = r { simpleRequest = m }- in srequest b+ sres1 <-+ let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"+ s = simpleRequest r+ m = s{requestMethod = "GET"}+ b = r{simpleRequest = m}+ in srequest b assertHeader "Method" "GET" sres1 -- Post requests are modified if _method comes first- sres2 <- srequest $ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"+ sres2 <-+ srequest $+ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin" assertHeader "Method" "PUT" sres2 -- Post requests are unmodified if _method doesn't come first- sres3 <- srequest $ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin"+ sres3 <-+ srequest $+ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin" assertHeader "Method" "POST" sres3 -- Post requests are unmodified if Content-Type header isn't set to "application/x-www-form-urlencoded"- sres4 <- srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin"+ sres4 <-+ srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin" assertHeader "Method" "POST" sres4 aoApp :: Application-aoApp = acceptOverride $ \req f -> f $ responseLBS status200- [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""+aoApp = acceptOverride $ \req f ->+ f $+ responseLBS+ status200+ [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)]+ "" caseAcceptOverride :: Assertion-caseAcceptOverride = flip runSession aoApp $ do- sres1 <- request defaultRequest+caseAcceptOverride = withSession aoApp $ do+ sres1 <-+ request+ defaultRequest { queryString = [] , requestHeaders = [("Accept", "foo")] } assertHeader "Accept" "foo" sres1 - sres2 <- request defaultRequest+ sres2 <-+ request+ defaultRequest { queryString = [] , requestHeaders = [("Accept", "bar")] } assertHeader "Accept" "bar" sres2 - sres3 <- request defaultRequest+ sres3 <-+ request+ defaultRequest { queryString = [("_accept", Just "baz")] , requestHeaders = [("Accept", "bar")] }@@ -325,33 +590,42 @@ caseDebugRequestBody :: Assertion caseDebugRequestBody = do- flip runSession (debugApp postOutput) $ do+ withSession (debugApp postOutput) $ do let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin" res <- srequest req assertStatus 200 res let qs = "?foo=bar&baz=bin"- flip runSession (debugApp $ getOutput params) $ do- assertStatus 200 =<< request defaultRequest- { requestMethod = "GET"- , queryString = map (\(k,v) -> (k, Just v)) params- , rawQueryString = qs- , requestHeaders = []- , rawPathInfo = "/location"- }+ withSession (debugApp $ getOutput params) $ do+ assertStatus 200+ =<< request+ defaultRequest+ { requestMethod = "GET"+ , queryString = map (\(k, v) -> (k, Just v)) params+ , rawQueryString = qs+ , requestHeaders = []+ , rawPathInfo = "/location"+ } 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")- getOutput params' = ("GET /location\n Params: " <> T.pack (show params') <> "\n Accept: \n Status: 200 OK 0", "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)- , outputFormat = Detailed False- }- res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send+ middleware <-+ mkRequestLogger+ defaultRequestLoggerSettings+ { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs)+ , outputFormat = Detailed False+ }+ res <- middleware (\_req f -> f $ responseLBS status200 [] "") req send actual <- logToBs <$> I.readIORef iactual actual `shouldSatisfy` S.isPrefixOf begin actual `shouldSatisfy` S.isSuffixOf end@@ -359,72 +633,73 @@ return res where begin = TE.encodeUtf8 $ T.toStrict beginning- end = TE.encodeUtf8 $ T.toStrict ending+ end = TE.encodeUtf8 $ T.toStrict ending logToBs = fromLogStr - {-debugApp = debug $ \req -> do-}- {-return $ responseLBS status200 [ ] ""-}+{-debugApp = debug $ \req -> do-}+{-return $ responseLBS status200 [ ] ""-} urlMapTestApp :: Application-urlMapTestApp = mapUrls $- mount "bugs" bugsApp- <|> mount "helpdesk" helpdeskApp- <|> mount "api"- ( mount "v1" apiV1- <|> mount "v2" apiV2- )- <|> mountRoot mainApp-+urlMapTestApp =+ mapUrls $+ mount "bugs" bugsApp+ <|> mount "helpdesk" helpdeskApp+ <|> mount+ "api"+ ( mount "v1" apiV1+ <|> mount "v2" apiV2+ )+ <|> mountRoot mainApp where- trivialApp :: S.ByteString -> Application- trivialApp name req f =- f $- responseLBS- status200- [ ("content-type", "text/plain")- , ("X-pathInfo", S8.pack . show . pathInfo $ req)- , ("X-rawPathInfo", rawPathInfo req)- , ("X-appName", name)- ]- ""+ trivialApp :: S.ByteString -> Application+ trivialApp name req f =+ f $+ responseLBS+ status200+ [ ("content-type", "text/plain")+ , ("X-pathInfo", S8.pack . show . pathInfo $ req)+ , ("X-rawPathInfo", rawPathInfo req)+ , ("X-appName", name)+ ]+ "" - bugsApp = trivialApp "bugs"- helpdeskApp = trivialApp "helpdesk"- apiV1 = trivialApp "apiv1"- apiV2 = trivialApp "apiv2"- mainApp = trivialApp "main"+ bugsApp = trivialApp "bugs"+ helpdeskApp = trivialApp "helpdesk"+ apiV1 = trivialApp "apiv1"+ apiV2 = trivialApp "apiv2"+ mainApp = trivialApp "main" casesUrlMap :: [(String, Assertion)] casesUrlMap = [pair1, pair2, pair3, pair4] where- makePair name session = (name, runSession session urlMapTestApp)- get reqPath = request $ setPath defaultRequest reqPath- s = S8.pack . show :: [TS.Text] -> S.ByteString+ makePair name session = (name, runSession session urlMapTestApp)+ get reqPath = request $ setPath defaultRequest reqPath+ s = S8.pack . show :: [TS.Text] -> S.ByteString - pair1 = makePair "should mount root" $ do- res1 <- get "/"- assertStatus 200 res1- assertHeader "X-rawPathInfo" "/" res1- assertHeader "X-pathInfo" (s []) res1- assertHeader "X-appName" "main" res1+ pair1 = makePair "should mount root" $ do+ res1 <- get "/"+ assertStatus 200 res1+ assertHeader "X-rawPathInfo" "/" res1+ assertHeader "X-pathInfo" (s []) res1+ assertHeader "X-appName" "main" res1 - pair2 = makePair "should mount apps" $ do- res2 <- get "/bugs"- assertStatus 200 res2- assertHeader "X-rawPathInfo" "/" res2- assertHeader "X-pathInfo" (s []) res2- assertHeader "X-appName" "bugs" res2+ pair2 = makePair "should mount apps" $ do+ res2 <- get "/bugs"+ assertStatus 200 res2+ assertHeader "X-rawPathInfo" "/" res2+ assertHeader "X-pathInfo" (s []) res2+ assertHeader "X-appName" "bugs" res2 - pair3 = makePair "should preserve extra path info" $ do- res3 <- get "/helpdesk/issues/11"- assertStatus 200 res3- assertHeader "X-rawPathInfo" "/issues/11" res3- assertHeader "X-pathInfo" (s ["issues", "11"]) res3+ pair3 = makePair "should preserve extra path info" $ do+ res3 <- get "/helpdesk/issues/11"+ assertStatus 200 res3+ assertHeader "X-rawPathInfo" "/issues/11" res3+ assertHeader "X-pathInfo" (s ["issues", "11"]) res3 - pair4 = makePair "should 404 if none match" $ do- res4 <- get "/api/v3"- assertStatus 404 res4+ pair4 = makePair "should 404 if none match" $ do+ res4 <- get "/api/v3"+ assertStatus 404 res4 testFile :: FilePath testFile = "test/WaiExtraSpec.hs"@@ -433,19 +708,130 @@ streamFileApp = streamFile $ \_ f -> f $ responseFile status200 [] testFile Nothing caseStreamFile :: Assertion-caseStreamFile = flip runSession streamFileApp $ do+caseStreamFile = withSession streamFileApp $ do sres <- request defaultRequest assertStatus 200 sres assertBodyContains "caseStreamFile" sres assertNoHeader "Transfer-Encoding" sres streamLBSApp :: Application-streamLBSApp = streamFile $ \_ f -> f $ responseLBS status200- [("Content-Type", "text/plain")]- "test"+streamLBSApp = streamFile $ \_ f ->+ f $+ responseLBS+ status200+ [("Content-Type", "text/plain")]+ "test" caseStreamLBS :: Assertion-caseStreamLBS = flip runSession streamLBSApp $ do+caseStreamLBS = withSession streamLBSApp $ do sres <- request defaultRequest assertStatus 200 sres assertBody "test" sres++caseModifyPostParamsInLogs :: Assertion+caseModifyPostParamsInLogs = do+ let formatUnredacted = DetailedWithSettings $ DetailedSettings False Nothing Nothing False+ outputUnredacted = [("username", "some_user"), ("password", "dont_show_me")]+ formatRedacted =+ DetailedWithSettings $ DetailedSettings False (Just hidePasswords) Nothing False+ hidePasswords p@(k, _) = Just $ if k == "password" then (k, "***REDACTED***") else p+ outputRedacted = [("username", "some_user"), ("password", "***REDACTED***")]++ testLogs formatUnredacted outputUnredacted+ testLogs formatRedacted outputRedacted+ where+ testLogs :: OutputFormat -> [(String, String)] -> Assertion+ testLogs format output = withSession (debugApp format output) $ do+ let req =+ toRequest+ "application/x-www-form-urlencoded"+ "username=some_user&password=dont_show_me"+ res <- srequest req+ assertStatus 200 res++ postOutputStart params = TE.encodeUtf8 $ T.toStrict $ "POST /\n Params: " <> (T.pack . show $ params)+ postOutputEnd = TE.encodeUtf8 $ T.toStrict "s\n"++ debugApp format output req send = do+ iactual <- I.newIORef mempty+ middleware <-+ mkRequestLogger+ defaultRequestLoggerSettings+ { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs)+ , outputFormat = format+ }+ res <- middleware (\_req f -> f $ responseLBS status200 [] "") req send+ actual <- fromLogStr <$> I.readIORef iactual+ actual `shouldSatisfy` S.isPrefixOf (postOutputStart output)+ actual `shouldSatisfy` S.isSuffixOf postOutputEnd++ return res++caseFilterRequestsInLogs :: Assertion+caseFilterRequestsInLogs = do+ let formatUnfiltered = DetailedWithSettings $ DetailedSettings False Nothing Nothing False+ formatFiltered =+ DetailedWithSettings $+ DetailedSettings False Nothing (Just hideHealthCheck) False+ pathHidden = "/health-check"+ pathNotHidden = "/foobar"++ -- filter is off+ testLogs formatUnfiltered pathNotHidden True+ testLogs formatUnfiltered pathHidden True+ -- filter is on, path does not match+ testLogs formatFiltered pathNotHidden True+ -- filter is on, path matches+ testLogs formatFiltered pathHidden False+ where+ testLogs :: OutputFormat -> S8.ByteString -> Bool -> Assertion+ testLogs format rpath haslogs = withSession (debugApp format rpath haslogs) $ do+ let req = flip SRequest "" $ setPath defaultRequest rpath+ res <- srequest req+ assertStatus 200 res++ hideHealthCheck req _res = pathInfo req /= ["health-check"]++ debugApp format rpath haslogs req send = do+ iactual <- I.newIORef mempty+ middleware <-+ mkRequestLogger+ defaultRequestLoggerSettings+ { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs)+ , outputFormat = format+ }+ res <- middleware (\_req f -> f $ responseLBS status200 [] "") req send+ actual <- fromLogStr <$> I.readIORef iactual+ if haslogs+ then do+ actual `shouldSatisfy` S.isPrefixOf ("GET " <> rpath <> "\n")+ actual `shouldSatisfy` S.isSuffixOf "s\n"+ else actual `shouldBe` ""++ return res++-- | Unit test to make sure 'parseQValueList' works correctly+caseQValues :: Assertion+caseQValues = do+ let encodings =+ mconcat+ -- This has weird white space on purpose, because this+ -- should be acceptable according to RFC 7231+ [ "deflate, compress; q=0.813 ,gzip ; q=0.9, * ;q=0, "+ , "notq;charset=bar, "+ , "noq;q=, "+ , "toolong;q=0.0023, "+ , "toohigh ;q=1.1"+ ]+ qList = parseQValueList encodings+ expected =+ [ ("deflate", Just 1000)+ , ("compress", Just 813)+ , ("gzip", Just 900)+ , ("*", Just 0)+ , ("notq", Nothing)+ , ("noq", Nothing)+ , ("toolong", Nothing)+ , ("toohigh", Nothing)+ ]+ assertEqual "invalid Q values" expected qList
+ test/json.gz view
@@ -0,0 +1,1 @@+test
+ test/noprecompress view
@@ -0,0 +1,1 @@+noprecompress
test/sample.hs view
@@ -5,22 +5,29 @@ import Data.Text () import Network.HTTP.Types import Network.Wai+import Network.Wai.Handler.Warp import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Jsonp-import Network.Wai.Handler.Warp app :: Application app request = return $ case pathInfo request of- [] -> responseLBS status200 []- $ fromChunks $ flip map [1..10000] $ \i -> pack $ concat- [ "<p>Just this same paragraph again. "- , show (i :: Int)- , "</p>"- ]+ [] -> responseLBS status200 [] $+ fromChunks $+ flip map [1 .. 10000] $ \i ->+ pack $+ concat+ [ "<p>Just this same paragraph again. "+ , show (i :: Int)+ , "</p>"+ ] ["test.html"] -> ResponseFile status200 [] "test.html" Nothing- ["json"] -> ResponseFile status200 [(hContentType, "application/json")]- "json" Nothing- _ -> ResponseFile status404 [] "../LICENSE" Nothing+ ["json"] ->+ ResponseFile+ status200+ [(hContentType, "application/json")]+ "json"+ Nothing+ _ -> ResponseFile status404 [] "../LICENSE" Nothing main :: IO ()-main = run 3000 $ gzip def $ jsonp app+main = run 3000 $ gzip defaultGzipSettings $ jsonp app
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 3.0.32+Version: 3.1.18 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality:@@ -27,10 +27,18 @@ . Clean a request path to a canonical form. .+ * Combine Headers+ .+ Combine duplicate headers into one.+ . * GZip Compression . Negotiate HTTP payload gzip compression. .+ * Health check endpoint+ .+ Add an empty health check endpoint.+ . * HTTP Basic Authentication . WAI Basic Authentication Middleware which uses Authorization header.@@ -53,6 +61,10 @@ . Rewrite request path info based on a custom conversion rules. .+ * Select+ .+ Dynamically choose between Middlewares.+ . * Stream Files . Convert ResponseFile type responses into ResponseStream type.@@ -76,6 +88,8 @@ extra-source-files: test/requests/dalvik-request test/json+ test/json.gz+ test/noprecompress test/test.html test/sample.hs ChangeLog.md@@ -87,35 +101,32 @@ default: False Library- Build-Depends: base >= 4.8 && < 5+ Build-Depends: base >= 4.12 && < 5+ , aeson+ , ansi-terminal >= 0.4+ , base64-bytestring , bytestring >= 0.10.4- , wai >= 3.0.3.0 && < 3.3- , old-locale >= 1.0.0.2 && < 1.1- , time >= 1.1.4- , network >= 2.6.1.0- , directory >= 1.0.1- , transformers >= 0.2.2- , http-types >= 0.7- , text >= 0.7+ , call-stack , case-insensitive >= 0.2- , data-default-class- , fast-logger >= 2.4.5- , wai-logger >= 2.3.2- , ansi-terminal- , resourcet >= 0.4.6 && < 1.3- , void >= 0.5 , containers- , base64-bytestring- , word8- , deepseq- , streaming-commons >= 0.2- , unix-compat , cookie+ , data-default+ , directory >= 1.2.7.0+ , fast-logger >= 2.4.5+ , http-types >= 0.7+ , HUnit+ , iproute >= 1.7.8+ , network >= 2.6.1.0+ , resourcet >= 0.4.6 && < 1.4+ , streaming-commons >= 0.2+ , text >= 0.7+ , time >= 1.1.4+ , transformers >= 0.2.2 , vault- , zlib- , aeson- , iproute- , http2+ , wai >= 3.2.4 && < 3.3+ , wai-logger >= 2.3.7+ , warp >= 3.3.22+ , word8 if os(windows) cpp-options: -DWINDOWS@@ -124,7 +135,9 @@ default-extensions: OverloadedStrings - Exposed-modules: Network.Wai.Handler.CGI+ Exposed-modules: Network.Wai.EventSource+ Network.Wai.EventSource.EventStream+ Network.Wai.Handler.CGI Network.Wai.Handler.SCGI Network.Wai.Header Network.Wai.Middleware.AcceptOverride@@ -132,30 +145,36 @@ Network.Wai.Middleware.Approot Network.Wai.Middleware.Autohead Network.Wai.Middleware.CleanPath- Network.Wai.Middleware.Local- Network.Wai.Middleware.RequestLogger- Network.Wai.Middleware.RequestLogger.JSON+ Network.Wai.Middleware.CombineHeaders+ Network.Wai.Middleware.ForceDomain+ Network.Wai.Middleware.ForceSSL Network.Wai.Middleware.Gzip+ Network.Wai.Middleware.HealthCheckEndpoint+ Network.Wai.Middleware.HttpAuth Network.Wai.Middleware.Jsonp+ Network.Wai.Middleware.Local Network.Wai.Middleware.MethodOverride Network.Wai.Middleware.MethodOverridePost+ Network.Wai.Middleware.RealIp+ Network.Wai.Middleware.RequestLogger+ Network.Wai.Middleware.RequestLogger.JSON+ Network.Wai.Middleware.RequestSizeLimit+ Network.Wai.Middleware.RequestSizeLimit.Internal Network.Wai.Middleware.Rewrite- Network.Wai.Middleware.StripHeaders- Network.Wai.Middleware.Vhost- Network.Wai.Middleware.HttpAuth- Network.Wai.Middleware.StreamFile- Network.Wai.Middleware.ForceDomain- Network.Wai.Middleware.ForceSSL Network.Wai.Middleware.Routed+ Network.Wai.Middleware.Select+ Network.Wai.Middleware.StreamFile+ Network.Wai.Middleware.StripHeaders Network.Wai.Middleware.Timeout+ Network.Wai.Middleware.ValidateHeaders+ Network.Wai.Middleware.Vhost Network.Wai.Parse Network.Wai.Request- Network.Wai.UrlMap Network.Wai.Test Network.Wai.Test.Internal- Network.Wai.EventSource- Network.Wai.EventSource.EventStream+ Network.Wai.UrlMap other-modules: Network.Wai.Middleware.RequestLogger.Internal+ Network.Wai.Util default-language: Haskell2010 ghc-options: -Wall @@ -165,12 +184,12 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall if flag(build-example) build-depends: base+ , bytestring+ , http-types+ , time+ , wai , wai-extra , warp- , wai- , time- , http-types- , bytestring else buildable: False default-language: Haskell2010@@ -179,33 +198,46 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs- other-modules: Network.Wai.TestSpec- Network.Wai.ParseSpec- Network.Wai.RequestSpec- Network.Wai.Middleware.ApprootSpec+ other-modules: Network.Wai.Middleware.ApprootSpec+ Network.Wai.Middleware.CombineHeadersSpec Network.Wai.Middleware.ForceSSLSpec+ Network.Wai.Middleware.RealIpSpec+ Network.Wai.Middleware.RequestSizeLimitSpec Network.Wai.Middleware.RoutedSpec+ Network.Wai.Middleware.SelectSpec Network.Wai.Middleware.StripHeadersSpec Network.Wai.Middleware.TimeoutSpec+ Network.Wai.Middleware.ValidateHeadersSpec+ Network.Wai.ParseSpec+ Network.Wai.RequestSpec+ Network.Wai.TestSpec WaiExtraSpec+ build-tool-depends: hspec-discover:hspec-discover build-depends: base >= 4 && < 5- , wai-extra- , wai- , hspec >= 1.3- , transformers+ , aeson+ , bytestring+ , cookie+ , case-insensitive+ , directory , fast-logger+ , hspec >= 1.3 , http-types- , zlib- , text- , resourcet- , bytestring , HUnit- , cookie+ , iproute+ , resourcet+ , temporary+ , text , time- , case-insensitive- , http2+ , wai-extra+ , wai+ , warp+ , word8+ , zlib ghc-options: -Wall default-language: Haskell2010++ if os(windows)+ cpp-options: -DWINDOWS source-repository head type: git