wai-extra-3.1.13.0/Network/0000755000000000000000000000000014307354461013464 5ustar0000000000000000wai-extra-3.1.13.0/Network/Wai/0000755000000000000000000000000014330135132014170 5ustar0000000000000000wai-extra-3.1.13.0/Network/Wai/EventSource/0000755000000000000000000000000014307354461016446 5ustar0000000000000000wai-extra-3.1.13.0/Network/Wai/Handler/0000755000000000000000000000000014307354461015561 5ustar0000000000000000wai-extra-3.1.13.0/Network/Wai/Middleware/0000755000000000000000000000000014330135132016245 5ustar0000000000000000wai-extra-3.1.13.0/Network/Wai/Middleware/RequestLogger/0000755000000000000000000000000014307354461021051 5ustar0000000000000000wai-extra-3.1.13.0/Network/Wai/Middleware/RequestSizeLimit/0000755000000000000000000000000014307354461021543 5ustar0000000000000000wai-extra-3.1.13.0/Network/Wai/Test/0000755000000000000000000000000014307354461015123 5ustar0000000000000000wai-extra-3.1.13.0/example/0000755000000000000000000000000014307354461013466 5ustar0000000000000000wai-extra-3.1.13.0/test/0000755000000000000000000000000014307354461013012 5ustar0000000000000000wai-extra-3.1.13.0/test/Network/0000755000000000000000000000000014307354461014443 5ustar0000000000000000wai-extra-3.1.13.0/test/Network/Wai/0000755000000000000000000000000014307354461015163 5ustar0000000000000000wai-extra-3.1.13.0/test/Network/Wai/Middleware/0000755000000000000000000000000014330135132017224 5ustar0000000000000000wai-extra-3.1.13.0/test/requests/0000755000000000000000000000000014307354461014665 5ustar0000000000000000wai-extra-3.1.13.0/Network/Wai/EventSource.hs0000644000000000000000000000377314307354461017014 0ustar0000000000000000{-| 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 wai-extra-3.1.13.0/Network/Wai/EventSource/EventStream.hs0000644000000000000000000000365114307354461021244 0ustar0000000000000000{-# 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 {-| 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 = char7 '\n' {-| Field names as Builder -} nameField, idField, dataField, retryField, commentField :: Builder nameField = string7 "event:" idField = string7 "id:" dataField = string7 "data:" retryField = string7 "retry:" commentField = char7 ':' {-| 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') wai-extra-3.1.13.0/Network/Wai/Handler/CGI.hs0000755000000000000000000001641714307354461016533 0ustar0000000000000000{-# 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 #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat, mempty, mappend) #endif import Control.Arrow ((***)) import Control.Monad (unless, void) import Data.ByteString.Builder (byteString, char7, string8, toLazyByteString) import Data.ByteString.Builder.Extra (flush) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Internal (defaultChunkSize) import qualified Data.CaseInsensitive as CI import Data.Char (toLower) import Data.Function (fix) import Data.IORef (newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) import qualified Data.Streaming.ByteString.Builder as Builder import qualified Data.String as String import Network.HTTP.Types (Status (..), hContentLength, hContentType, hRange) import qualified Network.HTTP.Types as H import Network.Socket (addrAddress, getAddrInfo) import Network.Wai import Network.Wai.Internal import System.IO (Handle) import qualified System.IO #if WINDOWS import System.Environment (getEnvironment) #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 lookup' :: String -> [(String, String)] -> String lookup' key pairs = fromMaybe "" $ lookup key pairs -- | Run an application using CGI. run :: Application -> IO () run app = do vars <- getEnvironment let input = requestBodyHandle System.IO.stdin output = B.hPut System.IO.stdout runGeneric vars input output Nothing app -- | 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 sf app = do vars <- getEnvironment let input = requestBodyHandle System.IO.stdin output = B.hPut System.IO.stdout runGeneric vars input output (Just sf) app -- | A generic CGI helper, which allows other backends (FastCGI and SCGI) to -- use the same code as CGI. Most users will not need this function, and can -- stick with 'run' or 'runSendfile'. runGeneric :: [(String, String)] -- ^ all variables -> (Int -> IO (IO B.ByteString)) -- ^ responseBody of input -> (B.ByteString -> IO ()) -- ^ destination for output -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header? -> Application -> IO () 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 contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars remoteHost' = case lookup "REMOTE_ADDR" vars of Just x -> x Nothing -> fromMaybe "" $ 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 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost' reqHeaders = map (cleanupVarName *** B.pack) vars env = Request { requestMethod = rmethod , rawPathInfo = B.pack pinfo , pathInfo = H.decodePathSegments $ B.pack pinfo , rawQueryString = B.pack qstring , queryString = H.parseQuery $ B.pack qstring , requestHeaders = reqHeaders , isSecure = isSecure' , remoteHost = addr , httpVersion = H.http11 -- FIXME , requestBody = requestBody' , vault = mempty , requestBodyLength = KnownLength $ fromIntegral contentLength , requestHeaderHost = lookup "host" reqHeaders , requestHeaderRange = lookup hRange reqHeaders #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) -> do mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp return ResponseReceived _ -> do 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` char7 '\n' b sendBuilder (sendBuilder flush) blazeFinish >>= maybe (return ()) outputH return ResponseReceived where headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs)) status (Status i m) = (byteString "Status", mconcat [ string8 $ show i , char7 ' ' , byteString m ]) header' (x, y) = (byteString $ CI.original x, byteString y) header (x, y) = mconcat [ x , byteString ": " , y , char7 '\n' ] sfBuilder s hs sf fp = mconcat [ headers s hs , header (byteString sf, string8 fp) , char7 '\n' , byteString sf , byteString " not supported" ] fixHeaders 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" = 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 _ -> String.fromString s -- FIXME remove? where helper' ('_':x:rest) = '-' : x : helper' rest helper' (x:rest) = toLower x : helper' rest helper' [] = [] 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 -> 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 wai-extra-3.1.13.0/Network/Wai/Handler/SCGI.hs0000644000000000000000000000643214307354461016647 0ustar0000000000000000{-# 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 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@((_, conLenS):_) = parseHeaders $ S.split 0 headersBS let conLen = case reads conLenS of (i, _):_ -> i [] -> 0 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 let [c] = S8.unpack bs if c == ':' then return l else readLen $ l * 10 + (fromEnum c - fromEnum '0') 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 wai-extra-3.1.13.0/Network/Wai/Header.hs0000644000000000000000000000555414330135132015725 0ustar0000000000000000-- | 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 -- 'S8.all' is also 'True' for an empty string Just (i, rest) | S8.all (== ' ') 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 wai-extra-3.1.13.0/Network/Wai/Middleware/AcceptOverride.hs0000644000000000000000000000171014307354461021513 0ustar0000000000000000module Network.Wai.Middleware.AcceptOverride ( -- $howto acceptOverride ) where import Network.Wai import Control.Monad (join) 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' where req' = case join $ lookup "_accept" $ queryString req of Nothing -> req Just a -> req { requestHeaders = replaceHeader "Accept" a $ requestHeaders req } wai-extra-3.1.13.0/Network/Wai/Middleware/AddHeaders.hs0000644000000000000000000000117114307354461020601 0ustar0000000000000000-- | -- -- 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 ++) wai-extra-3.1.13.0/Network/Wai/Middleware/Approot.hs0000644000000000000000000001042514307354461020243 0ustar0000000000000000{-# 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 (getEnvironment) 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 env <- getEnvironment pure $ case lookup name env 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 wai-extra-3.1.13.0/Network/Wai/Middleware/Autohead.hs0000644000000000000000000000113614307354461020350 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Automatically produce responses to HEAD requests based on the underlying -- applications GET response. module Network.Wai.Middleware.Autohead (autohead) where #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) #endif import Network.Wai (Middleware, requestMethod, responseBuilder, responseToStream) autohead :: Middleware autohead app req sendResponse | requestMethod req == "HEAD" = app req { requestMethod = "GET" } $ \res -> do let (s, hs, _) = responseToStream res sendResponse $ responseBuilder s hs mempty | otherwise = app req sendResponse wai-extra-3.1.13.0/Network/Wai/Middleware/CleanPath.hs0000644000000000000000000000214414307354461020455 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Middleware.CleanPath ( cleanPath ) where import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L #if __GLASGOW_HASKELL__ < 710 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 sendResponse = case splitter $ pathInfo env of Right pieces -> app pieces env sendResponse Left p -> sendResponse $ responseLBS status301 [(hLocation, mconcat [prefix, p, suffix])] L.empty where -- include the query string if present suffix = case B.uncons $ rawQueryString env of Nothing -> B.empty Just ('?', _) -> rawQueryString env _ -> B.cons '?' $ rawQueryString env wai-extra-3.1.13.0/Network/Wai/Middleware/CombineHeaders.hs0000644000000000000000000002457514330135132021466 0ustar0000000000000000{-# 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, requestHeaders, mapResponseHeaders) 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) ] wai-extra-3.1.13.0/Network/Wai/Middleware/ForceDomain.hs0000644000000000000000000000257014307354461021007 0ustar0000000000000000{-# 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 wai-extra-3.1.13.0/Network/Wai/Middleware/ForceSSL.hs0000644000000000000000000000216514307354461020241 0ustar0000000000000000{-# 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 wai-extra-3.1.13.0/Network/Wai/Middleware/Gzip.hs0000644000000000000000000003712614330135132017523 0ustar0000000000000000--------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Gzip -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : Unstable -- Portability : portable -- -- Automatic gzip compression of responses. -- --------------------------------------------------------- module Network.Wai.Middleware.Gzip ( -- * How to use this module -- $howto -- ** The Middleware -- $gzip gzip -- ** The Settings -- $settings , GzipSettings , 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.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.Default.Class (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, using just 'def' is enough. -- 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 the 'def' method and set the -- fields you would like to change as follows: -- -- @ -- myGzipSettings :: 'GzipSettings' -- myGzipSettings = -- 'def' -- { 'gzipFiles' = 'GzipCompress' -- , 'gzipCheckMime' = myMimeCheckFunction -- , 'gzipSizeThreshold' = 860 -- } -- @ data GzipSettings = GzipSettings { -- | Gzip behavior for files -- -- Only applies to 'ResponseFile' ('responseFile') responses. -- So any streamed data will be compressed based solely on the -- response headers having the right \"Content-Type\" and -- \"Content-Length\". (which are checked with 'gzipCheckMime' -- and 'gzipSizeThreshold', respectively) gzipFiles :: GzipFiles -- | Decide which files to compress based on MIME type -- -- The 'S.ByteString' is the value of the \"Content-Type\" response -- header and will default to 'False' if the header is missing. -- -- E.g. if you'd only want to compress @json@ data, you might -- define your own function as follows: -- -- > myCheckMime mime = mime == "application/json" , gzipCheckMime :: S.ByteString -> Bool -- | Skip compression when the size of the response body is -- below this amount of bytes (default: 860.) -- -- /Setting this option to less than 150 will actually increase/ -- /the size of outgoing data if its original size is less than 150 bytes/. -- -- This will only skip compression if the response includes a -- \"Content-Length\" header /AND/ the length is less than this -- threshold. , gzipSizeThreshold :: Integer } -- | 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) -- $miscellaneous -- -- 'def' is re-exported for convenience sake, and 'defaultCheckMime' -- is exported in case anyone wants to use it in defining their own -- 'gzipCheckMime' function. -- | Use default MIME settings; /do not/ compress files; skip -- compression on data smaller than 860 bytes. instance Default GzipSettings where def = GzipSettings GzipIgnore defaultCheckMime minimumLength -- | 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 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 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 -- 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 $ IO.withBinaryFile file IO.ReadMode $ \inH -> IO.withBinaryFile tmpfile IO.WriteMode $ \outH -> do deflate <- Z.initDeflate 7 $ Z.WindowBits 31 -- FIXME this code should write to a temporary file, then -- rename to the final file let goPopper popper = fix $ \loop -> do res <- popper case res of Z.PRDone -> return () Z.PRNext bs -> do S.hPut outH bs loop Z.PRError ex -> throwIO ex fix $ \loop -> do bs <- S.hGetSome inH defaultChunkSize unless (S.null bs) $ do Z.feedDeflate deflate bs >>= goPopper loop goPopper $ Z.finishDeflate deflate either onErr (const onSucc) (x :: Either SomeException ()) where onSucc = sendResponse $ responseFile s (fixHeaders hs) tmpfile Nothing reportError err = IO.hPutStrLn IO.stderr $ "Network.Wai.Middleware.Gzip: compression failed: " <> err onErr e -- Catching IOExceptions for file system / hardware oopsies | Just ioe <- fromException e = do reportError $ show (ioe :: IOException) sendResponse $ responseFile s hs file Nothing -- Catching ZlibExceptions for compression oopsies | Just zlibe <- fromException e = do reportError $ show (zlibe :: Z.ZlibException) sendResponse $ responseFile s hs file Nothing | otherwise = throwIO e -- 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 safe c | 'A' <= c && c <= 'Z' = c | 'a' <= c && c <= 'z' = c | '0' <= c && c <= '9' = c safe '-' = '-' safe '_' = '_' safe _ = '_' 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, wb) = responseToStream res -- Remove Content-Length header, since we will certainly have a -- different length after gzip compression. fixHeaders :: [Header] -> [Header] fixHeaders = replaceHeader hContentEncoding "gzip" . filter notLength where notLength (x, _) = x /= hContentLength wai-extra-3.1.13.0/Network/Wai/Middleware/HealthCheckEndpoint.hs0000644000000000000000000000177014307354461022466 0ustar0000000000000000--------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.HealthCheckEndpoint -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : Unstable -- Portability : portable -- -- Add empty endpoint (for Health check tests) -- --------------------------------------------------------- module Network.Wai.Middleware.HealthCheckEndpoint ( healthCheck, voidEndpoint, ) where import Data.ByteString (ByteString) import Network.HTTP.Types (status200) import Network.Wai -- | Add empty endpoint (for Health check tests) called \"/_healthz\" -- -- @since 3.1.9 healthCheck :: Middleware healthCheck = voidEndpoint "/_healthz" -- | Add empty endpoint -- -- @since 3.1.9 voidEndpoint :: ByteString -> Middleware voidEndpoint endpointPath router request respond = if rawPathInfo request == endpointPath then respond $ responseLBS status200 mempty "-" else router request respond wai-extra-3.1.13.0/Network/Wai/Middleware/HttpAuth.hs0000644000000000000000000001004414307354461020355 0ustar0000000000000000{-# 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 checkCreds = basicAuth' (\_ -> checkCreds) -- | 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 wai-extra-3.1.13.0/Network/Wai/Middleware/Jsonp.hs0000644000000000000000000000626314307354461017715 0ustar0000000000000000{-# LANGUAGE CPP #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Jsonp -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : Unstable -- Portability : portable -- -- Automatic wrapping of JSON responses to convert into JSONP. -- --------------------------------------------------------- module Network.Wai.Middleware.Jsonp (jsonp) where 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 Data.Maybe (fromMaybe) #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 convert that into a JSONP response, -- having a content type of \"text\/javascript\" and calling the specified -- callback function. jsonp :: Middleware 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 then join $ lookup "callback" $ queryString env else Nothing let env' = case callback of Nothing -> env Just _ -> env { requestHeaders = changeVal hAccept "application/json" $ requestHeaders env } app env' $ \res -> case callback of Nothing -> sendResponse res Just c -> go c res where go c r@(ResponseBuilder s hs b) = sendResponse $ case checkJSON hs of Nothing -> r Just hs' -> responseBuilder s hs' $ byteStringCopy c `mappend` char7 '(' `mappend` b `mappend` char7 ')' go c r = case checkJSON hs of Just hs' -> addCallback c s hs' wb Nothing -> sendResponse r where (s, hs, wb) = responseToStream r checkJSON hs = case lookup hContentType hs of Just x | B8.pack "application/json" `S.isPrefixOf` x -> Just $ fixHeaders hs _ -> Nothing fixHeaders = changeVal hContentType "text/javascript" 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 wai-extra-3.1.13.0/Network/Wai/Middleware/Local.hs0000644000000000000000000000146114307354461017651 0ustar0000000000000000{-# 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) wai-extra-3.1.13.0/Network/Wai/Middleware/MethodOverride.hs0000644000000000000000000000123614307354461021537 0ustar0000000000000000module Network.Wai.Middleware.MethodOverride ( methodOverride ) where 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 (requestMethod req, join $ lookup "_method" $ queryString req) of ("POST", Just m) -> req { requestMethod = m } _ -> req wai-extra-3.1.13.0/Network/Wai/Middleware/MethodOverridePost.hs0000644000000000000000000000322114307354461022401 0ustar0000000000000000{-# 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) case parseQuery body of (("_method", Just newmethod):_) -> return $ req {requestBody = rb, requestMethod = newmethod} _ -> return $ req {requestBody = rb} wai-extra-3.1.13.0/Network/Wai/Middleware/RealIp.hs0000644000000000000000000000644514307354461020002 0ustar0000000000000000-- | 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 respond = app req' respond 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 = mapMaybe (readMaybe . B8.unpack) $ concatMap (B8.split ',') headerVals nonTrusted = filter (not . isTrusted) ips wai-extra-3.1.13.0/Network/Wai/Middleware/RequestLogger.hs0000644000000000000000000004606114325447352021416 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should -- not use CPP. -- EDIT: Fixed this by adding two "zero-width spaces" in between the "*/*" module Network.Wai.Middleware.RequestLogger ( -- * Basic stdout logging logStdout , logStdoutDev -- * Create more versions , mkRequestLogger , RequestLoggerSettings , defaultRequestLoggerSettings , outputFormat , autoFlush , destination , OutputFormat (..) , ApacheSettings , defaultApacheSettings , setApacheIPAddrSource , setApacheRequestFilter , setApacheUserGetter , DetailedSettings (..) , OutputFormatter , OutputFormatterWithDetails , OutputFormatterWithDetailsAndHeaders , Destination (..) , Callback , IPAddrSource (..) ) where import Control.Monad (when) import Control.Monad.IO.Class (liftIO) 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.Class (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 ( Request(..), requestBodyLength, RequestBodyLength(..) , Middleware , Response, responseStatus, responseHeaders , getRequestBodyChunk ) 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.Header (contentLength) import Network.Wai.Middleware.RequestLogger.Internal import Network.Wai.Parse ( Param , File , fileName , getRequestBodyType , lbsBackEnd , sinkRequestBody ) -- | The logging format. data OutputFormat = Apache IPAddrSource | ApacheWithSettings ApacheSettings -- ^ @since 3.1.8 | Detailed Bool -- ^ use colors? | DetailedWithSettings DetailedSettings -- ^ @since 3.1.3 | CustomOutputFormat OutputFormatter | CustomOutputFormatWithDetails OutputFormatterWithDetails | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders -- | Settings for the `ApacheWithSettings` `OutputFormat`. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards -- compatibility. In order to create an 'ApacheSettings' value, use 'defaultApacheSettings' -- and the various \'setApache\' functions to modify individual fields. For example: -- -- > setApacheIPAddrSource FromHeader defaultApacheSettings -- -- @since 3.1.8 data ApacheSettings = ApacheSettings { apacheIPAddrSource :: IPAddrSource , apacheUserGetter :: Request -> Maybe BS.ByteString , apacheRequestFilter :: Request -> Response -> Bool } defaultApacheSettings :: ApacheSettings defaultApacheSettings = ApacheSettings { apacheIPAddrSource = FromSocket , apacheRequestFilter = \_ _ -> True , apacheUserGetter = \_ -> Nothing } -- | Where to take IP addresses for clients from. See 'IPAddrSource' for more information. -- -- Default value: FromSocket -- -- @since 3.1.8 setApacheIPAddrSource :: IPAddrSource -> ApacheSettings -> ApacheSettings setApacheIPAddrSource x y = y { apacheIPAddrSource = x } -- | Function that allows you to filter which requests are logged, based on -- the request and response -- -- Default: log all requests -- -- @since 3.1.8 setApacheRequestFilter :: (Request -> Response -> Bool) -> ApacheSettings -> ApacheSettings setApacheRequestFilter x y = y { apacheRequestFilter = x } -- | Function that allows you to get the current user from the request, which -- will then be added in the log. -- -- Default: return no user -- -- @since 3.1.8 setApacheUserGetter :: (Request -> Maybe BS.ByteString) -> ApacheSettings -> ApacheSettings setApacheUserGetter x y = y { apacheUserGetter = x } -- | Settings for the `Detailed` `OutputFormat`. -- -- `mModifyParams` allows you to pass a function to hide confidential -- information (such as passwords) from the logs. If result is `Nothing`, then -- the parameter is hidden. For example: -- > myformat = Detailed True (Just hidePasswords) -- > where hidePasswords p@(k,v) = if k = "password" then (k, "***REDACTED***") else p -- -- `mFilterRequests` allows you to filter which requests are logged, based on -- the request and response. -- -- @since 3.1.3 data DetailedSettings = DetailedSettings { useColors :: Bool , mModifyParams :: Maybe (Param -> Maybe Param) , mFilterRequests :: Maybe (Request -> Response -> Bool) , mPrelogRequests :: Bool -- ^ @since 3.1.7 } instance Default DetailedSettings where def = DetailedSettings { useColors = True , mModifyParams = Nothing , mFilterRequests = Nothing , mPrelogRequests = False } type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr type OutputFormatterWithDetails = ZonedDate -> Request -> Status -> Maybe Integer -> NominalDiffTime -> [S8.ByteString] -> B.Builder -> LogStr -- | 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 data Destination = Handle Handle | Logger LoggerSet | Callback Callback type Callback = LogStr -> IO () -- | @RequestLoggerSettings@ is an instance of Default. See for more information. -- -- @outputFormat@, @autoFlush@, and @destination@ are record fields -- for the record type @RequestLoggerSettings@, so they can be used to -- modify settings values using record syntax. data RequestLoggerSettings = RequestLoggerSettings { -- | Default value: @Detailed@ @True@. outputFormat :: OutputFormat -- | Only applies when using the @Handle@ constructor for @destination@. -- -- Default value: @True@. , autoFlush :: Bool -- | Default: @Handle@ @stdout@. , destination :: Destination } defaultRequestLoggerSettings :: RequestLoggerSettings defaultRequestLoggerSettings = RequestLoggerSettings { outputFormat = Detailed True , autoFlush = True , destination = Handle stdout } instance Default RequestLoggerSettings where def = defaultRequestLoggerSettings 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 = def { 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 def { outputFormat = Apache FromSocket } -- | Development request logger middleware. -- -- This uses the 'Detailed' 'True' logging format and logs to 'stdout'. {-# NOINLINE logStdoutDev #-} logStdoutDev :: Middleware logStdoutDev = unsafePerformIO $ mkRequestLogger def -- | 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 -- -- Note that it logs the request immediately when it is received. -- 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. -- -- 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 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' = req { requestBody = rbody } return (req', body) detailedMiddleware' :: Callback -> DetailedSettings -> (Color -> BS.ByteString -> [BS.ByteString]) -> (BS.ByteString -> [BS.ByteString]) -> (BS.ByteString -> BS.ByteString -> [BS.ByteString]) -> Middleware detailedMiddleware' cb DetailedSettings{..} ansiColor ansiMethod ansiStatusCode app req sendResponse = do (req', body) <- -- second tuple item should not be necessary, but a test runner might mess it up case (requestBodyLength req, contentLength (requestHeaders req)) of -- log the request body if it is small (KnownLength len, _) | len <= 2048 -> getRequestBody req (_, Just len) | len <= 2048 -> getRequestBody req _ -> return (req, []) let reqbodylog _ = if null body || isJust mModifyParams then [""] else ansiColor White " Request Body: " <> body <> ["\n"] reqbody = concatMap (either (const [""]) reqbodylog . decodeUtf8') body postParams <- if requestMethod req `elem` ["GET", "HEAD"] then return [] else do (unmodifiedPostParams, files) <- liftIO $ allPostParams body let postParams = case mModifyParams of Just modifyParams -> mapMaybe modifyParams unmodifiedPostParams Nothing -> unmodifiedPostParams return $ collectPostParams (postParams, files) let getParams = map emptyGetParam $ queryString req accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req params = let par | not $ null postParams = [pack (show postParams)] | not $ null getParams = [pack (show getParams)] | otherwise = [] in if null par then [""] else ansiColor White " Params: " <> par <> ["\n"] t0 <- getCurrentTime -- Optionally prelog the request when mPrelogRequests $ cb $ "PRELOGGING REQUEST: " <> mkRequestLog params reqbody accept app req' $ \rsp -> do case mFilterRequests of Just f | not $ f req' rsp -> pure () _ -> do let isRaw = case rsp of ResponseRaw{} -> True _ -> False stCode = statusBS rsp stMsg = msgBS rsp t1 <- getCurrentTime -- 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 -> 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,"") collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param] collectPostParams (postParams, files) = postParams ++ map (\(k,v) -> (k, "FILE: " <> fileName v)) files mkRequestLog :: (Foldable t, ToLogStr m) => t m -> t m -> m -> LogStr mkRequestLog params reqbody accept = foldMap toLogStr (ansiMethod (requestMethod req)) <> " " <> toLogStr (rawPathInfo req) <> "\n" <> foldMap toLogStr params <> foldMap toLogStr reqbody <> foldMap toLogStr (ansiColor White " Accept: ") <> toLogStr accept <> "\n" mkResponseLog :: Bool -> S8.ByteString -> S8.ByteString -> UTCTime -> UTCTime -> LogStr mkResponseLog isRaw stCode stMsg t1 t0 = if isRaw then "" else foldMap toLogStr (ansiColor White " Status: ") <> foldMap toLogStr (ansiStatusCode stCode (stCode <> " " <> stMsg)) <> " " <> toLogStr (pack $ show $ diffUTCTime t1 t0) <> "\n" statusBS :: Response -> BS.ByteString statusBS = pack . show . statusCode . responseStatus msgBS :: Response -> BS.ByteString msgBS = statusMessage . responseStatus wai-extra-3.1.13.0/Network/Wai/Middleware/RequestLogger/JSON.hs0000644000000000000000000001352314307354461022162 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# 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 wai-extra-3.1.13.0/Network/Wai/Middleware/RequestSizeLimit.hs0000644000000000000000000000653614307354461022111 0ustar0000000000000000{-# 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`." ]) wai-extra-3.1.13.0/Network/Wai/Middleware/RequestSizeLimit/Internal.hs0000644000000000000000000000564314307354461023663 0ustar0000000000000000-- | 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 } wai-extra-3.1.13.0/Network/Wai/Middleware/Rewrite.hs0000644000000000000000000003076314307354461020247 0ustar0000000000000000{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} module Network.Wai.Middleware.Rewrite ( -- * How to use this module -- $howto -- ** A note on semantics -- $semantics -- ** Paths and Queries -- $pathsandqueries PathsAndQueries -- ** An example rewriting paths with queries -- $takeover -- ** Upgrading from wai-extra ≤ 3.0.16.1 -- $upgrading -- * 'Middleware' -- ** Recommended functions , rewriteWithQueries , rewritePureWithQueries , rewriteRoot -- ** Deprecated , rewrite , rewritePure -- * Operating on 'Request's , rewriteRequest , rewriteRequestPure ) where -- GHC ≤ 7.10 does not export Applicative functions from the prelude. #if __GLASGOW_HASKELL__ <= 710 import Control.Applicative #endif import Control.Monad.IO.Class (liftIO) import Data.Functor.Identity (Identity (..)) import Data.Text (Text) import qualified Data.Text 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'. -- $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 -- -- package to serve the old -- site from the new site, but there’s a problem. The old site uses pages like -- -- @ -- index.php?page=/page/ -- @ -- -- whereas the new site would look like -- -- @ -- index\//page/ -- @ -- -- In doing this, we want to separate the migration code from our new -- website. So we’d like to handle links internally using the path -- formulation, but externally have the old links still work. -- -- Therefore, we will use middleware ('rewritePureWithQueries') from this -- module to rewrite incoming requests from the query formulation to the -- paths formulation. -- -- > {-# LANGUAGE ViewPatterns #-} -- > -- > rewritePathFromPhp :: Middleware -- > rewritePathFromPhp = rewritePureWithQueries pathFromPhp -- > -- > pathFromPhp :: PathsAndQueries -> H.RequestHeaders -> PathsAndQueries -- > pathFromPhp (pieces, queries) _ = piecesConvert pieces queries -- > where -- > piecesConvert :: [Text] -> H.Query -> PathsAndQueries -- > piecesConvert ["index.php"] qs@(join . lookup "page" -> Just page) = -- > ( ["index", TE.decodeUtf8With TE.lenientDecode page] -- > , delete ("page", pure page) qs -- > ) -- > piecesConvert ps qs = (ps, qs) -- -- On the other side, we will use 'rewriteRequestPure' to rewrite outgoing -- requests to the original website from the reverse proxy code (using the -- 'Network.HTTP.ReverseProxy.WPRModifiedRequest' or -- 'Network.HTTP.ReverseProxy.WPRModifiedRequestSecure' constructors. Note, -- these links will only work if the haddock documentation for -- -- is installed). -- -- > rewritePhpFromPath :: Request -> Request -- > rewritePhpFromPath = rewriteRequestPure phpFromPath -- > -- > phpFromPath :: PathsAndQueries -> H.RequestHeaders -> PathsAndQueries -- > phpFromPath (pieces, queries) _ = piecesConvert pieces queries -- > where -- > piecesConvert :: [Text] -> H.Query -> PathsAndQueries -- > piecesConvert ["index", page] qs = ( ["index.php"], ("page", pure . TE.encodeUtf8 $ page) : qs ) -- > piecesConvert ps qs = (ps, qs) -- -- For the whole example, see -- . -- $upgrading -- It is quite simple to upgrade from 'rewrite' and 'rewritePure', to -- 'rewriteWithQueries' and 'rewritePureWithQueries'. -- Insert 'Data.Bifunctor.first', which specialises to -- -- @ -- 'Data.Bifunctor.first' :: (['Text'] -> ['Text']) -> 'PathsAndQueries' -> 'PathsAndQueries' -- @ -- -- as the following example demonstrates. -- -- Old versions of the library could only handle path pieces, not queries. -- This could have been supplied to 'rewritePure'. -- -- @ -- staticConvert' :: [Text] -> H.RequestHeaders -> [Text] -- staticConvert' pieces _ = piecesConvert pieces -- where -- piecesConvert [] = ["static", "html", "pages.html"] -- piecesConvert route@("pages":_) = "static":"html":route -- @ -- -- Instead, use this function, supplied to 'rewritePureWithQueries'. -- -- @ -- staticConvert :: 'PathsAndQueries' -> H.RequestHeaders -> 'PathsAndQueries' -- staticConvert pathsAndQueries _ = 'Data.Bifunctor.first' piecesConvert pathsAndQueries -- where -- piecesConvert [] = ["static", "html", "pages.html"] -- piecesConvert route@("pages":_) = "static":"html":route -- @ -- -- The former formulation is deprecated for two reasons: -- -- 1. The original formulation of 'rewrite' modified 'rawPathInfo', which -- is deprecated behaviour. -- -- 2. The original formulation did not allow query parameters to -- influence the path. -- -- Concerning the first point, take care with semantics of your program when -- upgrading as the upgraded functions no longer modify 'rawPathInfo'. -------------------------------------------------- -- * Types -------------------------------------------------- -- | A tuple of the path sections as ['Text'] and query parameters as -- 'H.Query'. This makes writing type signatures for the conversion -- function far more pleasant. -- -- Note that this uses 'H.Query' not 'H.QueryText' to more accurately -- reflect the paramaters that can be supplied in URLs. It may be safe to -- treat parameters as text; use the 'H.queryToQueryText' and -- 'H.queryTextToQuery' functions to interconvert. type PathsAndQueries = ([Text], H.Query) -------------------------------------------------- -- * Rewriting 'Middleware' -------------------------------------------------- -- | Rewrite based on your own conversion function for paths only, to be -- supplied by users of this library (with the conversion operating in 'IO'). -- -- For new code, use 'rewriteWithQueries' instead. rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware rewrite convert app req sendResponse = do let convertIO = pathsOnly . curry $ liftIO . uncurry convert newReq <- rewriteRequestRawM convertIO req app newReq sendResponse {-# WARNING rewrite [ "This modifies the 'rawPathInfo' field of a 'Request'." , " This is not recommended behaviour; it is however how" , " this function has worked in the past." , " Use 'rewriteWithQueries' instead"] #-} -- | Rewrite based on pure conversion function for paths only, to be -- supplied by users of this library. -- -- For new code, use 'rewritePureWithQueries' instead. rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware rewritePure convert app req = let convertPure = pathsOnly . curry $ Identity . uncurry convert newReq = runIdentity $ rewriteRequestRawM convertPure req in app newReq {-# WARNING rewritePure [ "This modifies the 'rawPathInfo' field of a 'Request'." , " This is not recommended behaviour; it is however how" , " this function has worked in the past." , " Use 'rewritePureWithQueries' instead"] #-} -- | Rewrite based on your own conversion function for paths and queries. -- This function is to be supplied by users of this library, and operates -- in 'IO'. rewriteWithQueries :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries) -> Middleware rewriteWithQueries convert app req sendResponse = do newReq <- rewriteRequestM convert req app newReq sendResponse -- | Rewrite based on pure conversion function for paths and queries. This -- function is to be supplied by users of this library. rewritePureWithQueries :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries) -> Middleware rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req -- | Rewrite root requests (/) to a specified path -- -- Note that /index.html/ in example below should already be a valid route. -- -- @ -- rewriteRoot "index.html" :: Middleware -- @ -- -- @since 3.0.23.0 rewriteRoot :: Text -> Middleware rewriteRoot root = rewritePureWithQueries onlyRoot where onlyRoot ([], q) _ = ([root], q) onlyRoot paths _ = paths -------------------------------------------------- -- * Modifying 'Request's directly -------------------------------------------------- -- | Modify a 'Request' using the supplied function in 'IO'. This is suitable for -- the reverse proxy example. rewriteRequest :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries) -> Request -> IO Request rewriteRequest convert req = let convertIO = curry $ liftIO . uncurry convert in rewriteRequestRawM convertIO req -- | Modify a 'Request' using the pure supplied function. This is suitable for -- the reverse proxy example. rewriteRequestPure :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries) -> Request -> Request rewriteRequestPure convert req = let convertPure = curry $ Identity . uncurry convert in runIdentity $ rewriteRequestRawM convertPure req -------------------------------------------------- -- * Helper functions -------------------------------------------------- -- | This helper function factors out the common behaviour of rewriting requests. rewriteRequestM :: (Applicative m, Monad m) => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries) -> Request -> m Request rewriteRequestM convert req = do (pInfo, qByteStrings) <- curry convert (pathInfo req) (queryString req) (requestHeaders req) pure req {pathInfo = pInfo, queryString = qByteStrings} -- | This helper function preserves the semantics of wai-extra ≤ 3.0, in -- which the rewrite functions modify the 'rawPathInfo' parameter. Note -- that this has not been extended to modify the 'rawQueryInfo' as -- modifying either of these values has been deprecated. rewriteRequestRawM :: (Applicative m, Monad m) => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries) -> Request -> m Request rewriteRequestRawM convert req = do newReq <- rewriteRequestM convert req let rawPInfo = TE.encodeUtf8 . T.intercalate "/" . pathInfo $ newReq pure newReq { rawPathInfo = rawPInfo } {-# WARNING rewriteRequestRawM [ "This modifies the 'rawPathInfo' field of a 'Request'." , " This is not recommended behaviour; it is however how" , " this function has worked in the past." , " Use 'rewriteRequestM' instead"] #-} -- | Produce a function that works on 'PathsAndQueries' from one working -- only on paths. This is not exported, as it is only needed to handle -- code written for versions ≤ 3.0 of the library; see the -- example above using 'Data.Bifunctor.first' to do something similar. pathsOnly :: (Applicative m, Monad m) => ([Text] -> H.RequestHeaders -> m [Text]) -> PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries pathsOnly convert psAndQs headers = (,[]) <$> convert (fst psAndQs) headers {-# INLINE pathsOnly #-} wai-extra-3.1.13.0/Network/Wai/Middleware/Routed.hs0000644000000000000000000000233114307354461020056 0ustar0000000000000000-- | -- -- 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 = maybe False (== domain) mHost where mHost = requestHeaderHost req wai-extra-3.1.13.0/Network/Wai/Middleware/Select.hs0000644000000000000000000000560314307354461020040 0ustar0000000000000000--------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Select -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : Unstable -- Portability : portable -- -- Dynamically choose between Middlewares -- -- It's useful when you want some 'Middleware's applied selectively. -- -- Example: do not log health check calls: -- -- > import Network.Wai -- > import Network.Wai.Middleware.HealthCheckEndpoint -- > import Network.Wai.Middleware.RequestLogger -- > -- > app' :: Application -- > app' = -- > selectMiddleware (selectMiddlewareExceptRawPathInfo "/_healthz" logStdout) -- > $ healthCheck app -- -- @since 3.1.10 -- --------------------------------------------------------- module Network.Wai.Middleware.Select ( -- * Middleware selection MiddlewareSelection (..), selectMiddleware, -- * Helpers selectMiddlewareOn, selectMiddlewareOnRawPathInfo, selectMiddlewareExceptRawPathInfo, passthroughMiddleware, ) where import Control.Applicative ((<|>)) import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Network.Wai -------------------------------------------------- -- * Middleware selection -------------------------------------------------- -- | Relevant Middleware for a given 'Request'. newtype MiddlewareSelection = MiddlewareSelection { applySelectedMiddleware :: Request -> Maybe Middleware } instance Semigroup MiddlewareSelection where MiddlewareSelection f <> MiddlewareSelection g = MiddlewareSelection $ \req -> f req <|> g req instance Monoid MiddlewareSelection where mempty = MiddlewareSelection $ const Nothing -- | Create the 'Middleware' dynamically applying 'MiddlewareSelection'. selectMiddleware :: MiddlewareSelection -> Middleware selectMiddleware selection app request respond = mw app request respond where mw :: Middleware mw = fromMaybe passthroughMiddleware (applySelectedMiddleware selection request) -------------------------------------------------- -- * Helpers -------------------------------------------------- passthroughMiddleware :: Middleware passthroughMiddleware = id -- | Use the 'Middleware' when the predicate holds. selectMiddlewareOn :: (Request -> Bool) -> Middleware -> MiddlewareSelection selectMiddlewareOn doesApply mw = MiddlewareSelection $ \request -> if doesApply request then Just mw else Nothing -- | Use the `Middleware` for the given 'rawPathInfo'. selectMiddlewareOnRawPathInfo :: ByteString -> Middleware -> MiddlewareSelection selectMiddlewareOnRawPathInfo path = selectMiddlewareOn ((== path) . rawPathInfo) -- | Use the `Middleware` for all 'rawPathInfo' except then given one. selectMiddlewareExceptRawPathInfo :: ByteString -> Middleware -> MiddlewareSelection selectMiddlewareExceptRawPathInfo path = selectMiddlewareOn ((/= path) . rawPathInfo) wai-extra-3.1.13.0/Network/Wai/Middleware/StreamFile.hs0000644000000000000000000000233014307354461020646 0ustar0000000000000000-- | -- -- 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 wai-extra-3.1.13.0/Network/Wai/Middleware/StripHeaders.hs0000644000000000000000000000315314307354461021214 0ustar0000000000000000-- 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, modifyResponse, mapResponseHeaders, ifRequest) 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) wai-extra-3.1.13.0/Network/Wai/Middleware/Timeout.hs0000644000000000000000000000166314307354461020251 0ustar0000000000000000-- | 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) wai-extra-3.1.13.0/Network/Wai/Middleware/Vhost.hs0000644000000000000000000000241314307354461017720 0ustar0000000000000000{-# 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 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 wai-extra-3.1.13.0/Network/Wai/Parse.hs0000644000000000000000000006326214307354461015623 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} -- | Some helpers for parsing data out of a raw WAI 'Request'. module Network.Wai.Parse ( parseHttpAccept , parseRequestBody , RequestBodyType (..) , getRequestBodyType , sinkRequestBody , sinkRequestBodyEx , BackEnd , lbsBackEnd , tempFileBackEnd , tempFileBackEndOpts , Param , File , FileInfo (..) , parseContentType , ParseRequestBodyOptions , defaultParseRequestBodyOptions , noLimitParseRequestBodyOptions , parseRequestBodyEx , setMaxRequestKeyLength , clearMaxRequestKeyLength , setMaxRequestNumFiles , clearMaxRequestNumFiles , setMaxRequestFileSize , clearMaxRequestFileSize , setMaxRequestFilesSize , clearMaxRequestFilesSize , setMaxRequestParmsSize , clearMaxRequestParmsSize , setMaxHeaderLines , clearMaxHeaderLines , setMaxHeaderLineLength , clearMaxHeaderLineLength #if TEST , Bound (..) , findBound , sinkTillBound , killCR , killCRLF , takeLine #endif ) where import Prelude hiding (lines) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Data.CaseInsensitive (mk) 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 qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Function (fix, on) import Data.IORef import Data.Int (Int64) import Data.List (sortBy) import Data.Maybe (catMaybes, fromMaybe) import Data.Word (Word8) import Network.HTTP.Types (hContentType) import qualified Network.HTTP.Types as H import Network.Wai import Network.Wai.Handler.Warp (InvalidRequest(..)) import System.Directory (getTemporaryDirectory, removeFile) import System.IO (hClose, openBinaryTempFile) import System.IO.Error (isDoesNotExistError) breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s = let (x, y) = S.break (== w) s in (x, S.drop 1 y) -- | Parse the HTTP accept string to determine supported content types. parseHttpAccept :: S.ByteString -> [S.ByteString] parseHttpAccept = map fst . sortBy (rcompare `on` snd) . map (addSpecificity . grabQ) . S.split 44 -- comma where rcompare :: (Double,Int) -> (Double,Int) -> Ordering rcompare = flip compare addSpecificity (s, q) = -- Prefer higher-specificity types let semicolons = S.count 0x3B s stars = S.count 0x2A s in (s, (q, semicolons - stars)) grabQ s = -- Stripping all spaces may be too harsh. -- Maybe just strip either side of semicolon? let (s', q) = S.breakSubstring ";q=" (S.filter (/=0x20) s) -- 0x20 is space q' = S.takeWhile (/=0x3B) (S.drop 3 q) -- 0x3B is semicolon in (s', readQ q') readQ s = case reads $ S8.unpack s of (x, _):_ -> x _ -> 1.0 -- | Store uploaded files in memory 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 -- -- 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 { -- | The maximum length of a filename prboKeyLength :: Maybe Int , -- | The maximum number of files. prboMaxNumFiles :: Maybe Int , -- | The maximum filesize per file. prboMaxFileSize :: Maybe Int64 , -- | The maximum total filesize. prboMaxFilesSize :: Maybe Int64 , -- | The maximum size of the sum of all parameters prboMaxParmsSize :: Maybe Int , -- | The maximum header lines per mime/multipart entry prboMaxHeaderLines :: Maybe Int , -- | The maximum header line length per mime/multipart entry prboMaxHeaderLineLength :: Maybe Int } -- | Set the maximum length of a filename. -- -- @since 3.0.16.0 setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions setMaxRequestKeyLength l p = p { prboKeyLength=Just l } -- | Do not limit the length of filenames. -- -- @since 3.0.16.0 clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions clearMaxRequestKeyLength p = p { prboKeyLength=Nothing } -- | Set the maximum number of files per request. -- -- @since 3.0.16.0 setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions setMaxRequestNumFiles l p = p { prboMaxNumFiles=Just l } -- | Do not limit the maximum number of files per request. -- -- @since 3.0.16.0 clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions clearMaxRequestNumFiles p = p { prboMaxNumFiles=Nothing } -- | Set the maximum filesize per file (in bytes). -- -- @since 3.0.16.0 setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions setMaxRequestFileSize l p = p { prboMaxFileSize=Just l } -- | Do not limit the maximum filesize per file. -- -- @since 3.0.16.0 clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions clearMaxRequestFileSize p = p { prboMaxFileSize=Nothing } -- | Set the maximum size of all files per request. -- -- @since 3.0.16.0 setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions setMaxRequestFilesSize l p = p { prboMaxFilesSize=Just l } -- | Do not limit the maximum size of all files per request. -- -- @since 3.0.16.0 clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions clearMaxRequestFilesSize p = p { prboMaxFilesSize=Nothing } -- | Set the maximum size of the sum of all parameters. -- -- @since 3.0.16.0 setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions setMaxRequestParmsSize l p = p { prboMaxParmsSize=Just l } -- | Do not limit the maximum size of the sum of all parameters. -- -- @since 3.0.16.0 clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions clearMaxRequestParmsSize p = p { prboMaxParmsSize=Nothing } -- | Set the maximum header lines per mime/multipart entry. -- -- @since 3.0.16.0 setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions setMaxHeaderLines l p = p { prboMaxHeaderLines=Just l } -- | Do not limit the maximum header lines per mime/multipart entry. -- -- @since 3.0.16.0 clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions clearMaxHeaderLines p = p { prboMaxHeaderLines=Nothing } -- | Set the maximum header line length per mime/multipart entry. -- -- @since 3.0.16.0 setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions setMaxHeaderLineLength l p = p { prboMaxHeaderLineLength=Just l } -- | Do not limit the maximum header lines per mime/multipart entry. -- -- @since 3.0.16.0 clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing } -- | A reasonable default set of parsing options. -- Maximum key/filename length: 32 bytes; -- maximum files: 10; filesize unlimited; maximum -- size for parameters: 64kbytes; maximum number of header -- lines: 32 bytes (applies only to headers of a mime/multipart message); -- maximum header line length: Apache's default for that is 8190 bytes -- (http://httpd.apache.org/docs/2.2/mod/core.html#limitrequestline) -- so we're using that here as well. -- -- @since 3.0.16.0 defaultParseRequestBodyOptions :: ParseRequestBodyOptions defaultParseRequestBodyOptions = ParseRequestBodyOptions { prboKeyLength=Just 32 , prboMaxNumFiles=Just 10 , prboMaxFileSize=Nothing , prboMaxFilesSize=Nothing , prboMaxParmsSize=Just 65336 , prboMaxHeaderLines=Just 32 , prboMaxHeaderLineLength=Just 8190 } -- | Do not impose any memory limits. -- -- @since 3.0.21.0 noLimitParseRequestBodyOptions :: ParseRequestBodyOptions noLimitParseRequestBodyOptions = ParseRequestBodyOptions { prboKeyLength=Nothing , prboMaxNumFiles=Nothing , prboMaxFileSize=Nothing , prboMaxFilesSize=Nothing , prboMaxParmsSize=Nothing , prboMaxHeaderLines=Nothing , prboMaxHeaderLineLength=Nothing } -- | Information on an uploaded file. data FileInfo c = FileInfo { fileName :: S.ByteString , fileContentType :: S.ByteString , fileContent :: c } 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) -- | 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 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 semicolon = 59 equals = 61 space = 32 dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote then S.tail $ S.init s else s 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 (== equals) bs v = S.drop 1 v' in (strip k, dq $ strip v) strip = S.dropWhile (== space) . fst . S.breakEnd (/= space) -- | 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. 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. parseRequestBodyEx :: ParseRequestBodyOptions -> BackEnd y -> Request -> IO ([Param], [File y]) parseRequestBodyEx o s r = case getRequestBodyType r of Nothing -> return ([], []) Just rbt -> sinkRequestBodyEx o s rbt (requestBody r) sinkRequestBody :: BackEnd y -> RequestBodyType -> IO S.ByteString -> IO ([Param], [File y]) sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions -- | -- -- @since 3.0.16.0 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 (\(a, b) -> (reverse a, reverse b)) <$> 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. 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) $ error "Maximum size of parameters exceeded" 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 -- | Take one header or subheader line. -- Since: 3.0.26 -- Throw 431 if headers too large. takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString) takeLine maxlen src = go "" where go front = 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) bs -- LF in if S.null y then go $ front `S.append` x else do when (S.length y > 1) $ leftover src $ S.drop 1 y let res = front `S.append` x case maxlen of Just maxlen' -> when (S.length res > maxlen') $ E.throwIO RequestHeaderFieldsTooLarge Nothing -> return () return . Just $ killCR res takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString] takeLines' lineLength maxLines source = reverse <$> takeLines'' [] lineLength maxLines source 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') $ error "Too many lines in mime/multipart header" Nothing -> return () res <- takeLine lineLength src case res of Nothing -> return lines Just l | S.null l -> return lines | otherwise -> takeLines'' (l:lines) lineLength maxLines src data Source = Source (IO S.ByteString) (IORef S.ByteString) mkSource :: IO S.ByteString -> IO Source mkSource f = do ref <- newIORef S.empty return $ Source f ref readSource :: Source -> IO S.ByteString readSource (Source f ref) = do bs <- atomicModifyIORef ref $ \bs -> (S.empty, bs) if S.null bs then f else return bs leftover :: Source -> S.ByteString -> IO () leftover (Source _ ref) = writeIORef ref 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 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) $ error "Filename is too long" Nothing -> return () case prboMaxNumFiles o of Just maxFiles -> when (numFiles >= maxFiles) $ error "Maximum number of files exceeded" Nothing -> return () let ct = fromMaybe "application/octet-stream" mct 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) $ error "Parameter name is too long" Nothing -> return () let seed = id let iter front bs = return $ front . (:) bs ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src (fromIntegral <$> prboMaxParmsSize o) let bs = S.concat $ front [] let x' = (name, bs) let newParmSize = parmSize + S.length name + S.length bs case prboMaxParmsSize o of Just maxParmSize -> when (newParmSize > maxParmSize) $ error "Maximum size of parameters exceeded" Nothing -> return () add $ Left x' when wasFound $ loop (numParms + 1) numFiles newParmSize filesSize src _ -> do -- ignore this part let seed = () iter () _ = return () ((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 58 s -- colon in (mk x, S.dropWhile (== 32) y) -- space data Bound = FoundBound S.ByteString S.ByteString | NoBound | PartialBound deriving (Eq, Show) findBound :: S.ByteString -> S.ByteString -> Bound findBound b bs = handleBreak $ S.breakSubstring b bs where handleBreak (h, t) | S.null t = go [lowBound..S.length bs - 1] | 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 | otherwise = let endI = i + S.length b in if endI > S.length bs then PartialBound else FoundBound (S.take i bs) (S.drop endI bs) mismatch [] _ = False mismatch _ [] = False mismatch (x:xs) (y:ys) | S.index b x == S.index bs y = mismatch xs ys | otherwise = True sinkTillBound' :: S.ByteString -> S.ByteString -> FileInfo () -> BackEnd y -> Source -> Maybe Int64 -> IO ((Bool, Int64), y) sinkTillBound' bound name fi sink src max' = do (next, final) <- wrapTillBound bound src max' y <- sink name fi next b <- final return (b, y) data WTB = WTBWorking (S.ByteString -> S.ByteString) | WTBDone Bool wrapTillBound :: S.ByteString -- ^ bound -> Source -> Maybe Int64 -> IO (IO S.ByteString, IO (Bool, Int64)) -- ^ Bool indicates if the bound was found wrapTillBound bound src max' = do ref <- newIORef $ WTBWorking id sref <- newIORef (0 :: Int64) return (go ref sref, final ref sref) where 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) parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)] parseAttrs = map go . S.split 59 -- semicolon where tw = S.dropWhile (== 32) -- space dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote then S.tail $ S.init s else s go s = let (x, y) = breakDiscard 61 s -- equals sign in (tw x, dq $ tw y) killCRLF :: S.ByteString -> S.ByteString killCRLF bs | S.null bs || S.last bs /= 10 = bs -- line feed | otherwise = killCR $ S.init bs killCR :: S.ByteString -> S.ByteString killCR bs | S.null bs || S.last bs /= 13 = bs -- carriage return | otherwise = S.init bs wai-extra-3.1.13.0/Network/Wai/Request.hs0000644000000000000000000000731014307354461016171 0ustar0000000000000000{-# 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 $ req { requestBody = throwIO (RequestSizeException maxSize) } else return req ChunkedBody -> do currentSize <- newIORef 0 return $ req { requestBody = do bs <- requestBody 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 } wai-extra-3.1.13.0/Network/Wai/Test.hs0000644000000000000000000002425714307354461015471 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} module Network.Wai.Test ( -- * Session Session , runSession , withSession -- * Client Cookies , ClientCookies , getClientCookies , modifyClientCookies , setClientCookie , deleteClientCookie -- * Requests , request , srequest , SRequest (..) , SResponse (..) , defaultRequest , setPath , setRawPathInfo -- * Assertions , assertStatus , assertContentType , assertBody , assertBodyContains , assertHeader , assertNoHeader , assertClientCookieExists , assertNoClientCookieExists , assertClientCookieValue ) where #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 request $ req { requestBody = atomicModifyIORef refChunks $ \bss -> case bss of [] -> ([], S.empty) x:y -> (y, x) } 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) wai-extra-3.1.13.0/Network/Wai/Test/Internal.hs0000644000000000000000000000200114307354461017224 0ustar0000000000000000module 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 wai-extra-3.1.13.0/Network/Wai/UrlMap.hs0000644000000000000000000000643514307354461015750 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {- | This module gives you a way to mount applications under sub-URIs. For example: > bugsApp, helpdeskApp, apiV1, apiV2, mainApp :: Application > > myApp :: Application > myApp = mapUrls $ > mount "bugs" bugsApp > <|> mount "helpdesk" helpdeskApp > <|> mount "api" > ( mount "v1" apiV1 > <|> mount "v2" apiV2 > ) > <|> mountRoot mainApp -} 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 (\(p, a) -> (p, f a)) 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) 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 thing = mount' [prefix] thing -- | 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 tuples = foldl go Nothing tuples 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 wai-extra-3.1.13.0/Network/Wai/Middleware/RequestLogger/Internal.hs0000644000000000000000000000161714307354461023166 0ustar0000000000000000{-# 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 wai-extra-3.1.13.0/Network/Wai/Util.hs0000644000000000000000000000134214330135132015441 0ustar0000000000000000{-# 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 wai-extra-3.1.13.0/example/Main.hs0000644000000000000000000000423514307354461014712 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Data.ByteString.Builder (string8) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Chan import Control.Monad (forever) import Data.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 (gzip, def) 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 def $ headers $ app chan) where -- headers required for SSE to work through nginx -- not required if using warp directly headers :: Middleware headers = addHeaders [ ("X-Accel-Buffering", "no") , ("Cache-Control", "no-cache") ] wai-extra-3.1.13.0/test/Spec.hs0000644000000000000000000000005414307354461014237 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} wai-extra-3.1.13.0/test/Network/Wai/Middleware/ApprootSpec.hs0000644000000000000000000000226314307354461022036 0ustar0000000000000000{-# 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)] "" wai-extra-3.1.13.0/test/Network/Wai/Middleware/CombineHeadersSpec.hs0000644000000000000000000001221514330135132023244 0ustar0000000000000000{-# 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 "" wai-extra-3.1.13.0/test/Network/Wai/Middleware/ForceSSLSpec.hs0000644000000000000000000000365714307354461022042 0ustar0000000000000000{-# 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 [] "" wai-extra-3.1.13.0/test/Network/Wai/Middleware/RealIpSpec.hs0000644000000000000000000000730614307354461021571 0ustar0000000000000000{-# 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 wai-extra-3.1.13.0/test/Network/Wai/Middleware/RequestSizeLimitSpec.hs0000644000000000000000000001153614307354461023677 0ustar0000000000000000{-# 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 = defaultRequest { isSecure = False , requestBodyLength = ChunkedBody , requestBody = return "a" } it "413s if the combined chunk size is > the size limit" $ do resp <- runStreamingChunkApp 11 tenByteLimitSettings streamingReq simpleStatus resp `shouldBe` status413 it "200s if the combined chunk size is <= the size limit" $ do resp <- runStreamingChunkApp 10 tenByteLimitSettings streamingReq simpleStatus resp `shouldBe` status200 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 [] "" wai-extra-3.1.13.0/test/Network/Wai/Middleware/RoutedSpec.hs0000644000000000000000000000271314307354461021654 0ustar0000000000000000{-# 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.Routed import Network.Wai.Middleware.ForceSSL (forceSSL) 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" wai-extra-3.1.13.0/test/Network/Wai/Middleware/SelectSpec.hs0000644000000000000000000000454414307354461021635 0ustar0000000000000000{-# 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 wai-extra-3.1.13.0/test/Network/Wai/Middleware/StripHeadersSpec.hs0000644000000000000000000000406514307354461023011 0ustar0000000000000000{-# 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` tail 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 [] "" wai-extra-3.1.13.0/test/Network/Wai/Middleware/TimeoutSpec.hs0000644000000000000000000000337414307354461022044 0ustar0000000000000000{-# 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 wai-extra-3.1.13.0/test/Network/Wai/ParseSpec.hs0000644000000000000000000003037014307354461017407 0ustar0000000000000000{-# 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 Network.Wai (Request (requestBody, requestHeaders), defaultRequest) 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` anyErrorCall it "exceeding parameter length" $ do SRequest req4 _bod4 <- toRequest'' ctype3 content3 (parseRequestBodyEx ( setMaxRequestKeyLength 2 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall 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` anyErrorCall 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` anyErrorCall 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" <> S8.replicate 8190 'e' <> "\"\r\n" <> "Content-Type: application/octet-stream\r\n\r\n" <> "Photo blog using Hack.\r\n\r\n" <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n" 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" 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 -> return $ SRequest defaultRequest { requestHeaders = [("Content-Type", ctype)], requestBody = b } (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) wai-extra-3.1.13.0/test/Network/Wai/RequestSpec.hs0000644000000000000000000000636614307354461017775 0ustar0000000000000000{-# 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) 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 = defaultRequest { isSecure = False , requestBodyLength = KnownLength (limit + 1) , requestBody = return "repeat this chunk" } checkedRequest <- requestSizeCheck limit largeRequest body <- try (requestBody 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 = defaultRequest { isSecure = False , requestBodyLength = ChunkedBody , requestBody = return "repeat this chunk" } checkedRequest <- requestSizeCheck limit largeRequest body <- try (forever $ requestBody 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 wai-extra-3.1.13.0/test/Network/Wai/TestSpec.hs0000644000000000000000000001772514307354461017265 0ustar0000000000000000{-# 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 $ defaultRequest { requestBody = getBodyChunk } 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.def { Cookie.setCookieName = TE.encodeUtf8 name , Cookie.setCookieValue = TE.encodeUtf8 val } ) ] "set_cookie_body" ["delete", name] -> respond $ responseLBS status200 [( "Set-Cookie" , toByteString $ Cookie.renderSetCookie $ Cookie.def { Cookie.setCookieName = TE.encodeUtf8 name , Cookie.setCookieExpires = Just $ UTCTime (fromGregorian 1970 1 1) 0 } ) ] "set_cookie_body" _ -> respond $ responseLBS status200 [] ( L8.pack $ show $ map snd $ filter ((=="Cookie") . fst) $ requestHeaders req ) it "sends a Cookie header with correct value after receiving a Set-Cookie header" $ do sresp <- flip runSession cookieApp $ do void $ request $ setPath defaultRequest "/set/cookie_name/cookie_value" request $ setPath defaultRequest "/get" simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" it "sends a Cookie header with 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.def { Cookie.setCookieName = "cookie_name" , Cookie.setCookieValue = "cookie_value" } ) request $ setPath defaultRequest "/get" simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" it "sends a cookie updated with setClientCookie to server" $ do sresp <- flip runSession cookieApp $ do setClientCookie (Cookie.def { Cookie.setCookieName = "cookie_name" , Cookie.setCookieValue = "cookie_value" } ) setClientCookie (Cookie.def { Cookie.setCookieName = "cookie_name" , Cookie.setCookieValue = "cookie_value2" } ) request $ setPath defaultRequest "/get" simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]" it "does not send a cookie deleted with deleteClientCookie to server" $ do sresp <- flip runSession cookieApp $ do setClientCookie (Cookie.def { Cookie.setCookieName = "cookie_name" , Cookie.setCookieValue = "cookie_value" } ) deleteClientCookie "cookie_name" request $ setPath defaultRequest "/get" simpleBody sresp `shouldBe` "[]" wai-extra-3.1.13.0/test/WaiExtraSpec.hs0000644000000000000000000006264314307354461015720 0ustar0000000000000000{-# 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 (..), def, 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 def $ \_ 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 def) $ do _ <- doesNotEncodeGzipJSON [acceptGzip] _ <- doesNotEncodeGzipJSON [] pure () -- Just compresses the file withSession (gzipFileApp def{gzipFiles = GzipCompress}) $ do _ <- doesEncodeGzipJSON [acceptGzip] _ <- doesNotEncodeGzipJSON [] pure () -- Checks for a "filename.gz" file in the same folder withSession (gzipFileApp def{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 def{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 def{gzipFiles = GzipCacheFolder path}) $ do _ <- doesEncodeGzipJSON [acceptGzip] liftIO $ checkTempDir 2 "just to make sure it isn't a fluke" where noPreCompressApp set = gzipFileApp' def{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 def { 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 def { 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 def { 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 wai-extra-3.1.13.0/LICENSE0000644000000000000000000000207514307354461013044 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 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: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 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. wai-extra-3.1.13.0/Setup.lhs0000755000000000000000000000016214307354461013645 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain wai-extra-3.1.13.0/wai-extra.cabal0000644000000000000000000001751414330135132014714 0ustar0000000000000000Name: wai-extra Version: 3.1.13.0 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality: . * WAI Testing Framework . Hspec testing facilities and helpers for WAI. . * Event Source/Event Stream . Send server events to the client. Compatible with the JavaScript EventSource API. . * Accept Override . Override the Accept header in a request. Special handling for the _accept query parameter (which is used throughout WAI override the Accept header). . * Add Headers . WAI Middleware for adding arbitrary headers to an HTTP request. . * Clean Path . Clean a request path to a canonical form. . * Combine Headers . Combine duplicate headers into one. . * GZip Compression . Negotiate HTTP payload gzip compression. . * Health check endpoint . Add an empty health check endpoint. . * HTTP Basic Authentication . WAI Basic Authentication Middleware which uses Authorization header. . * JSONP . \"JSON with Padding\" middleware. Automatic wrapping of JSON responses to convert into JSONP. . * Method Override / Post . Allows overriding of the HTTP request method via the _method query string parameter. . * Request Logging . Request logging middleware for development and production environments . * Request Rewrite . Rewrite request path info based on a custom conversion rules. . * Select . Dynamically choose between Middlewares. . * Stream Files . Convert ResponseFile type responses into ResponseStream type. . * Virtual Host . Redirect incoming requests to a new host based on custom rules. . . API docs and the README are available at . License: MIT License-file: LICENSE Author: Michael Snoyman Maintainer: michael@snoyman.com Homepage: http://github.com/yesodweb/wai Category: Web Build-Type: Simple Cabal-Version: >=1.10 Stability: Stable extra-source-files: test/requests/dalvik-request test/json test/json.gz test/noprecompress test/test.html test/sample.hs ChangeLog.md README.md flag build-example description: Build example executable. manual: True default: False Library Build-Depends: base >= 4.12 && < 5 , aeson , ansi-terminal , base64-bytestring , bytestring >= 0.10.4 , call-stack , case-insensitive >= 0.2 , containers , cookie , data-default-class , 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.0.3.0 && < 3.3 , wai-logger >= 2.3.7 , warp >= 3.3.22 , word8 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.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.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 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.ParseSpec Network.Wai.RequestSpec Network.Wai.TestSpec WaiExtraSpec build-tool-depends: hspec-discover:hspec-discover build-depends: base >= 4 && < 5 , aeson , bytestring , cookie , case-insensitive , directory , fast-logger , hspec >= 1.3 , http-types , HUnit , iproute , resourcet , temporary , text , time , wai-extra , wai , warp , zlib ghc-options: -Wall default-language: Haskell2010 if os(windows) cpp-options: -DWINDOWS source-repository head type: git location: git://github.com/yesodweb/wai.git wai-extra-3.1.13.0/test/requests/dalvik-request0000644000000000000000000002760614307354461017563 0ustar0000000000000000--***** Content-Disposition: form-data; name="scannedTime"; 1.298590056748E9 --***** Content-Disposition: form-data; name="geoLong"; 0 --***** Content-Disposition: form-data; name="geoLat"; 0 --***** Content-Disposition: form-data; name="password"; 89478462726416 --***** Content-Disposition: form-data; name="email"; 91E7154950A75780@fastreg.stamp4.me --***** Content-Disposition: form-data; name="geoAccuracy"; 1 --***** Content-Disposition: form-data; name="img"; filename="image.jpg" Content-Type: image/jpeg JFIFC   (1#%(:3=<9387@H\N@DWE78PmQW_bghg>Mqypdx\egcC//cB8Bcccccccccccccccccccccccccccccccccccccccccccccccccc^" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?hB ( ( ( ( ( ( ( ( ( ( ( ( ( ?C^ph-t4B҈ kF,c1yTN?w]?#޺)a5sMI#teʞ4?|ޏٿnTe׃U#'ב'?w)/uk&fD_QϜ_]UvfOaim5[o5?/ {`*  ?5~kW_>٦V 2IJNjWBAX[z; xtI\u%֢cR+fֶnE2Ve.2'|:P䓳j)f ]֤͕ZcM]$?xjp ՐXO c&VM3VSe8=5Ш=D1 ~9ce7ҟ\;!;=Cq 7z],R.hE0(/-!h.rGbt >=ϫMerwwy}~j^Ѓg$msvP؏5%}m޳*+]EMˆETC^pjP׿}\PmD6Q1Y.êcq"!"B+#IC6up~'ԍ򭪹b((*ŲFbsqyjyYUqPn@P`#fN^$•xJz$/y6(UqWooc $YV(u j22F51Pˣ"N~a(%Ym&GwY!\ʽ*u9)(I5HհXz/ :XU$fW{ CE"0u Zy`WOb.mO*oĿ]rCźlWUU=Ɋ (*T5Tm+n-=3J 5n n_z[ @ƪMs,bGjӖ>'w6׈SUs6TTʬ´,{f댭gԖҘfWҥ>Yk!%HRUJ $YTgI8M#Wa_yV!#K S{h̞Mj8>dU\f_]E6$QE!P}\U ?|3Ƈ glȭZ˺?Y0ǔuM(@z.5U/-vJ>͉ :pXU6.})Z"mc ?j<.ğz?KhjI1˱5)i.QEfEPEPUyuk?&0έ85.}$VuZ+cK̃'zSѸ4Oi7;FI={jH#F S\ K)a/v>G*$QEH¨kP׿}\Pt}8DͱkBц=${9td\/CZM+ Ԩ'[x=jZ)0 o\3d6jhL8>Nr+U9.H9PqM .jEHIaETQEQEQEV#"~tSM+v<֔eg ##e ƭ,FE9dG0+E]Z&,KˏV/,4@+us%UbF}zvnm l  }WAN`* 7C^po@aF=*wyr4r/ލFa~R}0s8IǪ_¯Iʅd 77㣏hjEsI-]}:޴̶dQU>u53 L"z @ZQʷPqZcOxeY!ppz*=Jټ*!;́ʥ)?yj 3W ()UK($@ EXN\K'Ƶ 3*)b{Z6gFAu1¸j}v:Q`tɥYR4fcT_­stzC${vJꌒ9?աN~<»F*M:4v1D 3òÿSZ2Ϩh MVٞqs?iSmĕ(0*T5Ty~R/JZ(u[]Ihhcufk$12~O VY6ui#,~unE/ƙctIcE>eGݺŸذ( c${_@MKeG4 a,M`ì$l֙% p4TC&lz?/e  ~U*Qj~P?4ۗVo'ZF=O:Z“IlĠpxjT?lZAVHcFl} 4XO(LzB^=aҢ!/.%:GS}OMEQE*Ҭo]~CVQEC^poWꆽ ;ʀ//JZEK@Q@FWKvݾ9j5--WOk4qq F[R(׫;k+ul'/-帾KBVNj o *O?fC,|q?磍}Т#<1ʾXzyћDL#SD/rnHPI p\r 9@p-nb"VMXvutm 7>'H3P㪒:^K-Զ{[Id?-^lZejGǫ'ܞj'KK&I VU(((?iVn!ЫJ ( 7C^po@-C=6=ċHfcvd=sҀ-_62Iy[7yΣNlYGsŸ?ZaZicnԞjSfUH3cɩ//m!nHc>w>¤JB.w ۗ9^s֕]VdFJ(:QCobYZk$E+nvZV.IwzC9ꄗ*D$M&5n21vW3}XH+@git)kvqZ?ue9l9G  n6u Xv"*hY|y\ۏޅB:󎣓ӠƑbݰ{8ջxrU9?xZ<έf5M4iq5qʜCSi7i(]p0j/&Jrv-<RG}}n-5'܇OG EfՋFQH((( o]~CVf (*T5TK{9KEm)="JGvb'gx[Jv9F8lHϘ猜a)Iϱit%蚃iz7X%AÏU=k\^[f6G! C +VKh.c8q]+ lnͳ:H>{ M=M=>͂Hؒ吿$g$ ԚPRY0iNcb d}@[]27gW?q$LmFp?Ɣb7%aȒ /+Wr;ZcF0kZbBGI18桴{y|8wv*$ =ZjO?g) КJ*͎N UכֿͱXd5bI$M2LVe1ʝ}Ax~YɼsX#Io|B?ˏ ~3PY@DC]2~VjRQEQE*Ҭo]~CVQEC^poWꆽ ;ʀ//Jl֒pXe0jCAdp#9e?: W(QF !$#tVG ;Ce%l#lRh^cs}Z֏ImpC!<èȫOK%ĥeCX_qI>d/rHs펇OV9o._FLOa3er֯!̀(tsTw2FE7%љB=;SAq"h$Y#axS6;(wȮQw?rWW)$ѥ˿^,FH΃sg$euz}6e2@oRi KU`>Vaʠ';Iei 4~_,|?VI58SV?җgM-v=\bwjlm юUgz}5D᷾^I͍AK Y>̥$AA: w<3 xR/uwpv7H~:~'2IdxͳQՔZx~W3Zk"lz~\nt]IL mf捾68$pA?O4I,lC+c袊(?iVn!ЫJ ( 7C^po@-" Z=)*ϡr=ܶ{.>[qku] }@ҹ_Y%jMm2k SҚvakup-WO`@xo QLnմjU&)FFcq|򿅘t=]3ڥƑBgyؠe:{Cܖ*> Hs֢ky]v%n?:UֹK/& |F20C9Y>|#A^ՏUNdnnu8Q\NK]ZrQq?*XnmbH40N(FOP KZr:mB94njxL]Ť-=Cc"mg'.>D{Tm-R%8P*Kȍ&bˎ$`~jXn%$.s3_`ǯn=UfeIO#(aH+wY<\(9w85(vy]臙gr^ׁ@ 2PjY #rU?p(۵5ʌu ܛ˝1qjOxhK-ld-&p,cg ik=uv2(e?QWq]@ۢC)QE*Ҭo]~CVQEC^poWꆽ ;ʀ//JZEK@CwmݬR=MErK ̶mG߀z+RHrʃ ,mA9 gWT.  qȩ4IIXI4 0(#g5KT';iRUz,*#jȱ .8AQDL8ifK#} )ࣟg[ĦVtMʯz3N8Kd̬KF R=dpLL$r:P/.#yc*`nG_A׮i<;\F~pz1JX|ȤPʻX89qלZbMUr2"89=-\[{֬ZD@<InHM'PTӡcxVA@\(7[Wg_UY?B*(* ;ʯ {@w^_>GҖ (,i4Oe==EprE&n6jP1?zQ؟J6EKLc|O󦀽m"Zc4gkJwEW,q#LN_!=OҲ27+ܛJ)k-΢!ϓ Oኒ m`Mph|;hx$fV 'x4˻Ԗ6UY'ڕ g4t3q"} @FqSe[&b5,\lag=9M҉bG1!C.KuchX{.4x@vi pO8a-3o-p< М=$ LLɂ%]gHn%K2*Ǹ@?˽SGzW9nUA$u tBaS mr>Q=WVK/S \F|%-7H8$ӱVEgpZ@q`4$k/";^i&yRxz21p9=7~y̶WR;+ݹ@ah?0ߧjڦ(CE;o`191 +;CN,.ˈɊth7[Wg_UY?B*(* ;ʯ {@w^_>GҖ ( FA @!-RH~lZfH饳Qokk?#IqOL\/XKyl޿ć؎ՙ<vOf&[W'(9S?ATm^'{%"N0=~4SCz-/6WTAio(qvNBgc)c,p>FwvpF;bC S*p(Fn^/(YmPX&>Oaێrtyaflm .Tj^Q`#EdlI#8Wӥi`ĉ$}F)L".G}#t9FjHW(Js0z}2}!0vݑd[pUӯ9= V.H$bp]{uR?3XSK?LNlLF6 +gpG~M]HL#H.d`N p^JH&<8.fAPOR<q' lP]m7rÿ_I3_7*g`poY/ZY#.AЀ=h~#w傻WNXP7 ۊ@lrOj;簑mWx< ^8x k VAG\zPz?&S7o3Yfz̺!v2/!<=w5ޘ76L}YN3h?B*?iR(*T5Ty~R/JZ((+H՞W! ]/~0{qY>$OyjhS@5n%nlIp׵ݑ :ϦG׭CII-cbc<F0I`zI q#;7(;`cs"o" M3 DL( !(V3#{TkvnIM"xy$:;kxGm0u1X [sB=3}Ym23,Yo/">A?a}*Ů?eiKr' =OӧO4胧ԞV]9"IQ UP $p}{U[QTtP?Pբ{p@9?4%cHm#?x9f>֡훈c\_JO{"iֽs_?* ~әU@z)3rk}&Kjw5mJ\ .= biA*k3B2r**Ҭo]~CV ( 7[Rk:+K '$PKYp cO)swO(Jι?:t€4 3wO(Jι?:t€9Z5gn6g/O`--Xv$Ho\Pvؘ_*H+FEfebzEp?G퟼>QA=5:kVp:1`)==i> 2ј m~}iړ$ ۛnwg$pZH쭂2 SY|vUY÷8qiѪA+K0ǮHޕF>DMeK,b;QS~&+O2mr}fk[Gk݉go;B ۞e"I?E9]sPG̴Gq9e?-͚{˄##!_\8ANk2Sd'yGxA.{IqKٷgtgt kJU4RmHlVMFLӿǵt*FFsFuHTVnu?ok "k]VɳX%o/vNӜ ֽQEQEQEQEQEQExONx7QFp":(TzŨJK{v^ 5܂(HMCz}h2Kfٟ 0{BA2_;*1U2KB%nn8"{W5F%Q},Whǡ?!+xpD 訠T-z#/L G=? Ԣ@QEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQE --*****-- wai-extra-3.1.13.0/test/json0000644000000000000000000000003514307354461013704 0ustar0000000000000000{"data":"this is some data"} wai-extra-3.1.13.0/test/json.gz0000644000000000000000000000000514307354461014320 0ustar0000000000000000test wai-extra-3.1.13.0/test/noprecompress0000644000000000000000000000001614307354461015631 0ustar0000000000000000noprecompress wai-extra-3.1.13.0/test/test.html0000644000000000000000000000060114307354461014654 0ustar0000000000000000 There should be some content loaded below:
wai-extra-3.1.13.0/test/sample.hs0000644000000000000000000000164614307354461014636 0ustar0000000000000000{-# 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.Middleware.Gzip import Network.Wai.Middleware.Jsonp import Network.Wai.Handler.Warp app :: Application app request = return $ case pathInfo request of [] -> responseLBS status200 [] $ fromChunks $ flip map [1..10000] $ \i -> pack $ concat [ "

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

" ] ["test.html"] -> ResponseFile status200 [] "test.html" Nothing ["json"] -> ResponseFile status200 [(hContentType, "application/json")] "json" Nothing _ -> ResponseFile status404 [] "../LICENSE" Nothing main :: IO () main = run 3000 $ gzip def $ jsonp app wai-extra-3.1.13.0/ChangeLog.md0000644000000000000000000002065514330135132014200 0ustar0000000000000000# Changelog for wai-extra ## 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. wai-extra-3.1.13.0/README.md0000644000000000000000000000050714307354461013314 0ustar0000000000000000# 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 ```