wai-extra 1.1.0.1 → 3.1.18
raw patch · 65 files changed
Files
- ChangeLog.md +331/−0
- LICENSE +17/−22
- Network/Wai/EventSource.hs +64/−0
- Network/Wai/EventSource/EventStream.hs +69/−0
- Network/Wai/Handler/CGI.hs +142/−112
- Network/Wai/Handler/SCGI.hs +117/−0
- Network/Wai/Header.hs +74/−0
- Network/Wai/Middleware/AcceptOverride.hs +27/−16
- Network/Wai/Middleware/AddHeaders.hs +22/−0
- Network/Wai/Middleware/Approot.hs +127/−0
- Network/Wai/Middleware/Autohead.hs +15/−11
- Network/Wai/Middleware/CleanPath.hs +30/−24
- Network/Wai/Middleware/CombineHeaders.hs +302/−0
- Network/Wai/Middleware/ForceDomain.hs +43/−0
- Network/Wai/Middleware/ForceSSL.hs +39/−0
- Network/Wai/Middleware/Gzip.hs +385/−89
- Network/Wai/Middleware/HealthCheckEndpoint.hs +38/−0
- Network/Wai/Middleware/HttpAuth.hs +149/−0
- Network/Wai/Middleware/Jsonp.hs +56/−47
- Network/Wai/Middleware/Local.hs +25/−0
- Network/Wai/Middleware/MethodOverride.hs +12/−8
- Network/Wai/Middleware/MethodOverridePost.hs +48/−0
- Network/Wai/Middleware/RealIp.hs +95/−0
- Network/Wai/Middleware/RequestLogger.hs +567/−145
- Network/Wai/Middleware/RequestLogger/Internal.hs +37/−0
- Network/Wai/Middleware/RequestLogger/JSON.hs +195/−0
- Network/Wai/Middleware/RequestSizeLimit.hs +86/−0
- Network/Wai/Middleware/RequestSizeLimit/Internal.hs +63/−0
- Network/Wai/Middleware/Rewrite.hs +355/−30
- Network/Wai/Middleware/Routed.hs +46/−0
- Network/Wai/Middleware/Select.hs +97/−0
- Network/Wai/Middleware/StreamFile.hs +36/−0
- Network/Wai/Middleware/StripHeaders.hs +50/−0
- Network/Wai/Middleware/Timeout.hs +33/−0
- Network/Wai/Middleware/ValidateHeaders.hs +138/−0
- Network/Wai/Middleware/Vhost.hs +40/−2
- Network/Wai/Parse.hs +730/−241
- Network/Wai/Request.hs +102/−0
- Network/Wai/Test.hs +368/−0
- Network/Wai/Test/Internal.hs +35/−0
- Network/Wai/UrlMap.hs +121/−0
- Network/Wai/Util.hs +27/−0
- README.md +16/−0
- example/Main.hs +79/−0
- test/Network/Wai/Middleware/ApprootSpec.hs +45/−0
- test/Network/Wai/Middleware/CombineHeadersSpec.hs +165/−0
- test/Network/Wai/Middleware/ForceSSLSpec.hs +73/−0
- test/Network/Wai/Middleware/RealIpSpec.hs +94/−0
- test/Network/Wai/Middleware/RequestSizeLimitSpec.hs +157/−0
- test/Network/Wai/Middleware/RoutedSpec.hs +60/−0
- test/Network/Wai/Middleware/SelectSpec.hs +82/−0
- test/Network/Wai/Middleware/StripHeadersSpec.hs +74/−0
- test/Network/Wai/Middleware/TimeoutSpec.hs +57/−0
- test/Network/Wai/Middleware/ValidateHeadersSpec.hs +59/−0
- test/Network/Wai/ParseSpec.hs +367/−0
- test/Network/Wai/RequestSpec.hs +104/−0
- test/Network/Wai/TestSpec.hs +241/−0
- test/Spec.hs +1/−0
- test/WaiExtraSpec.hs +837/−0
- test/WaiExtraTest.hs +0/−442
- test/json.gz +1/−0
- test/noprecompress +1/−0
- test/sample.hs +26/−18
- tests.hs +0/−5
- wai-extra.cabal +206/−43
+ ChangeLog.md view
@@ -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.
LICENSE view
@@ -1,25 +1,20 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.--Copyright 2010, Michael Snoyman. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ -* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.+Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions: -* Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.+The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Network/Wai/EventSource.hs view
@@ -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_" -}
+ Network/Wai/EventSource/EventStream.hs view
@@ -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')
Network/Wai/Handler/CGI.hs view
@@ -1,43 +1,55 @@-{-# LANGUAGE OverloadedStrings #-}+{-# 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 qualified Data.Conduit as C-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@@ -53,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@@ -65,120 +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 -> C.Source 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'- C.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- }- -- FIXME worry about exception?- res <- app env+ 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+ }+ 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 [C.Chunk $ headers s hs `mappend` fromChar '\n']- `mappend` b- src C.$$ 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 = C.SinkData push (return ())- push (C.Chunk bs) = do- liftIO $ outputH bs- return $ C.Processing push (return ())- -- FIXME actually flush?- push C.Flush = return $ C.Processing push (return ())- builderSink = builderToByteStringFlush C.=$ 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 -> C.Source 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 -> C.Source IO B.ByteString-requestBodyFunc get count0 =- C.sourceState count0 pull- where- pull 0 = return C.StateClosed- pull count = do- mbs <- liftIO $ get $ min count defaultChunkSize- let count' = count - maybe 0 B.length mbs- return $ case mbs of- Nothing -> C.StateClosed- Just bs -> C.StateOpen count' bs+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
+ Network/Wai/Handler/SCGI.hs view
@@ -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
+ Network/Wai/Header.hs view
@@ -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
Network/Wai/Middleware/AcceptOverride.hs view
@@ -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+ }
+ Network/Wai/Middleware/AddHeaders.hs view
@@ -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 ++)
+ Network/Wai/Middleware/Approot.hs view
@@ -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
Network/Wai/Middleware/Autohead.hs view
@@ -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
Network/Wai/Middleware/CleanPath.hs view
@@ -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
+ Network/Wai/Middleware/CombineHeaders.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Sometimes incoming requests don't stick to the+-- "no duplicate headers" invariant, for a number+-- of possible reasons (e.g. proxy servers blindly+-- adding headers), or your application (or other+-- middleware) blindly adds headers.+--+-- In those cases, you can use this 'Middleware'+-- to make sure that headers that /can/ be combined+-- /are/ combined. (e.g. applications might only+-- check the first \"Accept\" header and fail, while+-- there might be another one that would match)+module Network.Wai.Middleware.CombineHeaders (+ combineHeaders,+ CombineSettings,+ defaultCombineSettings,+ HeaderMap,+ HandleType,+ defaultHeaderMap,++ -- * Adjusting the settings+ setHeader,+ removeHeader,+ setHeaderMap,+ regular,+ keepOnly,+ setRequestHeaders,+ setResponseHeaders,+) where++import qualified Data.ByteString as B+import qualified Data.List as L (foldl', reverse)+import qualified Data.Map.Strict as M+import Data.Word8 (_comma, _space, _tab)+import Network.HTTP.Types (Header, HeaderName, RequestHeaders)+import qualified Network.HTTP.Types.Header as H+import Network.Wai (Middleware, mapResponseHeaders, requestHeaders)+import Network.Wai.Util (dropWhileEnd)++-- | The mapping of 'HeaderName' to 'HandleType'+type HeaderMap = M.Map HeaderName HandleType++-- | These settings define which headers should be combined,+-- if the combining should happen on incoming (request) headers+-- and if it should happen on outgoing (response) headers.+--+-- Any header you put in the header map *will* be used to+-- combine those headers with commas. There's no check to see+-- if it is a header that allows comma-separated lists, so if+-- you want to combine custom headers, go ahead.+--+-- (You can check the documentation of 'defaultCombineSettings'+-- to see which standard headers are specified to be able to be+-- combined)+--+-- @since 3.1.13.0+data CombineSettings = CombineSettings+ { combineHeaderMap :: HeaderMap+ -- ^ Which headers should be combined? And how? (cf. 'HandleType')+ , combineRequestHeaders :: Bool+ -- ^ Should request headers be combined?+ , combineResponseHeaders :: Bool+ -- ^ Should response headers be combined?+ }+ deriving (Eq, Show)++-- | Settings that combine request headers,+-- but don't touch response headers.+--+-- All types of headers that /can/ be combined+-- (as defined in the spec) /will/ be combined.+--+-- To be exact, this is the list:+--+-- * Accept+-- * Accept-CH+-- * Accept-Charset+-- * Accept-Encoding+-- * Accept-Language+-- * Accept-Post+-- * Access-Control-Allow-Headers+-- * Access-Control-Allow-Methods+-- * Access-Control-Expose-Headers+-- * Access-Control-Request-Headers+-- * Allow+-- * Alt-Svc @(KeepOnly \"clear\"")@+-- * Cache-Control+-- * Clear-Site-Data @(KeepOnly \"*\")@+-- * Connection+-- * Content-Encoding+-- * Content-Language+-- * Digest+-- * If-Match+-- * If-None-Match @(KeepOnly \"*\")@+-- * Link+-- * Permissions-Policy+-- * TE+-- * Timing-Allow-Origin @(KeepOnly \"*\")@+-- * Trailer+-- * Transfer-Encoding+-- * Upgrade+-- * Via+-- * Vary @(KeepOnly \"*\")@+-- * Want-Digest+--+-- N.B. Any header name that has \"KeepOnly\" after it+-- will be combined like normal, unless one of the values+-- is the one mentioned (\"*\" most of the time), then+-- that value is used and all others are dropped.+--+-- @since 3.1.13.0+defaultCombineSettings :: CombineSettings+defaultCombineSettings =+ CombineSettings+ { combineHeaderMap = defaultHeaderMap+ , combineRequestHeaders = True+ , combineResponseHeaders = False+ }++-- | Override the 'HeaderMap' of the 'CombineSettings'+-- (default: 'defaultHeaderMap')+--+-- @since 3.1.13.0+setHeaderMap :: HeaderMap -> CombineSettings -> CombineSettings+setHeaderMap mp set = set{combineHeaderMap = mp}++-- | Set whether the combining of headers should be applied to+-- the incoming request headers. (default: True)+--+-- @since 3.1.13.0+setRequestHeaders :: Bool -> CombineSettings -> CombineSettings+setRequestHeaders b set = set{combineRequestHeaders = b}++-- | Set whether the combining of headers should be applied to+-- the outgoing response headers. (default: False)+--+-- @since 3.1.13.0+setResponseHeaders :: Bool -> CombineSettings -> CombineSettings+setResponseHeaders b set = set{combineResponseHeaders = b}++-- | Convenience function to add a header to the header map or,+-- if it is already in the map, to change the 'HandleType'.+--+-- @since 3.1.13.0+setHeader :: HeaderName -> HandleType -> CombineSettings -> CombineSettings+setHeader name typ settings =+ settings+ { combineHeaderMap = M.insert name typ $ combineHeaderMap settings+ }++-- | Convenience function to remove a header from the header map.+--+-- @since 3.1.13.0+removeHeader :: HeaderName -> CombineSettings -> CombineSettings+removeHeader name settings =+ settings+ { combineHeaderMap = M.delete name $ combineHeaderMap settings+ }++-- | This middleware will reorganize the incoming and/or outgoing+-- headers in such a way that it combines any duplicates of+-- headers that, on their own, can normally have more than one+-- value, and any other headers will stay untouched.+--+-- This middleware WILL change the global order of headers+-- (they will be put in alphabetical order), but keep the+-- order of the same type of header. I.e. if there are 3+-- \"Set-Cookie\" headers, the first one will still be first,+-- the second one will still be second, etc. But now they are+-- guaranteed to be next to each other.+--+-- N.B. This 'Middleware' assumes the headers it combines+-- are correctly formatted. If one of the to-be-combined+-- headers is malformed, the new combined header will also+-- (probably) be malformed.+--+-- @since 3.1.13.0+combineHeaders :: CombineSettings -> Middleware+combineHeaders CombineSettings{..} app req resFunc =+ app newReq $ resFunc . adjustRes+ where+ newReq+ | combineRequestHeaders = req{requestHeaders = mkNewHeaders oldHeaders}+ | otherwise = req+ oldHeaders = requestHeaders req+ adjustRes+ | combineResponseHeaders = mapResponseHeaders mkNewHeaders+ | otherwise = id+ mkNewHeaders =+ M.foldrWithKey' finishHeaders [] . L.foldl' go mempty+ go acc hdr@(name, _) =+ M.alter (checkHeader hdr) name acc+ checkHeader :: Header -> Maybe HeaderHandling -> Maybe HeaderHandling+ checkHeader (name, newVal) =+ Just . \case+ Nothing -> (name `M.lookup` combineHeaderMap, [newVal])+ -- Yes, this reverses the order of headers, but these+ -- will be reversed again in 'finishHeaders'+ Just (mHandleType, hdrs) -> (mHandleType, newVal : hdrs)++-- | Unpack 'HeaderHandling' back into 'Header's again+finishHeaders+ :: HeaderName -> HeaderHandling -> RequestHeaders -> RequestHeaders+finishHeaders name (shouldCombine, xs) hdrs =+ case shouldCombine of+ Just typ -> (name, combinedHeader typ) : hdrs+ Nothing ->+ -- Yes, this reverses the headers, but they+ -- were already reversed by 'checkHeader'+ L.foldl' (\acc el -> (name, el) : acc) hdrs xs+ where+ combinedHeader Regular = combineHdrs xs+ combinedHeader (KeepOnly val)+ | val `elem` xs = val+ | otherwise = combineHdrs xs+ -- headers were reversed, so do 'reverse' before combining+ combineHdrs = B.intercalate ", " . fmap clean . L.reverse+ clean = dropWhileEnd $ \w -> w == _comma || w == _space || w == _tab++type HeaderHandling = (Maybe HandleType, [B.ByteString])++-- | Both will concatenate with @,@ (commas), but 'KeepOnly' will drop all+-- values except the given one if present (e.g. in case of wildcards/special values)+--+-- For example: If there are multiple @"Clear-Site-Data"@ headers, but one of+-- them is the wildcard @\"*\"@ value, using @'KeepOnly' "*"@ will cause all+-- others to be dropped and only the wildcard value to remain.+-- (The @\"*\"@ wildcard in this case means /ALL site data/ should be cleared,+-- so no need to include more)+--+-- @since 3.1.13.0+data HandleType+ = Regular+ | KeepOnly B.ByteString+ deriving (Eq, Show)++-- | Use the regular strategy when combining headers.+-- (i.e. merge into one header and separate values with commas)+--+-- @since 3.1.13.0+regular :: HandleType+regular = Regular++-- | Use the regular strategy when combining headers,+-- but if the exact supplied 'ByteString' is encountered+-- then discard all other values and only keep that value.+--+-- e.g. @keepOnly "*"@ will drop all other encountered values+--+-- @since 3.1.13.0+keepOnly :: B.ByteString -> HandleType+keepOnly = KeepOnly++-- | The default collection of HTTP headers that can be combined+-- in case there are multiples in one request or response.+--+-- See the documentation of 'defaultCombineSettings' for the exact list.+--+-- @since 3.1.13.0+defaultHeaderMap :: HeaderMap+defaultHeaderMap =+ M.fromList+ [ (H.hAccept, Regular)+ , ("Accept-CH", Regular)+ , (H.hAcceptCharset, Regular)+ , (H.hAcceptEncoding, Regular)+ , (H.hAcceptLanguage, Regular)+ , ("Accept-Post", Regular)+ , ("Access-Control-Allow-Headers", Regular) -- wildcard? yes, but can just add to list+ , ("Access-Control-Allow-Methods", Regular) -- wildcard? yes, but can just add to list+ , ("Access-Control-Expose-Headers", Regular) -- wildcard? yes, but can just add to list+ , ("Access-Control-Request-Headers", Regular)+ , (H.hAllow, Regular)+ , ("Alt-Svc", KeepOnly "clear") -- special "clear" value (if any is "clear", only keep that one)+ , (H.hCacheControl, Regular)+ , ("Clear-Site-Data", KeepOnly "*") -- wildcard (if any is "*", only keep that one)+ , -- If "close" and anything else is used together, it's already F-ed,+ -- so just combine them.+ (H.hConnection, Regular)+ , (H.hContentEncoding, Regular)+ , (H.hContentLanguage, Regular)+ , ("Digest", Regular)+ , -- We could handle this, but it's experimental AND+ -- will be replaced by "Permissions-Policy"+ -- , "Feature-Policy" -- "semicolon ';' separated"++ (H.hIfMatch, Regular)+ , (H.hIfNoneMatch, KeepOnly "*") -- wildcard? (if any is "*", only keep that one)+ , ("Link", Regular)+ , ("Permissions-Policy", Regular)+ , (H.hTE, Regular)+ , ("Timing-Allow-Origin", KeepOnly "*") -- wildcard? (if any is "*", only keep that one)+ , (H.hTrailer, Regular)+ , (H.hTransferEncoding, Regular)+ , (H.hUpgrade, Regular)+ , (H.hVia, Regular)+ , (H.hVary, KeepOnly "*") -- wildcard? (if any is "*", only keep that one)+ , ("Want-Digest", Regular)+ ]
+ Network/Wai/Middleware/ForceDomain.hs view
@@ -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
+ Network/Wai/Middleware/ForceSSL.hs view
@@ -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
Network/Wai/Middleware/Gzip.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-} ---------------------------------------------------------++---------------------------------------------------------+ -- | -- Module : Network.Wai.Middleware.Gzip -- Copyright : Michael Snoyman@@ -12,126 +12,422 @@ -- Portability : portable -- -- Automatic gzip compression of responses.--------------------------------------------------------------module Network.Wai.Middleware.Gzip- ( gzip- , GzipSettings- , gzipFiles- , GzipFiles (..)- , def- , defaultCheckMime- ) where+module Network.Wai.Middleware.Gzip (+ -- * How to use this module+ -- $howto -import Network.Wai-import Data.Maybe (fromMaybe)-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--defaultCheckMime :: S.ByteString -> Bool-defaultCheckMime = S8.isPrefixOf "text/"+-- $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'. --- | Use gzip to compress the body of the response.+-- | DO NOT USE THIS INSTANCE!+-- Please use 'defaultGzipSettings'. ----- Analyzes the \"Accept-Encoding\" header from the client to determine--- if gzip is supported.+-- 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. ----- Possible future enhancements:+-- * Does not compress files.+-- * Uses 'defaultCheckMime'.+-- * Compession threshold set to 860 bytes. ----- * Only compress if the response is above a certain size.+-- @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.break (== _semicolon) bs+ toCompress =+ Set.fromList+ [ "application/json"+ , "application/javascript"+ , "application/ecmascript"+ , "image/x-icon"+ ]++-- | Use gzip to compress the body of the response. 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- 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+ 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
+ Network/Wai/Middleware/HealthCheckEndpoint.hs view
@@ -0,0 +1,38 @@+---------------------------------------------------------++---------------------------------------------------------++-- |+-- Module : Network.Wai.Middleware.HealthCheckEndpoint+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Add empty endpoint (for Health check tests)+module Network.Wai.Middleware.HealthCheckEndpoint (+ healthCheck,+ voidEndpoint,+)+where++import Data.ByteString (ByteString)+import Network.HTTP.Types (status200)+import Network.Wai++-- | Add empty endpoint (for Health check tests) called \"/_healthz\"+--+-- @since 3.1.9+healthCheck :: Middleware+healthCheck = voidEndpoint "/_healthz"++-- | Add empty endpoint+--+-- @since 3.1.9+voidEndpoint :: ByteString -> Middleware+voidEndpoint endpointPath router request respond =+ if rawPathInfo request == endpointPath+ then respond $ responseLBS status200 mempty "-"+ else router request respond
+ Network/Wai/Middleware/HttpAuth.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++-- | Implements HTTP Basic Authentication.+--+-- This module may add digest authentication in the future.+module Network.Wai.Middleware.HttpAuth (+ -- * Middleware+ basicAuth,+ basicAuth',+ CheckCreds,+ AuthSettings,+ authRealm,+ authOnNoAuth,+ authIsProtected,++ -- * Helping functions+ extractBasicAuth,+ extractBearerAuth,+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import Data.ByteString.Base64 (decodeLenient)+import Data.String (IsString (..))+import Data.Word8 (isSpace, toLower, _colon)+import Network.HTTP.Types (hAuthorization, hContentType, status401)+import Network.Wai (+ Application,+ Middleware,+ Request (requestHeaders),+ responseLBS,+ )++-- | Check if a given username and password is valid.+type CheckCreds =+ ByteString+ -> ByteString+ -> IO Bool++-- | Perform basic authentication.+--+-- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm"+--+-- @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 sendResponse+ else authOnNoAuth authRealm req sendResponse+ where+ check =+ case lookup hAuthorization (requestHeaders req)+ >>= extractBasicAuth of+ Nothing -> return False+ Just (username, password) -> checkCreds req username password++-- | 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+data AuthSettings = AuthSettings+ { authRealm :: !ByteString+ -- ^+ --+ -- @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 -> IO Bool)+ -- ^ Determine if access to the requested resource is restricted.+ --+ -- Default: always returns @True@.+ --+ -- @since 1.3.4+ }++instance IsString AuthSettings where+ fromString s =+ AuthSettings+ { authRealm = fromString s+ , authOnNoAuth = \realm _req f ->+ f $+ responseLBS+ status401+ [ (hContentType, "text/plain")+ ,+ ( "WWW-Authenticate"+ , S.concat+ [ "Basic realm=\""+ , realm+ , "\""+ ]+ )+ ]+ "Basic authentication is required"+ , authIsProtected = const $ return True+ }++-- | 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
Network/Wai/Middleware/Jsonp.hs view
@@ -1,6 +1,9 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+ ---------------------------------------------------------++---------------------------------------------------------+ -- | -- Module : Network.Wai.Middleware.Jsonp -- Copyright : Michael Snoyman@@ -11,32 +14,32 @@ -- 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. -- -- Basically, if the user requested a \"text\/javascript\" and supplied a -- \"callback\" GET parameter, ask the application for an--- \"application/json\" response, then convern that into a JSONP response,+-- \"application/json\" response, then convert that into a JSONP response, -- 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
+ Network/Wai/Middleware/Local.hs view
@@ -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)
Network/Wai/Middleware/MethodOverride.hs view
@@ -1,16 +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) +-- | Overriding of HTTP request method via `_method` query string parameter.+--+-- 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 join $ lookup "_method" $ queryString req of- Nothing -> req- Just m -> req { requestMethod = m }+ case (requestMethod req, join $ lookup "_method" $ queryString req) of+ ("POST", Just m) -> req{requestMethod = m}+ _ -> req
+ Network/Wai/Middleware/MethodOverridePost.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------++-----------------------------------------------------------------++-- | Module : Network.Wai.Middleware.MethodOverridePost+--+-- Changes the request-method via first post-parameter _method.+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++-- | Allows overriding of the HTTP request method via the _method post string parameter.+--+-- * Looks for the Content-Type requestHeader.+--+-- * If the header is set to application/x-www-form-urlencoded+-- and the first POST parameter is _method+-- then it changes the request-method to the value of that+-- parameter.+--+-- * This middleware only applies when the initial request method is POST.+methodOverridePost :: Middleware+methodOverridePost app req send =+ case (requestMethod req, lookup hContentType (requestHeaders req)) of+ ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send+ _ -> app req send++setPost :: Request -> IO Request+setPost req = do+ body <- (mconcat . toChunks) `fmap` lazyRequestBody req+ ref <- newIORef body+ let rb = atomicModifyIORef ref $ \bs -> (mempty, bs)+ req' = setRequestBodyChunks rb req+ case parseQuery body of+ (("_method", Just newmethod) : _) -> return req'{requestMethod = newmethod}+ _ -> return req'++{- HLint ignore setPost "Use tuple-section" -}
+ Network/Wai/Middleware/RealIp.hs view
@@ -0,0 +1,95 @@+-- | Infer the remote IP address using headers+module Network.Wai.Middleware.RealIp (+ realIp,+ realIpHeader,+ realIpTrusted,+ defaultTrusted,+ ipInRange,+) where++import qualified Data.ByteString.Char8 as B8 (split, unpack)+import qualified Data.IP as IP+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Network.HTTP.Types (HeaderName, RequestHeaders)+import Network.Wai (Middleware, remoteHost, requestHeaders)+import Text.Read (readMaybe)++-- | Infer the remote IP address from the @X-Forwarded-For@ header,+-- trusting requests from any private IP address. See 'realIpHeader' and+-- 'realIpTrusted' for more information and options.+--+-- @since 3.1.5+realIp :: Middleware+realIp = realIpHeader "X-Forwarded-For"++-- | Infer the remote IP address using the given header, trusting+-- requests from any private IP address. See 'realIpTrusted' for more+-- information and options.+--+-- @since 3.1.5+realIpHeader :: HeaderName -> Middleware+realIpHeader header =+ realIpTrusted header $ \ip -> any (ipInRange ip) defaultTrusted++-- | Infer the remote IP address using the given header, but only if the+-- request came from an IP that is trusted by the provided predicate.+--+-- The last non-trusted address is used to replace the 'remoteHost' in+-- the 'Request', unless all present IP addresses are trusted, in which+-- case the first address is used. Invalid IP addresses are ignored, and+-- the remoteHost value remains unaltered if no valid IP addresses are+-- found.+--+-- Examples:+--+-- @ realIpTrusted "X-Forwarded-For" $ flip ipInRange "10.0.0.0/8" @+--+-- @ realIpTrusted "X-Real-Ip" $ \\ip -> any (ipInRange ip) defaultTrusted @+--+-- @since 3.1.5+realIpTrusted :: HeaderName -> (IP.IP -> Bool) -> Middleware+realIpTrusted header isTrusted app req = app req'+ where+ req' = fromMaybe req $ do+ (ip, port) <- IP.fromSockAddr (remoteHost req)+ ip' <-+ if isTrusted ip+ then findRealIp (requestHeaders req) header isTrusted+ else Nothing+ Just $ req{remoteHost = IP.toSockAddr (ip', port)}++-- | Standard private IP ranges.+--+-- @since 3.1.5+defaultTrusted :: [IP.IPRange]+defaultTrusted =+ [ "127.0.0.0/8"+ , "10.0.0.0/8"+ , "172.16.0.0/12"+ , "192.168.0.0/16"+ , "::1/128"+ , "fc00::/7"+ ]++-- | Check if the given IP address is in the given range.+--+-- IPv4 addresses can be checked against IPv6 ranges, but testing an+-- IPv6 address against an IPv4 range is always 'False'.+--+-- @since 3.1.5+ipInRange :: IP.IP -> IP.IPRange -> Bool+ipInRange (IP.IPv4 ip) (IP.IPv4Range r) = ip `IP.isMatchedTo` r+ipInRange (IP.IPv6 ip) (IP.IPv6Range r) = ip `IP.isMatchedTo` r+ipInRange (IP.IPv4 ip) (IP.IPv6Range r) = IP.ipv4ToIPv6 ip `IP.isMatchedTo` r+ipInRange _ _ = False++findRealIp :: RequestHeaders -> HeaderName -> (IP.IP -> Bool) -> Maybe IP.IP+findRealIp reqHeaders header isTrusted =+ case (nonTrusted, ips) of+ ([], xs) -> listToMaybe xs+ (xs, _) -> listToMaybe $ reverse xs+ where+ -- account for repeated headers+ headerVals = [v | (k, v) <- reqHeaders, k == header]+ ips = concatMap (mapMaybe (readMaybe . B8.unpack) . B8.split ',') headerVals+ nonTrusted = filter (not . isTrusted) ips
Network/Wai/Middleware/RequestLogger.hs view
@@ -1,90 +1,404 @@-{-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.RequestLogger- ( logStdout- , logCallback- , logStdoutDev- , logCallbackDev- -- * Deprecated- , logHandle- , logHandleDev- ) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} -import System.IO (stdout, hFlush)-import qualified Data.ByteString as BS-import Data.ByteString.Char8 (pack, unpack)+-- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should+-- not use CPP.+-- EDIT: Fixed this by adding two "zero-width spaces" in between the "*/*"+module Network.Wai.Middleware.RequestLogger (+ -- * Basic stdout logging+ logStdout,+ logStdoutDev,++ -- * Create more versions+ mkRequestLogger,+ -- ** 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)-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 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-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+ } -logHandle :: (BS.ByteString -> IO ()) -> Middleware-logHandle = logCallback-{-# DEPRECATED logHandle "Please use logCallback instead." #-}-logHandleDev :: (BS.ByteString -> IO ()) -> Middleware-logHandleDev = logCallbackDev-{-# DEPRECATED logHandleDev "Please use logCallbackDev instead." #-}+defaultApacheSettings :: ApacheSettings+defaultApacheSettings =+ ApacheSettings+ { apacheIPAddrSource = FromSocket+ , apacheRequestFilter = \_ _ -> True+ , apacheUserGetter = const Nothing+ } --- | Production request logger middleware.--- Implemented on top of "logCallback", but prints to 'stdout'-logStdout :: Middleware-logStdout = logHandle $ \bs -> hPutLogStr stdout [LB bs]+-- | 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} --- | Development request logger middleware.--- Implemented on top of "logCallbackDev", but prints to 'stdout'+-- | Function that allows you to filter which requests are logged, based on+-- the request and response ----- Flushes 'stdout' on each request, which would be inefficient in production use.--- Use "logStdout" in production.-logStdoutDev :: Middleware-logStdoutDev = logHandleDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout+-- Default: log all requests+--+-- @since 3.1.8+setApacheRequestFilter+ :: (Request -> Response -> Bool) -> ApacheSettings -> ApacheSettings+setApacheRequestFilter x y = y{apacheRequestFilter = x} --- | Prints a message using the given callback function for each request.--- Designed for fast production use at the expense of convenience.--- In particular, no POST parameter information is currently given+-- | Function that allows you to get the current user from the request, which+-- will then be added in the log. ----- This is lower-level - use "logStdout" unless you need this greater control-logCallback :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.- -> Middleware-logCallback cb app req = do- liftIO $ cb $ BS.concat- [ requestMethod req- , " "- , rawPathInfo req- , rawQueryString req- , " "- , "Accept: "- , maybe "" toBS $ lookup "Accept" $ requestHeaders req- , "\n"- ]- app req+-- Default: return no user+--+-- @since 3.1.8+setApacheUserGetter+ :: (Request -> Maybe BS.ByteString) -> ApacheSettings -> ApacheSettings+setApacheUserGetter x y = y{apacheUserGetter = x} -toBS :: H.Ascii -> BS.ByteString-toBS = id+-- | 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+ } --- no black or white which are expected to be existing terminal colors.-colors :: IORef [Color]-colors = unsafePerformIO $ newIORef $ [- Red - , Green - , Yellow - , Blue - , Magenta - , Cyan- ]+-- | DO NOT USE THIS INSTANCE!+-- Please use 'defaultDetailedSettings'+--+-- This instance will be removed in a future major version.+instance Default DetailedSettings where+ def = defaultDetailedSettings -rotateColors :: [Color] -> ([Color], Color)-rotateColors [] = error "Impossible! There must be colors!"-rotateColors (c:cs) = (cs ++ [c], c)+-- | 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+ { outputFormat :: OutputFormat+ -- ^ Default value: @Detailed True@.+ --+ -- @since 1.3.0+ , autoFlush :: Bool+ -- ^ 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+ }++-- | Default 'RequestLoggerSettings'.+--+-- Use this to create 'RequestLoggerSettings', and use the+-- accompanying fields to edit these settings.+--+-- @since 3.1.8+defaultRequestLoggerSettings :: RequestLoggerSettings+defaultRequestLoggerSettings =+ RequestLoggerSettings+ { outputFormat = Detailed True+ , autoFlush = True+ , destination = Handle stdout+ }++-- | DO NOT USE THIS INSTANCE!+-- Please use 'defaultRequestLoggerSettings' instead.+--+-- This instance will be removed in a future major release.+instance Default RequestLoggerSettings where+ def = defaultRequestLoggerSettings++-- | Create the 'Middleware' using the given 'RequestLoggerSettings'+--+-- @since 1.3.0+mkRequestLogger :: RequestLoggerSettings -> IO Middleware+mkRequestLogger RequestLoggerSettings{..} = do+ let (callback, flusher) =+ 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 <- 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 <- 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+ :: (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 sendResponse = app req $ \res -> do+ date <- liftIO getdate+ 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.+--+-- 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 defaultRequestLoggerSettings{outputFormat = Apache FromSocket}++-- | Development request logger middleware.+--+-- This uses the 'Detailed' 'True' logging format and logs to 'stdout'.+{-# NOINLINE logStdoutDev #-}+logStdoutDev :: Middleware+logStdoutDev = unsafePerformIO $ mkRequestLogger defaultRequestLoggerSettings+ -- | Prints a message using the given callback function for each request. -- This is not for serious production use- it is inefficient. -- It immediately consumes a POST body and fills it back in and is otherwise inefficient@@ -93,99 +407,207 @@ -- 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.+-- 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--- --- GET static/css/normalize.css--- Accept: text/css,*/*;q=0.1--- GET [("LXwioiBG","")]------ Status: 304 Not Modified. static/css/normalize.css-logCallbackDev :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.- -> Middleware-logCallbackDev cb app req = do- let mlen = lookup "content-length" (requestHeaders req) >>= readInt+-- > GET 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+-- > 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++ansiColor' :: Color -> BS.ByteString -> [BS.ByteString]+ansiColor' color bs =+ [ pack $ setSGRCode [SetColor Foreground Dull color]+ , bs+ , pack $ setSGRCode [Reset]+ ]++-- | 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- let req' = req { requestBody = CL.sourceList body }- return (req', body)+ (KnownLength len, _) | len <= 2048 -> getRequestBody req+ (_, Just len) | len <= 2048 -> getRequestBody req _ -> return (req, []) - postParams <- if any (requestMethod req ==) ["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-- color <- liftIO $ atomicModifyIORef colors rotateColors+ 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"] - -- log the request immediately.- liftIO $ cb $ BS.concat $ ansiColor color (requestMethod req) ++- [ " "- , rawPathInfo req- , "\n"- , "Accept: "- , maybe "" id $ lookup "Accept" $ requestHeaders req- , paramsToBS "GET " getParams- , paramsToBS "POST " postParams- , "\n"- ]+ t0 <- getCurrentTime - rsp <- app req'+ -- Optionally prelog the request+ when mPrelogRequests $+ cb $+ "PRELOGGING REQUEST: " <> mkRequestLog params reqbody accept - -- 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 $ BS.concat $ ansiColor color "Status: " ++ [- sCode rsp- , " "- , msg rsp- , ". "- , rawPathInfo req -- if you need help matching the 2 logging statements- , "\n"- ]- return rsp- where- ansiColor color bs = [- pack $ setSGRCode [SetColor Foreground Vivid color]- , bs- , pack $ setSGRCode [Reset]- ]- sCode = pack . show . statusCode . responseStatus- msg = statusMessage . responseStatus+ 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 - 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++msgBS :: Response -> BS.ByteString+msgBS = statusMessage . responseStatus
+ Network/Wai/Middleware/RequestLogger/Internal.hs view
@@ -0,0 +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 (+ getDateGetter,+ logToByteString,+) where++#if !MIN_VERSION_wai_logger(2, 2, 0)+import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (forever)+#endif+import Data.ByteString (ByteString)+import Network.Wai.Logger (clockDateCacher)+import System.Log.FastLogger (LogStr, fromLogStr)++logToByteString :: LogStr -> ByteString+logToByteString = fromLogStr++getDateGetter+ :: IO ()+ -- ^ flusher+ -> IO (IO ByteString)+#if !MIN_VERSION_wai_logger(2, 2, 0)+getDateGetter flusher = do+ (getter, updater) <- clockDateCacher+ _ <- forkIO $ forever $ do+ threadDelay 1000000+ updater+ flusher+#else+getDateGetter _ = do+ (getter, _) <- clockDateCacher+#endif+ return getter
+ Network/Wai/Middleware/RequestLogger/JSON.hs view
@@ -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
+ Network/Wai/Middleware/RequestSizeLimit.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE CPP #-}++-- | The functions in this module allow you to limit the total size of incoming request bodies.+--+-- Limiting incoming request body size helps protect your server against denial-of-service (DOS) attacks,+-- in which an attacker sends huge bodies to your server.+module Network.Wai.Middleware.RequestSizeLimit (+ -- * Middleware+ requestSizeLimitMiddleware,++ -- * Constructing 'RequestSizeLimitSettings'+ defaultRequestSizeLimitSettings,++ -- * 'RequestSizeLimitSettings' and accessors+ RequestSizeLimitSettings,+ setMaxLengthForRequest,+ setOnLengthExceeded,+) where++import Control.Exception (catch, try)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as LS8+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#endif+import Data.Word (Word64)+import Network.HTTP.Types.Status (requestEntityTooLarge413)+import Network.Wai++import Network.Wai.Middleware.RequestSizeLimit.Internal (+ RequestSizeLimitSettings (..),+ setMaxLengthForRequest,+ setOnLengthExceeded,+ )+import Network.Wai.Request++-- | Create a 'RequestSizeLimitSettings' with these settings:+--+-- * 2MB size limit for all requests+-- * When the limit is exceeded, return a plain text response describing the error, with a 413 status code.+--+-- @since 3.1.1+defaultRequestSizeLimitSettings :: RequestSizeLimitSettings+defaultRequestSizeLimitSettings =+ RequestSizeLimitSettings+ { maxLengthForRequest = \_req -> pure $ Just $ 2 * 1024 * 1024+ , onLengthExceeded = \maxLen _app req sendResponse -> sendResponse (tooLargeResponse maxLen (requestBodyLength req))+ }++-- | Middleware to limit request bodies to a certain size.+--+-- This uses 'requestSizeCheck' under the hood; see that function for details.+--+-- @since 3.1.1+requestSizeLimitMiddleware :: RequestSizeLimitSettings -> Middleware+requestSizeLimitMiddleware settings app req sendResponse = do+ maybeMaxLen <- maxLengthForRequest settings req++ case maybeMaxLen of+ Nothing -> app req sendResponse+ Just maxLen -> do+ eitherSizeExceptionOrNewReq <- try (requestSizeCheck maxLen req)+ case eitherSizeExceptionOrNewReq of+ -- In the case of a known-length request, RequestSizeException will be thrown immediately+ Left (RequestSizeException _maxLen) -> handleLengthExceeded maxLen+ -- In the case of a chunked request (unknown length), RequestSizeException will be thrown during the processing of a body+ Right newReq ->+ app newReq sendResponse `catch` \(RequestSizeException _maxLen) -> handleLengthExceeded maxLen+ where+ handleLengthExceeded maxLen = onLengthExceeded settings maxLen app req sendResponse++tooLargeResponse :: Word64 -> RequestBodyLength -> Response+tooLargeResponse maxLen bodyLen =+ responseLBS+ requestEntityTooLarge413+ [("Content-Type", "text/plain")]+ ( BSL.concat+ [ "Request body too large to be processed. The maximum size is "+ , LS8.pack (show maxLen)+ , " bytes; your request body was "+ , case bodyLen of+ KnownLength knownLen -> LS8.pack (show knownLen) <> " bytes."+ ChunkedBody -> "split into chunks, whose total size is unknown, but exceeded the limit."+ , " If you're the developer of this site, you can configure the maximum length with `requestSizeLimitMiddleware`."+ ]+ )
+ Network/Wai/Middleware/RequestSizeLimit/Internal.hs view
@@ -0,0 +1,63 @@+-- | Internal constructors and helper functions. Note that no guarantees are given for stability of these interfaces.+module Network.Wai.Middleware.RequestSizeLimit.Internal (+ RequestSizeLimitSettings (..),+ setMaxLengthForRequest,+ setOnLengthExceeded,+) where++import Data.Word (Word64)+import Network.Wai (Middleware, Request)++-- | Settings to configure 'requestSizeLimitMiddleware'.+--+-- This type (but not the constructor, or record fields) is exported from "Network.Wai.Middleware.RequestSizeLimit".+-- Since the constructor isn't exported, create a default value with 'defaultRequestSizeLimitSettings' first,+-- then set the values using 'setMaxLengthForRequest' and 'setOnLengthExceeded' (See the examples below).+--+-- If you need to access the constructor directly, it's exported from "Network.Wai.Middleware.RequestSizeLimit.Internal".+--+-- ==== __Examples__+--+-- ===== Conditionally setting the limit based on the request+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Network.Wai+-- > import Network.Wai.Middleware.RequestSizeLimit+-- >+-- > let megabyte = 1024 * 1024+-- > let sizeForReq req = if pathInfo req == ["upload", "image"] then pure $ Just $ megabyte * 20 else pure $ Just $ megabyte * 2+-- > let finalSettings = setMaxLengthForRequest sizeForReq defaultRequestSizeLimitSettings+--+-- ===== JSON response+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Network.Wai+-- > import Network.Wai.Middleware.RequestSizeLimit+-- > import Network.HTTP.Types.Status (requestEntityTooLarge413)+-- > import Data.Aeson+-- > import Data.Text (Text)+-- >+-- > let jsonResponse = \_maxLen _app _req sendResponse -> sendResponse $ responseLBS requestEntityTooLarge413 [("Content-Type", "application/json")] (encode $ object ["error" .= ("request size too large" :: Text)])+-- > let finalSettings = setOnLengthExceeded jsonResponse defaultRequestSizeLimitSettings+--+-- @since 3.1.1+data RequestSizeLimitSettings = RequestSizeLimitSettings+ { maxLengthForRequest :: Request -> IO (Maybe Word64)+ -- ^ Function to determine the maximum request size in bytes for the request. Return 'Nothing' for no limit. Since 3.1.1+ , onLengthExceeded :: Word64 -> Middleware+ -- ^ Callback function when maximum length is exceeded. The 'Word64' argument is the limit computed by 'maxLengthForRequest'. Since 3.1.1+ }++-- | Function to determine the maximum request size in bytes for the request. Return 'Nothing' for no limit.+--+-- @since 3.1.1+setMaxLengthForRequest+ :: (Request -> IO (Maybe Word64))+ -> RequestSizeLimitSettings+ -> RequestSizeLimitSettings+setMaxLengthForRequest fn settings = settings{maxLengthForRequest = fn}++-- | Callback function when maximum length is exceeded. The 'Word64' argument is the limit computed by 'setMaxLengthForRequest'.+--+-- @since 3.1.1+setOnLengthExceeded+ :: (Word64 -> Middleware) -> RequestSizeLimitSettings -> RequestSizeLimitSettings+setOnLengthExceeded fn settings = settings{onLengthExceeded = fn}
Network/Wai/Middleware/Rewrite.hs view
@@ -1,39 +1,364 @@-{-# LANGUAGE OverloadedStrings #-}-module Network.Wai.Middleware.Rewrite- ( rewrite, autoHtmlRewrite- ) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-} -import Network.Wai-import System.Directory (doesFileExist)+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.Text (Text, unpack, pack)-import qualified Data.Text.Encoding as TE+import Data.Functor.Identity (Identity (..))+import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import Network.HTTP.Types as H+import Network.Wai +-- $howto+-- This module provides 'Middleware' to rewrite URL paths. It also provides+-- 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--- Example usage: rewrite (autoHtmlRewrite "static")+-- $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.++-- $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++-- $takeover+-- Let’s say we want to replace a website written in PHP with one written+-- using WAI. We’ll use the+-- <https://hackage.haskell.org/package/http-reverse-proxy http-reverse-proxy>+-- 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+-- <https://hackage.haskell.org/package/http-reverse-proxy http-reverse-proxy>+-- 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+-- <https://gist.github.com/dbaynard/c844d0df124f68ec8b6da152c581ce6d>.++-- $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 = do- newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req)- let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo- app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo }+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"+ ]+ #-} --- | example rewriter--- We don't recommend normally checking the file system on every request - this is just an example.--- Implements 2 rules for static html re-writes--- 1) for a directory foo/, check for foo/index.html--- 2) for a non-directory bar, check for bar.html--- Do the rewrite only if the html file exists.-autoHtmlRewrite :: String -> [Text] -> H.RequestHeaders -> IO [Text]-autoHtmlRewrite staticDir pieces' _ = do- fe <- doesFileExist $ staticDir ++ "/" ++ reWritePath- return $ if fe then map pack reWritePieces else pieces'+-- | 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 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- pieces = map unpack pieces'- reWritePath = concat $ map ((:) '/') reWritePieces- reWritePieces =- if (null pieces) || (null $ last pieces)- then pieces ++ ["index.html"]- else (init pieces) ++ [(last pieces) ++ ".html"]+ 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 #-}
+ Network/Wai/Middleware/Routed.hs view
@@ -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
+ Network/Wai/Middleware/Select.hs view
@@ -0,0 +1,97 @@+---------------------------------------------------------++---------------------------------------------------------++-- |+-- Module : Network.Wai.Middleware.Select+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Dynamically choose between Middlewares+--+-- It's useful when you want some 'Middleware's applied selectively.+--+-- Example: do not log health check calls:+--+-- > import Network.Wai+-- > import Network.Wai.Middleware.HealthCheckEndpoint+-- > import Network.Wai.Middleware.RequestLogger+-- >+-- > app' :: Application+-- > app' =+-- > selectMiddleware (selectMiddlewareExceptRawPathInfo "/_healthz" logStdout)+-- > $ healthCheck app+--+-- @since 3.1.10+module Network.Wai.Middleware.Select (+ -- * Middleware selection+ MiddlewareSelection (..),+ selectMiddleware,++ -- * Helpers+ selectMiddlewareOn,+ selectMiddlewareOnRawPathInfo,+ selectMiddlewareExceptRawPathInfo,+ passthroughMiddleware,+)+where++import Control.Applicative ((<|>))+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import Network.Wai++--------------------------------------------------++-- * Middleware selection++--------------------------------------------------++-- | Relevant Middleware for a given 'Request'.+newtype MiddlewareSelection = MiddlewareSelection+ { applySelectedMiddleware :: Request -> Maybe Middleware+ }++instance Semigroup MiddlewareSelection where+ MiddlewareSelection f <> MiddlewareSelection g =+ MiddlewareSelection $ \req -> f req <|> g req++instance Monoid MiddlewareSelection where+ mempty = MiddlewareSelection $ const Nothing++-- | Create the 'Middleware' dynamically applying 'MiddlewareSelection'.+selectMiddleware :: MiddlewareSelection -> Middleware+selectMiddleware selection app request respond =+ mw app request respond+ where+ mw :: Middleware+ mw = fromMaybe passthroughMiddleware (applySelectedMiddleware selection request)++--------------------------------------------------++-- * Helpers++--------------------------------------------------++passthroughMiddleware :: Middleware+passthroughMiddleware = id++-- | Use the 'Middleware' when the predicate holds.+selectMiddlewareOn :: (Request -> Bool) -> Middleware -> MiddlewareSelection+selectMiddlewareOn doesApply mw = MiddlewareSelection $ \request ->+ if doesApply request+ then Just mw+ else Nothing++-- | Use the `Middleware` for the given 'rawPathInfo'.+selectMiddlewareOnRawPathInfo :: ByteString -> Middleware -> MiddlewareSelection+selectMiddlewareOnRawPathInfo path = selectMiddlewareOn ((== path) . rawPathInfo)++-- | Use the `Middleware` for all 'rawPathInfo' except then given one.+selectMiddlewareExceptRawPathInfo+ :: ByteString -> Middleware -> MiddlewareSelection+selectMiddlewareExceptRawPathInfo path = selectMiddlewareOn ((/= path) . rawPathInfo)
+ Network/Wai/Middleware/StreamFile.hs view
@@ -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
+ Network/Wai/Middleware/StripHeaders.hs view
@@ -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)
+ Network/Wai/Middleware/Timeout.hs view
@@ -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)
+ Network/Wai/Middleware/ValidateHeaders.hs view
@@ -0,0 +1,138 @@+-- | This module provides a middleware to validate response headers.+-- [RFC 9110](https://www.rfc-editor.org/rfc/rfc9110.html#section-5) constrains the allowed octets in header names and values:+--+-- * Header names are [tokens](https://www.rfc-editor.org/rfc/rfc9110#section-5.6.2), i.e. visible ASCII characters (octets 33 to 126 inclusive) except delimiters.+-- * Header values should be limited to visible ASCII characters, the whitespace characters space and horizontal tab and octets 128 to 255. Headers values may not have trailing whitespace (see [RFC 9110 Section 5.5](https://www.rfc-editor.org/rfc/rfc9110.html#section-5.5)). Folding is not allowed.+--+-- 'validateHeadersMiddleware' enforces these constraints for response headers by responding with a 500 Internal Server Error when an offending character is present. This is meant to catch programmer errors early on and reduce attack surface.+module Network.Wai.Middleware.ValidateHeaders+ ( -- * Middleware+ validateHeadersMiddleware+ -- * Settings+ , ValidateHeadersSettings (..)+ , defaultValidateHeadersSettings+ -- * Types+ , InvalidHeader (..)+ , InvalidHeaderReason (..)+ ) where++import Data.CaseInsensitive (original)+import Data.Char (chr)+import Data.Word (Word8)+import Network.HTTP.Types (Header, ResponseHeaders, internalServerError500)+import Network.Wai (Middleware, Response, responseHeaders, responseLBS)+import Text.Printf (printf)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL++-- | Middleware to validate response headers.+--+-- @since 3.1.15+validateHeadersMiddleware :: ValidateHeadersSettings -> Middleware+validateHeadersMiddleware settings app req respond =+ app req respond'+ where+ respond' response = case getInvalidHeader $ responseHeaders response of+ Just invalidHeader -> onInvalidHeader settings invalidHeader app req respond+ Nothing -> respond response++-- | Configuration for 'validateHeadersMiddleware'.+--+-- @since 3.1.15+data ValidateHeadersSettings = ValidateHeadersSettings+ { -- | Called when an invalid header is present.+ onInvalidHeader :: InvalidHeader -> Middleware+ }++-- | Default configuration for 'validateHeadersMiddleware'.+-- Checks that each header meets the requirements listed at the top of this module: Allowed octets for name and value and no trailing whitespace in the value.+--+-- @since 3.1.15+defaultValidateHeadersSettings :: ValidateHeadersSettings+defaultValidateHeadersSettings = ValidateHeadersSettings+ { onInvalidHeader = \invalidHeader _app _req respond -> respond $ invalidHeaderResponse invalidHeader+ }++-- | Description of an invalid header.+--+-- @since 3.1.15+data InvalidHeader = InvalidHeader Header InvalidHeaderReason++-- | Reasons a header might be invalid.+--+-- @since 3.1.15+data InvalidHeaderReason+ -- | Header name contains an invalid octet.+ = InvalidOctetInHeaderName Word8+ -- | Header value contains an invalid octet.+ | InvalidOctetInHeaderValue Word8+ -- | Header value contains trailing whitespace.+ | TrailingWhitespaceInHeaderValue++-- Internal stuff.+-- 'getInvalidHeader' returns an appropriate 'InvalidHeader' for a given header if applicable.+-- 'invalidHeaderResponse' creates a 'Response' for a given 'InvalidHeader'.++getInvalidHeader :: ResponseHeaders -> Maybe InvalidHeader+getInvalidHeader = firstJust . map go+ where+ firstJust :: [Maybe a] -> Maybe a+ firstJust [] = Nothing+ firstJust (Just x : _) = Just x+ firstJust (_ : xs) = firstJust xs++ go :: Header -> Maybe InvalidHeader+ go header@(name, value) = InvalidHeader header <$> firstJust+ [ InvalidOctetInHeaderName <$> BS.find (not . isValidHeaderNameOctet) (original name)+ , InvalidOctetInHeaderValue <$> BS.find (not . isValidHeaderValueOctet) value+ , if hasTrailingWhitespace value then Just TrailingWhitespaceInHeaderValue else Nothing+ ]++isValidHeaderNameOctet :: Word8 -> Bool+isValidHeaderNameOctet octet =+ isVisibleASCII octet && not (isDelimiter octet)++isValidHeaderValueOctet :: Word8 -> Bool+isValidHeaderValueOctet octet =+ isVisibleASCII octet || isWhitespace octet || isObsText octet++isVisibleASCII :: Word8 -> Bool+isVisibleASCII octet = octet >= 33 && octet <= 126++isDelimiter :: Word8 -> Bool+isDelimiter octet = chr (fromIntegral octet) `elem` ("\"(),/:;<=>?@[\\]{}" :: String)++-- Whitespace characters are only horizontal tab and space here.+isWhitespace :: Word8 -> Bool+isWhitespace octet = octet == 0x9 || octet == 0x20++isObsText :: Word8 -> Bool+isObsText octet = octet >= 0x80++hasTrailingWhitespace :: BS.ByteString -> Bool+hasTrailingWhitespace bs+ | BS.length bs == 0 = False+ | otherwise = isWhitespace (BS.index bs 0) || isWhitespace (BS.index bs $ BS.length bs - 1)++invalidHeaderResponse :: InvalidHeader -> Response+invalidHeaderResponse (InvalidHeader (headerName, headerValue) reason) =+ responseLBS internalServerError500 [("Content-Type", "text/plain")] $ BSL.concat+ [ "Invalid response header found:\n"+ , "In header '"+ , BSL.fromStrict $ original headerName+ , "' with value '"+ , BSL.fromStrict headerValue+ , "': "+ , showReason reason+ , "\nYou are seeing this error message because validateHeadersMiddleware is enabled."+ ]+ where+ showReason (InvalidOctetInHeaderName octet) = "Name contains invalid octet " <> showOctet octet+ showReason (InvalidOctetInHeaderValue octet) = "Value contains invalid octet " <> showOctet octet+ showReason TrailingWhitespaceInHeaderValue = "Value contains trailing whitespace."++ showOctet octet+ | isVisibleASCII octet = BSL.fromStrict $ BS8.pack $ printf "'%c' (0x%02X)" (chr $ fromIntegral octet) octet+ | otherwise = BSL.fromStrict $ BS8.pack $ printf "0x%02X" octet
Network/Wai/Middleware/Vhost.hs view
@@ -1,9 +1,47 @@-module Network.Wai.Middleware.Vhost (vhost) where+{-# LANGUAGE CPP #-} +module Network.Wai.Middleware.Vhost (+ vhost,+ redirectWWW,+ redirectTo,+ redirectToLogged,+) where++import qualified Data.ByteString as BS+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (mappend)+#endif+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types as H import Network.Wai vhost :: [(Request -> Bool, Application)] -> Application -> Application vhost vhosts def req = case filter (\(b, _) -> b req) vhosts of [] -> def req- (_, app):_ -> app req+ (_, app) : _ -> app req++redirectWWW :: Text -> Application -> Application -- W.MiddleWare+redirectWWW home =+ redirectIf+ home+ (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)++redirectIf :: 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
Network/Wai/Parse.hs view
@@ -1,143 +1,322 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-}--- | Some helpers for parsing data out of a raw WAI 'Request'.+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-} -module Network.Wai.Parse- ( parseHttpAccept- , parseRequestBody- , RequestBodyType (..)- , getRequestBodyType- , sinkRequestBody- , conduitRequestBody- , lbsBackEnd- , tempFileBackEnd- , BackEnd (..)- , Param- , File- , FileInfo (..)- -- ** Deprecated- , lbsSink- , tempFileSink+-- | Some helpers for parsing data out of a raw WAI 'Request'.+module Network.Wai.Parse (+ parseHttpAccept,+ parseRequestBody,+ RequestBodyType (..),+ getRequestBodyType,+ sinkRequestBody,+ sinkRequestBodyEx,+ RequestParseException (..),+ BackEnd,+ lbsBackEnd,+ tempFileBackEnd,+ tempFileBackEndOpts,+ Param,+ File,+ FileInfo (..),+ parseContentType,+ ParseRequestBodyOptions,+ defaultParseRequestBodyOptions,+ noLimitParseRequestBodyOptions,+ parseRequestBodyEx,+ setMaxRequestKeyLength,+ clearMaxRequestKeyLength,+ setMaxRequestNumFiles,+ clearMaxRequestNumFiles,+ setMaxRequestFileSize,+ clearMaxRequestFileSize,+ setMaxRequestFilesSize,+ clearMaxRequestFilesSize,+ setMaxRequestParmsSize,+ clearMaxRequestParmsSize,+ setMaxHeaderLines,+ clearMaxHeaderLines,+ setMaxHeaderLineLength,+ clearMaxHeaderLineLength, #if TEST- , Bound (..)- , findBound- , sinkTillBound- , killCR- , killCRLF- , takeLine+ Bound (..),+ findBound,+ sinkTillBound,+ killCR,+ killCRLF,+ takeLine, #endif- ) where+) where +import Prelude hiding (lines)++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif+import Control.Exception (catchJust)+import qualified Control.Exception as E+import Control.Monad (guard, unless, when)+import Control.Monad.Trans.Resource (+ InternalState,+ allocate,+ register,+ release,+ runInternalState,+ )+import Data.Bifunctor (bimap) import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8-import Data.Word (Word8)-import Data.Bits-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 qualified Data.Conduit as C-import qualified Data.Conduit.List as CL-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)--uncons :: S.ByteString -> Maybe (Word8, S.ByteString)-uncons s- | S.null s = Nothing- | otherwise = Just (S.head s, S.tail s)+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 = let (x, y) = S.break (== w) s in (x, S.drop 1 y) -qsDecode :: S.ByteString -> S.ByteString-qsDecode z = fst $ S.unfoldrN (S.length z) go z- where- go bs =- case uncons bs of- Nothing -> Nothing- Just (43, ws) -> Just (32, ws) -- plus to space- Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent- (x, xs) <- uncons ws- x' <- hexVal x- (y, ys) <- uncons xs- y' <- hexVal y- Just $ (combine x' y', ys)- Just (w, ws) -> Just (w, ws)- hexVal w- | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9- | 65 <= w && w <= 70 = Just $ w - 55 -- A - F- | 97 <= w && w <= 102 = Just $ w - 87 -- a - f- | otherwise = Nothing- combine :: Word8 -> Word8 -> Word8- combine a b = shiftL a 4 .|. b- -- | Parse the HTTP accept string to determine supported content types. parseHttpAccept :: S.ByteString -> [S.ByteString]-parseHttpAccept = map fst- . sortBy (rcompare `on` snd)- . map grabQ- . S.split 44 -- comma+parseHttpAccept =+ map fst+ . sortBy (rcompare `on` snd)+ . map (addSpecificity . grabQ)+ . S.split _comma where- rcompare :: Double -> Double -> Ordering+ rcompare :: (Double, Int) -> (Double, Int) -> Ordering rcompare = flip compare+ addSpecificity (s, q) =+ -- Prefer higher-specificity types+ let semicolons = S.count _semicolon s+ stars = S.count _asterisk s+ in (s, (q, semicolons - stars)) grabQ s =- let (s', q) = breakDiscard 59 s -- semicolon- (_, q') = breakDiscard 61 q -- equals sign- in (trimWhite s', readQ $ trimWhite q')+ -- Stripping all spaces may be too harsh.+ -- Maybe just strip either side of 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- trimWhite = S.dropWhile (== 32) -- space---- | A destination for file data, with concrete implemtations--- provided by 'lbsBackEnd' and 'tempFileBackEnd'-data BackEnd y = forall x . BackEnd- { initialize :: IO x- , append :: x -> S.ByteString -> IO x- , close :: x -> IO y- , finalize :: y -> IO ()- }+ (x, _) : _ -> x+ _ -> 1.0 -- | Store uploaded files in memory-lbsBackEnd :: BackEnd L.ByteString-lbsBackEnd = BackEnd- { initialize = return id- , append = \front bs -> return $ front . (:) bs- , close = \front -> return $ L.fromChunks $ front []- , finalize = \_ -> return ()- }+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 :: BackEnd FilePath-tempFileBackEnd = BackEnd- { initialize = do- tempDir <- getTemporaryDirectory- openBinaryTempFile tempDir "webenc.buf"- , append = \(fp, h) bs -> S.hPut h bs >> return (fp, h)- , close = \(fp, h) -> do- hClose h- return fp- , finalize = \fp -> removeFile fp+--+-- 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 '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 } --- | This function has been renamed to 'lbsBackEnd'-lbsSink :: BackEnd L.ByteString-lbsSink = lbsBackEnd+-- | Set the maximum length of a filename.+--+-- @since 3.0.16.0+setMaxRequestKeyLength+ :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions+setMaxRequestKeyLength l p = p{prboKeyLength = Just l} --- | This function has been renamed to 'tempFileBackEnd'-tempFileSink :: BackEnd FilePath-tempFileSink = tempFileBackEnd+-- | Do not limit the length of filenames.+--+-- @since 3.0.16.0+clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions+clearMaxRequestKeyLength p = p{prboKeyLength = Nothing} -{-# DEPRECATED lbsSink "Please use 'lbsBackEnd'" #-}-{-# DEPRECATED tempFileSink "Please use 'tempFileBackEnd'" #-}+-- | 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@@ -146,145 +325,371 @@ } deriving (Eq, Show) +-- | Post parameter name and value. type Param = (S.ByteString, S.ByteString)++-- | Post parameter name and associated file information. type File y = (S.ByteString, FileInfo y) -data RequestBodyType = UrlEncoded | Multipart S.ByteString+-- | 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 +-- | 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- if urlenc `S.isPrefixOf` ctype- then Just UrlEncoded- else case boundary ctype of- Just x -> Just $ Multipart x- Nothing -> Nothing+ ctype' <- lookup hContentType $ requestHeaders req+ let (ctype, attrs) = parseContentType ctype'+ case ctype of+ "application/x-www-form-urlencoded" -> return UrlEncoded+ "multipart/form-data" | Just bound <- lookup "boundary" attrs -> return $ Multipart bound+ _ -> Nothing++-- | 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)])+parseContentType a = do+ let (ctype, b) = S.break (== _semicolon) a+ attrs = goAttrs id $ S.drop 1 b+ in (ctype, attrs) where- urlenc = S8.pack "application/x-www-form-urlencoded"- formBound = S8.pack "multipart/form-data;"- bound' = "boundary="- boundary s =- if "multipart/form-data;" `S.isPrefixOf` s- then- let s' = S.dropWhile (== 32) $ S.drop (S.length formBound) s- in if bound' `S.isPrefixOf` s'- then Just $ S.drop (S.length bound') s'- else Nothing- else Nothing+ 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+ goAttr bs =+ let (k, v') = S.break (== _equal) bs+ v = S.drop 1 v'+ in (strip k, dq $ strip v)+ strip = S.dropWhile (== _space) . fst . S.breakEnd (/= _space) -parseRequestBody :: BackEnd y- -> Request- -> C.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 C.$$ conduitRequestBody s rbt C.=$ CL.consume+ Just rbt -> sinkRequestBodyEx o s rbt (getRequestBodyChunk r) -sinkRequestBody :: BackEnd y- -> RequestBodyType- -> C.Sink S.ByteString IO ([Param], [File y])-sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r C.=$ 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- -> C.Conduit S.ByteString IO (Either Param (File y))-conduitRequestBody _ UrlEncoded = C.sequenceSink () $ \() -> do -- url-encoded+-- | 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- return $ C.Emit () $ 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 -takeLine :: C.Sink S.ByteString IO (Maybe S.ByteString)-takeLine =- C.sinkState id push close'+-- | 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- close' _ = return Nothing+ 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 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 return $ C.StateProcessing $ S.append x+ then go $ front `S.append` x else do- let lo = if S.length y > 1 then Just (S.drop 1 y) else Nothing- return $ C.StateDone lo $ 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 -takeLines :: C.Sink S.ByteString IO [S.ByteString]-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- -> C.Conduit S.ByteString IO (Either Param (File y))-parsePieces sink bound = C.sequenceSink True (parsePiecesSink sink bound)+data Source = Source (IO S.ByteString) (IORef S.ByteString) -parsePiecesSink :: BackEnd y- -> S.ByteString- -> C.SequencedSink Bool S.ByteString IO (Either Param (File y))-parsePiecesSink _ _ False = return C.Stop-parsePiecesSink BackEnd{initialize=initialize',append=append',close=close'}- bound True = do- _boundLine <- takeLine- res' <- takeLines- case res' of- [] -> return C.Stop- _ -> do+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 :: 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- seed <- liftIO initialize'- (seed', wasFound) <-- sinkTillBound bound append' seed- y <- liftIO $ close' seed'- let fi = FileInfo filename ct y- let y' = (name, fi)- return $ C.Emit wasFound [Right y']+ fi0 = FileInfo filename ct ()+ 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- (front, wasFound) <-- sinkTillBound bound iter seed+ ((wasFound, _fileSize), front) <-+ sinkTillBound+ bound+ iter+ seed+ src+ (fromIntegral <$> prboMaxParmsSize o) let bs = S.concat $ front []- let x' = (name, qsDecode bs)- return $ C.Emit wasFound [Left x']+ let x' = (name, bs)+ 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- return $ C.Emit wasFound []- where- contDisp = S8.pack "Content-Disposition"- contType = S8.pack "Content-Type"- parsePair s =- let (x, y) = breakDiscard 58 s -- colon- in (x, S.dropWhile (== 32) y) -- space+ ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing+ when wasFound $ loop numParms numFiles parmSize filesSize src+ where+ contDisp = mk $ S8.pack "Content-Disposition"+ contType = mk $ S8.pack "Content-Type"+ parsePair s =+ 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 = go [0..S.length bs - 1]+findBound b bs = handleBreak $ S.breakSubstring b bs where+ handleBreak (h, t)+ | 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@@ -292,57 +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- -> (x -> S.ByteString -> IO x)- -> x- -> C.Sink S.ByteString IO (x, Bool)-sinkTillBound bound iter seed0 = C.sinkState- (id, seed0)- push- close'- where- close' (front, seed) = do- seed' <- liftIO $ iter seed $ front S.empty- return (seed', False)- push (front, seed) bs' = do- let bs = front bs'- case findBound bound bs of- FoundBound before after -> do- let before' = killCRLF before- seed' <- liftIO $ iter seed before'- return $ C.StateDone (Just after) (seed', 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)- seed' <- liftIO $ iter seed toEmit- return $ C.StateProcessing (front', seed')- PartialBound -> return $ C.StateProcessing (S.append bs, seed)+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) -parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]-parseAttrs = map go . S.split 59 -- semicolon+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- 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)+ 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) + 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++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
+ Network/Wai/Request.hs view
@@ -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
+ Network/Wai/Test.hs view
@@ -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)
+ Network/Wai/Test/Internal.hs view
@@ -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
+ Network/Wai/UrlMap.hs view
@@ -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
+ Network/Wai/Util.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}++-- | Some helpers functions.+module Network.Wai.Util (+ dropWhileEnd,+ splitCommas,+ trimWS,+) where++import qualified Data.ByteString as S+import Data.Word8 (Word8, _comma, _space)++-- | Used to split a header value which is a comma separated list+splitCommas :: S.ByteString -> [S.ByteString]+splitCommas = map trimWS . S.split _comma++-- Trim whitespace+trimWS :: S.ByteString -> S.ByteString+trimWS = dropWhileEnd (== _space) . S.dropWhile (== _space)++-- | Dropping all 'Word8's from the end that satisfy the predicate.+dropWhileEnd :: (Word8 -> Bool) -> S.ByteString -> S.ByteString+#if MIN_VERSION_bytestring(0,10,12)+dropWhileEnd = S.dropWhileEnd+#else+dropWhileEnd p = fst . S.spanEnd p+#endif
+ README.md view
@@ -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+```
+ example/Main.hs view
@@ -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")+ ]
+ test/Network/Wai/Middleware/ApprootSpec.hs view
@@ -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)] ""
+ test/Network/Wai/Middleware/CombineHeadersSpec.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.CombineHeadersSpec (+ main,+ spec,+) where++import Data.ByteString (ByteString)+import Data.IORef (newIORef, readIORef, writeIORef)+import Network.HTTP.Types (status200)+import Network.HTTP.Types.Header+import Network.Wai+import Test.Hspec++import Network.Wai.Middleware.CombineHeaders (+ CombineSettings,+ combineHeaders,+ defaultCombineSettings,+ setRequestHeaders,+ setResponseHeaders,+ )+import Network.Wai.Test (SResponse (simpleHeaders), request, runSession)++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ let test name settings reqHeaders expectedReqHeaders resHeaders expectedResHeaders = it name $ do+ (reqHdrs, resHdrs) <- runApp settings reqHeaders resHeaders+ reqHdrs `shouldBe` expectedReqHeaders+ resHdrs `shouldBe` expectedResHeaders+ testReqHdrs name a b =+ test name defaultCombineSettings a b [] []+ testResHdrs name a b =+ test+ name+ (setRequestHeaders False $ setResponseHeaders True defaultCombineSettings)+ []+ []+ a+ b++ -- Request Headers+ testReqHdrs+ "should reorder alphabetically (request)"+ [host, userAgent, acceptHtml]+ [acceptHtml, host, userAgent]+ -- Response Headers+ testResHdrs+ "should reorder alphabetically (response)"+ [expires, location, contentTypeHtml]+ [contentTypeHtml, expires, location]++ -- Request Headers+ testReqHdrs+ "combines Accept (in order)"+ [userAgent, acceptHtml, host, acceptJSON]+ [acceptHtml `combineHdrs` acceptJSON, host, userAgent]+ -- Response Headers+ testResHdrs+ -- Using the default header map, Cache-Control is a "combineable" header, "Set-Cookie" is not+ "combines Cache-Control (in order) and keeps Set-Cookie (in order)"+ [cacheControlPublic, setCookie "2", date, cacheControlMax, setCookie "1"]+ [ cacheControlPublic `combineHdrs` cacheControlMax+ , date+ , setCookie "2"+ , setCookie "1"+ ]++ -- Request Headers+ testReqHdrs+ "KeepOnly works as expected (present | request)"+ -- "Alt-Svc" has (KeepOnly "clear")+ [date, altSvc "wrong", altSvc "clear", altSvc "wrong again", host]+ [altSvc "clear", date, host]+ testReqHdrs+ "KeepOnly works as expected ( absent | request)"+ -- "Alt-Svc" has (KeepOnly "clear"), but will combine when there's no "clear" (AND keeps order)+ [date, altSvc "wrong", altSvc "not clear", altSvc "wrong again", host]+ [altSvc "wrong, not clear, wrong again", date, host]++ -- Response Headers+ testResHdrs+ "KeepOnly works as expected (present | response)"+ -- "If-None-Match" has (KeepOnly "*")+ [date, ifNoneMatch "wrong", ifNoneMatch "*", ifNoneMatch "wrong again", host]+ [date, host, ifNoneMatch "*"]+ testResHdrs+ "KeepOnly works as expected ( absent | response)"+ -- "If-None-Match" has (KeepOnly "*"), but will combine when there's no "*" (AND keeps order)+ [ date+ , ifNoneMatch "wrong"+ , ifNoneMatch "not *"+ , ifNoneMatch "wrong again"+ , host+ ]+ [date, host, ifNoneMatch "wrong, not *, wrong again"]++ -- Request Headers+ testReqHdrs+ "Technically acceptable headers get combined correctly (request)"+ [ ifNoneMatch "correct, "+ , ifNoneMatch "something else \t"+ , ifNoneMatch "and more , "+ ]+ [ifNoneMatch "correct, something else, and more"]+ -- Response Headers+ testResHdrs+ "Technically acceptable headers get combined correctly (response)"+ [altSvc "correct\t, ", altSvc "something else", altSvc "and more, , "]+ [altSvc "correct, something else, and more"]++combineHdrs :: Header -> Header -> Header+combineHdrs (hname, h1) (_, h2) = (hname, h1 <> ", " <> h2)++acceptHtml+ , acceptJSON+ , cacheControlMax+ , cacheControlPublic+ , contentTypeHtml+ , date+ , expires+ , host+ , location+ , userAgent+ :: Header+acceptHtml = (hAccept, "text/html")+acceptJSON = (hAccept, "application/json")+altSvc :: ByteString -> Header+altSvc x = ("Alt-Svc", x)+cacheControlPublic = (hCacheControl, "public")+cacheControlMax = (hCacheControl, "public")+contentTypeHtml = (hContentType, "text/html")+date = (hDate, "Mon, 19 Aug 2022 18:18:31 GMT")+expires = (hExpires, "Mon, 19 Sep 2022 18:18:31 GMT")+host = (hHost, "google.com")+ifNoneMatch :: ByteString -> Header+ifNoneMatch x = (hIfNoneMatch, x)+location = (hLocation, "http://www.google.com/")+setCookie :: ByteString -> Header+setCookie val = (hSetCookie, val)+userAgent = (hUserAgent, "curl/7.68.0")++runApp+ :: CombineSettings+ -> RequestHeaders+ -> ResponseHeaders+ -> IO (RequestHeaders, ResponseHeaders)+runApp settings reqHeaders resHeaders = do+ reqHdrs <- newIORef $ error "IORef not set"+ sResponse <-+ runSession+ session+ $ combineHeaders settings+ $ app reqHdrs+ finalReqHeaders <- readIORef reqHdrs+ pure (finalReqHeaders, simpleHeaders sResponse)+ where+ session =+ request+ defaultRequest{requestHeaders = reqHeaders}+ app hdrRef req respond = do+ writeIORef hdrRef $ requestHeaders req+ respond $ responseLBS status200 resHeaders ""
+ test/Network/Wai/Middleware/ForceSSLSpec.hs view
@@ -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 [] ""
+ test/Network/Wai/Middleware/RealIpSpec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.RealIpSpec (+ spec,+) where++import qualified Data.ByteString.Lazy.Char8 as B8+import qualified Data.IP as IP+import Network.HTTP.Types (RequestHeaders, status200)+import Network.Wai+import Test.Hspec++import Network.Wai.Middleware.RealIp+import Network.Wai.Test++spec :: Spec+spec = do+ describe "realIp" $ do+ it "does nothing when header is missing" $ do+ resp <- runApp "127.0.0.1" [] realIp+ simpleBody resp `shouldBe` "127.0.0.1"++ it "uses X-Forwarded-For when present" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1")]+ resp <- runApp "127.0.0.1" headers realIp+ simpleBody resp `shouldBe` "1.1.1.1"++ it "ignores X-Forwarded-For from non-trusted ip" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1")]+ resp <- runApp "1.2.3.4" headers realIp+ simpleBody resp `shouldBe` "1.2.3.4"++ it "ignores trusted ip addresses in X-Forwarded-For" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1, 10.0.0.1")]+ resp <- runApp "127.0.0.1" headers realIp+ simpleBody resp `shouldBe` "1.1.1.1"++ it "ignores invalid ip addresses" $ do+ let headers1 = [("X-Forwarded-For", "1.1.1")]+ resp1 <- runApp "127.0.0.1" headers1 realIp+ let headers2 = [("X-Forwarded-For", "1.1.1.1,foo")]+ resp2 <- runApp "127.0.0.1" headers2 realIp++ simpleBody resp1 `shouldBe` "127.0.0.1"+ simpleBody resp2 `shouldBe` "1.1.1.1"++ it "takes the last non-trusted address" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1, 2.2.2.2, 10.0.0.1")]+ resp <- runApp "127.0.0.1" headers realIp+ simpleBody resp `shouldBe` "2.2.2.2"++ it "takes the first address when all are trusted" $ do+ let headers = [("X-Forwarded-For", "192.168.0.1, 10.0.0.2, 10.0.0.1")]+ resp <- runApp "127.0.0.1" headers realIp+ simpleBody resp `shouldBe` "192.168.0.1"++ it "handles repeated headers" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1"), ("X-Forwarded-For", "2.2.2.2")]+ resp <- runApp "127.0.0.1" headers realIp+ simpleBody resp `shouldBe` "2.2.2.2"++ it "handles ipv6 addresses" $ do+ let headers = [("X-Forwarded-For", "2001:db8::ff00:42:8329,10.0.0.1")]+ resp <- runApp "::1" headers realIp+ simpleBody resp `shouldBe` "2001:db8::ff00:42:8329"++ describe "realIpHeader" $ do+ it "uses specified header" $ do+ let headers = [("X-Forwarded-For", "1.1.1.1"), ("X-Real-Ip", "2.2.2.2")]+ resp <- runApp "127.0.0.1" headers $ realIpHeader "X-Real-Ip"+ simpleBody resp `shouldBe` "2.2.2.2"++ describe "realIpTrusted" $ do+ it "uses provided trusted predicate" $ do+ let headers = [("X-Forwarded-For", "10.0.0.1, 1.1.1.1")]+ isTrusted1 ip = any (ipInRange ip) ["127.0.0.1/32", "1.1.1.1/32"]+ isTrusted2 = flip ipInRange "1.1.1.1/32"++ resp1 <- runApp "127.0.0.1" headers $ realIpTrusted "X-Forwarded-For" isTrusted1+ resp2 <- runApp "10.0.0.2" headers $ realIpTrusted "X-Forwarded-For" isTrusted2++ simpleBody resp1 `shouldBe` "10.0.0.1"+ simpleBody resp2 `shouldBe` "10.0.0.2"++runApp :: IP.IP -> RequestHeaders -> Middleware -> IO SResponse+runApp ip hs mw =+ runSession+ ( request+ defaultRequest{remoteHost = IP.toSockAddr (ip, 80), requestHeaders = hs}+ )+ $ mw app+ where+ app req respond = respond $ responseLBS status200 [] $ renderIp req+ renderIp = B8.pack . maybe "" (show . fst) . IP.fromSockAddr . remoteHost
+ test/Network/Wai/Middleware/RequestSizeLimitSpec.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.RequestSizeLimitSpec (main, spec) where++import Control.Monad (replicateM)+import Data.Aeson (encode, object, (.=))+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import Data.Text (Text)+import Network.HTTP.Types (hContentLength, status200, status413)+import Network.Wai+import Test.Hspec++import Network.Wai.Middleware.RequestSizeLimit+import Network.Wai.Test++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "RequestSizeLimitMiddleware" $ do+ describe "Plain text response" $ do+ runStrictBodyTests+ "returns 413 for request bodies > 10 bytes, when streaming the whole body"+ tenByteLimitSettings+ "1234567890a"+ isStatus413+ runStrictBodyTests+ "returns 200 for request bodies <= 10 bytes, when streaming the whole body"+ tenByteLimitSettings+ "1234567890"+ isStatus200++ describe "JSON response" $ do+ runStrictBodyTests+ "returns 413 for request bodies > 10 bytes, when streaming the whole body"+ tenByteLimitJSONSettings+ "1234567890a"+ (isStatus413 >> isJSONContentType)+ runStrictBodyTests+ "returns 200 for request bodies <= 10 bytes, when streaming the whole body"+ tenByteLimitJSONSettings+ "1234567890"+ isStatus200++ describe "Per-request sizes" $ do+ it "allows going over the limit, when the path has been whitelisted" $ do+ let req =+ SRequest+ defaultRequest+ { pathInfo = ["upload", "image"]+ }+ "1234567890a"+ settings =+ setMaxLengthForRequest+ ( \req' ->+ if pathInfo req' == ["upload", "image"] then pure $ Just 20 else pure $ Just 10+ )+ defaultRequestSizeLimitSettings+ resp <- runStrictBodyApp settings req+ isStatus200 resp++ describe "streaming chunked bodies" $ do+ let streamingReq =+ setRequestBodyChunks+ (return "a")+ defaultRequest+ { isSecure = False+ , requestBodyLength = ChunkedBody+ }+ it "413s if the combined chunk size is > the size limit" $ do+ resp <- runStreamingChunkApp 11 tenByteLimitSettings streamingReq+ simpleStatus resp `shouldBe` status413+ it "200s if the combined chunk size is <= the size limit" $ do+ resp <- runStreamingChunkApp 10 tenByteLimitSettings streamingReq+ simpleStatus resp `shouldBe` status200+ where+ tenByteLimitSettings =+ setMaxLengthForRequest+ (\_req -> pure $ Just 10)+ defaultRequestSizeLimitSettings+ tenByteLimitJSONSettings =+ setOnLengthExceeded+ ( \_maxLen _app _req sendResponse ->+ sendResponse $+ responseLBS+ status413+ [("Content-Type", "application/json")]+ (encode $ object ["error" .= ("request size too large" :: Text)])+ )+ tenByteLimitSettings++ isStatus413 = \sResp -> simpleStatus sResp `shouldBe` status413+ isStatus200 = \sResp -> simpleStatus sResp `shouldBe` status200+ isJSONContentType = \sResp -> simpleHeaders sResp `shouldBe` [("Content-Type", "application/json")]++data LengthType = UseKnownLength | UseChunked+ deriving (Show, Eq)++runStrictBodyTests+ :: String+ -> RequestSizeLimitSettings+ -> ByteString+ -> (SResponse -> Expectation)+ -> Spec+runStrictBodyTests name settings reqBody runExpectations = describe name $ do+ it "chunked" $ do+ let req = mkRequestWithBytestring reqBody UseChunked+ resp <- runStrictBodyApp settings req++ runExpectations resp+ it "non-chunked" $ do+ let req = mkRequestWithBytestring reqBody UseKnownLength+ resp <- runStrictBodyApp settings req++ runExpectations resp+ where+ mkRequestWithBytestring :: ByteString -> LengthType -> SRequest+ mkRequestWithBytestring body lengthType =+ SRequest adjustedRequest $+ L.fromChunks $+ map S.singleton $+ S.unpack body+ where+ adjustedRequest =+ defaultRequest+ { requestHeaders =+ [ (hContentLength, S8.pack $ show $ S.length body)+ | lengthType == UseKnownLength+ ]+ , requestMethod = "POST"+ , requestBodyLength =+ if lengthType == UseKnownLength+ then KnownLength $ fromIntegral $ S.length body+ else ChunkedBody+ }++runStrictBodyApp :: RequestSizeLimitSettings -> SRequest -> IO SResponse+runStrictBodyApp settings req =+ runSession (srequest req) $+ requestSizeLimitMiddleware settings app+ where+ app req' respond = do+ _body <- strictRequestBody req'+ respond $ responseLBS status200 [] ""++runStreamingChunkApp+ :: Int -> RequestSizeLimitSettings -> Request -> IO SResponse+runStreamingChunkApp times settings req =+ runSession (request req) $+ requestSizeLimitMiddleware settings app+ where+ app req' respond = do+ _chunks <- replicateM times (getRequestBodyChunk req')+ respond $ responseLBS status200 [] ""
+ test/Network/Wai/Middleware/RoutedSpec.hs view
@@ -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"
+ test/Network/Wai/Middleware/SelectSpec.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.SelectSpec (+ main,+ spec,+)+where++import Data.ByteString (ByteString)+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#endif+import Network.HTTP.Types (Status, status200, status401, status500)+import Network.Wai+import Network.Wai.Middleware.Select+import Network.Wai.Test (SResponse (simpleStatus), request, runSession)+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "Select" $ do+ it "With empty select should passthrough" $+ runApp (selectMiddleware mempty) "/" `shouldReturn` status200+ it "With other path select should passthrough" $+ runApp (selectMiddleware $ selectOverride "/_" status401) "/"+ `shouldReturn` status200+ it "With path select should hit override" $+ runApp (selectMiddleware $ selectOverride "/_" status401) "/_"+ `shouldReturn` status401+ it "With twice path select should hit first override" $+ runApp+ ( selectMiddleware $+ selectOverride "/_" status401 <> selectOverride "/_" status500+ )+ "/_"+ `shouldReturn` status401+ it "With two paths select should hit first matching (first)" $+ runApp+ ( selectMiddleware $+ selectOverride "/_" status401 <> selectOverride "/-" status500+ )+ "/_"+ `shouldReturn` status401+ it "With two paths select should hit first matching (last)" $+ runApp+ ( selectMiddleware $+ selectOverride "/_" status401 <> selectOverride "/-" status500+ )+ "/-"+ `shouldReturn` status500+ it "With other two paths select should passthrough" $+ runApp+ ( selectMiddleware $+ selectOverride "/_" status401 <> selectOverride "/-" status500+ )+ "/"+ `shouldReturn` status200+ it "With mempty then the path select should hit the pass" $+ runApp (selectMiddleware $ mempty <> selectOverride "/-" status500) "/-"+ `shouldReturn` status500++runApp :: Middleware -> ByteString -> IO Status+runApp mw path =+ fmap simpleStatus+ $ runSession+ (request $ defaultRequest{rawPathInfo = path})+ $ mw app++app :: Application+app = constApp status200++constApp :: Status -> Application+constApp status _ respond = respond $ responseLBS status [] ""++overrideMiddleware :: Application -> Middleware+overrideMiddleware = const++selectOverride :: ByteString -> Status -> MiddlewareSelection+selectOverride path status = selectMiddlewareOnRawPathInfo path $ overrideMiddleware $ constApp status
+ test/Network/Wai/Middleware/StripHeadersSpec.hs view
@@ -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 [] ""
+ test/Network/Wai/Middleware/TimeoutSpec.hs view
@@ -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
+ test/Network/Wai/Middleware/ValidateHeadersSpec.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ValidateHeadersSpec (spec) where++import Network.HTTP.Types (ResponseHeaders, status200)+import Network.Wai (Application, defaultRequest, responseLBS)+import Test.Hspec (Spec, describe, it)++import Network.Wai.Middleware.ValidateHeaders (validateHeadersMiddleware, defaultValidateHeadersSettings)+import Network.Wai.Test (Session, assertStatus, request, withSession)++spec :: Spec+spec = do+ describe "validateHeadersMiddleware" $ do+ it "allows token characters in header names" $ withHeadersApp [("token!#$%&'*+-.^_`|~123", "bar")] $ do+ assertStatus 200 =<< request defaultRequest++ it "does not allow colons in header names" $ withHeadersApp [("broken:header", "foo")] $ do+ assertStatus 500 =<< request defaultRequest++ it "does not allow whitespace in header names" $ do+ withHeadersApp [("white space", "foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("white\nspace", "foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("white\rspace", "foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("white\tspace", "foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("ehite\vspace", "foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("white\fspace", "foo")] $ assertStatus 500 =<< request defaultRequest++ it "allows visible ASCII, space and horizontal tab in header values" $ do+ withHeadersApp [("MyHeader", "the quick brown\tfox jumped over the lazy dog!")] $ do+ assertStatus 200 =<< request defaultRequest++ it "allows octets beyond 0x80 in headers values" $ do+ -- Just an example+ withHeadersApp [("MyHeader", "verr\252ckt")] $ do+ assertStatus 200 =<< request defaultRequest++ it "does not allow other whitespace in header values" $ do+ withHeadersApp [("MyHeader", "white\nspace")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("MyHeader", "white\rspace")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("MyHeader", "white\vspace")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("MyHeader", "white\fspace")] $ assertStatus 500 =<< request defaultRequest++ it "does not allow control characters in header values" $ do+ -- Just examples again+ withHeadersApp [("MyHeader", "control character \0")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("MyHeader", "control character \27")] $ assertStatus 500 =<< request defaultRequest++ it "does not allow trailing whitespace in header values" $ do+ withHeadersApp [("MyHeader", " foo")] $ assertStatus 500 =<< request defaultRequest+ withHeadersApp [("MyHeader", "foo ")] $ assertStatus 500 =<< request defaultRequest++withHeadersApp :: ResponseHeaders -> Session a -> IO a+withHeadersApp headers session =+ withSession (validateHeadersMiddleware defaultValidateHeadersSettings $ headersApp headers) session++headersApp :: ResponseHeaders -> Application+headersApp headers _ respond =+ respond $ responseLBS status200 headers ""
+ test/Network/Wai/ParseSpec.hs view
@@ -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)
+ test/Network/Wai/RequestSpec.hs view
@@ -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
+ test/Network/Wai/TestSpec.hs view
@@ -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` "[]"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/WaiExtraSpec.hs view
@@ -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
− test/WaiExtraTest.hs
@@ -1,442 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module WaiExtraTest (specs) where--import Test.Hspec.Monadic-import Test.Hspec.HUnit ()-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.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.AcceptOverride-import Network.Wai.Middleware.RequestLogger (logCallback)-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 Data.Monoid (mappend)--specs :: Specs-specs = do- describe "Network.Wai.Parse" $ do- it "parseQueryString" caseParseQueryString- it "parseQueryString with question mark" caseParseQueryStringQM- it "parseHttpAccept" caseParseHttpAccept- it "parseRequestBody" caseParseRequestBody- {-- , 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 "vhost" caseVhost- it "autohead" caseAutohead- it "method override" caseMethodOverride- it "accept override" caseAcceptOverride- it "dalvik multipart" caseDalvikMultipart- 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, text/x-dvi; q=0.8, text/x-c"- expected = ["text/html", "text/x-c", "text/x-dvi", "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'--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"--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--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"--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--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--caseDalvikMultipart :: Assertion-caseDalvikMultipart = do- let headers =- [ ("content-length", "12098")- , ("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", "/")- ]- 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 qs) $ 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 / Accept: \n"- -- FIXME getOutput _qs = T.pack $ "GET /location" ++ "\nAccept: \nGET " ++ (show params) -- \nAccept: \n" ++ (show params)- getOutput _qs = T.pack $ "GET /location?foo=bar&baz=bin Accept: \n"-- debugApp output' = logCallback (\t -> liftIO $ assertEqual "debug" output t) $ \_req -> do- return $ responseLBS status200 [ ] ""- where- output = TE.encodeUtf8 $ T.toStrict output'- {-debugApp = debug $ \req -> do-}- {-return $ responseLBS status200 [ ] ""-}
+ test/json.gz view
@@ -0,0 +1,1 @@+test
+ test/noprecompress view
@@ -0,0 +1,1 @@+noprecompress
test/sample.hs view
@@ -1,25 +1,33 @@-import Data.ByteString.Char8 (unpack, pack)+{-# LANGUAGE OverloadedStrings #-}++import Data.ByteString.Char8 (pack) import Data.ByteString.Lazy (fromChunks)+import Data.Text ()+import Network.HTTP.Types import Network.Wai-import Network.Wai.Enumerator+import Network.Wai.Handler.Warp import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Jsonp-import Network.Wai.Middleware.CleanPath-import Network.Wai.Handler.SimpleServer -app :: [String] -> Application-app [] _ = return $ Response Status200 [] $ Right $ fromLBS- $ fromChunks $ flip map [1..10000] $ \i -> pack $- concat- [ "<p>Just this same paragraph again. "- , show i- , "</p>"- ]-app ["test.html"] _ = return $ Response Status200 [] $ Left "test.html"-app ["json"] _ =return $ Response Status200- [(ContentType, pack "application/json")]- $ Left "json"-app _ _ = return $ Response Status404 [] $ Left "../LICENSE"+app :: Application+app request = return $ case pathInfo request of+ [] -> responseLBS status200 [] $+ fromChunks $+ flip map [1 .. 10000] $ \i ->+ pack $+ concat+ [ "<p>Just this same paragraph again. "+ , show (i :: Int)+ , "</p>"+ ]+ ["test.html"] -> ResponseFile status200 [] "test.html" Nothing+ ["json"] ->+ ResponseFile+ status200+ [(hContentType, "application/json")]+ "json"+ Nothing+ _ -> ResponseFile status404 [] "../LICENSE" Nothing main :: IO ()-main = run 3000 $ jsonp $ gzip $ cleanPath app+main = run 3000 $ gzip defaultGzipSettings $ jsonp app
− tests.hs
@@ -1,5 +0,0 @@-import Test.Hspec.Monadic-import qualified WaiExtraTest--main :: IO ()-main = hspecX WaiExtraTest.specs
wai-extra.cabal view
@@ -1,80 +1,243 @@ Name: wai-extra-Version: 1.1.0.1+Version: 3.1.18 Synopsis: Provides some basic WAI handlers and middleware.-Description: The goal here is to provide common features without many dependencies.-License: BSD3+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 <http://www.stackage.org/package/wai-extra>.++License: MIT License-file: LICENSE Author: Michael Snoyman Maintainer: michael@snoyman.com 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 && < 0.10- , wai >= 1.1 && < 1.2- , old-locale >= 1.0.0.2 && < 1.1- , time >= 1.1.4- , network >= 2.2.1.5 && < 2.4- , directory >= 1.0.1 && < 1.2- , transformers >= 0.2.2 && < 0.3- , blaze-builder >= 0.2.1.4 && < 0.4- , http-types >= 0.6 && < 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 >= 0.3 && < 0.4- , fast-logger >= 0.0.2- , conduit >= 0.2 && < 0.3- , zlib-conduit >= 0.2 && < 0.3- , blaze-builder-conduit >= 0.2 && < 0.3- , ansi-terminal+ , containers+ , 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 - 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.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- , hspec >= 0.8 && < 0.10+ , aeson+ , bytestring+ , cookie+ , case-insensitive+ , directory+ , fast-logger+ , hspec >= 1.3+ , http-types , HUnit-+ , iproute+ , resourcet+ , temporary+ , text+ , time+ , wai-extra , wai- , http-types- , transformers+ , warp+ , word8 , zlib- , text- , bytestring- , directory - , zlib-bindings- , blaze-builder >= 0.2.1.4 && < 0.4- , data-default- , conduit+ ghc-options: -Wall+ default-language: Haskell2010++ if os(windows)+ cpp-options: -DWINDOWS source-repository head type: git