diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Network/Wai/EventSource.hs b/Network/Wai/EventSource.hs --- a/Network/Wai/EventSource.hs +++ b/Network/Wai/EventSource.hs @@ -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_" -} diff --git a/Network/Wai/EventSource/EventStream.hs b/Network/Wai/EventSource/EventStream.hs --- a/Network/Wai/EventSource/EventStream.hs +++ b/Network/Wai/EventSource/EventStream.hs @@ -1,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') diff --git a/Network/Wai/Handler/CGI.hs b/Network/Wai/Handler/CGI.hs --- a/Network/Wai/Handler/CGI.hs +++ b/Network/Wai/Handler/CGI.hs @@ -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 diff --git a/Network/Wai/Handler/SCGI.hs b/Network/Wai/Handler/SCGI.hs --- a/Network/Wai/Handler/SCGI.hs +++ b/Network/Wai/Handler/SCGI.hs @@ -1,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 diff --git a/Network/Wai/Header.hs b/Network/Wai/Header.hs --- a/Network/Wai/Header.hs +++ b/Network/Wai/Header.hs @@ -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 diff --git a/Network/Wai/Middleware/AcceptOverride.hs b/Network/Wai/Middleware/AcceptOverride.hs --- a/Network/Wai/Middleware/AcceptOverride.hs +++ b/Network/Wai/Middleware/AcceptOverride.hs @@ -1,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 + } diff --git a/Network/Wai/Middleware/AddHeaders.hs b/Network/Wai/Middleware/AddHeaders.hs --- a/Network/Wai/Middleware/AddHeaders.hs +++ b/Network/Wai/Middleware/AddHeaders.hs @@ -1,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 ++) diff --git a/Network/Wai/Middleware/Approot.hs b/Network/Wai/Middleware/Approot.hs --- a/Network/Wai/Middleware/Approot.hs +++ b/Network/Wai/Middleware/Approot.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} + -- | Middleware for establishing the root of the application. -- -- Many application need the ability to create URLs referring back to the @@ -13,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. -- diff --git a/Network/Wai/Middleware/Autohead.hs b/Network/Wai/Middleware/Autohead.hs --- a/Network/Wai/Middleware/Autohead.hs +++ b/Network/Wai/Middleware/Autohead.hs @@ -1,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 - diff --git a/Network/Wai/Middleware/CleanPath.hs b/Network/Wai/Middleware/CleanPath.hs --- a/Network/Wai/Middleware/CleanPath.hs +++ b/Network/Wai/Middleware/CleanPath.hs @@ -1,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 diff --git a/Network/Wai/Middleware/CombineHeaders.hs b/Network/Wai/Middleware/CombineHeaders.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/CombineHeaders.hs @@ -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) + ] diff --git a/Network/Wai/Middleware/ForceDomain.hs b/Network/Wai/Middleware/ForceDomain.hs --- a/Network/Wai/Middleware/ForceDomain.hs +++ b/Network/Wai/Middleware/ForceDomain.hs @@ -1,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 diff --git a/Network/Wai/Middleware/ForceSSL.hs b/Network/Wai/Middleware/ForceSSL.hs --- a/Network/Wai/Middleware/ForceSSL.hs +++ b/Network/Wai/Middleware/ForceSSL.hs @@ -1,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 diff --git a/Network/Wai/Middleware/Gzip.hs b/Network/Wai/Middleware/Gzip.hs --- a/Network/Wai/Middleware/Gzip.hs +++ b/Network/Wai/Middleware/Gzip.hs @@ -1,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) diff --git a/Network/Wai/Middleware/HealthCheckEndpoint.hs b/Network/Wai/Middleware/HealthCheckEndpoint.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/HealthCheckEndpoint.hs @@ -0,0 +1,38 @@ +--------------------------------------------------------- + +--------------------------------------------------------- + +-- | +-- Module : Network.Wai.Middleware.HealthCheckEndpoint +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- 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 diff --git a/Network/Wai/Middleware/HttpAuth.hs b/Network/Wai/Middleware/HttpAuth.hs --- a/Network/Wai/Middleware/HttpAuth.hs +++ b/Network/Wai/Middleware/HttpAuth.hs @@ -1,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 diff --git a/Network/Wai/Middleware/Jsonp.hs b/Network/Wai/Middleware/Jsonp.hs --- a/Network/Wai/Middleware/Jsonp.hs +++ b/Network/Wai/Middleware/Jsonp.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE 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 diff --git a/Network/Wai/Middleware/Local.hs b/Network/Wai/Middleware/Local.hs --- a/Network/Wai/Middleware/Local.hs +++ b/Network/Wai/Middleware/Local.hs @@ -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) diff --git a/Network/Wai/Middleware/MethodOverride.hs b/Network/Wai/Middleware/MethodOverride.hs --- a/Network/Wai/Middleware/MethodOverride.hs +++ b/Network/Wai/Middleware/MethodOverride.hs @@ -1,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 diff --git a/Network/Wai/Middleware/MethodOverridePost.hs b/Network/Wai/Middleware/MethodOverridePost.hs --- a/Network/Wai/Middleware/MethodOverridePost.hs +++ b/Network/Wai/Middleware/MethodOverridePost.hs @@ -1,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" -} diff --git a/Network/Wai/Middleware/RealIp.hs b/Network/Wai/Middleware/RealIp.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/RealIp.hs @@ -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 diff --git a/Network/Wai/Middleware/RequestLogger.hs b/Network/Wai/Middleware/RequestLogger.hs --- a/Network/Wai/Middleware/RequestLogger.hs +++ b/Network/Wai/Middleware/RequestLogger.hs @@ -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 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 diff --git a/Network/Wai/Middleware/RequestLogger/Internal.hs b/Network/Wai/Middleware/RequestLogger/Internal.hs --- a/Network/Wai/Middleware/RequestLogger/Internal.hs +++ b/Network/Wai/Middleware/RequestLogger/Internal.hs @@ -1,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 diff --git a/Network/Wai/Middleware/RequestLogger/JSON.hs b/Network/Wai/Middleware/RequestLogger/JSON.hs --- a/Network/Wai/Middleware/RequestLogger/JSON.hs +++ b/Network/Wai/Middleware/RequestLogger/JSON.hs @@ -1,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 diff --git a/Network/Wai/Middleware/RequestSizeLimit.hs b/Network/Wai/Middleware/RequestSizeLimit.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/RequestSizeLimit.hs @@ -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`." + ] + ) diff --git a/Network/Wai/Middleware/RequestSizeLimit/Internal.hs b/Network/Wai/Middleware/RequestSizeLimit/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/RequestSizeLimit/Internal.hs @@ -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} diff --git a/Network/Wai/Middleware/Rewrite.hs b/Network/Wai/Middleware/Rewrite.hs --- a/Network/Wai/Middleware/Rewrite.hs +++ b/Network/Wai/Middleware/Rewrite.hs @@ -1,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 #-} diff --git a/Network/Wai/Middleware/Routed.hs b/Network/Wai/Middleware/Routed.hs --- a/Network/Wai/Middleware/Routed.hs +++ b/Network/Wai/Middleware/Routed.hs @@ -1,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 diff --git a/Network/Wai/Middleware/Select.hs b/Network/Wai/Middleware/Select.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/Select.hs @@ -0,0 +1,97 @@ +--------------------------------------------------------- + +--------------------------------------------------------- + +-- | +-- Module : Network.Wai.Middleware.Select +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- 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) diff --git a/Network/Wai/Middleware/StreamFile.hs b/Network/Wai/Middleware/StreamFile.hs --- a/Network/Wai/Middleware/StreamFile.hs +++ b/Network/Wai/Middleware/StreamFile.hs @@ -1,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 diff --git a/Network/Wai/Middleware/StripHeaders.hs b/Network/Wai/Middleware/StripHeaders.hs --- a/Network/Wai/Middleware/StripHeaders.hs +++ b/Network/Wai/Middleware/StripHeaders.hs @@ -7,26 +7,31 @@ -- When using this, care should be taken not to strip out headers that are -- required for correct operation of the client (eg Content-Type). -module Network.Wai.Middleware.StripHeaders - ( stripHeader - , stripHeaders - , stripHeaderIf - , stripHeadersIf - ) where - -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) diff --git a/Network/Wai/Middleware/Timeout.hs b/Network/Wai/Middleware/Timeout.hs --- a/Network/Wai/Middleware/Timeout.hs +++ b/Network/Wai/Middleware/Timeout.hs @@ -1,9 +1,9 @@ -- | Timeout requests -module Network.Wai.Middleware.Timeout - ( timeout - , timeoutStatus - , timeoutAs - ) where +module Network.Wai.Middleware.Timeout ( + timeout, + timeoutStatus, + timeoutAs, +) where import Network.HTTP.Types (Status, status503) import Network.Wai diff --git a/Network/Wai/Middleware/ValidateHeaders.hs b/Network/Wai/Middleware/ValidateHeaders.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/ValidateHeaders.hs @@ -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 diff --git a/Network/Wai/Middleware/Vhost.hs b/Network/Wai/Middleware/Vhost.hs --- a/Network/Wai/Middleware/Vhost.hs +++ b/Network/Wai/Middleware/Vhost.hs @@ -1,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 diff --git a/Network/Wai/Parse.hs b/Network/Wai/Parse.hs --- a/Network/Wai/Parse.hs +++ b/Network/Wai/Parse.hs @@ -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 diff --git a/Network/Wai/Request.hs b/Network/Wai/Request.hs --- a/Network/Wai/Request.hs +++ b/Network/Wai/Request.hs @@ -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 diff --git a/Network/Wai/Test.hs b/Network/Wai/Test.hs --- a/Network/Wai/Test.hs +++ b/Network/Wai/Test.hs @@ -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) diff --git a/Network/Wai/Test/Internal.hs b/Network/Wai/Test/Internal.hs --- a/Network/Wai/Test/Internal.hs +++ b/Network/Wai/Test/Internal.hs @@ -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 } diff --git a/Network/Wai/UrlMap.hs b/Network/Wai/UrlMap.hs --- a/Network/Wai/UrlMap.hs +++ b/Network/Wai/UrlMap.hs @@ -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 "/" diff --git a/Network/Wai/Util.hs b/Network/Wai/Util.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Util.hs @@ -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 diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -1,26 +1,36 @@ {-# LANGUAGE OverloadedStrings #-} + module Main where -import Data.ByteString.Builder (string8) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Chan -import Control.Monad +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") + ] diff --git a/test/Network/Wai/Middleware/ApprootSpec.hs b/test/Network/Wai/Middleware/ApprootSpec.hs --- a/test/Network/Wai/Middleware/ApprootSpec.hs +++ b/test/Network/Wai/Middleware/ApprootSpec.hs @@ -1,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)] "" diff --git a/test/Network/Wai/Middleware/CombineHeadersSpec.hs b/test/Network/Wai/Middleware/CombineHeadersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/CombineHeadersSpec.hs @@ -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 "" diff --git a/test/Network/Wai/Middleware/ForceSSLSpec.hs b/test/Network/Wai/Middleware/ForceSSLSpec.hs --- a/test/Network/Wai/Middleware/ForceSSLSpec.hs +++ b/test/Network/Wai/Middleware/ForceSSLSpec.hs @@ -1,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 [] "" diff --git a/test/Network/Wai/Middleware/RealIpSpec.hs b/test/Network/Wai/Middleware/RealIpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/RealIpSpec.hs @@ -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 diff --git a/test/Network/Wai/Middleware/RequestSizeLimitSpec.hs b/test/Network/Wai/Middleware/RequestSizeLimitSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/RequestSizeLimitSpec.hs @@ -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 [] "" diff --git a/test/Network/Wai/Middleware/RoutedSpec.hs b/test/Network/Wai/Middleware/RoutedSpec.hs --- a/test/Network/Wai/Middleware/RoutedSpec.hs +++ b/test/Network/Wai/Middleware/RoutedSpec.hs @@ -1,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" diff --git a/test/Network/Wai/Middleware/SelectSpec.hs b/test/Network/Wai/Middleware/SelectSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/SelectSpec.hs @@ -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 diff --git a/test/Network/Wai/Middleware/StripHeadersSpec.hs b/test/Network/Wai/Middleware/StripHeadersSpec.hs --- a/test/Network/Wai/Middleware/StripHeadersSpec.hs +++ b/test/Network/Wai/Middleware/StripHeadersSpec.hs @@ -1,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 [] "" diff --git a/test/Network/Wai/Middleware/TimeoutSpec.hs b/test/Network/Wai/Middleware/TimeoutSpec.hs --- a/test/Network/Wai/Middleware/TimeoutSpec.hs +++ b/test/Network/Wai/Middleware/TimeoutSpec.hs @@ -1,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 diff --git a/test/Network/Wai/Middleware/ValidateHeadersSpec.hs b/test/Network/Wai/Middleware/ValidateHeadersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/ValidateHeadersSpec.hs @@ -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 "" diff --git a/test/Network/Wai/ParseSpec.hs b/test/Network/Wai/ParseSpec.hs --- a/test/Network/Wai/ParseSpec.hs +++ b/test/Network/Wai/ParseSpec.hs @@ -1,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) diff --git a/test/Network/Wai/RequestSpec.hs b/test/Network/Wai/RequestSpec.hs --- a/test/Network/Wai/RequestSpec.hs +++ b/test/Network/Wai/RequestSpec.hs @@ -1,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 diff --git a/test/Network/Wai/TestSpec.hs b/test/Network/Wai/TestSpec.hs --- a/test/Network/Wai/TestSpec.hs +++ b/test/Network/Wai/TestSpec.hs @@ -1,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` "[]" diff --git a/test/WaiExtraSpec.hs b/test/WaiExtraSpec.hs --- a/test/WaiExtraSpec.hs +++ b/test/WaiExtraSpec.hs @@ -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 diff --git a/test/json.gz b/test/json.gz new file mode 100644 --- /dev/null +++ b/test/json.gz @@ -0,0 +1,1 @@ +test diff --git a/test/noprecompress b/test/noprecompress new file mode 100644 --- /dev/null +++ b/test/noprecompress @@ -0,0 +1,1 @@ +noprecompress diff --git a/test/sample.hs b/test/sample.hs --- a/test/sample.hs +++ b/test/sample.hs @@ -5,22 +5,29 @@ import Data.Text () import Network.HTTP.Types import Network.Wai +import Network.Wai.Handler.Warp import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Jsonp -import Network.Wai.Handler.Warp app :: Application app request = return $ case pathInfo request of - [] -> responseLBS status200 [] - $ fromChunks $ flip map [1..10000] $ \i -> pack $ concat - [ "

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

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

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

" + ] ["test.html"] -> ResponseFile status200 [] "test.html" Nothing - ["json"] -> ResponseFile status200 [(hContentType, "application/json")] - "json" Nothing - _ -> ResponseFile status404 [] "../LICENSE" Nothing + ["json"] -> + ResponseFile + status200 + [(hContentType, "application/json")] + "json" + Nothing + _ -> ResponseFile status404 [] "../LICENSE" Nothing main :: IO () -main = run 3000 $ gzip def $ jsonp app +main = run 3000 $ gzip defaultGzipSettings $ jsonp app diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -1,5 +1,5 @@ Name: wai-extra -Version: 3.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