diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,331 @@ +# 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 + +## 3.0.31 + +* Undo WaiTestFailure change in previous release + +## 3.0.30 + +* `Network.Wai.Test`: Add support for source locations to assertion primitives [#812](https://github.com/yesodweb/wai/pull/812) + +## 3.0.29.2 + +* flush SSE headers early [#804](https://github.com/yesodweb/wai/pull/804) + +## 3.0.29.1 + +* Fix `Network.Wai.Test.request` always sending an empty request body [#794](https://github.com/yesodweb/wai/pull/794) + +## 3.0.29 + +* Export `Network.Wai.EventSource.eventStreamAppRaw` [#786](https://github.com/yesodweb/wai/pull/786) + +## 3.0.28 + +* Add `Network.Wai.EventSource.eventStreamAppRaw` [#767](https://github.com/yesodweb/wai/pull/767) + +## 3.0.27 + +* Add custom request log formatter which includes response headers [#762](https://github.com/yesodweb/wai/pull/762) + +## 3.0.26.1 + +* When available, supply the response size to custom loggers + [#757](https://github.com/yesodweb/wai/pull/757) + +## 3.0.26 + +* Throw 413 for too large payload +* Throw 431 for too large headers + [#741](https://github.com/yesodweb/wai/pull/741) + +## 3.0.25 + +* Supporting `network` version 3.0. + +## 3.0.24.3 + +* Drop unnecessary `lifted-base` dependency +* Drop unnecessary `stringsearch` dependency [#714](https://github.com/yesodweb/wai/pull/714) + +## 3.0.24.2 + +* Consider quoted multipart form boundary markers [#700](https://github.com/yesodweb/wai/pull/700). +* Don't raise exceptions in `formatAsJSON` [#709](https://github.com/yesodweb/wai/pull/709) + +## 3.0.24.1 + +* Fix a "file not found" exception in wai-extra [#705](https://github.com/yesodweb/wai/pull/706) + +## 3.0.24.0 + +* Add timeout middleware [#702](https://github.com/yesodweb/wai/pull/702). + +## 3.0.23.0 + +* Add rewriteRoot middleware [#697](https://github.com/yesodweb/wai/pull/697). + +## 3.0.22.1 + +* Drop dependency on blaze-builder, requiring streaming-commons >= 0.2 + +## 3.0.22.0 + +* Support for streaming-commons 0.2 +* Support for resourcet 1.2 + +## 3.0.21.0 + +* Export `Network.Wai.Parse.noLimitParseRequestBodyOptions` [#662](https://github.com/yesodweb/wai/pull/662). + +## 3.0.20.2 + +* Revert previous change to `srequest`, which caused breakage + +## 3.0.20.1 + +* Set `requestBodyLength` for `srequest` [#654](https://github.com/yesodweb/wai/pull/654) + +## 3.0.20.0 + +* runSessionWith (runSession variant that gives access to ClientState) [#629](https://github.com/yesodweb/wai/pull/629) + +## 3.0.19.1 + +* All loggers follow the autoFlush setting [#604](https://github.com/yesodweb/wai/pull/604) + +## 3.0.19 + +* Add a new function basicAuth', which passes request to the CheckCreds argument. + +## 3.0.18 + +* ForceSSL: preserve port number when redirecting to https. [#582](https://github.com/yesodweb/wai/pull/582) + +## 3.0.17 + +* Gzip pre compressed [#580](https://github.com/yesodweb/wai/pull/580) + +## 3.0.16.1 + +* Fix the way the header length is checked (for limiting the max header length) + +## 3.0.16.0 + +* Add a new function "parseRequestBodyEx" that allows various size limits to be set. + +## 3.0.15.3 + +* Allow wai-logger 2.3 + +## 3.0.15.2 + +* Doc improvements + +## 3.0.15.1 + +* don't use deprecated CRT functions on Windows [#544](https://github.com/yesodweb/wai/pull/544) + +## 3.0.15 + +* add requestSizeCheck [#525](https://github.com/yesodweb/wai/pull/525) + +## 3.0.14.3 + +* Add missing `requestHeaderReferer` and `requestHeaderUserAgent` fields to CGI [yesod#1186](https://github.com/yesodweb/yesod/issues/1186) + +## 3.0.14.2 + +* Case insensitive multipart request header lookup [#518](https://github.com/yesodweb/wai/pull/518) + +## 3.0.14.1 + +* Doc update for logStdout and logStdoutDev [#515](https://github.com/yesodweb/wai/issues/515) + +## 3.0.14 + +* Middleware to force domain names. [#506](https://github.com/yesodweb/wai/issues/506) [#507](https://github.com/yesodweb/wai/pull/507) + +## 3.0.13.1 + +* Support wai 3.2 + +## 3.0.13 + +* Autoflush handle [#466](https://github.com/yesodweb/wai/pull/466) + +## 3.0.12 + +* Add Network.Wai.Header.contentLength to read the Content-Length header of a response +* The gzip middleware no longer zips responses smaller than 860 bytes + +## 3.0.11 + +* Add constructor for more detailed custom output formats for RequestLogger +* Add JSON output formatter for RequestLogger + +## 3.0.10 + +* Adding Request Body to RequestLogger [#401](https://github.com/yesodweb/wai/pull/401) + +## 3.0.9 + +* Network.Wai.Middleware.Routed module added + +## 3.0.7 + +* Add appearsSecure: check if a request appears to be using SSL even in the + presence of reverse proxies [#362](https://github.com/yesodweb/wai/pull/362) +* Add ForceSSL middleware [#363](https://github.com/yesodweb/wai/pull/363) +* Add Approot middleware + +## 3.0.6.1 + +* Test code: only include a Cookie header if there are cookies. Without this + patch, yesod-test cookie handling is broken. + +## 3.0.6 + +* Add Cookie Handling to Network.Wai.Test [#356](https://github.com/yesodweb/wai/pull/356) + +## 3.0.5 + +* add functions to extract authentication data from Authorization header [#352](add functions to extract authentication data from Authorization header #352) + +## 3.0.4.6 + +* Access log sequence not valid [#336](https://github.com/yesodweb/wai/issues/336) + +## 3.0.4.5 + +* Allow fast-logger 2.3 + +## 3.0.4.3 + +Test suite warning cleanup + +## 3.0.4.2 + +Allow blaze-builder 0.4 + +## 3.0.4.1 + +Fix compilation failure on Windows [#321](https://github.com/yesodweb/wai/issues/321) + +## 3.0.4 + +Add the `StreamFile` middleware. + +## 3.0.3 + +Add the `AddHeaders` middleware. diff --git a/Network/Wai/EventSource.hs b/Network/Wai/EventSource.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/EventSource.hs @@ -0,0 +1,64 @@ +-- | +-- A WAI adapter to the HTML5 Server-Sent Events API. +-- +-- If running through a proxy like Nginx you might need to add the +-- headers: +-- +-- > [ ("X-Accel-Buffering", "no"), ("Cache-Control", "no-cache")] +-- +-- There is a small example using these functions in the @example@ directory. +module Network.Wai.EventSource ( + ServerEvent (..), + eventSourceAppChan, + eventSourceAppIO, + eventStreamAppRaw, +) where + +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 + +-- | Make a new WAI EventSource application reading events from +-- the given channel. +eventSourceAppChan :: Chan ServerEvent -> Application +eventSourceAppChan chan req sendResponse = do + chan' <- liftIO $ dupChan chan + eventSourceAppIO (readChan chan') req sendResponse + +-- | Make a new WAI EventSource application reading events from +-- the given IO action. +eventSourceAppIO :: IO ServerEvent -> Application +eventSourceAppIO src _ sendResponse = + 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 + +-- | Make a new WAI EventSource application with a handler that emits events. +-- +-- @since 3.0.28 +eventStreamAppRaw :: ((ServerEvent -> IO ()) -> IO () -> IO ()) -> Application +eventStreamAppRaw handler _ sendResponse = + 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 + +{- HLint ignore eventStreamAppRaw "Use forM_" -} diff --git a/Network/Wai/EventSource/EventStream.hs b/Network/Wai/EventSource/EventStream.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/EventSource/EventStream.hs @@ -0,0 +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. +module Network.Wai.EventSource.EventStream ( + 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. +data ServerEvent + = ServerEvent + { eventName :: Maybe Builder + , eventId :: Maybe Builder + , eventData :: [Builder] + } + | CommentEvent + { eventComment :: Builder + } + | RetryEvent + { eventRetry :: Int + } + | CloseEvent + +-- | +-- Newline as a Builder. +nl :: Builder +nl = word8 _lf + +-- | +-- Field names as Builder +nameField, idField, dataField, retryField, commentField :: Builder +nameField = string7 "event:" +idField = string7 "id:" +dataField = string7 "data:" +retryField = string7 "retry:" +commentField = word8 _colon + +-- | +-- 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. +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 + where + name Nothing = id + name (Just n') = mappend (field nameField n') + 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,44 +1,55 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# 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.Socket (getAddrInfo, addrAddress) -import System.Environment (getEnvironment) -import Data.Maybe (fromMaybe) +import Control.Arrow ((***)) +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 Control.Arrow ((***)) +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import qualified Data.CaseInsensitive as CI import Data.Char (toLower) -import qualified System.IO +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 qualified Data.String as String -import Data.Monoid (mconcat, mempty) -import Blaze.ByteString.Builder (fromByteString, toLazyByteString) -import Blaze.ByteString.Builder.Char8 (fromChar, fromString) -import Data.Conduit.Blaze (builderToByteStringFlush) -import Control.Monad.IO.Class (liftIO) -import Data.ByteString.Lazy.Internal (defaultChunkSize) -import System.IO (Handle) -import Network.HTTP.Types (Status (..)) +import Data.Word8 (_lf, _space) +import Network.HTTP.Types (Status (..), hContentLength, hContentType, hRange) import qualified Network.HTTP.Types as H -import qualified Data.CaseInsensitive as CI -import Data.Monoid (mappend) -import Data.Conduit -import qualified Data.Conduit.List as CL +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) +#else +import qualified System.Posix.Env.ByteString as Env + +getEnvironment :: IO [(String, String)] +getEnvironment = map (B.unpack *** B.unpack) `fmap` Env.getEnvironment +#endif + 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 @@ -54,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 @@ -66,123 +80,135 @@ -- 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 -> Source (ResourceT 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 qstring = lookup' "QUERY_STRING" vars - servername = lookup' "SERVER_NAME" vars - serverport = safeRead 80 $ lookup' "SERVER_PORT" vars contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars 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 _ -> False addrs <- getAddrInfo Nothing (Just remoteHost') Nothing + requestBody' <- inputH contentLength let addr = case addrs of - a:_ -> addrAddress a + a : _ -> addrAddress a [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost' - runResourceT $ do - let env = Request - { requestMethod = rmethod - , rawPathInfo = B.pack pinfo - , pathInfo = H.decodePathSegments $ B.pack pinfo - , rawQueryString = B.pack qstring - , queryString = H.parseQuery $ B.pack qstring - , serverName = B.pack servername - , serverPort = serverport - , requestHeaders = map (cleanupVarName *** B.pack) vars - , isSecure = isSecure' - , remoteHost = addr - , httpVersion = H.http11 -- FIXME - , requestBody = inputH contentLength - , vault = mempty -#if MIN_VERSION_wai(1, 4, 0) - , requestBodyLength = KnownLength $ fromIntegral contentLength + reqHeaders = map (cleanupVarName *** B.pack) vars + 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 #endif - } - -- FIXME worry about exception? - res <- app env + } + void $ app env $ \res -> case (xsendfile, res) of - (Just sf, ResponseFile s hs fp Nothing) -> - liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp + (Just sf, ResponseFile s hs fp Nothing) -> do + mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp + return ResponseReceived _ -> do - let (s, hs, b) = responseSource res - src = CL.sourceList [Chunk $ headers s hs `mappend` fromChar '\n'] - `mappend` b - src $$ builderSink + let (s, hs, wb) = responseToStream res + (blazeRecv, blazeFinish) <- Builder.newBuilderRecv Builder.defaultStrategy + wb $ \b -> do + let sendBuilder builder = do + popper <- blazeRecv builder + fix $ \loop -> do + bs <- popper + unless (B.null bs) $ do + outputH bs + loop + 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) = (fromByteString "Status", mconcat - [ fromString $ show i - , fromChar ' ' - , fromByteString m - ]) - header' (x, y) = (fromByteString $ CI.original x, fromByteString y) - header (x, y) = mconcat - [ x - , fromByteString ": " - , y - , fromChar '\n' - ] - sfBuilder s hs sf fp = mconcat - [ headers s hs - , header $ (fromByteString sf, fromString fp) - , fromChar '\n' - , fromByteString sf - , fromByteString " not supported" - ] - bsSink = await >>= maybe (return ()) push - push (Chunk bs) = do - liftIO $ outputH bs - bsSink - -- FIXME actually flush? - push Flush = bsSink - builderSink = builderToByteStringFlush =$ bsSink + 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 + , 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 "content-type" h of - Nothing -> ("Content-Type", "text/html; charset=utf-8") : h + case lookup hContentType h of + Nothing -> (hContentType, "text/html; charset=utf-8") : h Just _ -> h cleanupVarName :: String -> CI.CI B.ByteString -cleanupVarName "CONTENT_TYPE" = "Content-Type" -cleanupVarName "CONTENT_LENGTH" = "Content-Length" +cleanupVarName "CONTENT_TYPE" = hContentType +cleanupVarName "CONTENT_LENGTH" = hContentLength 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 -> Source (ResourceT IO) B.ByteString +requestBodyHandle :: Handle -> Int -> IO (IO B.ByteString) requestBodyHandle h = requestBodyFunc $ \i -> do bs <- B.hGet h i return $ if B.null bs then Nothing else Just bs -requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source (ResourceT IO) B.ByteString -requestBodyFunc get = - loop - where - loop 0 = return () - loop count = do - mbs <- liftIO $ get $ min count defaultChunkSize - let count' = count - maybe 0 B.length mbs - case mbs of - Nothing -> return () - Just bs -> yield bs >> loop count' +requestBodyFunc + :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString) +requestBodyFunc get count0 = do + ref <- newIORef count0 + return $ do + count <- readIORef ref + if count <= 0 + then return B.empty + else do + mbs <- get $ min count defaultChunkSize + writeIORef ref $ count - maybe 0 B.length mbs + return $ fromMaybe B.empty mbs diff --git a/Network/Wai/Handler/SCGI.hs b/Network/Wai/Handler/SCGI.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/SCGI.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Network.Wai.Handler.SCGI ( + run, + runSendfile, +) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import qualified Data.ByteString.Unsafe as S +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (fromMaybe, listToMaybe) +import Foreign.C (CChar, CInt (..)) +import Foreign.Marshal.Alloc (free, mallocBytes) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Network.Wai (Application) +import Network.Wai.Handler.CGI (requestBodyFunc, runGeneric) + +run :: Application -> IO () +run app = runOne Nothing app >> run app + +runSendfile :: ByteString -> Application -> IO () +runSendfile sf app = runOne (Just sf) app >> runSendfile sf app + +runOne :: Maybe ByteString -> Application -> IO () +runOne sf app = do + socket <- c'accept 0 nullPtr nullPtr + headersBS <- readNetstring socket + 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 + drain socket conLenI + _ <- c'close socket + return () + +write :: CInt -> S.ByteString -> IO () +write socket bs = S.unsafeUseAsCStringLen bs $ \(s, l) -> do + _ <- c'write socket s (fromIntegral l) + return () + +input :: CInt -> IORef Int -> Int -> IO (Maybe S.ByteString) +input socket ilen rlen = do + len <- readIORef ilen + case len of + 0 -> return Nothing + _ -> do + bs <- + readByteString socket $ + minimum [defaultChunkSize, len, rlen] + writeIORef ilen $ len - S.length bs + return $ Just bs + +drain :: CInt -> IORef Int -> IO () -- FIXME do it in chunks +drain socket ilen = do + len <- readIORef ilen + _ <- readByteString socket len + return () + +parseHeaders :: [S.ByteString] -> [(String, String)] +parseHeaders (x : y : z) = (S8.unpack x, S8.unpack y) : parseHeaders z +parseHeaders _ = [] + +readNetstring :: CInt -> IO S.ByteString +readNetstring socket = do + len <- readLen 0 + bs <- readByteString socket len + _ <- readByteString socket 1 -- the comma + return bs + where + readLen l = do + bs <- readByteString socket 1 + 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 + buf <- mallocBytes len + _ <- c'read socket buf $ fromIntegral len + S.unsafePackCStringFinalizer (castPtr buf) len $ free buf + +foreign import ccall unsafe "accept" + c'accept :: CInt -> Ptr a -> Ptr a -> IO CInt + +#if WINDOWS +foreign import ccall unsafe "_close" + c'close :: CInt -> IO CInt + +foreign import ccall unsafe "_write" + c'write :: CInt -> Ptr CChar -> CInt -> IO CInt + +foreign import ccall unsafe "_read" + c'read :: CInt -> Ptr CChar -> CInt -> IO CInt +#else +foreign import ccall unsafe "close" + c'close :: CInt -> IO CInt + +foreign import ccall unsafe "write" + c'write :: CInt -> Ptr CChar -> CInt -> IO CInt + +foreign import ccall unsafe "read" + c'read :: CInt -> Ptr CChar -> CInt -> IO CInt +#endif diff --git a/Network/Wai/Header.hs b/Network/Wai/Header.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Header.hs @@ -0,0 +1,74 @@ +-- | Some helpers for dealing with WAI 'Header's. +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 + +readInt :: S8.ByteString -> Maybe Integer +readInt bs = + case S8.readInteger bs of + -- '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,13 +1,29 @@ -{-# LANGUAGE OverloadedStrings #-} - -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' @@ -15,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 new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/AddHeaders.hs @@ -0,0 +1,22 @@ +-- | +-- +-- Since 3.0.3 +module Network.Wai.Middleware.AddHeaders ( + addHeaders, +) where + +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 (h ++) diff --git a/Network/Wai/Middleware/Approot.hs b/Network/Wai/Middleware/Approot.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/Approot.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Middleware for establishing the root of the application. +-- +-- Many application need the ability to create URLs referring back to the +-- application itself. For example: generate RSS feeds or sitemaps, giving +-- users copy-paste links, or sending emails. In many cases, the approot can be +-- determined correctly from the request headers. However, some things can +-- prevent this, especially reverse proxies. This module provides multiple ways +-- of configuring approot discovery, and functions for applications to get that +-- approot. +-- +-- Approots are structured such that they can be prepended to a string such as +-- @/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 + +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 (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 #-} + +-- | The most generic version of the middleware, allowing you to provide a +-- function to get the approot for each request. For many use cases, one of the +-- helper functions provided by this module will give the necessary +-- functionality more conveniently. +-- +-- Since 3.0.7 +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} + app req' respond + +-- | Same as @'envFallbackNamed' "APPROOT"@. +-- +-- The environment variable @APPROOT@ is used by Keter, School of Haskell, and yesod-devel. +-- +-- Since 3.0.7 +envFallback :: IO Middleware +envFallback = envFallbackNamed "APPROOT" + +-- | Produce a middleware that takes the approot from the given environment +-- variable, falling back to the behavior of 'fromRequest' if the variable is +-- not set. +-- +-- Since 3.0.7 +envFallbackNamed :: String -> IO Middleware +envFallbackNamed name = do + approot <- lookupEnv name + pure $ case approot of + Just s -> hardcoded $ S8.pack s + Nothing -> fromRequest + +-- | Hard-code the given value as the approot. +-- +-- Since 3.0.7 +hardcoded :: ByteString -> Middleware +hardcoded ar = approotMiddleware (const $ return ar) + +-- | Get the approot by analyzing the request. This is not a full-proof +-- approach, but in many common cases will work. Situations that can break this +-- are: +-- +-- * Requests which spoof headers and imply the connection is over HTTPS +-- +-- * Reverse proxies that change ports in surprising ways +-- +-- * Invalid Host headers +-- +-- * Reverse proxies which modify the path info +-- +-- Normally trusting headers in this way is insecure, however in the case of +-- approot, the worst that can happen is that the client will get an incorrect +-- URL. If you are relying on the approot for some security-sensitive purpose, +-- it is highly recommended to use @hardcoded@, which cannot be spoofed. +-- +-- Since 3.0.7 +fromRequest :: Middleware +fromRequest = approotMiddleware (return . guessApproot) + +data ApprootMiddlewareNotSetup = ApprootMiddlewareNotSetup + deriving (Show, Typeable) +instance Exception ApprootMiddlewareNotSetup + +-- | Get the approot set by the middleware. If the middleware is not in use, +-- then this function will return an exception. For a total version of the +-- function, see 'getApprootMay'. +-- +-- Since 3.0.7 +getApproot :: Request -> ByteString +getApproot = fromMaybe (throw ApprootMiddlewareNotSetup) . getApprootMay + +-- | A total version of 'getApproot', which returns 'Nothing' if the middleware +-- is not in use. +-- +-- Since 3.0.7 +getApprootMay :: Request -> Maybe ByteString +getApprootMay req = V.lookup approotKey $ vault req 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,18 +1,22 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# 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 - | requestMethod req == "HEAD" = do - res <- app req { requestMethod = "GET" } - case res of - ResponseFile s hs _ _ -> return $ ResponseBuilder s hs mempty - ResponseBuilder s hs _ -> return $ ResponseBuilder s hs mempty - ResponseSource s hs _ -> return $ ResponseBuilder s hs mempty - | otherwise = app req - +autohead app req sendResponse + | 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,30 +1,36 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Middleware.CleanPath - ( cleanPath - ) where +{-# LANGUAGE CPP #-} -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) -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 splitter prefix app env = +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 - Left p -> return - $ responseLBS status301 - [("Location", 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 + 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 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 new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/ForceDomain.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} + +-- | +-- +-- @since 3.0.14 +module Network.Wai.Middleware.ForceDomain where + +import Data.ByteString (ByteString) +#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 Network.Wai (Middleware, Request (..), responseBuilder) + +import Network.Wai.Request (appearsSecure) + +-- | Force a domain by redirecting. +-- The `checkDomain` function takes the current domain and checks whether it is correct. +-- It should return `Nothing` if the domain is correct, or `Just "domain.com"` if it is incorrect. +-- +-- @since 3.0.14 +forceDomain :: (ByteString -> Maybe ByteString) -> Middleware +forceDomain checkDomain app req sendResponse = + case requestHeaderHost req >>= checkDomain of + Nothing -> + app req sendResponse + Just domain -> + sendResponse $ redirectResponse domain + 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 + + status + | requestMethod req == methodGet = status301 + | otherwise = status307 diff --git a/Network/Wai/Middleware/ForceSSL.hs b/Network/Wai/Middleware/ForceSSL.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/ForceSSL.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} + +-- | Redirect non-SSL requests to https +-- +-- Since 3.0.7 +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 +forceSSL :: Middleware +forceSSL app req sendResponse = + case (appearsSecure req, redirectResponse req) of + (False, Just resp) -> sendResponse resp + _ -> app req sendResponse + +redirectResponse :: Request -> Maybe Response +redirectResponse req = do + host <- requestHeaderHost req + return $ responseBuilder status [(hLocation, location host)] mempty + where + location h = "https://" <> h <> rawPathInfo req <> rawQueryString req + status + | requestMethod req == methodGet = status301 + | otherwise = status307 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,7 +1,7 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- + +--------------------------------------------------------- + -- | -- Module : Network.Wai.Middleware.Gzip -- Copyright : Michael Snoyman @@ -12,141 +12,422 @@ -- 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 -import Network.HTTP.Types (Status, Header) -import Control.Monad.IO.Class (liftIO) -import System.Directory (doesFileExist, createDirectoryIfMissing) -import qualified Data.Conduit as C -import qualified Data.Conduit.Zlib as CZ -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL -import Data.Conduit.Blaze (builderToByteStringFlush) -import Blaze.ByteString.Builder (fromByteString) -import Control.Exception (try, SomeException) +import Data.ByteString.Builder (byteString) +import qualified Data.ByteString.Builder.Extra as Blaze (flush) +import qualified Data.ByteString.Char8 as S8 +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import qualified Data.Default as Default (Default (..)) +import Data.Function (fix) +import Data.Maybe (isJust) import qualified Data.Set as Set +import qualified Data.Streaming.ByteString.Builder as B +import qualified Data.Streaming.Zlib as Z +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 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. } -data GzipFiles = GzipIgnore | GzipCompress | GzipCacheFolder FilePath +-- | Gzip behavior for files. +data GzipFiles + = -- | 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) -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@. defaultCheckMime :: S.ByteString -> Bool defaultCheckMime bs = S8.isPrefixOf "text/" bs || bs' `Set.member` toCompress where - bs' = fst $ S.breakByte 59 bs -- semicolon - toCompress = Set.fromList - [ "application/json" - , "application/javascript" - , "application/ecmascript" - ] + bs' = fst $ S.break (== _semicolon) bs + 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. --- --- Possible future enhancements: --- --- * Only compress if the response is above a certain size. gzip :: GzipSettings -> Middleware -gzip set app env = do - res <- app env - case res of - ResponseFile{} | gzipFiles set == GzipIgnore -> return res - _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) - then - case (res, gzipFiles set) of - (ResponseFile s hs file Nothing, GzipCacheFolder cache) -> - case lookup "content-type" hs of - Just m - | gzipCheckMime set m -> liftIO $ compressFile s hs file cache - _ -> return res - _ -> return $ compressE set res - else return 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 "user-agent" $ requestHeaders env - isMSIE6 = "MSIE 6" `S.isInfixOf` ua - responseHeaders res = case res of - ResponseFile _ h _ _ -> h - ResponseBuilder _ h _ -> h - ResponseSource _ h _ -> h - isEncoded res = isJust $ lookup "Content-Encoding" $ 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 -compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response -compressFile s hs file cache = do + -- 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 + + -- 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 + +-- 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 $ C.runResourceT $ CB.sourceFile file - C.$$ CZ.gzip C.=$ CB.sinkFile tmpfile - either onErr (const onSucc) x + 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 ()) where - onSucc = return $ ResponseFile s (fixHeaders hs) tmpfile Nothing + 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 :: SomeException -> IO Response - onErr = const $ return $ 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 -compressE set res = - case lookup "content-type" hs of - Just m | gzipCheckMime set m -> - let hs' = fixHeaders hs - in ResponseSource s hs' $ b C.$= builderToByteStringFlush - C.$= CZ.compressFlush 1 (CZ.WindowBits 31) - C.$= CL.map (fmap fromByteString) - _ -> res +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.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, b) = responseSource res + (s, hs, wb) = responseToStream res -- Remove Content-Length header, since we will certainly have a -- different length after gzip compression. fixHeaders :: [Header] -> [Header] fixHeaders = - (("Content-Encoding", "gzip") :) . filter notLength + replaceHeader hContentEncoding "gzip" . filter notLength where - notLength (x, _) = x /= "content-length" - -splitCommas :: String -> [String] -splitCommas [] = [] -splitCommas x = - let (y, z) = break (== ',') x - in y : splitCommas (dropWhile (== ' ') $ drop 1 z) + notLength (x, _) = x /= hContentLength 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,98 +1,149 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + -- | Implements HTTP Basic Authentication. -- -- This module may add digest authentication in the future. -module Network.Wai.Middleware.HttpAuth - ( basicAuth - , CheckCreds - , AuthSettings - , authRealm - , authOnNoAuth - , authIsProtected - ) where +module Network.Wai.Middleware.HttpAuth ( + -- * Middleware + basicAuth, + basicAuth', + CheckCreds, + AuthSettings, + authRealm, + authOnNoAuth, + authIsProtected, -import Network.Wai -import Network.HTTP.Types (status401) + -- * 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.String (IsString (..)) -import Control.Monad.Trans.Resource (ResourceT) -import Data.Word8 (isSpace, _colon, toLower) import Data.ByteString.Base64 (decodeLenient) +import Data.String (IsString (..)) +import Data.Word8 (isSpace, toLower, _colon) +import Network.HTTP.Types (hAuthorization, hContentType, status401) +import Network.Wai ( + Application, + Middleware, + Request (requestHeaders), + responseLBS, + ) -- | Check if a given username and password is valid. -type CheckCreds = ByteString - -> ByteString - -> ResourceT 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 AuthSettings {..} app req = do +-- @since 1.3.4 +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 isProtected <- authIsProtected req allowed <- if isProtected then check else return True if allowed - then app req - else authOnNoAuth authRealm req + then app req sendResponse + else authOnNoAuth authRealm req sendResponse where check = - case lookup "Authorization" $ requestHeaders req of - Nothing -> return False - Just bs -> - let (x, y) = S.break isSpace bs - in if S.map toLower x == "basic" - then checkB64 $ S.dropWhile isSpace y - else return False - checkB64 encoded = - case S.uncons password' of - Just (_, password) -> checkCreds username password + case lookup hAuthorization (requestHeaders req) + >>= extractBasicAuth of Nothing -> return False - where - raw = decodeLenient encoded - (username, password') = S.breakByte _colon raw + Just (username, password) -> checkCreds req username password --- | Authentication settings. This value is an instance of @IsString@, so the --- recommended approach to create a value is to provide a string literal (which --- will be the realm) and then overriding individual fields. +-- | Basic authentication settings. This value is an instance of +-- @IsString@, so the recommended approach to create a value is to +-- provide a string literal (which will be the realm) and then +-- overriding individual fields. -- -- > "My Realm" { authIsProtected = someFunc } :: AuthSettings -- --- Since 1.3.4 +-- @since 1.3.4 data AuthSettings = AuthSettings { authRealm :: !ByteString -- ^ -- - -- Since 1.3.4 + -- @since 1.3.4 , authOnNoAuth :: !(ByteString -> Application) -- ^ Takes the realm and returns an appropriate 401 response when -- authentication is not provided. -- - -- Since 1.3.4 - , authIsProtected :: !(Request -> ResourceT IO Bool) + -- @since 1.3.4 + , authIsProtected :: !(Request -> IO Bool) -- ^ Determine if access to the requested resource is restricted. -- -- Default: always returns @True@. -- - -- Since 1.3.4 + -- @since 1.3.4 } instance IsString AuthSettings where - fromString s = AuthSettings - { authRealm = fromString s - , authOnNoAuth = \realm _req -> return $ responseLBS - status401 - [ ("Content-Type", "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 +-- +-- @since 3.0.5 +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 + where + extract encoded = + let raw = decodeLenient encoded + (username, password') = S.break (== _colon) raw + in (username,) . snd <$> S.uncons password' + +-- | Extract bearer authentication data from __Authorization__ header +-- value. Returns bearer token +-- +-- @since 3.0.5 +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 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,6 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} + --------------------------------------------------------- + +--------------------------------------------------------- + -- | -- Module : Network.Wai.Middleware.Jsonp -- Copyright : Michael Snoyman @@ -11,21 +14,21 @@ -- Portability : portable -- -- Automatic wrapping of JSON responses to convert into JSONP. --- ---------------------------------------------------------- module Network.Wai.Middleware.Jsonp (jsonp) where -import Network.Wai +import Control.Monad (join) import Data.ByteString (ByteString) +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 Blaze.ByteString.Builder (copyByteString) -import Blaze.ByteString.Builder.Char8 (fromChar) -import Data.Monoid (mappend) -import Control.Monad (join) import Data.Maybe (fromMaybe) -import qualified Data.ByteString as S -import qualified Data.Conduit as C -import qualified Data.Conduit.List as CL +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mappend) +#endif +import Network.HTTP.Types (hAccept, hContentType) +import Network.Wai +import Network.Wai.Internal -- | Wrap json responses in a jsonp callback. -- @@ -35,8 +38,8 @@ -- having a content type of \"text\/javascript\" and calling the specified -- callback function. jsonp :: Middleware -jsonp app env = do - let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env +jsonp app env sendResponse = do + let accept = fromMaybe B8.empty $ lookup hAccept $ requestHeaders env let callback :: Maybe B8.ByteString callback = if B8.pack "text/javascript" `B8.isInfixOf` accept @@ -45,49 +48,55 @@ let env' = case callback of Nothing -> env - Just _ -> env - { requestHeaders = changeVal "Accept" - "application/json" - $ requestHeaders env + Just _ -> + env + { requestHeaders = + changeVal + hAccept + "application/json" + $ requestHeaders env } - res <- app env' - case callback of - Nothing -> return res - Just c -> go c res + app env' $ \res -> + case callback of + Nothing -> sendResponse res + Just c -> go c res where go c r@(ResponseBuilder s hs b) = - case checkJSON hs of - Nothing -> return r - Just hs' -> return $ ResponseBuilder s hs' $ - copyByteString c - `mappend` fromChar '(' - `mappend` b - `mappend` fromChar ')' + sendResponse $ case checkJSON hs of + Nothing -> r + 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' b - Nothing -> return r + Just hs' -> addCallback c s hs' wb + Nothing -> sendResponse r where - (s, hs, b) = responseSource r + (s, hs, wb) = responseToStream r checkJSON hs = - case lookup "Content-Type" hs of + case lookup hContentType hs of Just x | B8.pack "application/json" `S.isPrefixOf` x -> Just $ fixHeaders hs _ -> Nothing - fixHeaders = changeVal "Content-Type" "text/javascript" + fixHeaders = changeVal hContentType "text/javascript" - addCallback cb s hs b = - return $ ResponseSource s hs $ - CL.sourceList [C.Chunk $ copyByteString cb `mappend` fromChar '('] - `mappend` b - `mappend` CL.sourceList [C.Chunk $ fromChar ')'] + addCallback cb s hs wb = + wb $ \body -> sendResponse $ responseStream s hs $ \sendChunk flush -> do + sendChunk $ byteStringCopy cb `mappend` char7 '(' + _ <- 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 new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/Local.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} + +-- | Only allow local connections. +module Network.Wai.Middleware.Local ( + local, +) where + +import Network.Socket (SockAddr (..)) +import Network.Wai (Middleware, Response, remoteHost) + +-- | 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 +#if !defined(mingw32_HOST_OS) && !defined(_WIN32) + SockAddrUnix _ -> f r k +#endif + _ -> 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,22 +1,20 @@ -{-# LANGUAGE OverloadedStrings #-} -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) --- | Allows overriding of the HTTP request method via the _method query string --- parameter. +-- | Overriding of HTTP request method via `_method` query string parameter. -- --- This middlware only applies when the initial request method is POST. This --- allow submitting of normal HTML forms, without worries of semantics --- mismatches in the HTTP spec. +-- This middleware only applies when the initial request method is POST. +-- Allows submitting of normal HTML forms, without worries of semantic +-- mismatches with the HTTP spec. methodOverride :: Middleware methodOverride app req = app req' 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,19 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------- + +----------------------------------------------------------------- + -- | Module : Network.Wai.Middleware.MethodOverridePost -- -- Changes the request-method via first post-parameter _method. ------------------------------------------------------------------ -module Network.Wai.Middleware.MethodOverridePost - ( methodOverridePost - ) where +module Network.Wai.Middleware.MethodOverridePost ( + methodOverridePost, +) where +import Data.ByteString.Lazy (toChunks) +import Data.IORef (atomicModifyIORef, newIORef) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mconcat, mempty) +#endif +import Network.HTTP.Types (hContentType, parseQuery) import Network.Wai -import Network.HTTP.Types (parseQuery) -import Data.Monoid (mconcat) -import Data.Conduit.Lazy (lazyConsume) -import Control.Monad.Trans.Resource (ResourceT) -import Data.Conduit.List (sourceList) -- | Allows overriding of the HTTP request method via the _method post string parameter. -- @@ -24,16 +28,21 @@ -- then it changes the request-method to the value of that -- parameter. -- --- * This middlware only applies when the initial request method is POST. --- +-- * This middleware only applies when the initial request method is POST. methodOverridePost :: Middleware -methodOverridePost app req = case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of - ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= app - _ -> app req +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 -setPost :: Request -> ResourceT IO Request +setPost :: Request -> IO Request setPost req = do - body <- lazyConsume (requestBody req) - case parseQuery (mconcat body) of - (("_method", Just newmethod):_) -> return $ req {requestBody = sourceList body, requestMethod = newmethod} - _ -> return $ req {requestBody = sourceList body} + 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,139 +1,403 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# 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 - , 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, stdout) -import qualified Data.ByteString as BS -import Data.ByteString.Char8 (pack, unpack) + -- * 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(..), Middleware, responseStatus, Response) -import System.Log.FastLogger +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B (Builder, byteString) +import Data.ByteString.Char8 (pack) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as LBS +import Data.Default (Default (def)) +import Data.IORef +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 Data.Maybe (fromMaybe) +import Network.Wai ( + Middleware, + Request (..), + RequestBodyLength (..), + Response, + getRequestBodyChunk, + requestBodyLength, + responseHeaders, + responseStatus, + setRequestBodyChunks, + ) +import Network.Wai.Internal (Response (..)) +import Network.Wai.Logger +import System.Console.ANSI +import System.IO (Handle, hFlush, stdout) +import System.IO.Unsafe (unsafePerformIO) +import System.Log.FastLogger -import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType) -import qualified Data.ByteString.Lazy as LBS +import Network.Wai.Header (contentLength) +import Network.Wai.Middleware.RequestLogger.Internal +import Network.Wai.Parse ( + File, + Param, + fileName, + getRequestBodyType, + lbsBackEnd, + sinkRequestBody, + ) -import qualified Data.Conduit as C -import qualified Data.Conduit.List as CL +-- | The logging format. +-- +-- @since 1.3.0 +data OutputFormat + = Apache IPAddrSource + | -- | @since 3.1.8 + ApacheWithSettings ApacheSettings + | -- | use colors? + Detailed Bool + | -- | @since 3.1.3 + DetailedWithSettings DetailedSettings + | CustomOutputFormat OutputFormatter + | CustomOutputFormatWithDetails OutputFormatterWithDetails + | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders -import System.Console.ANSI -import Data.IORef.Lifted -import System.IO.Unsafe +-- | 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 + } -import Data.Default (Default (def)) -import Network.Wai.Logger.Format (apacheFormat, IPAddrSource (..)) -import Network.Wai.Middleware.RequestLogger.Internal +defaultApacheSettings :: ApacheSettings +defaultApacheSettings = + ApacheSettings + { apacheIPAddrSource = FromSocket + , apacheRequestFilter = \_ _ -> True + , apacheUserGetter = const Nothing + } -data OutputFormat = Apache IPAddrSource - | Detailed Bool -- ^ use colors? - | CustomOutputFormat OutputFormatter +-- | 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} -type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> [LogStr] +-- | 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} -data Destination = Handle Handle - | Logger Logger - | Callback Callback +-- | 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} -type Callback = [LogStr] -> IO () +-- | 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 + +-- | Same as @OutputFormatterWithDetails@ but with response headers included +-- +-- This is useful if you wish to include arbitrary application data in your +-- logs, e.g., an authenticated user ID, which you would set in a response +-- 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 + +-- | 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 () + +-- | 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 - (callback, mgetdate) <- - case destination of - Handle h -> fmap fromLogger $ mkLogger autoFlush h - Logger l -> return $ fromLogger l - Callback c -> return (c, Nothing) + let (callback, flusher) = + case destination of + Handle h -> (BS.hPutStr h . logToByteString, when autoFlush (hFlush h)) + Logger l -> (pushLogStr l, when autoFlush (flushLogStr l)) + Callback c -> (c, return ()) + callbackAndFlush str = callback str >> flusher case outputFormat of Apache ipsrc -> do - getdate <- dateHelper mgetdate - return $ apacheMiddleware callback ipsrc getdate - Detailed useColors -> detailedMiddleware callback useColors + getdate <- getDateGetter flusher + apache <- initLogger ipsrc (LogCallback callback flusher) getdate + 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 <- dateHelper mgetdate - return $ customMiddleware callback getdate formatter - where - fromLogger l = (loggerPutStr l, Just $ loggerDate l) - dateHelper mgetdate = do - case mgetdate of - Just x -> return x - Nothing -> getDateGetter + getDate <- getDateGetter flusher + return $ customMiddleware callbackAndFlush getDate formatter + CustomOutputFormatWithDetails formatter -> do + getdate <- getDateGetter flusher + return $ customMiddlewareWithDetails callbackAndFlush getdate formatter + CustomOutputFormatWithDetailsAndHeaders formatter -> do + getdate <- getDateGetter flusher + return $ + customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter -apacheMiddleware :: Callback -> IPAddrSource -> IO ZonedDate -> Middleware -apacheMiddleware cb ipsrc getdate = customMiddleware cb getdate $ apacheFormat ipsrc +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 -customMiddleware cb getdate formatter app req = do - res <- app req +customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> do date <- liftIO getdate - -- We use Nothing for the response size since we generally don't know it - liftIO $ cb $ formatter date req (responseStatus res) Nothing - return res + let msize = contentLength (responseHeaders res) + liftIO $ cb $ formatter date req (responseStatus res) msize + sendResponse res +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 + +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 + -- | Production request logger middleware. --- Implemented on top of "logCallback", but prints to 'stdout' +-- +-- 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. --- Implemented on top of "logCallbackDev", but prints to 'stdout' -- --- Flushes 'stdout' on each request, which would be inefficient in production use. --- Use "logStdout" in production. +-- This uses the 'Detailed' 'True' logging format and logs to 'stdout'. +{-# NOINLINE logStdoutDev #-} logStdoutDev :: Middleware -logStdoutDev = unsafePerformIO $ mkRequestLogger def - --- no black or white which are expected to be existing terminal colors. -colors0 :: [Color] -colors0 = [ - Red - , Green - , Yellow - , Blue - , Magenta - , Cyan - ] - -rotateColors :: [Color] -> ([Color], Color) -rotateColors [] = error "Impossible! There must be colors!" -rotateColors (c:cs) = (cs ++ [c], c) +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. @@ -143,131 +407,204 @@ -- This meanst that you can accurately see the interleaving of requests. -- And if the app crashes you have still logged the request. -- However, if you are simulating 10 simultaneous users you may find this confusing. --- The request and response are connected by color on Unix and also by the request path. -- -- This is lower-level - use 'logStdoutDev' unless you need greater control. -- -- Example ouput: -- -- > GET search --- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8 --- > --- > Status: 200 OK. search +-- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*​/​*;q=0.8 +-- > Status: 200 OK 0.010555s -- > -- > GET static/css/normalize.css --- > Accept: text/css,*/*;q=0.1 --- > GET [("LXwioiBG","")] --- > --- > Status: 304 Not Modified. static/css/normalize.css +-- > Params: [("LXwioiBG","")] +-- > Accept: text/css,*​/​*;q=0.1 +-- > Status: 304 Not Modified 0.010555s +detailedMiddleware :: Callback -> DetailedSettings -> IO Middleware +-- NB: The *​/​* in the comments above have "zero-width spaces" in them, so the +-- CPP doesn't screw up everything. So don't copy those; they're technically wrong. +detailedMiddleware cb settings = + let (ansiColor, ansiMethod, ansiStatusCode) = + if useColors settings + then (ansiColor', ansiMethod', ansiStatusCode') + else (\_ t -> [t], (: []), \_ t -> [t]) + in return $ detailedMiddleware' cb settings ansiColor ansiMethod ansiStatusCode -detailedMiddleware :: Callback -> Bool -> IO Middleware -detailedMiddleware cb useColors = do - getAddColor <- - if useColors - then do - icolors <- newIORef colors0 - return $ do - color <- liftIO $ atomicModifyIORef icolors rotateColors - return $ ansiColor color - else return (return return) - return $ detailedMiddleware' cb getAddColor - where - ansiColor color bs = [ - pack $ setSGRCode [SetColor Foreground Vivid color] - , bs - , pack $ setSGRCode [Reset] - ] +ansiColor' :: Color -> BS.ByteString -> [BS.ByteString] +ansiColor' color bs = + [ pack $ setSGRCode [SetColor Foreground Dull color] + , bs + , pack $ setSGRCode [Reset] + ] -detailedMiddleware' :: Callback - -> (C.ResourceT IO (BS.ByteString -> [BS.ByteString])) - -> Middleware -detailedMiddleware' cb getAddColor app req = do - let mlen = lookup "content-length" (requestHeaders req) >>= readInt +-- | 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 + "DELETE" -> ansiColor' Red 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 + +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) +recordChunks i (ResponseBuilder s h b) = + modifyIORef i (<> b) >> return (ResponseBuilder s h b) +recordChunks _ r = + return r + +getRequestBody :: Request -> IO (Request, [S8.ByteString]) +getRequestBody req = do + let loop front = do + bs <- 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) + +{- 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) <- - case mlen of + -- 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 - Just len | len <= 2048 -> do - body <- requestBody req C.$$ CL.consume - -- 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 = do - chunks <- readIORef ichunks - case chunks of - [] -> return () - x:xs -> do - writeIORef ichunks xs - C.yield x - rbody - let req' = req { requestBody = rbody } - return (req', body) + (KnownLength len, _) | len <= 2048 -> getRequestBody req + (_, Just len) | len <= 2048 -> getRequestBody req _ -> return (req, []) - postParams <- if requestMethod req `elem` ["GET", "HEAD"] - then return [] - else do postParams <- liftIO $ allPostParams body - return $ collectPostParams postParams + let reqbodylog _ = + if null body || isJust mModifyParams + then [""] + else ansiColor White " Request Body: " <> body <> ["\n"] + reqbody = concatMap (either (const [""]) reqbodylog . decodeUtf8') body + postParams <- + if requestMethod req `elem` ["GET", "HEAD"] + then return [] + else do + (unmodifiedPostParams, files) <- liftIO $ allPostParams body + let postParams = + case mModifyParams of + Just modifyParams -> mapMaybe modifyParams unmodifiedPostParams + Nothing -> unmodifiedPostParams + return $ collectPostParams (postParams, files) let getParams = map emptyGetParam $ queryString req + accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req + params = + let par + | not $ null postParams = [pack (show postParams)] + | not $ null getParams = [pack (show getParams)] + | otherwise = [] + in if null par then [""] else ansiColor White " Params: " <> par <> ["\n"] - addColor <- getAddColor + t0 <- getCurrentTime - -- log the request immediately. - liftIO $ cb $ map LB $ addColor (requestMethod req) ++ - [ " " - , rawPathInfo req - , "\n" - , "Accept: " - , fromMaybe "" $ lookup "Accept" $ requestHeaders req - , paramsToBS "GET " getParams - , paramsToBS "POST " postParams - , "\n" - ] + -- Optionally prelog the request + when mPrelogRequests $ + cb $ + "PRELOGGING REQUEST: " <> mkRequestLog params reqbody accept - rsp <- app req' + app req' $ \rsp -> do + case mFilterRequests of + Just f | not $ f req' rsp -> pure () + _ -> do + let isRaw = + case rsp of + ResponseRaw{} -> True + _ -> False + stCode = statusBS rsp + stMsg = msgBS rsp + t1 <- getCurrentTime - -- log the status of the response - -- this is color coordinated with the request logging - -- also includes the request path to connect it to the request - liftIO $ cb $ map LB $ addColor "Status: " ++ [ - statusBS rsp - , " " - , msgBS rsp - , ". " - , rawPathInfo req -- if you need help matching the 2 logging statements - , "\n" - ] - return rsp - where - paramsToBS prefix params = - if null params then "" - else BS.concat ["\n", prefix, pack (show params)] + -- log the status of the response + cb $ + mkRequestLog params reqbody accept + <> mkResponseLog isRaw stCode stMsg t1 t0 + sendResponse rsp + where allPostParams body = case getRequestBodyType req of Nothing -> return ([], []) - Just rbt -> C.runResourceT $ CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt + Just rbt -> do + ichunks <- newIORef body + let rbody = atomicModifyIORef ichunks $ \chunks -> + case chunks of + [] -> ([], S8.empty) + 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, BS.append "FILE: " (fileName v))) files + collectPostParams (postParams, files) = + postParams + ++ map (\(k, v) -> (k, "FILE: " <> fileName v)) files - readInt bs = - case reads $ unpack bs of - (i, _):_ -> Just (i :: Int) - [] -> Nothing + 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,20 +1,37 @@ {-# LANGUAGE CPP #-} + -- | A module for containing some CPPed code, due to: -- -- https://github.com/yesodweb/wai/issues/192 -module Network.Wai.Middleware.RequestLogger.Internal where +module Network.Wai.Middleware.RequestLogger.Internal ( + getDateGetter, + logToByteString, +) where -import Data.ByteString (ByteString) -import System.Log.FastLogger -#if MIN_VERSION_fast_logger(0,3,0) -import System.Date.Cache (ondemandDateCacher) -#else -import System.Log.FastLogger.Date (getDate, dateInit, ZonedDate) +#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) -getDateGetter :: IO (IO ByteString) -#if MIN_VERSION_fast_logger(0, 3, 0) -getDateGetter = fmap fst $ ondemandDateCacher zonedDateCacheConf +logToByteString :: LogStr -> ByteString +logToByteString = fromLogStr + +getDateGetter + :: IO () + -- ^ flusher + -> IO (IO ByteString) +#if !MIN_VERSION_wai_logger(2, 2, 0) +getDateGetter flusher = do + (getter, updater) <- clockDateCacher + _ <- forkIO $ forever $ do + threadDelay 1000000 + updater + flusher #else -getDateGetter = fmap getDate dateInit +getDateGetter _ = do + (getter, _) <- clockDateCacher #endif + return getter diff --git a/Network/Wai/Middleware/RequestLogger/JSON.hs b/Network/Wai/Middleware/RequestLogger/JSON.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/RequestLogger/JSON.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP #-} + +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.CaseInsensitive (original) +import Data.IP (fromHostAddress, fromIPv4) +import Data.Maybe (maybeToList) +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#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 (PortNumber, SockAddr (..)) +import Network.Wai +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 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 +-- +-- This is useful for passing arbitrary data from your application out to the +-- WAI layer for it to be logged, but you may need to be careful to +-- subsequently redact any headers which may contain sensitive data. +-- +-- @since 3.0.27 +formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders +formatAsJSONWithHeaders date req status resSize duration reqBody res resHeaders = + toLogStr + ( encode $ + object + [ "request" .= requestToJSON req reqBody (Just duration) + , "response" + .= object + [ "status" .= statusCode status + , "size" .= resSize + , "headers" .= responseHeadersToJSON resHeaders + , "body" + .= if statusCode status >= 400 + then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ res + else Nothing + ] + , "time" .= decodeUtf8With lenientDecode date + ] + ) + <> "\n" + +word32ToHostAddress :: Word32 -> Text +word32ToHostAddress = T.intercalate "." . map (T.pack . show) . fromIPv4 . fromHostAddress + +readAsDouble :: String -> Double +readAsDouble = read + +-- | 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 + ] +sockToJSON (SockAddrInet6 pn _ ha _) = + object + [ "port" .= portToJSON pn + , "hostAddress" .= ha + ] +sockToJSON (SockAddrUnix 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) + +requestHeadersToJSON :: RequestHeaders -> Value +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 + +headerToJSON :: Header -> Value +headerToJSON (headerName, header) = + toJSON + ( decodeUtf8With lenientDecode . original $ headerName + , decodeUtf8With lenientDecode header + ) + +portToJSON :: PortNumber -> Value +portToJSON = toJSON . toInteger + +httpVersionToJSON :: HttpVersion -> Value +httpVersionToJSON (HttpVersion major minor) = String $ T.pack (show major) <> "." <> T.pack (show minor) + +requestBodyLengthToJSON :: RequestBodyLength -> Value +requestBodyLengthToJSON ChunkedBody = String "Unknown" +requestBodyLengthToJSON (KnownLength l) = toJSON l 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,33 +1,364 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Middleware.Rewrite - ( rewrite, rewritePure - ) where +{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} -import Network.Wai +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 + -- $takeover + + -- ** Upgrading from wai-extra ≤ 3.0.16.1 + -- $upgrading + + -- * 'Middleware' + + -- ** Recommended functions + rewriteWithQueries, + rewritePureWithQueries, + rewriteRoot, + + -- ** Deprecated + rewrite, + rewritePure, + + -- * 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.Encoding as TE import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Network.HTTP.Types as H +import Network.Wai +-- $howto +-- This module provides 'Middleware' to rewrite URL paths. It also provides +-- functions that will convert a 'Request' to a modified 'Request'. +-- Both operations require a function that takes URL parameters and +-- headers, and returns new URL parameters. Parameters are pieces of URL +-- paths and query parameters. +-- +-- If you are a new user of the library, use 'rewriteWithQueries' or +-- 'rewritePureWithQueries' for middleware. For modifying 'Request's +-- directly, use 'rewriteRequest' or 'rewriteRequestPure'. --- | rewrite based on your own conversion rules -rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware -rewrite convert app req = do - newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req) - let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo - app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo } +-- $semantics +-- +-- Versions of this library in wai-extra ≤ 3.0.16.1 exported only +-- 'rewrite' and 'rewritePure' and both modified 'rawPathInfo' of the +-- underlying requests. Such modification has been proscribed. The +-- semantics of these functions have not changed; instead the recommended +-- approach is to use 'rewriteWithQueries' and 'rewritePureWithQueries'. +-- The new functions are slightly different, as described in the section +-- on upgrading; code for previous library versions can be upgraded with +-- a single change, and as the type of the new function is different the +-- compiler will indicate where this change must be made. +-- +-- The 'rewriteRequest' and 'rewriteRequestPure' functions use the new +-- semantics, too. --- | rewrite based on your own conversion rules --- Example convert function: +-- $pathsandqueries +-- +-- This library defines the type synonym `PathsAndQueries` to make code +-- handling paths and queries easier to read. +-- +-- /e.g./ /\/foo\/bar/ would look like +-- +-- > ["foo", "bar"] :: Text +-- +-- /?bar=baz/ would look like +-- +-- > [("bar", Just "baz")] :: QueryText +-- +-- Together, +-- +-- /\/foo?bar=baz/ would look like +-- +-- > (["foo"],[("bar", Just "baz")]) :: PathsAndQueries --- staticConvert :: [Text] -> H.RequestHeaders -> [Text] --- staticConvert pieces _ = piecesConvert pieces +-- $takeover +-- Let’s say we want to replace a website written in PHP with one written +-- using WAI. We’ll use the +-- +-- package to serve the old +-- site from the new site, but there’s a problem. The old site uses pages like +-- +-- @ +-- index.php?page=/page/ +-- @ +-- +-- whereas the new site would look like +-- +-- @ +-- index\//page/ +-- @ +-- +-- In doing this, we want to separate the migration code from our new +-- website. So we’d like to handle links internally using the path +-- formulation, but externally have the old links still work. +-- +-- Therefore, we will use middleware ('rewritePureWithQueries') from this +-- module to rewrite incoming requests from the query formulation to the +-- paths formulation. +-- +-- > {-# LANGUAGE ViewPatterns #-} +-- > +-- > rewritePathFromPhp :: Middleware +-- > rewritePathFromPhp = rewritePureWithQueries pathFromPhp +-- > +-- > pathFromPhp :: PathsAndQueries -> H.RequestHeaders -> PathsAndQueries +-- > pathFromPhp (pieces, queries) _ = piecesConvert pieces queries +-- > where +-- > piecesConvert :: [Text] -> H.Query -> PathsAndQueries +-- > piecesConvert ["index.php"] qs@(join . lookup "page" -> Just page) = +-- > ( ["index", TE.decodeUtf8With TE.lenientDecode page] +-- > , delete ("page", pure page) qs +-- > ) +-- > piecesConvert ps qs = (ps, qs) +-- +-- On the other side, we will use 'rewriteRequestPure' to rewrite outgoing +-- requests to the original website from the reverse proxy code (using the +-- 'Network.HTTP.ReverseProxy.WPRModifiedRequest' or +-- 'Network.HTTP.ReverseProxy.WPRModifiedRequestSecure' constructors. Note, +-- these links will only work if the haddock documentation for +-- +-- is installed). +-- +-- > rewritePhpFromPath :: Request -> Request +-- > rewritePhpFromPath = rewriteRequestPure phpFromPath +-- > +-- > phpFromPath :: PathsAndQueries -> H.RequestHeaders -> PathsAndQueries +-- > phpFromPath (pieces, queries) _ = piecesConvert pieces queries +-- > where +-- > piecesConvert :: [Text] -> H.Query -> PathsAndQueries +-- > piecesConvert ["index", page] qs = ( ["index.php"], ("page", pure . TE.encodeUtf8 $ page) : qs ) +-- > piecesConvert ps qs = (ps, qs) +-- +-- For the whole example, see +-- . + +-- $upgrading +-- It is quite simple to upgrade from 'rewrite' and 'rewritePure', to +-- 'rewriteWithQueries' and 'rewritePureWithQueries'. +-- Insert 'Data.Bifunctor.first', which specialises to +-- +-- @ +-- 'Data.Bifunctor.first' :: (['Text'] -> ['Text']) -> 'PathsAndQueries' -> 'PathsAndQueries' +-- @ +-- +-- as the following example demonstrates. +-- +-- Old versions of the library could only handle path pieces, not queries. +-- This could have been supplied to 'rewritePure'. +-- +-- @ +-- staticConvert' :: [Text] -> H.RequestHeaders -> [Text] +-- staticConvert' pieces _ = piecesConvert pieces -- where -- piecesConvert [] = ["static", "html", "pages.html"] -- piecesConvert route@("pages":_) = "static":"html":route +-- @ +-- +-- Instead, use this function, supplied to 'rewritePureWithQueries'. +-- +-- @ +-- staticConvert :: 'PathsAndQueries' -> H.RequestHeaders -> 'PathsAndQueries' +-- staticConvert pathsAndQueries _ = 'Data.Bifunctor.first' piecesConvert pathsAndQueries +-- where +-- piecesConvert [] = ["static", "html", "pages.html"] +-- piecesConvert route@("pages":_) = "static":"html":route +-- @ +-- +-- The former formulation is deprecated for two reasons: +-- +-- 1. The original formulation of 'rewrite' modified 'rawPathInfo', which +-- is deprecated behaviour. +-- +-- 2. The original formulation did not allow query parameters to +-- influence the path. +-- +-- Concerning the first point, take care with semantics of your program when +-- upgrading as the upgraded functions no longer modify 'rawPathInfo'. + +-------------------------------------------------- + +-- * Types + +-------------------------------------------------- + +-- | A tuple of the path sections as ['Text'] and query parameters as +-- 'H.Query'. This makes writing type signatures for the conversion +-- function far more pleasant. +-- +-- Note that this uses 'H.Query' not 'H.QueryText' to more accurately +-- reflect the paramaters that can be supplied in URLs. It may be safe to +-- treat parameters as text; use the 'H.queryToQueryText' and +-- 'H.queryTextToQuery' functions to interconvert. +type PathsAndQueries = ([Text], H.Query) + +-------------------------------------------------- + +-- * Rewriting 'Middleware' + +-------------------------------------------------- + +-- | Rewrite based on your own conversion function for paths only, to be +-- supplied by users of this library (with the conversion operating in 'IO'). +-- +-- 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" + ] + #-} + +-- | Rewrite based on pure conversion function for paths only, to be +-- supplied by users of this library. +-- +-- For new code, use 'rewritePureWithQueries' instead. rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware rewritePure convert app req = - let pInfo = convert (pathInfo req) (requestHeaders req) - rawPInfo = TE.encodeUtf8 $ T.intercalate "/" pInfo - in app req { pathInfo = pInfo, rawPathInfo = rawPInfo } + 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 convert app req sendResponse = do + 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 convert app req = app $ rewriteRequestPure convert req + +-- | Rewrite root requests (/) to a specified path +-- +-- Note that /index.html/ in example below should already be a valid route. +-- +-- @ +-- rewriteRoot "index.html" :: Middleware +-- @ +-- +-- @since 3.0.23.0 +rewriteRoot :: Text -> Middleware +rewriteRoot root = rewritePureWithQueries onlyRoot + where + onlyRoot ([], q) _ = ([root], q) + 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 convert 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 convert 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 convert req = do + (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 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" + ] + #-} + +-- | 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 convert psAndQs headers = (,[]) <$> convert (fst psAndQs) headers +{-# INLINE pathsOnly #-} diff --git a/Network/Wai/Middleware/Routed.hs b/Network/Wai/Middleware/Routed.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/Routed.hs @@ -0,0 +1,46 @@ +-- | +-- +-- Since 3.0.9 +module Network.Wai.Middleware.Routed ( + routedMiddleware, + hostedMiddleware, +) where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Network.Wai + +-- | Apply a middleware based on a test of pathInfo +-- +-- example: +-- +-- > 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 pathCheck middle 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 domain middle app req + | hasDomain domain req = middle app req + | otherwise = app req + +hasDomain :: ByteString -> Request -> Bool +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 new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/StreamFile.hs @@ -0,0 +1,36 @@ +-- | +-- +-- Since 3.0.4 +module Network.Wai.Middleware.StreamFile (streamFile) where + +import qualified Data.ByteString.Char8 as S8 +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 +-- +-- 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. +-- +-- 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 +streamFile :: Middleware +streamFile app env sendResponse = app env $ \res -> + case res of + 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 diff --git a/Network/Wai/Middleware/StripHeaders.hs b/Network/Wai/Middleware/StripHeaders.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/StripHeaders.hs @@ -0,0 +1,50 @@ +-- This was written for one specific use case and then generalized. + +-- The specific use case was a JSON API with a consumer that would choke on the +-- "Set-Cookie" response header. The solution was to test for the API's +-- `pathInfo` in the Request and if it matched, filter the response headers. + +-- 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 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)) + +stripHeaders :: [ByteString] -> (Response -> Response) +stripHeaders hs = + 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. +-- +-- Since 3.0.8 +stripHeaderIf :: ByteString -> (Request -> Bool) -> Middleware +stripHeaderIf h rpred = + 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) diff --git a/Network/Wai/Middleware/Timeout.hs b/Network/Wai/Middleware/Timeout.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/Timeout.hs @@ -0,0 +1,33 @@ +-- | Timeout requests +module Network.Wai.Middleware.Timeout ( + timeout, + timeoutStatus, + timeoutAs, +) where + +import Network.HTTP.Types (Status, status503) +import Network.Wai +import qualified System.Timeout as Timeout + +-- | Time out the request after the given number of seconds +-- +-- Timeouts respond with @'status503'@. See @'timeoutStatus'@ or @'timeoutAs'@ +-- to customize the behavior of the timed-out case. +-- +-- @since 3.0.24.0@ +timeout :: Int -> Middleware +timeout = timeoutStatus status503 + +-- | Time out with the given @'Status'@ +-- +-- @since 3.0.24.0@ +timeoutStatus :: Status -> Int -> Middleware +timeoutStatus status = timeoutAs $ responseLBS status [] "" + +-- | Time out with the given @'Response'@ +-- +-- @since 3.0.24.0@ +timeoutAs :: Response -> Int -> Middleware +timeoutAs timeoutReponse seconds app req respond = + maybe (respond timeoutReponse) pure + =<< Timeout.timeout (seconds * 1000000) (app req respond) 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,23 +1,47 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Middleware.Vhost (vhost, redirectWWW) where +{-# LANGUAGE CPP #-} -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 app req = - if BS.isPrefixOf "www" $ serverName req - then return $ responseLBS H.status301 - [ ("Content-Type", "text/plain") , ("Location", TE.encodeUtf8 home) ] "Redirect" - else app req +redirectWWW home = + 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 + +redirectTo :: BS.ByteString -> Response +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 diff --git a/Network/Wai/Parse.hs b/Network/Wai/Parse.hs --- a/Network/Wai/Parse.hs +++ b/Network/Wai/Parse.hs @@ -1,63 +1,90 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} +{-# 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 - , conduitRequestBody - , BackEnd - , lbsBackEnd - , tempFileBackEnd - , tempFileBackEndOpts - , Param - , File - , FileInfo (..) - , parseContentType +-- | 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 qualified Data.ByteString.Search as Search +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 Data.Maybe (fromMaybe) +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.List (sortBy) -import Data.Function (on) -import System.Directory (removeFile, getTemporaryDirectory) -import System.IO (hClose, openBinaryTempFile) -import Network.Wai -import Data.Conduit -import Data.Conduit.Internal () -import qualified Data.Conduit.List as CL -import qualified Data.Conduit.Binary as CB -import Control.Monad.IO.Class (liftIO) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Typeable +import Data.Word8 +import Network.HTTP.Types (hContentType) import qualified Network.HTTP.Types as H -import Data.Either (partitionEithers) -import Control.Monad (when, unless) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Resource (allocate, release, register) -#if MIN_VERSION_conduit(1, 0, 0) -import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, injectLeftovers, ConduitM (..)) -import Data.Void (Void) -#else -import Data.Conduit.Internal (sinkToPipe) -#endif +import Network.Wai +import Network.Wai.Handler.Warp (InvalidRequest (..)) +import System.Directory (getTemporaryDirectory, removeFile) +import System.IO (hClose, openBinaryTempFile) +import System.IO.Error (isDoesNotExistError) breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s = @@ -66,52 +93,230 @@ -- | 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 -> Sink S.ByteString m L.ByteString -lbsBackEnd _ _ = fmap L.fromChunks CL.consume +lbsBackEnd + :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString +lbsBackEnd _ _ popper = + loop id + where + loop front = do + bs <- popper + if S.null bs + then return $ L.fromChunks $ front [] + else loop $ front . (bs :) -- | Save uploaded files on disk as temporary files -tempFileBackEnd :: MonadResource m => ignored1 -> ignored2 -> Sink S.ByteString m FilePath +-- +-- 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 = tempFileBackEndOpts getTemporaryDirectory "webenc.buf" --- | Same as 'tempFileSink', but use configurable temp folders and patterns. -tempFileBackEndOpts :: MonadResource m - => IO FilePath -- ^ get temporary directory - -> String -- ^ filename pattern - -> ignored1 - -> ignored2 - -> Sink S.ByteString m FilePath -tempFileBackEndOpts getTmpDir pattern _ _ = do - (key, (fp, h)) <- lift $ allocate (do - tempDir <- getTmpDir - openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h) - _ <- lift $ register $ removeFile fp - CB.sinkHandle h - lift $ release key +-- | 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 getTmpDir pattrn internalState _ _ popper = do + (key, (fp, h)) <- + flip runInternalState internalState $ allocate it (hClose . snd) + _ <- runInternalState (register $ removeFileQuiet fp) internalState + fix $ \loop -> do + bs <- popper + unless (S.null bs) $ do + S.hPut h bs + loop + release key return fp + 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 + { 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} + +-- | Do not limit the length of filenames. +-- +-- @since 3.0.16.0 +clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions +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} + +-- | Do not limit the maximum number of files per request. +-- +-- @since 3.0.16.0 +clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions +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} + +-- | Do not limit the maximum filesize per file. +-- +-- @since 3.0.16.0 +clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions +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} + +-- | Do not limit the maximum size of all files per request. +-- +-- @since 3.0.16.0 +clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions +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} + +-- | 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} + +-- | 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} + +-- | Do not limit the maximum header lines per mime/multipart entry. +-- +-- @since 3.0.16.0 +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} + +-- | Do not limit the maximum header lines per mime/multipart entry. +-- +-- @since 3.0.16.0 +clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions +clearMaxHeaderLineLength p = p{prboMaxHeaderLineLength = Nothing} + +-- | A reasonable default set of parsing options. +-- Maximum key/filename length: 32 bytes; +-- maximum files: 10; filesize unlimited; maximum +-- size for parameters: 64kbytes; maximum number of header +-- lines: 32 bytes (applies only to headers of a mime/multipart message); +-- maximum header line length: Apache's default for that is 8190 bytes +-- (http://httpd.apache.org/docs/2.2/mod/core.html#limitrequestline) +-- so we're using that here as well. +-- +-- @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 + } + +-- | 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 + } + -- | Information on an uploaded file. data FileInfo c = FileInfo { fileName :: S.ByteString @@ -126,17 +331,28 @@ -- | Post parameter name and associated file information. type File y = (S.ByteString, FileInfo y) --- | A file uploading backend. Takes the parameter name, file name, and content --- type, and returns a `Sink` for storing the contents. -type BackEnd a = S.ByteString -- ^ parameter name - -> FileInfo () - -> Sink S.ByteString (ResourceT IO) a +-- | 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 -data RequestBodyType = UrlEncoded | Multipart S.ByteString +-- | The mimetype of the http body. +-- Depending on whether just parameters or parameters and files +-- are passed, one or the other mimetype should be used. +data RequestBodyType + = -- | application/x-www-form-urlencoded (parameters only) + UrlEncoded + | -- | multipart/form-data (parameters and files) + Multipart S.ByteString +-- | Get the mimetype of the body of an http request. getRequestBodyType :: Request -> Maybe RequestBodyType getRequestBodyType req = do - ctype' <- lookup "Content-Type" $ requestHeaders req + ctype' <- lookup hContentType $ requestHeaders req let (ctype, attrs) = parseContentType ctype' case ctype of "application/x-www-form-urlencoded" -> return UrlEncoded @@ -146,152 +362,334 @@ -- | Parse a content type value, turning a single @ByteString@ into the actual -- content type and a list of pairs of attributes. -- --- Since 1.3.2 -parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)]) +-- @since 1.3.2 +parseContentType + :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)]) parseContentType a = do - let (ctype, b) = S.break (== semicolon) a + let (ctype, b) = S.break (== _semicolon) a attrs = goAttrs id $ S.drop 1 b in (ctype, attrs) where - semicolon = 59 - equals = 61 - space = 32 + dq s = + if S.length s > 2 && S.head s == _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, strip v) - strip = S.dropWhile (== space) . fst . S.breakEnd (/= space) + in (strip k, dq $ strip v) + strip = S.dropWhile (== _space) . fst . S.breakEnd (/= _space) -parseRequestBody :: BackEnd y - -> Request - -> ResourceT IO ([Param], [File y]) -parseRequestBody s r = +-- | Parse the body of an HTTP request. +-- See parseRequestBodyEx for details. +-- Note: This function does not limit the memory it allocates. +-- When dealing with untrusted data (as is usually the case when +-- receiving input from the internet), it is recommended to +-- use the 'parseRequestBodyEx' function instead. +-- +-- since 3.1.15 : throws 'RequestParseException' if something goes wrong +parseRequestBody + :: BackEnd y + -> Request + -> IO ([Param], [File y]) +parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions + +-- | Parse the body of an HTTP request, limit resource usage. +-- The HTTP body can contain both parameters and files. +-- This function will return a list of key,value pairs +-- for all parameters, and a list of key,a pairs +-- for filenames. The a depends on the used backend that +-- is responsible for storing the received files. +-- +-- since 3.1.15 : throws 'RequestParseException' if something goes wrong +parseRequestBodyEx + :: ParseRequestBodyOptions + -> BackEnd y + -> Request + -> IO ([Param], [File y]) +parseRequestBodyEx o s r = case getRequestBodyType r of Nothing -> return ([], []) - Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume + Just rbt -> sinkRequestBodyEx o s rbt (getRequestBodyChunk r) -sinkRequestBody :: BackEnd y - -> RequestBodyType - -> Sink S.ByteString (ResourceT IO) ([Param], [File y]) -sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume +-- | since 3.1.15 : throws 'RequestParseException' if something goes wrong +sinkRequestBody + :: BackEnd y + -> RequestBodyType + -> IO S.ByteString + -> IO ([Param], [File y]) +sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions -conduitRequestBody :: BackEnd y - -> RequestBodyType - -> Conduit S.ByteString (ResourceT IO) (Either Param (File y)) -conduitRequestBody _ UrlEncoded = do +-- | Throws 'RequestParseException' if something goes wrong +-- +-- @since 3.0.16.0 +-- +-- since 3.1.15 : throws 'RequestParseException' if something goes wrong +sinkRequestBodyEx + :: ParseRequestBodyOptions + -> BackEnd y + -> RequestBodyType + -> 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), ()) + conduitRequestBodyEx o s r body add + bimap reverse reverse <$> readIORef ref + +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 -- strict byte strings here. - bs <- CL.consume - mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs -conduitRequestBody backend (Multipart bound) = - parsePieces backend $ S8.pack "--" `S.append` bound + let loop size front = do + bs <- rbody + if S.null bs + then return $ S.concat $ front [] + else do + let newsize = size + S.length bs + case prboMaxParmsSize o of + Just maxSize -> + when (newsize > maxSize) $ + E.throwIO $ + MaxParamSizeExceeded newsize + Nothing -> return () + 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 -#if MIN_VERSION_conduit(1, 0, 0) -takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString) -#else -takeLine :: Monad m => Pipe S.ByteString S.ByteString o u m (Maybe S.ByteString) -#endif -takeLine = - go id +-- | Take one header or subheader line. +-- Since: 3.0.26 +-- Throw 431 if headers too large. +takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString) +takeLine maxlen src = + go "" where - go front = await >>= maybe (close front) (push front) + go front = do + bs <- readSource src + case maxlen of + Just maxlen' -> + when (S.length front > maxlen') $ + E.throwIO RequestHeaderFieldsTooLarge + Nothing -> return () + if S.null bs + then close front + else push front bs - close front = leftover (front S.empty) >> return Nothing + close front = leftover src front >> return Nothing push front bs = do - let (x, y) = S.break (== 10) $ front bs -- LF + let (x, y) = S.break (== _lf) bs in if S.null y - then go $ S.append x + then go $ front `S.append` x else do - when (S.length y > 1) $ leftover $ S.drop 1 y - return $ Just $ killCR x + 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 RequestHeaderFieldsTooLarge + Nothing -> return () + return . Just $ killCR res -#if MIN_VERSION_conduit(1, 0, 0) -takeLines :: Consumer S.ByteString (ResourceT IO) [S.ByteString] -#else -takeLines :: Pipe S.ByteString S.ByteString o u (ResourceT IO) [S.ByteString] -#endif -takeLines = do - res <- takeLine +-- | @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 + -> Maybe Int + -> Source + -> IO [S.ByteString] +takeLines'' lines lineLength maxLines src = do + case maxLines of + Just maxLines' -> + when (length lines > maxLines') $ + E.throwIO $ + TooManyHeaderLines (length lines) + Nothing -> return () + res <- takeLine lineLength src case res of - Nothing -> return [] + Nothing -> return lines Just l - | S.null l -> return [] - | otherwise -> do - ls <- takeLines - return $ l : ls + | S.null l -> return lines + | otherwise -> takeLines'' (l : lines) lineLength maxLines src -parsePieces :: BackEnd y - -> S.ByteString -#if MIN_VERSION_conduit(1, 0, 0) - -> ConduitM S.ByteString (Either Param (File y)) (ResourceT IO) () -#else - -> Pipe S.ByteString S.ByteString (Either Param (File y)) u (ResourceT IO) () -#endif -parsePieces sink bound = - loop +data Source = Source (IO S.ByteString) (IORef S.ByteString) + +mkSource :: IO S.ByteString -> IO Source +mkSource f = do + ref <- newIORef S.empty + return $ Source f ref + +readSource :: Source -> IO S.ByteString +readSource (Source f ref) = do + bs <- atomicModifyIORef ref $ \bs -> (S.empty, bs) + if S.null bs + then f + else return bs + +{- HLint ignore readSource "Use tuple-section" -} + +leftover :: Source -> S.ByteString -> IO () +leftover (Source _ ref) = writeIORef ref + +-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong +parsePiecesEx + :: ParseRequestBodyOptions + -> BackEnd y + -> S.ByteString + -> IO S.ByteString + -> (Either Param (File y) -> IO ()) + -> IO () +parsePiecesEx o sink bound rbody add = + mkSource rbody >>= loop 0 0 0 0 where - loop = do - _boundLine <- takeLine - res' <- takeLines + 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 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 Just (mct, name, Just filename) -> do + case prboKeyLength o of + Just maxKeyLength -> + when (S.length name > maxKeyLength) $ + E.throwIO $ + FilenameTooLong name maxKeyLength + Nothing -> return () + case prboMaxNumFiles o of + Just maxFiles -> + when (numFiles >= maxFiles) $ + E.throwIO $ + MaxFileNumberExceeded numFiles + Nothing -> return () let ct = fromMaybe "application/octet-stream" mct fi0 = FileInfo filename ct () - (wasFound, y) <- sinkTillBound' bound name fi0 sink - yield $ Right (name, fi0 { fileContent = y }) - when wasFound loop + 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}) + 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) $ + E.throwIO $ + ParamNameTooLong name maxKeyLength + Nothing -> return () let seed = id let iter front bs = return $ front . (:) bs - (wasFound, front) <- sinkTillBound bound iter seed + ((wasFound, _fileSize), front) <- + sinkTillBound + bound + iter + seed + src + (fromIntegral <$> prboMaxParmsSize o) let bs = S.concat $ front [] let x' = (name, bs) - yield $ Left x' - when wasFound loop + let newParmSize = parmSize + S.length name + S.length bs + case prboMaxParmsSize o of + Just maxParmSize -> + when (newParmSize > maxParmSize) $ + E.throwIO $ + MaxParamSizeExceeded newParmSize + Nothing -> return () + add $ Left x' + when wasFound $ + loop + (numParms + 1) + numFiles + newParmSize + filesSize + src _ -> do -- ignore this part let seed = () iter () _ = return () - (wasFound, ()) <- sinkTillBound bound iter seed - when wasFound loop + ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing + when wasFound $ loop numParms numFiles parmSize filesSize src where - contDisp = S8.pack "Content-Disposition" - contType = S8.pack "Content-Type" + contDisp = mk $ S8.pack "Content-Disposition" + contType = mk $ S8.pack "Content-Type" parsePair s = - let (x, y) = breakDiscard 58 s -- colon - in (x, S.dropWhile (== 32) y) -- space + let (x, y) = breakDiscard _colon s + in (mk x, S.dropWhile (== _space) y) -data Bound = FoundBound S.ByteString S.ByteString - | NoBound - | PartialBound +-- | Things that could go wrong while parsing a 'Request' +-- +-- @since 3.1.15 +data RequestParseException + = MaxParamSizeExceeded Int + | ParamNameTooLong S.ByteString Int + | MaxFileNumberExceeded Int + | FilenameTooLong S.ByteString Int + | TooManyHeaderLines Int + deriving (Eq, Typeable) + +instance E.Exception RequestParseException +instance Show RequestParseException where + show = \case + MaxParamSizeExceeded lmax -> unwords ["maximum parameter size exceeded:", show lmax] + ParamNameTooLong s lmax -> unwords ["parameter name", S8.unpack s, "is too long:", show lmax] + MaxFileNumberExceeded lmax -> unwords ["maximum number of files exceeded:", show lmax] + FilenameTooLong fn lmax -> + unwords ["file name", S8.unpack fn, "too long:", show lmax] + TooManyHeaderLines nmax -> unwords ["Too many lines in mime/multipart header:", show nmax] + +data Bound + = FoundBound S.ByteString S.ByteString + | NoBound + | PartialBound deriving (Eq, Show) findBound :: S.ByteString -> S.ByteString -> Bound -findBound b bs = handleBreak $ Search.breakOn b bs +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 @@ -299,116 +697,141 @@ 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 -#if MIN_VERSION_conduit(1, 0, 0) - -> ConduitM S.ByteString o (ResourceT IO) (Bool, y) -#else - -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, y) -#endif -sinkTillBound' bound name fi sink = -#if MIN_VERSION_conduit(1, 0, 0) - ConduitM $ anyOutput $ -#endif - conduitTillBound bound >+> withUpstream (fix $ sink name fi) - where -#if MIN_VERSION_conduit(1, 0, 0) - fix :: Sink S8.ByteString (ResourceT IO) y -> Pipe Void S8.ByteString Void Bool (ResourceT IO) y - fix (ConduitM p) = ignoreTerm >+> injectLeftovers p - ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm) - await' = NeedInput (return . Just) (const $ return Nothing) - yield' = HaveOutput (return ()) (return ()) - - anyOutput p = p >+> dropInput - dropInput = NeedInput (const dropInput) return -#else - fix = sinkToPipe -#endif +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) -conduitTillBound :: Monad m - => S.ByteString -- bound -#if MIN_VERSION_conduit(1, 0, 0) - -> Pipe S.ByteString S.ByteString S.ByteString () m Bool -#else - -> Pipe S.ByteString S.ByteString S.ByteString u m Bool -#endif -conduitTillBound bound = -#if MIN_VERSION_conduit(1, 0, 0) - unConduitM $ -#endif - go id +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) + return (go ref sref, final ref sref) where - go front = await >>= maybe (close front) (push front) - close front = do - let bs = front S.empty - unless (S.null bs) $ yield bs - return False - push front bs' = do - let bs = front bs' - case findBound bound bs of - FoundBound before after -> do - let before' = killCRLF before - yield before' - leftover after - return True - 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) - else (bs, id) - yield toEmit - go front' - PartialBound -> go $ S.append bs + final ref sref = do + x <- readIORef ref + case x of + WTBWorking _ -> error "wrapTillBound did not finish" + WTBDone y -> do + siz <- readIORef sref + return (y, siz) -sinkTillBound :: S.ByteString - -> (x -> S.ByteString -> IO x) - -> x -#if MIN_VERSION_conduit(1, 0, 0) - -> Consumer S.ByteString (ResourceT IO) (Bool, x) -#else - -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, x) -#endif -sinkTillBound bound iter seed0 = -#if MIN_VERSION_conduit(1, 0, 0) - ConduitM $ -#endif - (conduitTillBound bound >+> (withUpstream $ ij $ CL.foldM iter' seed0)) - where - iter' a b = liftIO $ iter a b -#if MIN_VERSION_conduit(1, 0, 0) - ij (ConduitM p) = ignoreTerm >+> injectLeftovers p - ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm) - await' = NeedInput (return . Just) (const $ return Nothing) - yield' = HaveOutput (return ()) (return ()) -#else - ij = id -#endif + go ref sref = do + state <- readIORef ref + case state of + WTBDone _ -> return S.empty + WTBWorking front -> do + bs <- readSource src + cur <- atomicModifyIORef' sref $ \cur -> + let new = cur + fromIntegral (S.length bs) in (new, new) + case max' of + Just max'' | cur > max'' -> E.throwIO PayloadTooLarge + _ -> return () + if S.null bs + then do + writeIORef ref $ WTBDone False + return $ front bs + else push $ front bs + where + push bs = do + case findBound bound bs of + FoundBound before after -> do + let before' = killCRLF before + leftover src after + writeIORef ref $ WTBDone True + return before' + 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) + else (bs, id) + writeIORef ref $ WTBWorking front' + if S.null toEmit + then go ref sref + else return toEmit + PartialBound -> do + writeIORef ref $ WTBWorking $ S.append bs + go ref sref -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) +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 + bs <- next + if S.null bs + then return seed + else iter seed bs >>= loop + seed <- loop seed0 + b <- final + return (b, seed) +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 new file mode 100644 --- /dev/null +++ b/Network/Wai/Request.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | 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 qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C +import Data.IORef (atomicModifyIORef', newIORef) +import Data.Maybe (fromMaybe) +import Data.Typeable (Typeable) +import Data.Word (Word64) +import Network.HTTP.Types (HeaderName) +import Network.Wai + +-- | Does this request appear to have been made over an SSL connection? +-- +-- This function first checks @'isSecure'@, but also checks for headers that may +-- indicate a secure connection even in the presence of reverse proxies. +-- +-- Note: these headers can be easily spoofed, so decisions which require a true +-- SSL connection (i.e. sending sensitive information) should only use +-- @'isSecure'@. This is not always the case though: for example, deciding to +-- force a non-SSL request to SSL by redirect. One can safely choose not to +-- redirect when the request /appears/ secure, even if it's actually not. +-- +-- @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. + ] + where + matchHeader :: HeaderName -> (ByteString -> Bool) -> Bool + matchHeader h f = maybe False f $ lookup h $ requestHeaders request + +-- | Guess the \"application root\" based on the given request. +-- +-- The application root is the basis for forming URLs pointing at the current +-- application. For more information and relevant caveats, please see +-- "Network.Wai.Middleware.Approot". +-- +-- @since 3.0.7 +guessApproot :: Request -> ByteString +guessApproot req = + (if appearsSecure req then "https://" else "http://") + `S.append` fromMaybe "localhost" (requestHeaderHost req) + +-- | see 'requestSizeCheck' +-- +-- @since 3.0.15 +newtype RequestSizeException + = RequestSizeException Word64 + deriving (Eq, Ord, Typeable) + +instance Exception RequestSizeException + +instance Show RequestSizeException where + showsPrec p (RequestSizeException limit) = + showString "Request Body is larger than " + . showsPrec p limit + . showString " bytes." + +-- | Check request body size to avoid server crash when request is too large. +-- +-- This function first checks @'requestBodyLength'@, if content-length is known +-- but larger than limit, or it's unknown but we have received too many chunks, +-- a 'RequestSizeException' are thrown when user use @'requestBody'@ to extract +-- request body inside IO. +-- +-- @since 3.0.15 +requestSizeCheck :: Word64 -> Request -> IO Request +requestSizeCheck maxSize req = + case requestBodyLength req of + KnownLength len -> + if len > maxSize + then return $ setRequestBodyChunks (throwIO $ RequestSizeException maxSize) req + else return req + ChunkedBody -> do + currentSize <- newIORef 0 + let rbody = do + bs <- getRequestBodyChunk req + total <- + atomicModifyIORef' currentSize $ \sz -> + let nextSize = sz + fromIntegral (S.length bs) + in (nextSize, nextSize) + if total > maxSize + then throwIO (RequestSizeException maxSize) + else return bs + return $ setRequestBodyChunks rbody req diff --git a/Network/Wai/Test.hs b/Network/Wai/Test.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Test.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE CPP #-} +{-# 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 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 Data.ByteString (ByteString) +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 Data.CallStack (HasCallStack) +import Data.CaseInsensitive (CI) +import Data.IORef +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +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 + +-- | +-- +-- Since 3.0.6 +getClientCookies :: Session ClientCookies +getClientCookies = clientCookies <$> lift ST.get + +-- | +-- +-- Since 3.0.6 +modifyClientCookies :: (ClientCookies -> ClientCookies) -> Session () +modifyClientCookies f = + 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 + +-- | +-- +-- Since 3.0.6 +deleteClientCookie :: ByteString -> Session () +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 + -- ^ Request body that will override the one set in 'simpleRequest'. + -- + -- This is usually simpler than setting the body as a stateful IO-action + -- in 'simpleRequest'. + } +data SResponse = SResponse + { simpleStatus :: H.Status + , simpleHeaders :: H.ResponseHeaders + , simpleBody :: L.ByteString + } + deriving (Show, Eq) + +request :: Request -> Session SResponse +request req = do + app <- ask + req' <- addCookiesToRequest req + response <- liftIO $ do + ref <- newIORef $ error "runResponse gave no result" + ResponseReceived <- app req' (runResponse ref) + readIORef ref + extractSetCookieFromSResponse response + +-- | 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 + } + 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} + where + 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 + +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 + +-- | 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 + let rbody = atomicModifyIORef refChunks $ \bss -> + case bss of + [] -> ([], S.empty) + 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 + let add y = atomicModifyIORef refBuilder $ \x -> (x `mappend` y, ()) + withBody $ \body -> body add (return ()) + builder <- readIORef refBuilder + let lbs = toLazyByteString builder + len = L.length lbs + -- Force evaluation of the body to have exceptions thrown at the right + -- time. + seq len $ writeIORef ref $ SResponse s h $ toLazyByteString builder + return ResponseReceived + where + (s, h, withBody) = responseToStream res + +assertBool :: HasCallStack => String -> Bool -> Session () +assertBool s b = unless b $ assertFailure s + +assertString :: HasCallStack => String -> Session () +assertString s = unless (null s) $ assertFailure s + +assertFailure :: HasCallStack => String -> Session () +assertFailure = liftIO . HUnit.assertFailure + +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') + where + go = S8.takeWhile (/= ';') + +assertStatus :: HasCallStack => Int -> SResponse -> Session () +assertStatus i SResponse{simpleStatus = s} = + assertBool + ( concat + [ "Expected status code " + , show i + , ", but received " + , show sc + ] + ) + $ i == sc + where + sc = H.statusCode s + +assertBody :: HasCallStack => L.ByteString -> SResponse -> Session () +assertBody lbs SResponse{simpleBody = lbs'} = + assertBool + ( concat + [ "Expected response body " + , show $ L8.unpack lbs + , ", but received " + , show $ L8.unpack lbs' + ] + ) + $ lbs == lbs' + +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 + :: 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') + +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 + ] + +-- | +-- +-- Since 3.0.6 +assertClientCookieExists :: HasCallStack => String -> ByteString -> Session () +assertClientCookieExists s cookieName = do + cookies <- getClientCookies + assertBool s $ Map.member cookieName cookies + +-- | +-- +-- Since 3.0.6 +assertNoClientCookieExists :: HasCallStack => String -> ByteString -> Session () +assertNoClientCookieExists s cookieName = do + cookies <- getClientCookies + assertBool s $ not $ Map.member cookieName cookies + +-- | +-- +-- Since 3.0.6 +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) diff --git a/Network/Wai/Test/Internal.hs b/Network/Wai/Test/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Test/Internal.hs @@ -0,0 +1,35 @@ +module Network.Wai.Test.Internal where + +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 + +type Session = ReaderT Application (ST.StateT ClientState IO) + +-- | +-- +-- Since 3.0.6 +type ClientCookies = Map ByteString Cookie.SetCookie + +newtype ClientState = ClientState + { clientCookies :: ClientCookies + } + +-- | +-- +-- Since 3.0.20.0 +initState :: ClientState +initState = ClientState Map.empty + +-- | Like 'runSession', but if allows you to hand in cookies and get +-- the updated cookies back. One use case for this is writing tests +-- that address the application under test alternatingly through rest +-- api and through db handle. +-- +-- Since 3.0.20.0 +runSessionWith :: ClientState -> Session a -> Application -> IO (a, ClientState) +runSessionWith st session app = ST.runStateT (runReaderT session app) st diff --git a/Network/Wai/UrlMap.hs b/Network/Wai/UrlMap.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/UrlMap.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# 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, +) where + +import Control.Applicative +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 Network.HTTP.Types (hContentType, status404) +import Network.Wai (Application, Request (pathInfo, rawPathInfo), responseLBS) + +type Path = [Text] +newtype UrlMap' a = UrlMap' {unUrlMap :: [(Path, a)]} + +instance Functor UrlMap' where + 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 + ] + +instance Alternative UrlMap' where + 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 +-- you the option to pass either an 'Network.Wai.Application' or an 'UrlMap' +-- as the second argument. +mount' :: ToApplication a => Path -> a -> UrlMap +mount' prefix thing = UrlMap' [(prefix, toApplication thing)] + +-- | A convenience function like mount', but for mounting things under a single +-- path segment. +mount :: ToApplication a => Text -> a -> UrlMap +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 + -> Maybe ([a], b) +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 + +instance ToApplication Application where + toApplication = id + +instance ToApplication UrlMap where + toApplication urlMap req sendResponse = + case try (pathInfo req) (unUrlMap urlMap) of + Just (newPath, app) -> + app + ( req + { pathInfo = newPath + , rawPathInfo = makeRaw newPath + } + ) + sendResponse + Nothing -> + sendResponse $ + responseLBS + status404 + [(hContentType, "text/plain")] + "Not found\n" + where + makeRaw :: [Text] -> B.ByteString + makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/" + +mapUrls :: UrlMap -> Application +mapUrls = toApplication 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +# wai-extra + +The goal here is to provide common features without many dependencies. + + +## Example using Server-Sent Events ## + +There is a small example using Server-Sent Events (SSE) in the +`./example` directory. + +Run the commands below to start the server on http://localhost:8080 + +``` +$ stack build . +$ stack exec example +``` diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.Chan +import Control.Monad (forever) +import Data.ByteString.Builder (string8) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Network.HTTP.Types (status200) +import Network.Wai (Application, Middleware, pathInfo, responseFile) +import Network.Wai.EventSource ( + ServerEvent (..), + eventSourceAppChan, + eventSourceAppIO, + ) +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.AddHeaders (addHeaders) +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 + ["eschan"] -> eventSourceAppChan chan req respond + ["esio"] -> eventSourceAppIO eventIO req respond + _ -> error "unexpected pathInfo" + +eventChan :: Chan ServerEvent -> IO () +eventChan chan = forever $ do + threadDelay 1000000 + time <- getPOSIXTime + writeChan chan (ServerEvent Nothing Nothing [string8 . show $ time]) + +eventIO :: IO ServerEvent +eventIO = do + threadDelay 1000000 + time <- getPOSIXTime + return $ + ServerEvent + (Just $ string8 "io") + Nothing + [string8 . show $ time] + +eventRaw :: (ServerEvent -> IO ()) -> IO () -> IO () +eventRaw = handle (0 :: Int) + where + handle counter emit flush = do + threadDelay 1000000 + _ <- + emit $ + ServerEvent + (Just $ string8 "raw") + Nothing + [string8 . show $ counter] + _ <- flush + handle (counter + 1) emit flush + +main :: IO () +main = do + chan <- newChan + _ <- forkIO . eventChan $ chan + 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 new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/ApprootSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.Middleware.ApprootSpec ( + main, + spec, +) where + +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 + +spec :: Spec +spec = do + let test name host secure headers expected = it name $ do + resp <- runApp host secure headers + 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" + +runApp :: ByteString -> Bool -> RequestHeaders -> IO SResponse +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 new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/ForceSSLSpec.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.Middleware.ForceSSLSpec ( + main, + spec, +) where + +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 () +main = hspec spec + +spec :: Spec +spec = describe "forceSSL" (forM_ hosts $ \host -> hostSpec host) + where + hosts = ["example.com", "example.com:80", "example.com:8080"] + +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 + + simpleStatus resp `shouldBe` status301 + 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 + } + + 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} + + 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" + } + + 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 + 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 new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/RoutedSpec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +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 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 + + 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 + +jsonApp :: Application +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" + } + +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 new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/StripHeadersSpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +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 (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" + let ciTestHeaders = map (first CI.mk) testHeaders + + 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 + + simpleHeaders resp1 `shouldBe` ciTestHeaders + simpleHeaders resp2 `shouldBe` 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 + + 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 + where + app _ respond = respond $ responseLBS status200 [] "" diff --git a/test/Network/Wai/Middleware/TimeoutSpec.hs b/test/Network/Wai/Middleware/TimeoutSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/TimeoutSpec.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +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 + +spec :: Spec +spec = do + describe "timeout" $ do + it "times out slow requests with 503" $ do + let app _req respond = do + threadDelay $ 2 * 1000000 + respond $ responseLBS status200 [] "" + + resp <- runApp $ timeout 1 app + + simpleStatus resp `shouldBe` status503 + + it "does not time out fast requests" $ do + let app _req respond = respond $ responseLBS status200 [] "" + + resp <- runApp $ timeout 3 app + + simpleStatus resp `shouldBe` status200 + + describe "timeoutStatus" $ do + it "allows customizing the timeout response status" $ do + let app _req respond = do + threadDelay $ 2 * 1000000 + respond $ responseLBS status200 [] "" + + resp <- runApp $ timeoutStatus status504 1 app + + simpleStatus resp `shouldBe` status504 + + describe "timeoutAs" $ do + it "allows customizing the timeout response" $ do + let app _req respond = do + threadDelay $ 2 * 1000000 + respond $ responseLBS status200 [] "" + timeoutResponse = responseLBS status503 [("X-Timeout", "1")] "" + + resp <- runApp $ timeoutAs timeoutResponse 1 app + + simpleStatus resp `shouldBe` status503 + simpleHeaders resp `shouldBe` [("X-Timeout", "1")] + +runApp :: Application -> IO SResponse +runApp = runSession $ request defaultRequest 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 new file mode 100644 --- /dev/null +++ b/test/Network/Wai/ParseSpec.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.ParseSpec (main, spec) where + +#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 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.Parse +import Network.Wai.Test (SRequest (SRequest)) +import WaiExtraSpec (toRequest) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "parseContentType" $ do + let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z) + 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")] + ) + ] + it "parseHttpAccept" caseParseHttpAccept + describe "parseRequestBody" $ do + caseParseRequestBody + it "multipart with plus" caseMultipartPlus + it "multipart with multiple attributes" caseMultipartAttrs + it "urlencoded with plus" caseUrlEncPlus + describe "dalvik multipart" $ do + it "non-chunked" $ dalvikHelper True + it "chunked" $ dalvikHelper False + +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" + 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' 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) + 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 + + 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 def = defaultParseRequestBodyOptions + it "parsing actual post multipart/form-data" $ do + result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3 + result3 `shouldBe` expected3 + + it "parsing actual post multipart/form-data 2" $ 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 "exceeding number of files" $ do + SRequest req4 _bod4 <- toRequest'' ctype3 content3 + parseRequestBodyEx (setMaxRequestNumFiles 0 def) lbsBackEnd req4 + `shouldThrow` anyException + + it "exceeding parameter length" $ do + SRequest req4 _bod4 <- toRequest'' ctype3 content3 + parseRequestBodyEx (setMaxRequestKeyLength 2 def) lbsBackEnd req4 + `shouldThrow` anyException + + it "exceeding file size" $ do + SRequest req4 _bod4 <- toRequest'' ctype3 content3 + parseRequestBodyEx (setMaxRequestFileSize 2 def) lbsBackEnd req4 + `shouldThrow` (== PayloadTooLarge) + + it "exceeding 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 parm value size" $ do + SRequest req4 _bod4 <- toRequest'' ctype2 content2 + parseRequestBodyEx (setMaxRequestParmsSize 10 def) lbsBackEnd req4 + `shouldThrow` (== PayloadTooLarge) + + it "exceeding max header lines" $ do + SRequest req4 _bod4 <- toRequest'' ctype2 content2 + parseRequestBodyEx (setMaxHeaderLines 1 def) lbsBackEnd req4 + `shouldThrow` anyException + + it "exceeding header line size" $ do + SRequest req4 _bod4 <- toRequest'' ctype3 content4 + parseRequestBodyEx (setMaxHeaderLineLength 8190 def) lbsBackEnd req4 + `shouldThrow` (== RequestHeaderFieldsTooLarge) + + 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--" + 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" + 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" + <> 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" + 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 + result <- parseRequestBody' lbsBackEnd $ toRequest ctype content + 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--" + ctype = "multipart/form-data; boundary=AaB03x" + +caseMultipartAttrs :: Assertion +caseMultipartAttrs = do + result <- parseRequestBody' lbsBackEnd $ toRequest ctype content + 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--" + ctype = "multipart/form-data; charset=UTF-8; boundary=AaB03x" + +caseUrlEncPlus :: Assertion +caseUrlEncPlus = do + result <- runResourceT $ withInternalState $ \state -> + parseRequestBody' (tempFileBackEnd state) $ toRequest ctype content + result @?= ([("email", "has+plus")], []) + where + content = "email=has%2Bplus" + ctype = "application/x-www-form-urlencoded" + +dalvikHelper :: Bool -> Assertion +dalvikHelper includeLength = do + let headers' = + [ ("content-type", "multipart/form-data;boundary=*****") + , ("GATEWAY_INTERFACE", "CGI/1.1") + , ("PATH_INFO", "/") + , ("QUERY_STRING", "") + , ("REMOTE_ADDR", "192.168.1.115") + , ("REMOTE_HOST", "ganjizza") + , ("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_HOST", "192.168.1.115:3000") + , ("HTTP_ACCEPT", "*, */*") + , ("HTTP_VERSION", "HTTP/1.1") + , ("REQUEST_PATH", "/") + ] + headers + | includeLength = ("content-length", "12098") : headers' + | otherwise = headers' + let request' = + defaultRequest + { requestHeaders = headers + } + (params, files) <- + case getRequestBodyType request' of + Nothing -> return ([], []) + Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h -> + sinkRequestBody lbsBackEnd rbt $ S.hGetSome h 2048 + lookup "scannedTime" params @?= Just "1.298590056748E9" + lookup "geoLong" params @?= Just "0" + lookup "geoLat" params @?= Just "0" + 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'' :: S8.ByteString -> S8.ByteString -> IO SRequest +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) diff --git a/test/Network/Wai/RequestSpec.hs b/test/Network/Wai/RequestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/RequestSpec.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.RequestSpec ( + main, + spec, +) where + +import Control.Exception (try) +import Control.Monad (forever) +import Data.ByteString (ByteString) +import Network.HTTP.Types (HeaderName) +import Network.Wai ( + Request (..), + RequestBodyLength (..), + defaultRequest, + getRequestBodyChunk, + setRequestBodyChunks, + ) +import Network.Wai.Request +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "requestSizeCheck" $ do + it "too large content length should throw RequestSizeException" $ do + let limit = 1024 + largeRequest = + setRequestBodyChunks + (return "repeat this chunk") + defaultRequest + { isSecure = False + , requestBodyLength = KnownLength (limit + 1) + } + checkedRequest <- requestSizeCheck limit largeRequest + body <- try (getRequestBodyChunk checkedRequest) + case body of + Left (RequestSizeException l) -> l `shouldBe` limit + Right _ -> expectationFailure "request size check failed" + + it "too many chunks should throw RequestSizeException" $ do + let limit = 1024 + largeRequest = + setRequestBodyChunks + (return "repeat this chunk") + defaultRequest + { isSecure = False + , requestBodyLength = ChunkedBody + } + checkedRequest <- requestSizeCheck limit largeRequest + body <- try (forever $ getRequestBodyChunk checkedRequest) + case body of + Left (RequestSizeException l) -> l `shouldBe` limit + 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") + ] + } + + 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} + + req `shouldSatisfy` appearsSecure + + it "checks for HTTP: on" $ do + let req = addHeader "HTTPS" "on" insecureRequest + + req `shouldSatisfy` appearsSecure + + it "checks for HTTP_X_FORWARDED_SSL: on" $ do + let req = addHeader "HTTP_X_FORWARDED_SSL" "on" insecureRequest + + req `shouldSatisfy` appearsSecure + + it "checks for HTTP_X_FORWARDED_SCHEME: https" $ do + let req = addHeader "HTTP_X_FORWARDED_SCHEME" "https" insecureRequest + + req `shouldSatisfy` appearsSecure + + it "checks for HTTP_X_FORWARDED_PROTO: https,..." $ do + let req = addHeader "HTTP_X_FORWARDED_PROTO" "https,xyz" insecureRequest + + req `shouldSatisfy` appearsSecure + +addHeader :: HeaderName -> ByteString -> Request -> Request +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 new file mode 100644 --- /dev/null +++ b/test/Network/Wai/TestSpec.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE OverloadedStrings #-} + +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 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 + +toByteString :: Builder -> ByteString +toByteString = L8.toStrict . toLazyByteString + +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" + + context "when path has no query string" $ do + it "sets rawQueryString to empty string" $ do + rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` "" + + 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 + sresp <- + flip runSession echoApp $ + srequest $ + SRequest defaultRequest "request body" + simpleBody sresp `shouldBe` "request body" + + describe "request" $ do + let echoApp req respond = do + reqBody <- L8.fromStrict <$> getRequestBodyChunk req + let reqHeaders = requestHeaders req + respond $ + responseLBS + status200 + reqHeaders + reqBody + + it "returns the status code of an echo app on default request" $ do + sresp <- runSession (request defaultRequest) echoApp + simpleStatus sresp `shouldBe` status200 + + it "returns the response body of an echo app" $ do + bodyRef <- IORef.newIORef "request body" + let getBodyChunk = IORef.atomicModifyIORef bodyRef $ \leftover -> ("", leftover) + sresp <- + flip runSession echoApp $ + request $ + setRequestBodyChunks getBodyChunk defaultRequest + simpleBody sresp `shouldBe` "request body" + + it "returns the response headers of an echo app" $ do + sresp <- + flip runSession echoApp $ + request $ + defaultRequest + { requestHeaders = [("foo", "bar")] + } + simpleHeaders sresp `shouldBe` [("foo", "bar")] + + 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 + "sends a Cookie header with correct value after receiving a Set-Cookie header" + $ do + sresp <- flip runSession cookieApp $ do + void $ + request $ + setPath defaultRequest "/set/cookie_name/cookie_value" + request $ + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" + + it + "sends a Cookie header with updated value after receiving a Set-Cookie header update" + $ do + sresp <- flip runSession cookieApp $ do + void $ + request $ + setPath defaultRequest "/set/cookie_name/cookie_value" + void $ + request $ + setPath defaultRequest "/set/cookie_name/cookie_value2" + request $ + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]" + + it "handles multiple cookies" $ do + sresp <- flip runSession cookieApp $ do + void $ + request $ + setPath defaultRequest "/set/cookie_name/cookie_value" + void $ + request $ + setPath defaultRequest "/set/cookie_name2/cookie_value2" + request $ + setPath defaultRequest "/get" + simpleBody sresp + `shouldBe` "[\"cookie_name=cookie_value;cookie_name2=cookie_value2\"]" + + it "removes a deleted cookie" $ do + sresp <- flip runSession cookieApp $ do + void $ + request $ + setPath defaultRequest "/set/cookie_name/cookie_value" + void $ + request $ + setPath defaultRequest "/set/cookie_name2/cookie_value2" + void $ + request $ + setPath defaultRequest "/delete/cookie_name2" + request $ + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" + + it "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/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/WaiExtraSpec.hs b/test/WaiExtraSpec.hs new file mode 100644 --- /dev/null +++ b/test/WaiExtraSpec.hs @@ -0,0 +1,837 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module WaiExtraSpec (spec, toRequest) where + +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.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 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.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 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" $ 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]) + +{- +caseFindBound :: Assertion +caseFindBound = do + findBound "def" "abcdefghi" @?= + FoundBound "abc" "ghi" + findBound "def" "ABC" @?= NoBound + findBound "def" "abcd" @?= PartialBound + findBound "def" "abcdE" @?= NoBound + findBound "def" "abcdEdef" @?= + FoundBound "abcdE" "" + +caseSinkTillBound :: Assertion +caseSinkTillBound = do + let iter () _ = return () + let src = "this is some text" + bound1 = "some" + bound2 = "some!" + let enum = enumList 1 [src] + let helper _ _ = return () + (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper () + res1 @?= True + (_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper () + res2 @?= False + +caseKillCR :: Assertion +caseKillCR = do + "foo" @=? killCR "foo" + "foo" @=? killCR "foo\r" + "foo\r\n" @=? killCR "foo\r\n" + "foo\r'" @=? killCR "foo\r'" + +caseKillCRLF :: Assertion +caseKillCRLF = do + "foo" @=? killCRLF "foo" + "foo\r" @=? killCRLF "foo\r" + "foo" @=? killCRLF "foo\r\n" + "foo\r'" @=? killCRLF "foo\r'" + "foo" @=? killCRLF "foo\n" + +caseTakeLine :: Assertion +caseTakeLine = do + helper "foo\nbar\nbaz" "foo" + helper "foo\r\nbar\nbaz" "foo" + helper "foo\nbar\r\nbaz" "foo" + helper "foo\rbar\r\nbaz" "foo\rbar" + where + helper haystack needle = do + x <- run_ $ enumList 1 [haystack] $$ takeLine + Just needle @=? x +-} + +jsonpApp :: Application +jsonpApp = jsonp $ \_ f -> + f $ + responseLBS + status200 + [("Content-Type", "application/json")] + "{\"foo\":\"bar\"}" + +caseJsonp :: Assertion +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 + { queryString = [("call_back", Just "test")] + , requestHeaders = [("Accept", "text/javascript")] + } + assertContentType "application/json" sres2 + assertBody "{\"foo\":\"bar\"}" sres2 + + sres3 <- + request + defaultRequest + { queryString = [("callback", Just "test")] + , requestHeaders = [("Accept", "text/html")] + } + assertContentType "application/json" sres3 + assertBody "{\"foo\":\"bar\"}" sres3 + +gzipApp :: Application +gzipApp = gzipApp' id + +gzipApp' :: (Response -> Response) -> Application +gzipApp' changeRes = + gzip defaultGzipSettings $ \_ f -> + f . changeRes $ + responseLBS + status200 + [("Content-Type", "text/plain")] + "test" + +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 hContentEncoding "gzip" sres + assertHeader hVary "Accept-Encoding" sres + liftIO $ decompress (simpleBody sres) @?= body + pure sres + +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 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) + go "application/json" True + go "application/javascript" True + go "application/something" False + go "text/something" True + go "foo/bar" False + go "application/json; charset=utf-8" True + +caseGzipMSIE :: Assertion +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 = + -- 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 + +caseVhost :: Assertion +caseVhost = withSession vhostApp $ do + sres1 <- + request + defaultRequest + { requestHeaders = [("Host", "foo.com")] + } + assertBody "app1" sres1 + + sres2 <- + request + defaultRequest + { requestHeaders = [("Host", "bar.com")] + } + assertBody "app2" sres2 + +autoheadApp :: Application +autoheadApp = autohead $ \_ f -> + f $ + responseLBS + status200 + [("Foo", "Bar")] + "body" + +caseAutohead :: Assertion +caseAutohead = withSession autoheadApp $ do + sres1 <- + request + defaultRequest + { requestMethod = "GET" + } + assertHeader "Foo" "Bar" sres1 + assertBody "body" sres1 + + sres2 <- + request + defaultRequest + { requestMethod = "HEAD" + } + assertHeader "Foo" "Bar" sres2 + assertBody "" sres2 + +moApp :: Application +moApp = methodOverride $ \req f -> + f $ + responseLBS + status200 + [("Method", requestMethod req)] + "" + +caseMethodOverride :: Assertion +caseMethodOverride = withSession moApp $ do + sres1 <- + request + defaultRequest + { requestMethod = "GET" + , queryString = [] + } + assertHeader "Method" "GET" sres1 + + sres2 <- + request + defaultRequest + { requestMethod = "POST" + , queryString = [] + } + assertHeader "Method" "POST" sres2 + + sres3 <- + request + defaultRequest + { requestMethod = "POST" + , queryString = [("_method", Just "PUT")] + } + assertHeader "Method" "PUT" sres3 + +mopApp :: Application +mopApp = methodOverridePost $ \req f -> f $ responseLBS status200 [("Method", requestMethod req)] "" + +caseMethodOverridePost :: Assertion +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 + 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" + 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" + 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" + assertHeader "Method" "POST" sres4 + +aoApp :: Application +aoApp = acceptOverride $ \req f -> + f $ + responseLBS + status200 + [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] + "" + +caseAcceptOverride :: Assertion +caseAcceptOverride = withSession aoApp $ do + sres1 <- + request + defaultRequest + { queryString = [] + , requestHeaders = [("Accept", "foo")] + } + assertHeader "Accept" "foo" sres1 + + sres2 <- + request + defaultRequest + { queryString = [] + , requestHeaders = [("Accept", "bar")] + } + assertHeader "Accept" "bar" sres2 + + sres3 <- + request + defaultRequest + { queryString = [("_accept", Just "baz")] + , requestHeaders = [("Accept", "bar")] + } + assertHeader "Accept" "baz" sres3 + +caseDebugRequestBody :: Assertion +caseDebugRequestBody = 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" + 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" + ) + + debugApp (beginning, ending) req send = do + iactual <- I.newIORef mempty + 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 + + return res + where + begin = TE.encodeUtf8 $ T.toStrict beginning + end = TE.encodeUtf8 $ T.toStrict ending + + logToBs = fromLogStr + +{-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 + 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) + ] + "" + + 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 + + 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 + + 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 + +testFile :: FilePath +testFile = "test/WaiExtraSpec.hs" + +streamFileApp :: Application +streamFileApp = streamFile $ \_ f -> f $ responseFile status200 [] testFile Nothing + +caseStreamFile :: Assertion +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" + +caseStreamLBS :: Assertion +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/WaiExtraTest.hs b/test/WaiExtraTest.hs deleted file mode 100644 --- a/test/WaiExtraTest.hs +++ /dev/null @@ -1,560 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module WaiExtraTest (specs) where - -import Test.Hspec -import Test.HUnit hiding (Test) - -import Network.Wai -import Network.Wai.Test -import Network.Wai.Parse -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import qualified Data.ByteString.Lazy as L -import qualified Data.Text.Lazy as T -import qualified Data.Text as TS -import qualified Data.Text.Encoding as TE -import Control.Arrow - -import Network.Wai.Middleware.Jsonp -import Network.Wai.Middleware.Gzip -import Network.Wai.Middleware.Vhost -import Network.Wai.Middleware.Autohead -import Network.Wai.Middleware.MethodOverride -import Network.Wai.Middleware.MethodOverridePost -import Network.Wai.Middleware.AcceptOverride -import Network.Wai.Middleware.RequestLogger -import Codec.Compression.GZip (decompress) - -import qualified Data.Conduit as C -import qualified Data.Conduit.List as CL -import Data.Conduit.Binary (sourceFile) -import Control.Monad.IO.Class (liftIO) -import Data.Maybe (fromMaybe) -import Network.HTTP.Types (parseSimpleQuery, status200) -import System.Log.FastLogger - -import qualified Data.IORef as I - -specs :: Spec -specs = do - describe "Network.Wai.Parse" $ do - describe "parseContentType" $ do - let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z) - 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")]) - ] - it "parseQueryString" caseParseQueryString - it "parseQueryString with question mark" caseParseQueryStringQM - it "parseHttpAccept" caseParseHttpAccept - it "parseRequestBody" caseParseRequestBody - it "multipart with plus" caseMultipartPlus - it "multipart with multiple attributes" caseMultipartAttrs - it "urlencoded with plus" caseUrlEncPlus - {- - , 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 - describe "dalvik multipart" $ do - it "non-chunked" $ dalvikHelper True - it "chunked" $ dalvikHelper False - it "debug request body" caseDebugRequestBody - -caseParseQueryString :: Assertion -caseParseQueryString = do - let go l r = - map (S8.pack *** S8.pack) l @=? parseSimpleQuery (S8.pack r) - - go [] "" - go [("foo", "")] "foo" - go [("foo", "bar")] "foo=bar" - go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin" - go [("%Q", "")] "%Q" - go [("%1Q", "")] "%1Q" - go [("%1", "")] "%1" - go [("/", "")] "%2F" - go [("/", "")] "%2f" - go [("foo bar", "")] "foo+bar" - -caseParseQueryStringQM :: Assertion -caseParseQueryStringQM = do - let go l r = - map (S8.pack *** S8.pack) l - @=? parseSimpleQuery (S8.pack $ '?' : r) - - go [] "" - go [("foo", "")] "foo" - go [("foo", "bar")] "foo=bar" - go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin" - go [("%Q", "")] "%Q" - go [("%1Q", "")] "%1Q" - go [("%1", "")] "%1" - go [("/", "")] "%2F" - go [("/", "")] "%2f" - go [("foo bar", "")] "foo+bar" - -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" - expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"] - expected @=? parseHttpAccept input - -parseRequestBody' :: BackEnd L.ByteString - -> SRequest - -> C.ResourceT IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)]) -parseRequestBody' sink (SRequest req bod) = - case getRequestBodyType req of - Nothing -> return ([], []) - Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody sink rbt - -caseParseRequestBody :: Assertion -caseParseRequestBody = - C.runResourceT t - where - content2 = S8.pack $ - "--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 = S8.pack "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\nContent-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\nContent-Type: application/octet-stream\r\n\r\nPhoto blog using Hack.\n\r\n------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n" - t = do - let content1 = "foo=bar&baz=bin" - let ctype1 = "application/x-www-form-urlencoded" - result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1 - liftIO $ assertEqual "parsing post x-www-form-urlencoded" - (map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], []) - result1 - - let ctype2 = "multipart/form-data; boundary=AaB03x" - result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2 - let expectedsmap2 = - [ ("title", "A File") - , ("summary", "This is my file\nfile test") - ] - let textPlain = S8.pack $ "text/plain; charset=iso-8859-1" - let expectedfile2 = - [(S8.pack "document", FileInfo (S8.pack "b.txt") textPlain $ L8.pack - "This is a file.\nIt has two lines.")] - let expected2 = (map (S8.pack *** S8.pack) expectedsmap2, expectedfile2) - liftIO $ assertEqual "parsing post multipart/form-data" - expected2 - result2 - - let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh" - result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3 - let expectedsmap3 = [] - let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $ - L8.pack "Photo blog using Hack.\n")] - let expected3 = (expectedsmap3, expectedfile3) - liftIO $ assertEqual "parsing actual post multipart/form-data" - expected3 - result3 - - result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2 - liftIO $ assertEqual "parsing post multipart/form-data 2" - expected2 - result2' - - result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3 - liftIO $ assertEqual "parsing actual post multipart/form-data 2" - expected3 - result3' - -caseMultipartPlus :: Assertion -caseMultipartPlus = do - result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content - liftIO $ result @?= ([("email", "has+plus")], []) - where - content = S8.pack $ - "--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 -caseMultipartAttrs = do - result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content - liftIO $ result @?= ([("email", "has+plus")], []) - where - content = S8.pack $ - "--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 <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content - liftIO $ result @?= ([("email", "has+plus")], []) - where - content = S8.pack $ "email=has%2Bplus" - ctype = "application/x-www-form-urlencoded" - -toRequest :: S8.ByteString -> S8.ByteString -> SRequest -toRequest ctype content = SRequest defaultRequest - { requestHeaders = [("Content-Type", ctype)] - , requestMethod = "POST" - , rawPathInfo = "/" - , rawQueryString = "" - , queryString = [] - } (L.fromChunks [content]) - -toRequest' :: S8.ByteString -> S8.ByteString -> SRequest -toRequest' ctype content = SRequest defaultRequest - { requestHeaders = [("Content-Type", ctype)] - } (L.fromChunks $ map S.singleton $ S.unpack content) - -{- -caseFindBound :: Assertion -caseFindBound = do - findBound (S8.pack "def") (S8.pack "abcdefghi") @?= - FoundBound (S8.pack "abc") (S8.pack "ghi") - findBound (S8.pack "def") (S8.pack "ABC") @?= NoBound - findBound (S8.pack "def") (S8.pack "abcd") @?= PartialBound - findBound (S8.pack "def") (S8.pack "abcdE") @?= NoBound - findBound (S8.pack "def") (S8.pack "abcdEdef") @?= - FoundBound (S8.pack "abcdE") (S8.pack "") - -caseSinkTillBound :: Assertion -caseSinkTillBound = do - let iter () _ = return () - let src = S8.pack "this is some text" - bound1 = S8.pack "some" - bound2 = S8.pack "some!" - let enum = enumList 1 [src] - let helper _ _ = return () - (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper () - res1 @?= True - (_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper () - res2 @?= False - -caseKillCR :: Assertion -caseKillCR = do - "foo" @=? killCR "foo" - "foo" @=? killCR "foo\r" - "foo\r\n" @=? killCR "foo\r\n" - "foo\r'" @=? killCR "foo\r'" - -caseKillCRLF :: Assertion -caseKillCRLF = do - "foo" @=? killCRLF "foo" - "foo\r" @=? killCRLF "foo\r" - "foo" @=? killCRLF "foo\r\n" - "foo\r'" @=? killCRLF "foo\r'" - "foo" @=? killCRLF "foo\n" - -caseTakeLine :: Assertion -caseTakeLine = do - helper "foo\nbar\nbaz" "foo" - helper "foo\r\nbar\nbaz" "foo" - helper "foo\nbar\r\nbaz" "foo" - helper "foo\rbar\r\nbaz" "foo\rbar" - where - helper haystack needle = do - x <- run_ $ enumList 1 [haystack] $$ takeLine - Just needle @=? x --} - -jsonpApp :: Application -jsonpApp = jsonp $ const $ return $ responseLBS - status200 - [("Content-Type", "application/json")] - "{\"foo\":\"bar\"}" - -caseJsonp :: Assertion -caseJsonp = flip runSession 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 - { queryString = [("call_back", Just "test")] - , requestHeaders = [("Accept", "text/javascript")] - } - assertContentType "application/json" sres2 - assertBody "{\"foo\":\"bar\"}" sres2 - - sres3 <- request defaultRequest - { queryString = [("callback", Just "test")] - , requestHeaders = [("Accept", "text/html")] - } - assertContentType "application/json" sres3 - assertBody "{\"foo\":\"bar\"}" sres3 - -gzipApp :: Application -gzipApp = gzip def $ const $ return $ responseLBS status200 - [("Content-Type", "text/plain")] - "test" - --- 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 $ const $ return $ responseLBS status200 - [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")] - "test" - -caseGzip :: Assertion -caseGzip = flip runSession gzipApp $ do - sres1 <- request defaultRequest - { requestHeaders = [("Accept-Encoding", "gzip")] - } - assertHeader "Content-Encoding" "gzip" sres1 - liftIO $ decompress (simpleBody sres1) @?= "test" - - sres2 <- request defaultRequest - { requestHeaders = [] - } - assertNoHeader "Content-Encoding" sres2 - assertBody "test" sres2 - -caseDefaultCheckMime :: Assertion -caseDefaultCheckMime = do - let go x y = (x, defaultCheckMime x) `shouldBe` (x, y) - go "application/json" True - go "application/javascript" True - go "application/something" False - go "text/something" True - go "foo/bar" False - 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" - -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 - -vhostApp1, vhostApp2, vhostApp :: Application -vhostApp1 = const $ return $ responseLBS status200 [] "app1" -vhostApp2 = const $ return $ responseLBS status200 [] "app2" -vhostApp = vhost - [ ((== "foo.com") . serverName, vhostApp1) - ] - vhostApp2 - -caseVhost :: Assertion -caseVhost = flip runSession vhostApp $ do - sres1 <- request defaultRequest - { serverName = "foo.com" - } - assertBody "app1" sres1 - - sres2 <- request defaultRequest - { serverName = "bar.com" - } - assertBody "app2" sres2 - -autoheadApp :: Application -autoheadApp = autohead $ const $ return $ responseLBS status200 - [("Foo", "Bar")] "body" - -caseAutohead :: Assertion -caseAutohead = flip runSession autoheadApp $ do - sres1 <- request defaultRequest - { requestMethod = "GET" - } - assertHeader "Foo" "Bar" sres1 - assertBody "body" sres1 - - sres2 <- request defaultRequest - { requestMethod = "HEAD" - } - assertHeader "Foo" "Bar" sres2 - assertBody "" sres2 - -moApp :: Application -moApp = methodOverride $ \req -> return $ responseLBS status200 - [("Method", requestMethod req)] "" - -caseMethodOverride :: Assertion -caseMethodOverride = flip runSession moApp $ do - sres1 <- request defaultRequest - { requestMethod = "GET" - , queryString = [] - } - assertHeader "Method" "GET" sres1 - - sres2 <- request defaultRequest - { requestMethod = "POST" - , queryString = [] - } - assertHeader "Method" "POST" sres2 - - sres3 <- request defaultRequest - { requestMethod = "POST" - , queryString = [("_method", Just "PUT")] - } - assertHeader "Method" "PUT" sres3 - -mopApp :: Application -mopApp = methodOverridePost $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] "" - -caseMethodOverridePost :: Assertion -caseMethodOverridePost = flip runSession 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 - 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" - 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" - 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" - assertHeader "Method" "POST" sres4 - -aoApp :: Application -aoApp = acceptOverride $ \req -> return $ responseLBS status200 - [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] "" - -caseAcceptOverride :: Assertion -caseAcceptOverride = flip runSession aoApp $ do - sres1 <- request defaultRequest - { queryString = [] - , requestHeaders = [("Accept", "foo")] - } - assertHeader "Accept" "foo" sres1 - - sres2 <- request defaultRequest - { queryString = [] - , requestHeaders = [("Accept", "bar")] - } - assertHeader "Accept" "bar" sres2 - - sres3 <- request defaultRequest - { queryString = [("_accept", Just "baz")] - , requestHeaders = [("Accept", "bar")] - } - assertHeader "Accept" "baz" sres3 - -dalvikHelper :: Bool -> Assertion -dalvikHelper includeLength = do - let headers' = - [ ("content-type", "multipart/form-data;boundary=*****") - , ("GATEWAY_INTERFACE", "CGI/1.1") - , ("PATH_INFO", "/") - , ("QUERY_STRING", "") - , ("REMOTE_ADDR", "192.168.1.115") - , ("REMOTE_HOST", "ganjizza") - , ("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_HOST", "192.168.1.115:3000") - , ("HTTP_ACCEPT", "*, */*") - , ("HTTP_VERSION", "HTTP/1.1") - , ("REQUEST_PATH", "/") - ] - headers - | includeLength = ("content-length", "12098") : headers' - | otherwise = headers' - let request' = defaultRequest - { requestHeaders = headers - } - (params, files) <- - case getRequestBodyType request' of - Nothing -> return ([], []) - Just rbt -> C.runResourceT $ sourceFile "test/requests/dalvik-request" - C.$$ sinkRequestBody lbsBackEnd rbt - lookup "scannedTime" params @?= Just "1.298590056748E9" - lookup "geoLong" params @?= Just "0" - lookup "geoLat" params @?= Just "0" - length files @?= 1 - -caseDebugRequestBody :: Assertion -caseDebugRequestBody = do - flip runSession (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" - } - where - params = [("foo", "bar"), ("baz", "bin")] - -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params) - postOutput = T.pack $ "POST /\nAccept: \nStatus: 200 OK. /\n" - getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n" - - debugApp output' req = do - iactual <- liftIO $ I.newIORef [] - middleware <- liftIO $ mkRequestLogger def - { destination = Callback $ \strs -> I.modifyIORef iactual $ (++ strs) - , outputFormat = Detailed False - } - res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req - actual <- liftIO $ I.readIORef iactual - liftIO $ assertEqual "debug" output $ logsToBs actual - return res - where - output = TE.encodeUtf8 $ T.toStrict output' - logsToBs = S.concat . map logToBs - - logToBs (LB bs) = bs - logToBs (LS s) = S8.pack s - - {-debugApp = debug $ \req -> do-} - {-return $ responseLBS status200 [ ] ""-} 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/tests.hs b/tests.hs deleted file mode 100644 --- a/tests.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Test.Hspec.Monadic -import qualified WaiExtraTest - -main :: IO () -main = hspec WaiExtraTest.specs diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -1,7 +1,81 @@ Name: wai-extra -Version: 1.3.4.6 +Version: 3.1.18 Synopsis: Provides some basic WAI handlers and middleware. -Description: The goal here is to provide common features without many dependencies. +description: + Provides basic WAI handler and middleware functionality: + . + * WAI Testing Framework + . + Hspec testing facilities and helpers for WAI. + . + * Event Source/Event Stream + . + Send server events to the client. Compatible with the JavaScript + EventSource API. + . + * Accept Override + . + Override the Accept header in a request. Special handling for the + _accept query parameter (which is used throughout WAI override the + Accept header). + . + * Add Headers + . + WAI Middleware for adding arbitrary headers to an HTTP request. + . + * Clean Path + . + 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. + . + * JSONP + . + \"JSON with Padding\" middleware. Automatic wrapping of JSON + responses to convert into JSONP. + . + * Method Override / Post + . + Allows overriding of the HTTP request method via the _method query string + parameter. + . + * Request Logging + . + Request logging middleware for development and production environments + . + * Request Rewrite + . + Rewrite request path info based on a custom conversion rules. + . + * Select + . + Dynamically choose between Middlewares. + . + * Stream Files + . + Convert ResponseFile type responses into ResponseStream type. + . + * Virtual Host + . + Redirect incoming requests to a new host based on custom rules. + . + . + API docs and the README are available at . + License: MIT License-file: LICENSE Author: Michael Snoyman @@ -9,86 +83,161 @@ Homepage: http://github.com/yesodweb/wai Category: Web Build-Type: Simple -Cabal-Version: >=1.8 +Cabal-Version: >=1.10 Stability: Stable extra-source-files: - tests.hs test/requests/dalvik-request test/json + test/json.gz + test/noprecompress test/test.html test/sample.hs - test/WaiExtraTest.hs + ChangeLog.md + README.md +flag build-example + description: Build example executable. + manual: True + default: False + Library - Build-Depends: base >= 4 && < 5 - , bytestring >= 0.9.1.4 - , wai >= 1.3 && < 1.5 - , old-locale >= 1.0.0.2 && < 1.1 - , time >= 1.1.4 - , network >= 2.2.1.5 - , directory >= 1.0.1 - , transformers >= 0.2.2 && < 0.4 - , blaze-builder >= 0.2.1.4 && < 0.4 - , http-types >= 0.7 - , text >= 0.7 && < 0.12 + Build-Depends: base >= 4.12 && < 5 + , aeson + , ansi-terminal >= 0.4 + , base64-bytestring + , bytestring >= 0.10.4 + , call-stack , case-insensitive >= 0.2 - , data-default - , date-cache >= 0.3 && < 0.4 - , fast-logger >= 0.2 && < 0.4 - , wai-logger >= 0.2 && < 0.4 - , conduit >= 0.5 && < 1.1 - , zlib-conduit >= 0.5 && < 1.1 - , blaze-builder-conduit >= 0.5 && < 1.1 - , ansi-terminal - , resourcet >= 0.3 && < 0.5 - , void >= 0.5 - , stringsearch >= 0.3 && < 0.4 , containers - , base64-bytestring + , 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 + , wai >= 3.2.4 && < 3.3 + , wai-logger >= 2.3.7 + , warp >= 3.3.22 , word8 - , lifted-base - Exposed-modules: Network.Wai.Handler.CGI + if os(windows) + cpp-options: -DWINDOWS + else + build-depends: unix + + default-extensions: OverloadedStrings + + Exposed-modules: Network.Wai.EventSource + Network.Wai.EventSource.EventStream + Network.Wai.Handler.CGI + Network.Wai.Handler.SCGI + Network.Wai.Header Network.Wai.Middleware.AcceptOverride + Network.Wai.Middleware.AddHeaders + Network.Wai.Middleware.Approot Network.Wai.Middleware.Autohead Network.Wai.Middleware.CleanPath - Network.Wai.Middleware.RequestLogger + 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.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.Middleware.HttpAuth Network.Wai.Parse + Network.Wai.Request + Network.Wai.Test + Network.Wai.Test.Internal + Network.Wai.UrlMap other-modules: Network.Wai.Middleware.RequestLogger.Internal + Network.Wai.Util + default-language: Haskell2010 ghc-options: -Wall - -test-suite tests - hs-source-dirs: test - main-is: ../tests.hs - type: exitcode-stdio-1.0 +executable example + hs-source-dirs: example + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + if flag(build-example) + build-depends: base + , bytestring + , http-types + , time + , wai + , wai-extra + , warp + else + buildable: False + default-language: Haskell2010 +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + 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-test >= 1.3 - , hspec >= 1.3 - , HUnit - - , wai - , http-types - , transformers - , zlib - , text + , aeson , bytestring + , cookie + , case-insensitive , directory - , zlib-bindings - , blaze-builder >= 0.2.1.4 && < 0.4 - , data-default - , conduit , fast-logger - ghc-options: -Wall + , hspec >= 1.3 + , http-types + , HUnit + , iproute + , resourcet + , temporary + , text + , time + , wai-extra + , wai + , warp + , word8 + , zlib + ghc-options: -Wall + default-language: Haskell2010 + + if os(windows) + cpp-options: -DWINDOWS source-repository head type: git