wai-extra-3.0.19/0000755000000000000000000000000013002336756011700 5ustar0000000000000000wai-extra-3.0.19/ChangeLog.md0000644000000000000000000000555113002336756014057 0ustar0000000000000000## 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.0.19/LICENSE0000644000000000000000000000207513002336756012711 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.0.19/README.md0000644000000000000000000000012513002336756013155 0ustar0000000000000000## wai-extra The goal here is to provide common features without many dependencies. wai-extra-3.0.19/Setup.lhs0000644000000000000000000000016213002336756013507 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain wai-extra-3.0.19/wai-extra.cabal0000644000000000000000000001454613002336756014577 0ustar0000000000000000Name: wai-extra Version: 3.0.19 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. . * GZip Compression . Negotiate HTTP payload gzip compression. . * 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. . * 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/test.html test/sample.hs ChangeLog.md README.md Library Build-Depends: base >= 4.6 && < 5 , bytestring >= 0.9.1.4 , wai >= 3.0.3.0 && < 3.3 , old-locale >= 1.0.0.2 && < 1.1 , time >= 1.1.4 , network >= 2.6.1.0 , directory >= 1.0.1 , transformers >= 0.2.2 , blaze-builder >= 0.2.1.4 && < 0.5 , http-types >= 0.7 , text >= 0.7 , case-insensitive >= 0.2 , data-default-class , fast-logger >= 2.4.5 && < 2.5 , wai-logger >= 2.2.6 && < 2.4 , ansi-terminal , resourcet >= 0.4.6 && < 1.2 , void >= 0.5 , stringsearch >= 0.3 && < 0.4 , containers , base64-bytestring , word8 , lifted-base >= 0.1.2 , deepseq , streaming-commons , unix-compat , cookie , vault , zlib , aeson , iproute if os(windows) cpp-options: -DWINDOWS else build-depends: unix default-extensions: OverloadedStrings Exposed-modules: 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.Local Network.Wai.Middleware.RequestLogger Network.Wai.Middleware.RequestLogger.JSON Network.Wai.Middleware.Gzip Network.Wai.Middleware.Jsonp Network.Wai.Middleware.MethodOverride Network.Wai.Middleware.MethodOverridePost Network.Wai.Middleware.Rewrite Network.Wai.Middleware.StripHeaders Network.Wai.Middleware.Vhost Network.Wai.Middleware.HttpAuth Network.Wai.Middleware.StreamFile Network.Wai.Middleware.ForceDomain Network.Wai.Middleware.ForceSSL Network.Wai.Middleware.Routed Network.Wai.Parse Network.Wai.Request Network.Wai.UrlMap Network.Wai.Test Network.Wai.EventSource Network.Wai.EventSource.EventStream other-modules: Network.Wai.Middleware.RequestLogger.Internal default-language: Haskell2010 ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs other-modules: Network.Wai.TestSpec Network.Wai.ParseSpec Network.Wai.RequestSpec Network.Wai.Middleware.ApprootSpec Network.Wai.Middleware.ForceSSLSpec Network.Wai.Middleware.RoutedSpec Network.Wai.Middleware.StripHeadersSpec WaiExtraSpec build-depends: base >= 4 && < 5 , wai-extra , wai , hspec >= 1.3 , transformers , fast-logger , http-types , zlib , text , resourcet , bytestring , HUnit , blaze-builder , cookie , time , case-insensitive ghc-options: -Wall default-language: Haskell2010 source-repository head type: git location: git://github.com/yesodweb/wai.git wai-extra-3.0.19/Network/0000755000000000000000000000000013002336755013330 5ustar0000000000000000wai-extra-3.0.19/Network/Wai/0000755000000000000000000000000013002336756014051 5ustar0000000000000000wai-extra-3.0.19/Network/Wai/EventSource.hs0000644000000000000000000000233513002336756016652 0ustar0000000000000000{-| A WAI adapter to the HTML5 Server-Sent Events API. -} module Network.Wai.EventSource ( ServerEvent(..), eventSourceAppChan, eventSourceAppIO ) where import Data.Function (fix) import Control.Concurrent.Chan (Chan, dupChan, readChan) import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types (status200, hContentType) import Network.Wai (Application, responseStream) import 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 -> fix $ \loop -> do se <- src case eventToBuilder se of Nothing -> return () Just b -> sendChunk b >> flush >> loop wai-extra-3.0.19/Network/Wai/Header.hs0000644000000000000000000000102213002336755015567 0ustar0000000000000000-- | Some helpers for dealing with WAI 'Header's. module Network.Wai.Header ( contentLength ) where import qualified Data.ByteString.Char8 as S8 import Network.HTTP.Types as H -- | 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 Just (i, "") -> Just i _ -> Nothing wai-extra-3.0.19/Network/Wai/Parse.hs0000644000000000000000000006222413002336756015465 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 , 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 qualified Data.ByteString.Search as Search import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Data.Word (Word8) import Data.Int (Int64) import Data.Maybe (catMaybes, fromMaybe) import Data.List (sortBy) import Data.Function (on, fix) import System.Directory (removeFile, getTemporaryDirectory) import System.IO (hClose, openBinaryTempFile) import Network.Wai import qualified Network.HTTP.Types as H import Control.Applicative ((<$>)) import Control.Monad (when, unless) import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState) import Data.IORef import Network.HTTP.Types (hContentType) import Data.CaseInsensitive (mk) import Prelude hiding (lines) breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s = let (x, y) = S.break (== w) s 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 $ removeFile 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 -- | 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.16.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 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, 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. 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') $ error "Header line length exceeds allowed maximum." 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') $ error "Header line length exceeds allowed maximum." 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) bs = writeIORef ref bs 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 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 $ Search.breakOn 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'' -> error "Maximum size exceeded" _ -> 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.0.19/Network/Wai/Request.hs0000644000000000000000000000731413002336756016042 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} -- | Some helpers for interrogating a WAI 'Request'. module Network.Wai.Request ( appearsSecure , guessApproot , RequestSizeException(..) , requestSizeCheck ) where import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Network.HTTP.Types (HeaderName) import Network.Wai import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C import Control.Exception (Exception, throwIO) import Data.Typeable (Typeable) import Data.Word (Word64) import Data.IORef (atomicModifyIORef', newIORef) -- | 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 data 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.0.19/Network/Wai/Test.hs0000644000000000000000000002416513002336756015334 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} module Network.Wai.Test ( -- * Session Session , runSession -- * Client Cookies , ClientCookies , getClientCookies , modifyClientCookies , setClientCookie , deleteClientCookie -- * Requests , request , srequest , SRequest (..) , SResponse (..) , defaultRequest , setPath , setRawPathInfo -- * Assertions , assertStatus , assertContentType , assertBody , assertBodyContains , assertHeader , assertNoHeader , assertClientCookieExists , assertNoClientCookieExists , assertClientCookieValue , WaiTestFailure (..) ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) import Data.Monoid (mempty, mappend) #endif import Network.Wai import Network.Wai.Internal (ResponseReceived (ResponseReceived)) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import qualified Control.Monad.Trans.State as ST import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) import Control.Monad (unless) import Control.DeepSeq (deepseq) import Control.Exception (throwIO, Exception) import Data.Typeable (Typeable) import Data.Map (Map) import qualified Data.Map as Map import qualified Web.Cookie as Cookie import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Blaze.ByteString.Builder (toLazyByteString, toByteString) import qualified Blaze.ByteString.Builder as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Network.HTTP.Types as H import Data.CaseInsensitive (CI) import qualified Data.ByteString as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.IORef import Data.Time.Clock (getCurrentTime) type Session = ReaderT Application (ST.StateT ClientState IO) -- | -- -- Since 3.0.6 type ClientCookies = Map ByteString Cookie.SetCookie data ClientState = ClientState { clientCookies :: ClientCookies } -- | -- -- 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 cookieName = modifyClientCookies (Map.delete cookieName) initState :: ClientState initState = ClientState Map.empty runSession :: Session a -> Application -> IO a runSession session app = ST.evalStateT (runReaderT session app) initState data SRequest = SRequest { simpleRequest :: Request , simpleRequestBody :: L.ByteString } data SResponse = SResponse { simpleStatus :: H.Status , simpleHeaders :: H.ResponseHeaders , simpleBody :: L.ByteString } deriving (Show, Eq) request :: Request -> Session SResponse request = srequest . flip SRequest L.empty -- | Set whole path (request path + query string). setPath :: Request -> S8.ByteString -> Request setPath req path = req { pathInfo = segments , rawPathInfo = B.toByteString (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 = toByteString $ 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 srequest :: SRequest -> Session SResponse srequest (SRequest req bod) = do app <- ask refChunks <- liftIO $ newIORef $ L.toChunks bod let req' = req { requestBody = atomicModifyIORef refChunks $ \bss -> case bss of [] -> ([], S.empty) x:y -> (y, x) } req'' <- addCookiesToRequest req' response <- liftIO $ do ref <- newIORef $ error "runResponse gave no result" ResponseReceived <- app req'' (runResponse ref) readIORef ref extractSetCookieFromSResponse response 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 :: String -> Bool -> Session () assertBool s b = unless b $ assertFailure s assertString :: String -> Session () assertString s = unless (null s) $ assertFailure s assertFailure :: String -> Session () assertFailure msg = msg `deepseq` liftIO (throwIO (WaiTestFailure msg)) data WaiTestFailure = WaiTestFailure String deriving (Show, Eq, Typeable) instance Exception WaiTestFailure assertContentType :: 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 :: Int -> SResponse -> Session () assertStatus i SResponse{simpleStatus = s} = assertBool (concat [ "Expected status code " , show i , ", but received " , show sc ]) $ i == sc where sc = H.statusCode s assertBody :: L.ByteString -> SResponse -> Session () assertBody lbs SResponse{simpleBody = lbs'} = assertBool (concat [ "Expected response body " , show $ L8.unpack lbs , ", but received " , show $ L8.unpack lbs' ]) $ lbs == lbs' assertBodyContains :: L.ByteString -> SResponse -> Session () assertBodyContains lbs SResponse{simpleBody = lbs'} = assertBool (concat [ "Expected response body to contain " , show $ L8.unpack lbs , ", but received " , show $ L8.unpack lbs' ]) $ strict lbs `S.isInfixOf` strict lbs' where strict = S.concat . L.toChunks assertHeader :: 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 :: 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 :: String -> ByteString -> Session () assertClientCookieExists s cookieName = do cookies <- getClientCookies assertBool s $ Map.member cookieName cookies -- | -- -- Since 3.0.6 assertNoClientCookieExists :: String -> ByteString -> Session () assertNoClientCookieExists s cookieName = do cookies <- getClientCookies assertBool s $ not $ Map.member cookieName cookies -- | -- -- Since 3.0.6 assertClientCookieValue :: 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.0.19/Network/Wai/UrlMap.hs0000644000000000000000000000625013002336756015610 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-} {- | This module gives you a way to mount applications under sub-URIs. For example: > bugsApp, helpdeskApp, apiV1, apiV2, mainApp :: Application > > myApp :: Application > myApp = mapUrls $ > mount "bugs" bugsApp > <|> mount "helpdesk" helpdeskApp > <|> mount "api" > ( mount "v1" apiV1 > <|> mount "v2" apiV2 > ) > <|> mountRoot mainApp -} module Network.Wai.UrlMap ( UrlMap', UrlMap, mount', mount, mountRoot, mapUrls ) where import Control.Applicative import Data.List import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString as B import Network.HTTP.Types import Network.Wai 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.0.19/Network/Wai/EventSource/0000755000000000000000000000000013002336756016313 5ustar0000000000000000wai-extra-3.0.19/Network/Wai/EventSource/EventStream.hs0000644000000000000000000000373513002336756021114 0ustar0000000000000000{-# LANGUAGE CPP #-} {- code adapted by Mathias Billman originaly 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 Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char8 #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 = fromChar '\n' {-| Field names as Builder -} nameField, idField, dataField, retryField, commentField :: Builder nameField = fromString "event:" idField = fromString "id:" dataField = fromString "data:" retryField = fromString "retry:" commentField = fromChar ':' {-| 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 (fromShow 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.0.19/Network/Wai/Handler/0000755000000000000000000000000013002336755015425 5ustar0000000000000000wai-extra-3.0.19/Network/Wai/Handler/CGI.hs0000644000000000000000000001651313002336755016371 0ustar0000000000000000{-# LANGUAGE RankNTypes, CPP #-} -- | Backend for Common Gateway Interface. Almost all users should use the -- 'run' function. module Network.Wai.Handler.CGI ( run , runSendfile , runGeneric , requestBodyFunc ) where import Network.Wai import Network.Wai.Internal import Network.Socket (getAddrInfo, addrAddress) import Data.IORef import Data.Maybe (fromMaybe) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L import Control.Arrow ((***)) import Data.Char (toLower) import qualified System.IO import qualified Data.String as String import Blaze.ByteString.Builder (fromByteString, toLazyByteString, flush) import Blaze.ByteString.Builder.Char8 (fromChar, fromString) import Data.ByteString.Lazy.Internal (defaultChunkSize) import System.IO (Handle) import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength) import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat, mempty, mappend) #endif import qualified Data.Streaming.Blaze as Blaze import Data.Function (fix) import Control.Monad (unless, void) #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 -> case lookup "REMOTE_HOST" vars of Just x -> x Nothing -> "" 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) <- Blaze.newBlazeRecv Blaze.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` fromChar '\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) = (fromByteString "Status", mconcat [ fromString $ show i , fromChar ' ' , fromByteString m ]) header' (x, y) = (fromByteString $ CI.original x, fromByteString y) header (x, y) = mconcat [ x , fromByteString ": " , y , fromChar '\n' ] sfBuilder s hs sf fp = mconcat [ headers s hs , header $ (fromByteString sf, fromString fp) , fromChar '\n' , fromByteString sf , fromByteString " not supported" ] 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.0.19/Network/Wai/Handler/SCGI.hs0000644000000000000000000000622413002336755016512 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Network.Wai.Handler.SCGI ( run , runSendfile ) where import Network.Wai import Network.Wai.Handler.CGI (runGeneric, requestBodyFunc) import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.C import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as S import qualified Data.ByteString.Char8 as S8 import Data.IORef import Data.ByteString.Lazy.Internal (defaultChunkSize) 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.0.19/Network/Wai/Middleware/0000755000000000000000000000000013002336756016126 5ustar0000000000000000wai-extra-3.0.19/Network/Wai/Middleware/AcceptOverride.hs0000644000000000000000000000117213002336755021361 0ustar0000000000000000module Network.Wai.Middleware.AcceptOverride ( acceptOverride ) where import Network.Wai import Control.Monad (join) import Data.ByteString (ByteString) acceptOverride :: Middleware acceptOverride app req = app req' where req' = case join $ lookup "_accept" $ queryString req of Nothing -> req Just a -> req { requestHeaders = changeVal "Accept" a $ requestHeaders req} changeVal :: Eq a => a -> ByteString -> [(a, ByteString)] -> [(a, ByteString)] changeVal key val old = (key, val) : filter (\(k, _) -> k /= key) old wai-extra-3.0.19/Network/Wai/Middleware/AddHeaders.hs0000644000000000000000000000122213002336755020442 0ustar0000000000000000-- | -- -- Since 3.0.3 module Network.Wai.Middleware.AddHeaders ( addHeaders ) where import Network.HTTP.Types (Header) import Network.Wai (Middleware, modifyResponse, mapResponseHeaders) import Network.Wai.Internal (Response(..)) import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI import Control.Arrow (first) addHeaders :: [(ByteString, ByteString)] -> Middleware -- ^ Prepend a list of headers without any checks -- -- Since 3.0.3 addHeaders h = modifyResponse $ addHeaders' (map (first CI.mk) h) addHeaders' :: [Header] -> Response -> Response addHeaders' h = mapResponseHeaders (\hs -> h ++ hs) wai-extra-3.0.19/Network/Wai/Middleware/Approot.hs0000644000000000000000000001063213002336755020107 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 (Request, vault, Middleware) import Network.Wai.Request (guessApproot) import System.Environment (getEnvironment) import System.IO.Unsafe (unsafePerformIO) 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 case lookup name env of Just s -> return $ hardcoded $ S8.pack s Nothing -> return 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.0.19/Network/Wai/Middleware/Autohead.hs0000644000000000000000000000104013002336755020206 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Automatically produce responses to HEAD requests based on the underlying -- applications GET response. module Network.Wai.Middleware.Autohead (autohead) where import Network.Wai #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) #endif 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.0.19/Network/Wai/Middleware/CleanPath.hs0000644000000000000000000000201313002336756020315 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Middleware.CleanPath ( cleanPath ) where import Network.Wai import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L import Network.HTTP.Types (status301, hLocation) import Data.Text (Text) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat) #endif 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.0.19/Network/Wai/Middleware/ForceDomain.hs0000644000000000000000000000233013002336756020646 0ustar0000000000000000-- | -- -- @since 3.0.14 module Network.Wai.Middleware.ForceDomain where import Data.ByteString (ByteString) import Data.Monoid ((<>), mempty) import Network.HTTP.Types (hLocation, methodGet, status301, status307) import Prelude import Network.Wai import Network.Wai.Request -- | 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.0.19/Network/Wai/Middleware/ForceSSL.hs0000644000000000000000000000201213002336756020075 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Redirect non-SSL requests to https -- -- Since 3.0.7 module Network.Wai.Middleware.ForceSSL ( forceSSL ) where import Network.Wai import Network.Wai.Request #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) import Data.Monoid (mempty) #endif import Data.Monoid ((<>)) import Network.HTTP.Types (hLocation, methodGet, status301, status307) -- | 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.0.19/Network/Wai/Middleware/Gzip.hs0000644000000000000000000002255713002336756017406 0ustar0000000000000000{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} --------------------------------------------------------- -- | -- 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 ( gzip , GzipSettings , gzipFiles , GzipFiles (..) , gzipCheckMime , def , defaultCheckMime ) where import Network.Wai import Data.Maybe (fromMaybe, isJust) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString as S import Data.Default.Class import Network.HTTP.Types ( Status, Header, hContentEncoding, hUserAgent , hContentType, hContentLength) import System.Directory (doesFileExist, createDirectoryIfMissing) import Blaze.ByteString.Builder (fromByteString) import Control.Exception (try, SomeException) import qualified Data.Set as Set import Network.Wai.Header import Network.Wai.Internal import qualified Data.Streaming.Blaze as B import qualified Data.Streaming.Zlib as Z import qualified Blaze.ByteString.Builder as Blaze import Control.Monad (unless) import Data.Function (fix) import Control.Exception (throwIO) import qualified System.IO as IO import Data.ByteString.Lazy.Internal (defaultChunkSize) import Data.Word8 (_semicolon) data GzipSettings = GzipSettings { gzipFiles :: GzipFiles , gzipCheckMime :: S.ByteString -> Bool } -- | Gzip behavior for files. data GzipFiles = GzipIgnore -- ^ Do not compress file responses. | GzipCompress -- ^ Compress files. Note that this may counteract -- zero-copy response optimizations on some -- platforms. | GzipCacheFolder FilePath -- ^ Compress files, caching them in -- some directory. | GzipPreCompressed GzipFiles -- ^ If we use compression then try to use the filename with ".gz" -- appended to it, if the file is missing then try next action -- -- @since 3.0.17 deriving (Show, Eq, Read) -- | Use default MIME settings; /do not/ compress files. instance Default GzipSettings where def = GzipSettings GzipIgnore defaultCheckMime -- | 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. -- -- Analyzes the \"Accept-Encoding\" header from the client to determine -- if gzip is supported. -- -- File responses will be compressed according to the 'GzipFiles' setting. gzip :: GzipSettings -> Middleware gzip set app env sendResponse = app env $ \res -> case res of ResponseRaw{} -> sendResponse res ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) && (bigEnough res) then let runAction x = case x of (ResponseFile s hs file Nothing, GzipPreCompressed nextAction) -> let compressedVersion = file ++ ".gz" in doesFileExist compressedVersion >>= \x -> if x then (sendResponse $ ResponseFile s (fixHeaders hs) compressedVersion Nothing) else (runAction (ResponseFile s hs file Nothing, nextAction)) (ResponseFile s hs file Nothing, GzipCacheFolder cache) -> case lookup hContentType hs of Just m | gzipCheckMime set m -> compressFile s hs file cache sendResponse _ -> sendResponse res (ResponseFile {}, GzipIgnore) -> sendResponse res _ -> compressE set res sendResponse in runAction (res, gzipFiles set) else sendResponse res where enc = fromMaybe [] $ (splitCommas . S8.unpack) `fmap` lookup "Accept-Encoding" (requestHeaders env) ua = fromMaybe "" $ lookup hUserAgent $ requestHeaders env isMSIE6 = "MSIE 6" `S.isInfixOf` ua isEncoded res = isJust $ lookup hContentEncoding $ responseHeaders res bigEnough rsp = case contentLength (responseHeaders rsp) of Nothing -> True -- This could be a streaming case Just len -> len >= minimumLength -- For a small enough response, gzipping will actually increase the size -- Potentially for anything less than 860 bytes gzipping could be a net loss -- The actual number is application specific though and may need to be adjusted -- http://webmasters.stackexchange.com/questions/31750/what-is-recommended-minimum-object-size-for-gzip-performance-benefits minimumLength = 860 compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a compressFile s hs file cache sendResponse = do e <- doesFileExist tmpfile if e then onSucc else do createDirectoryIfMissing True cache x <- try $ IO.withBinaryFile file IO.ReadMode $ \inH -> IO.withBinaryFile tmpfile IO.WriteMode $ \outH -> do deflate <- Z.initDeflate 7 $ Z.WindowBits 31 -- FIXME this code should write to a temporary file, then -- rename to the final file let goPopper popper = fix $ \loop -> do res <- popper case res of Z.PRDone -> return () Z.PRNext bs -> do S.hPut outH bs loop Z.PRError ex -> throwIO ex fix $ \loop -> do bs <- S.hGetSome inH defaultChunkSize unless (S.null bs) $ do Z.feedDeflate deflate bs >>= goPopper loop goPopper $ Z.finishDeflate deflate either onErr (const onSucc) (x :: Either SomeException ()) -- FIXME bad! don't catch all exceptions like that! where onSucc = sendResponse $ responseFile s (fixHeaders hs) tmpfile Nothing onErr _ = sendResponse $ responseFile s hs file Nothing -- FIXME log the error message tmpfile = cache ++ '/' : map safe file safe c | 'A' <= c && c <= 'Z' = c | 'a' <= c && c <= 'z' = c | '0' <= c && c <= '9' = c safe '-' = '-' safe '_' = '_' safe _ = '_' compressE :: GzipSettings -> Response -> (Response -> IO a) -> IO a compressE set res sendResponse = case lookup hContentType hs of Just m | gzipCheckMime set m -> let hs' = fixHeaders hs in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do (blazeRecv, _) <- B.newBlazeRecv 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 $ fromByteString bs' loop Z.PRError e -> throwIO e body sendBuilder flushBuilder sendBuilder Blaze.flush deflatePopper $ Z.finishDeflate deflate _ -> sendResponse res 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 = ((hContentEncoding, "gzip") :) . filter notLength where notLength (x, _) = x /= hContentLength splitCommas :: String -> [String] splitCommas [] = [] splitCommas x = let (y, z) = break (== ',') x in y : splitCommas (dropWhile (== ' ') $ drop 1 z) wai-extra-3.0.19/Network/Wai/Middleware/HttpAuth.hs0000644000000000000000000000770513002336756020234 0ustar0000000000000000{-# LANGUAGE RecordWildCards, TupleSections, CPP #-} -- | 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 Data.ByteString.Base64 (decodeLenient) import Data.String (IsString (..)) import Data.Word8 (isSpace, _colon, toLower) import Network.HTTP.Types (status401, hContentType, hAuthorization) import Network.Wai import qualified Data.ByteString as S -- | 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.0.19/Network/Wai/Middleware/Jsonp.hs0000644000000000000000000000632013002336756017554 0ustar0000000000000000{-# LANGUAGE RankNTypes, 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 Network.Wai import Network.Wai.Internal import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 import Blaze.ByteString.Builder (copyByteString) import Blaze.ByteString.Builder.Char8 (fromChar) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mappend) #endif import Control.Monad (join) import Data.Maybe (fromMaybe) import qualified Data.ByteString as S import Network.HTTP.Types (hAccept, hContentType) -- | 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' $ copyByteString c `mappend` fromChar '(' `mappend` b `mappend` fromChar ')' 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 $ copyByteString cb `mappend` fromChar '(' _ <- body sendChunk flush sendChunk $ fromChar ')' changeVal :: Eq a => a -> ByteString -> [(a, ByteString)] -> [(a, ByteString)] changeVal key val old = (key, val) : filter (\(k, _) -> k /= key) old wai-extra-3.0.19/Network/Wai/Middleware/Local.hs0000644000000000000000000000146713002336756017524 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Only allow local connections. -- module Network.Wai.Middleware.Local ( local ) where import Network.Wai (Middleware,remoteHost, Response) import Network.Socket (SockAddr(..)) -- | 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) * 1 wai-extra-3.0.19/Network/Wai/Middleware/MethodOverride.hs0000644000000000000000000000121013002336756021374 0ustar0000000000000000module Network.Wai.Middleware.MethodOverride ( methodOverride ) where import Network.Wai import Control.Monad (join) -- | Allows overriding of the HTTP request method via the _method query string -- parameter. -- -- This middleware only applies when the initial request method is POST. This -- allow submitting of normal HTML forms, without worries of semantics -- mismatches in the HTTP spec. 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.0.19/Network/Wai/Middleware/MethodOverridePost.hs0000644000000000000000000000321713002336756022253 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 Network.Wai import Network.HTTP.Types (parseQuery, hContentType) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat, mempty) #endif import Data.IORef import Data.ByteString.Lazy (toChunks) -- | 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.0.19/Network/Wai/Middleware/RequestLogger.hs0000644000000000000000000003057313002336756021262 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} -- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should -- not use CPP. module Network.Wai.Middleware.RequestLogger ( -- * Basic stdout logging logStdout , logStdoutDev -- * Create more versions , mkRequestLogger , RequestLoggerSettings , outputFormat , autoFlush , destination , OutputFormat (..) , OutputFormatter , OutputFormatterWithDetails , Destination (..) , Callback , IPAddrSource (..) ) where import System.IO (Handle, hFlush, stdout) import qualified Blaze.ByteString.Builder as B import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack, unpack) import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Network.Wai ( Request(..), requestBodyLength, RequestBodyLength(..) , Middleware , Response, responseStatus, responseHeaders ) import System.Log.FastLogger import Network.HTTP.Types as H import Data.Maybe (fromMaybe) import Data.Monoid (mconcat, (<>)) import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File , getRequestBodyType) import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Char8 as S8 import System.Console.ANSI import Data.IORef.Lifted import System.IO.Unsafe import Network.Wai.Internal (Response (..)) import Data.Default.Class (Default (def)) import Network.Wai.Logger import Network.Wai.Middleware.RequestLogger.Internal import Network.Wai.Header (contentLength) import Data.Text.Encoding (decodeUtf8') data OutputFormat = Apache IPAddrSource | Detailed Bool -- ^ use colors? | CustomOutputFormat OutputFormatter | CustomOutputFormatWithDetails OutputFormatterWithDetails type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr type OutputFormatterWithDetails = ZonedDate -> Request -> Status -> Maybe Integer -> NominalDiffTime -> [S8.ByteString] -> B.Builder -> 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 } instance Default RequestLoggerSettings where def = RequestLoggerSettings { outputFormat = Detailed True , autoFlush = True , destination = Handle stdout } 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 ()) case outputFormat of Apache ipsrc -> do getdate <- getDateGetter flusher apache <- initLogger ipsrc (LogCallback callback flusher) getdate return $ apacheMiddleware apache Detailed useColors -> detailedMiddleware (\str -> callback str >> flusher) useColors CustomOutputFormat formatter -> do getDate <- getDateGetter flusher return $ customMiddleware callback getDate formatter CustomOutputFormatWithDetails formatter -> do getdate <- getDateGetter flusher return $ customMiddlewareWithDetails callback getdate formatter apacheMiddleware :: ApacheLoggerActions -> Middleware apacheMiddleware ala app req sendResponse = app req $ \res -> do let msize = contentLength (responseHeaders res) apacheLogger ala req (responseStatus res) msize sendResponse res customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> do date <- liftIO getdate -- We use Nothing for the response size since we generally don't know it liftIO $ cb $ formatter date req (responseStatus res) Nothing 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 -- We use Nothing for the response size since we generally don't know it builderIO <- newIORef $ B.fromByteString "" res' <- recordChunks builderIO res rspRcv <- sendResponse res' _ <- liftIO . cb . formatter date req' (responseStatus res') Nothing (t1 `diffUTCTime` t0) reqBody =<< readIORef builderIO 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 -> Bool -> IO Middleware detailedMiddleware cb useColors = let (ansiColor, ansiMethod, ansiStatusCode) = if useColors then (ansiColor', ansiMethod', ansiStatusCode') else (\_ t -> [t], (:[]), \_ t -> [t]) in return $ detailedMiddleware' cb 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 <- requestBody req if S8.null bs then return $ front [] else loop $ front . (bs:) body <- loop id -- logging the body here consumes it, so fill it back up -- obviously not efficient, but this is the development logger -- -- Note: previously, we simply used CL.sourceList. However, -- that meant that you could read the request body in twice. -- While that in itself is not a problem, the issue is that, -- in production, you wouldn't be able to do this, and -- therefore some bugs wouldn't show up during testing. This -- implementation ensures that each chunk is only returned -- once. ichunks <- newIORef body let rbody = atomicModifyIORef ichunks $ \chunks -> case chunks of [] -> ([], S8.empty) x:y -> (y, x) let req' = req { requestBody = rbody } return (req', body) detailedMiddleware' :: Callback -> (Color -> BS.ByteString -> [BS.ByteString]) -> (BS.ByteString -> [BS.ByteString]) -> (BS.ByteString -> BS.ByteString -> [BS.ByteString]) -> Middleware detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do (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 then [""] else ansiColor White " Request Body: " <> body <> ["\n"] reqbody = concatMap (either (const [""]) reqbodylog . decodeUtf8') body postParams <- if requestMethod req `elem` ["GET", "HEAD"] then return [] else do postParams <- liftIO $ allPostParams body return $ collectPostParams postParams 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 app req' $ \rsp -> do let isRaw = case rsp of ResponseRaw{} -> True _ -> False stCode = statusBS rsp stMsg = msgBS rsp t1 <- getCurrentTime -- log the status of the response cb $ mconcat $ map toLogStr $ ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++ params ++ reqbody ++ ansiColor White " Accept: " ++ [accept, "\n"] ++ if isRaw then [] else ansiColor White " Status: " ++ ansiStatusCode stCode (stCode <> " " <> stMsg) ++ [" ", pack $ show $ diffUTCTime t1 t0, "\n"] 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 statusBS :: Response -> BS.ByteString statusBS = pack . show . statusCode . responseStatus msgBS :: Response -> BS.ByteString msgBS = statusMessage . responseStatus wai-extra-3.0.19/Network/Wai/Middleware/Rewrite.hs0000644000000000000000000003015413002336756020106 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 -- ** Deprecated , rewrite , rewritePure -- * Operating on 'Request's , rewriteRequest , rewriteRequestPure ) where import Network.Wai import Control.Monad.IO.Class (liftIO) import Data.Text (Text) import Data.Functor.Identity (Identity(..)) import qualified Data.Text.Encoding as TE import qualified Data.Text as T import Network.HTTP.Types as H -- GHC ≤ 7.10 does not export Applicative functions from the prelude. #if __GLASGOW_HASKELL__ <= 710 import Control.Applicative #endif -- $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 libary 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 -------------------------------------------------- -- * 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.0.19/Network/Wai/Middleware/Routed.hs0000644000000000000000000000233113002336756017723 0ustar0000000000000000-- | -- -- Since 3.0.9 module Network.Wai.Middleware.Routed ( routedMiddleware , hostedMiddleware ) where import Network.Wai import Data.ByteString (ByteString) import Data.Text (Text) -- | 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.0.19/Network/Wai/Middleware/StreamFile.hs0000644000000000000000000000260013002336756020513 0ustar0000000000000000-- | -- -- Since 3.0.4 module Network.Wai.Middleware.StreamFile (streamFile) where import Network.Wai (responseStream) import Network.Wai.Internal import Network.Wai (Middleware, responseToStream) import qualified Data.ByteString.Char8 as S8 import System.PosixCompat (getFileStatus, fileSize, FileOffset) import Network.HTTP.Types (hContentLength) -- |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 getFileSize :: FilePath -> IO FileOffset getFileSize path = do stat <- getFileStatus path return (fileSize stat) wai-extra-3.0.19/Network/Wai/Middleware/StripHeaders.hs0000644000000000000000000000322313002336756021057 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 Network.Wai (Middleware, Request, modifyResponse, mapResponseHeaders, ifRequest) import Network.Wai.Internal (Response) import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI 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.0.19/Network/Wai/Middleware/Vhost.hs0000644000000000000000000000236313002336756017571 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where import Network.Wai import Network.HTTP.Types as H import qualified Data.Text.Encoding as TE import Data.Text (Text) import qualified Data.ByteString as BS #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mappend) #endif 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.0.19/Network/Wai/Middleware/RequestLogger/0000755000000000000000000000000013002336756020716 5ustar0000000000000000wai-extra-3.0.19/Network/Wai/Middleware/RequestLogger/Internal.hs0000644000000000000000000000164013002336756023027 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 ( module Network.Wai.Middleware.RequestLogger.Internal ) where import Data.ByteString (ByteString) import Network.Wai.Logger (clockDateCacher) #if !MIN_VERSION_wai_logger(2, 2, 0) import Control.Concurrent (forkIO, threadDelay) import Control.Monad (forever) #endif import 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.0.19/Network/Wai/Middleware/RequestLogger/JSON.hs0000644000000000000000000000642213002336756022027 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Network.Wai.Middleware.RequestLogger.JSON (formatAsJSON) where import qualified Blaze.ByteString.Builder as BB import Data.Aeson import Data.CaseInsensitive (original) import Data.Monoid ((<>)) import qualified Data.ByteString.Char8 as S8 import Data.IP import qualified Data.Text as T import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) import Data.Time (NominalDiffTime) import Data.Word (Word32) import Network.HTTP.Types as H import Network.Socket (SockAddr (..), PortNumber) import Network.Wai import Network.Wai.Middleware.RequestLogger import System.Log.FastLogger (toLogStr) import Text.Printf (printf) formatAsJSON :: OutputFormatterWithDetails formatAsJSON date req status responseSize duration reqBody response = toLogStr (encode $ object [ "request" .= requestToJSON duration req reqBody , "response" .= object [ "status" .= statusCode status , "size" .= responseSize , "body" .= if statusCode status >= 400 then Just . decodeUtf8 . BB.toByteString $ response else Nothing ] , "time" .= decodeUtf8 date ]) <> "\n" word32ToHostAddress :: Word32 -> Text word32ToHostAddress = T.intercalate "." . map (T.pack . show) . fromIPv4 . fromHostAddress readAsDouble :: String -> Double readAsDouble = read requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value requestToJSON duration req reqBody = object [ "method" .= decodeUtf8 (requestMethod req) , "path" .= decodeUtf8 (rawPathInfo req) , "queryString" .= map queryItemToJSON (queryString req) , "durationMs" .= (readAsDouble . printf "%.2f" . rationalToDouble $ toRational duration * 1000) , "size" .= requestBodyLengthToJSON (requestBodyLength req) , "body" .= decodeUtf8 (S8.concat reqBody) , "remoteHost" .= sockToJSON (remoteHost req) , "httpVersion" .= httpVersionToJSON (httpVersion req) , "headers" .= requestHeadersToJSON (requestHeaders req) ] 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 ] sockToJSON (SockAddrCan i) = object [ "can" .= i ] queryItemToJSON :: QueryItem -> Value queryItemToJSON (name, mValue) = toJSON (decodeUtf8 name, fmap decodeUtf8 mValue) requestHeadersToJSON :: RequestHeaders -> Value requestHeadersToJSON = toJSON . map hToJ where -- Redact cookies hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text) hToJ hd = headerToJSON hd headerToJSON :: Header -> Value headerToJSON (headerName, header) = toJSON (decodeUtf8 . original $ headerName, decodeUtf8 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.0.19/test/0000755000000000000000000000000013002336756012657 5ustar0000000000000000wai-extra-3.0.19/test/json0000644000000000000000000000003513002336756013551 0ustar0000000000000000{"data":"this is some data"} wai-extra-3.0.19/test/sample.hs0000644000000000000000000000164613002336756014503 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.0.19/test/Spec.hs0000644000000000000000000000005413002336756014104 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} wai-extra-3.0.19/test/test.html0000644000000000000000000000060113002336756014521 0ustar0000000000000000 There should be some content loaded below:
wai-extra-3.0.19/test/WaiExtraSpec.hs0000644000000000000000000003457313002336756015566 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module WaiExtraSpec (spec, toRequest) where import Test.Hspec import Test.HUnit hiding (Test) #if MIN_VERSION_base(4,8,0) import Data.Monoid ((<>)) #else import Data.Monoid (mempty, mappend, (<>)) #endif import Network.Wai import Network.Wai.Test import Network.Wai.UrlMap import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.Text.Lazy as T import qualified Data.Text as TS import qualified Data.Text.Encoding as TE import Control.Applicative import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Vhost import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.MethodOverride import Network.Wai.Middleware.MethodOverridePost import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.RequestLogger import Codec.Compression.GZip (decompress) import Network.Wai.Middleware.StreamFile import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) import Network.HTTP.Types (status200) import System.Log.FastLogger import qualified Data.IORef as I 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 it "gzip" caseGzip it "gzip not for MSIE" caseGzipMSIE it "gzip bypass when precompressed" caseGzipBypassPre it "defaultCheckMime" caseDefaultCheckMime it "vhost" caseVhost it "autohead" caseAutohead it "method override" caseMethodOverride it "method override post" caseMethodOverridePost it "accept override" caseAcceptOverride it "debug request body" caseDebugRequestBody it "stream file" caseStreamFile it "stream LBS" caseStreamLBS 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 = flip runSession jsonpApp $ do sres1 <- request defaultRequest { queryString = [("callback", Just "test")] , requestHeaders = [("Accept", "text/javascript")] } assertContentType "text/javascript" sres1 assertBody "test({\"foo\":\"bar\"})" sres1 sres2 <- request defaultRequest { queryString = [("call_back", Just "test")] , requestHeaders = [("Accept", "text/javascript")] } assertContentType "application/json" sres2 assertBody "{\"foo\":\"bar\"}" sres2 sres3 <- request defaultRequest { queryString = [("callback", Just "test")] , requestHeaders = [("Accept", "text/html")] } assertContentType "application/json" sres3 assertBody "{\"foo\":\"bar\"}" sres3 gzipApp :: Application gzipApp = gzip def $ \_ f -> f $ responseLBS status200 [("Content-Type", "text/plain")] "test" -- Lie a little and don't compress the body. This way we test -- that the compression is skipped based on the presence of -- the Content-Encoding header. gzipPrecompressedApp :: Application gzipPrecompressedApp = gzip def $ \_ f -> f $ responseLBS status200 [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")] "test" caseGzip :: Assertion caseGzip = flip runSession gzipApp $ do sres1 <- request defaultRequest { requestHeaders = [("Accept-Encoding", "gzip")] } assertHeader "Content-Encoding" "gzip" sres1 liftIO $ decompress (simpleBody sres1) @?= "test" sres2 <- request defaultRequest { requestHeaders = [] } assertNoHeader "Content-Encoding" sres2 assertBody "test" sres2 caseDefaultCheckMime :: Assertion caseDefaultCheckMime = do let go x y = (x, defaultCheckMime x) `shouldBe` (x, y) go "application/json" True go "application/javascript" True go "application/something" False go "text/something" True go "foo/bar" False go "application/json; charset=utf-8" True caseGzipMSIE :: Assertion caseGzipMSIE = flip runSession gzipApp $ do sres1 <- request defaultRequest { requestHeaders = [ ("Accept-Encoding", "gzip") , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)") ] } assertNoHeader "Content-Encoding" sres1 liftIO $ simpleBody sres1 @?= "test" caseGzipBypassPre :: Assertion caseGzipBypassPre = flip runSession gzipPrecompressedApp $ do sres1 <- request defaultRequest { requestHeaders = [("Accept-Encoding", "gzip")] } assertHeader "Content-Encoding" "gzip" sres1 assertBody "test" sres1 -- the body is not actually compressed vhostApp1, vhostApp2, vhostApp :: Application vhostApp1 _ f = f $ responseLBS status200 [] "app1" vhostApp2 _ f = f $ responseLBS status200 [] "app2" vhostApp = vhost [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1) ] vhostApp2 caseVhost :: Assertion caseVhost = flip runSession 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 = flip runSession autoheadApp $ do sres1 <- request defaultRequest { requestMethod = "GET" } assertHeader "Foo" "Bar" sres1 assertBody "body" sres1 sres2 <- request defaultRequest { requestMethod = "HEAD" } assertHeader "Foo" "Bar" sres2 assertBody "" sres2 moApp :: Application moApp = methodOverride $ \req f -> f $ responseLBS status200 [("Method", requestMethod req)] "" caseMethodOverride :: Assertion caseMethodOverride = flip runSession moApp $ do sres1 <- request defaultRequest { requestMethod = "GET" , queryString = [] } assertHeader "Method" "GET" sres1 sres2 <- request defaultRequest { requestMethod = "POST" , queryString = [] } assertHeader "Method" "POST" sres2 sres3 <- request defaultRequest { requestMethod = "POST" , queryString = [("_method", Just "PUT")] } assertHeader "Method" "PUT" sres3 mopApp :: Application mopApp = methodOverridePost $ \req f -> f $ responseLBS status200 [("Method", requestMethod req)] "" caseMethodOverridePost :: Assertion caseMethodOverridePost = flip runSession mopApp $ do -- Get Request are unmodified sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin" s = simpleRequest r m = s { requestMethod = "GET" } b = r { simpleRequest = m } in srequest b assertHeader "Method" "GET" sres1 -- Post requests are modified if _method comes first sres2 <- srequest $ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin" assertHeader "Method" "PUT" sres2 -- Post requests are unmodified if _method doesn't come first sres3 <- srequest $ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin" assertHeader "Method" "POST" sres3 -- Post requests are unmodified if Content-Type header isn't set to "application/x-www-form-urlencoded" sres4 <- srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin" assertHeader "Method" "POST" sres4 aoApp :: Application aoApp = acceptOverride $ \req f -> f $ responseLBS status200 [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] "" caseAcceptOverride :: Assertion caseAcceptOverride = flip runSession aoApp $ do sres1 <- request defaultRequest { queryString = [] , requestHeaders = [("Accept", "foo")] } assertHeader "Accept" "foo" sres1 sres2 <- request defaultRequest { queryString = [] , requestHeaders = [("Accept", "bar")] } assertHeader "Accept" "bar" sres2 sres3 <- request defaultRequest { queryString = [("_accept", Just "baz")] , requestHeaders = [("Accept", "bar")] } assertHeader "Accept" "baz" sres3 caseDebugRequestBody :: Assertion caseDebugRequestBody = do flip runSession (debugApp postOutput) $ do let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin" res <- srequest req assertStatus 200 res let qs = "?foo=bar&baz=bin" flip runSession (debugApp $ getOutput params) $ do assertStatus 200 =<< request defaultRequest { requestMethod = "GET" , queryString = map (\(k,v) -> (k, Just v)) params , rawQueryString = qs , requestHeaders = [] , rawPathInfo = "/location" } where params = [("foo", "bar"), ("baz", "bin")] -- 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 = flip runSession 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 = flip runSession streamLBSApp $ do sres <- request defaultRequest assertStatus 200 sres assertBody "test" sres wai-extra-3.0.19/test/Network/0000755000000000000000000000000013002336755014307 5ustar0000000000000000wai-extra-3.0.19/test/Network/Wai/0000755000000000000000000000000013002336756015030 5ustar0000000000000000wai-extra-3.0.19/test/Network/Wai/ParseSpec.hs0000644000000000000000000002761313002336756017262 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.ParseSpec (main, spec) where import Test.Hspec import Test.HUnit import System.IO import Data.Monoid import qualified Data.IORef as I import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.Text as TS import qualified Data.Text.Encoding as TE import Control.Monad.Trans.Resource (withInternalState, runResourceT) import Network.Wai import Network.Wai.Test import Network.Wai.Parse 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")]) ] 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` anyErrorCall it "exceeding total file size" $ do SRequest req4 _bod4 <- toRequest'' ctype3 content3 (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall SRequest req5 _bod5 <- toRequest'' ctype3 content5 (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req5) `shouldThrow` anyErrorCall it "exceeding max parm value size" $ do SRequest req4 _bod4 <- toRequest'' ctype2 content2 (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall 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` anyErrorCall it "Testing parseRequestBodyEx with application/x-www-form-urlencoded" $ do let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou" let ctype = "application/x-www-form-urlencoded" SRequest req _bod <- toRequest'' ctype content result <- parseRequestBodyEx def lbsBackEnd req result `shouldBe` ([( "thisisalongparameterkey" , "andthisbeanevenlongerparametervaluehelloworldhowareyou" )], []) it "exceeding max parm value size with x-www-form-urlencoded mimetype" $ do let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou" let ctype = "application/x-www-form-urlencoded" SRequest req _bod <- toRequest'' ctype content (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req) `shouldThrow` 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.0.19/test/Network/Wai/RequestSpec.hs0000644000000000000000000000636513002336756017641 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.RequestSpec ( main , spec ) where import Test.Hspec import Data.ByteString (ByteString) import Network.HTTP.Types (HeaderName) import Network.Wai (Request(..), defaultRequest, RequestBodyLength(..)) import Network.Wai.Request import Control.Exception (try) import Control.Monad (forever) 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.0.19/test/Network/Wai/TestSpec.hs0000644000000000000000000001605413002336756017124 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.TestSpec (main, spec) where import Control.Monad (void) import qualified Data.Text.Encoding as TE import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime(..)) import Test.Hspec import Network.Wai import Network.Wai.Test import Network.HTTP.Types (status200) import qualified Data.ByteString.Lazy.Char8 as L8 import Blaze.ByteString.Builder (toByteString) import qualified Web.Cookie as Cookie main :: IO () main = hspec spec 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 "request" $ do let simpleApp _req respond = respond $ responseLBS status200 [("foo", "bar")] "simple" it "returns the status code of a simple app on default request" $ do sresp <- runSession (request defaultRequest) simpleApp simpleStatus sresp `shouldBe` status200 it "returns the response body of a simple app on default request" $ do sresp <- runSession (request defaultRequest) simpleApp simpleBody sresp `shouldBe` "simple" it "returns the response headers of a simple app on default request" $ do sresp <- runSession (request defaultRequest) simpleApp 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.0.19/test/Network/Wai/Middleware/0000755000000000000000000000000013002336756017105 5ustar0000000000000000wai-extra-3.0.19/test/Network/Wai/Middleware/ApprootSpec.hs0000644000000000000000000000211413002336756021676 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.ApprootSpec ( main , spec ) where import Test.Hspec import Network.Wai.Middleware.Approot import Network.Wai.Test import Network.Wai import Network.HTTP.Types import Data.ByteString (ByteString) 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.0.19/test/Network/Wai/Middleware/ForceSSLSpec.hs0000644000000000000000000000354213002336756021700 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.ForceSSLSpec ( main , spec ) where import Test.Hspec import Network.Wai.Middleware.ForceSSL import Control.Monad import Data.ByteString (ByteString) import Data.Monoid ((<>)) import Network.HTTP.Types (methodPost, status200, status301, status307) import Network.Wai 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.0.19/test/Network/Wai/Middleware/RoutedSpec.hs0000644000000000000000000000271413002336756021522 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.RoutedSpec ( main , spec ) where import Test.Hspec import Network.Wai.Middleware.Routed import Network.Wai.Middleware.ForceSSL (forceSSL) import Network.HTTP.Types (hContentType, status200) import Network.Wai import Network.Wai.Test import Data.ByteString (ByteString) import Data.String (IsString) 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.0.19/test/Network/Wai/Middleware/StripHeadersSpec.hs0000644000000000000000000000363713002336756022662 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.StripHeadersSpec ( main , spec ) where import Test.Hspec import Network.Wai.Middleware.AddHeaders import Network.Wai.Middleware.StripHeaders import Control.Arrow (first) import Data.ByteString (ByteString) import Data.Monoid ((<>)) import Network.HTTP.Types (status200) import Network.Wai import Network.Wai.Test import qualified Data.CaseInsensitive as CI 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.0.19/test/requests/0000755000000000000000000000000013002336756014532 5ustar0000000000000000wai-extra-3.0.19/test/requests/dalvik-request0000644000000000000000000002760613002336756017430 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 --*****--