wai-extra-3.0.13.1/0000755000000000000000000000000012640677145012040 5ustar0000000000000000wai-extra-3.0.13.1/ChangeLog.md0000644000000000000000000000315012640677145014210 0ustar0000000000000000## 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.13.1/LICENSE0000644000000000000000000000207512640677145013051 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.13.1/README.md0000644000000000000000000000012512640677145013315 0ustar0000000000000000## wai-extra The goal here is to provide common features without many dependencies. wai-extra-3.0.13.1/Setup.lhs0000644000000000000000000000016212640677145013647 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain wai-extra-3.0.13.1/wai-extra.cabal0000644000000000000000000001432112640677145014726 0ustar0000000000000000Name: wai-extra Version: 3.0.13.1 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.8 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 && < 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.1 && < 2.5 , wai-logger >= 2.0 && < 2.3 , 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 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.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 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 source-repository head type: git location: git://github.com/yesodweb/wai.git wai-extra-3.0.13.1/Network/0000755000000000000000000000000012640677145013471 5ustar0000000000000000wai-extra-3.0.13.1/Network/Wai/0000755000000000000000000000000012640677145014211 5ustar0000000000000000wai-extra-3.0.13.1/Network/Wai/EventSource.hs0000644000000000000000000000233512640677145017012 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.13.1/Network/Wai/Header.hs0000644000000000000000000000102212640677145015730 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.13.1/Network/Wai/Parse.hs0000644000000000000000000003445612640677145015633 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 , BackEnd , lbsBackEnd , tempFileBackEnd , tempFileBackEndOpts , Param , File , FileInfo (..) , parseContentType #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.Maybe (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.Monad (when, unless) import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState) import Data.IORef import Network.HTTP.Types (hContentType) 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 'tempFileSink', 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 pattern internalState _ _ popper = do (key, (fp, h)) <- flip runInternalState internalState $ allocate (do tempDir <- getTmpDir openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h) _ <- runInternalState (register $ removeFile fp) internalState fix $ \loop -> do bs <- popper unless (S.null bs) $ do S.hPut h bs loop release key return fp -- | 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 data RequestBodyType = UrlEncoded | Multipart S.ByteString 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) parseRequestBody :: BackEnd y -> Request -> IO ([Param], [File y]) parseRequestBody s r = case getRequestBodyType r of Nothing -> return ([], []) Just rbt -> sinkRequestBody s rbt (requestBody r) sinkRequestBody :: BackEnd y -> RequestBodyType -> IO S.ByteString -> IO ([Param], [File y]) sinkRequestBody s r body = do ref <- newIORef (id, id) let add x = atomicModifyIORef ref $ \(y, z) -> case x of Left y' -> ((y . (y':), z), ()) Right z' -> ((y, z . (z':)), ()) conduitRequestBody s r body add (x, y) <- readIORef ref return (x [], y []) conduitRequestBody :: BackEnd y -> RequestBodyType -> IO S.ByteString -> (Either Param (File y) -> IO ()) -> IO () conduitRequestBody _ 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 front = do bs <- rbody if S.null bs then return $ S.concat $ front [] else loop $ front . (bs:) bs <- loop id mapM_ (add . Left) $ H.parseSimpleQuery bs conduitRequestBody backend (Multipart bound) rbody add = parsePieces backend (S8.pack "--" `S.append` bound) rbody add takeLine :: Source -> IO (Maybe S.ByteString) takeLine src = go id where go front = do bs <- readSource src if S.null bs then close front else push front bs close front = leftover src (front S.empty) >> return Nothing push front bs = do let (x, y) = S.break (== 10) $ front bs -- LF in if S.null y then go $ S.append x else do when (S.length y > 1) $ leftover src $ S.drop 1 y return $ Just $ killCR x takeLines :: Source -> IO [S.ByteString] takeLines src = do res <- takeLine src case res of Nothing -> return [] Just l | S.null l -> return [] | otherwise -> do ls <- takeLines src return $ l : ls 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 parsePieces :: BackEnd y -> S.ByteString -> IO S.ByteString -> (Either Param (File y) -> IO ()) -> IO () parsePieces sink bound rbody add = mkSource rbody >>= loop where loop src = do _boundLine <- takeLine src res' <- takeLines 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 let ct = fromMaybe "application/octet-stream" mct fi0 = FileInfo filename ct () (wasFound, y) <- sinkTillBound' bound name fi0 sink src add $ Right (name, fi0 { fileContent = y }) when wasFound (loop src) Just (_ct, name, Nothing) -> do let seed = id let iter front bs = return $ front . (:) bs (wasFound, front) <- sinkTillBound bound iter seed src let bs = S.concat $ front [] let x' = (name, bs) add $ Left x' when wasFound (loop src) _ -> do -- ignore this part let seed = () iter () _ = return () (wasFound, ()) <- sinkTillBound bound iter seed src when wasFound (loop src) where contDisp = S8.pack "Content-Disposition" contType = S8.pack "Content-Type" parsePair s = let (x, y) = breakDiscard 58 s -- colon in (x, S.dropWhile (== 32) y) -- space 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 -> IO (Bool, y) sinkTillBound' bound name fi sink src = do (next, final) <- wrapTillBound bound src y <- sink name fi next b <- final return (b, y) data WTB = WTBWorking (S.ByteString -> S.ByteString) | WTBDone Bool wrapTillBound :: S.ByteString -- ^ bound -> Source -> IO (IO S.ByteString, IO Bool) -- ^ Bool indicates if the bound was found wrapTillBound bound src = do ref <- newIORef $ WTBWorking id return (go ref, final ref) where final ref = do x <- readIORef ref case x of WTBWorking _ -> error "wrapTillBound did not finish" WTBDone y -> return y go ref = do state <- readIORef ref case state of WTBDone _ -> return S.empty WTBWorking front -> do bs <- readSource src if S.null bs then do writeIORef ref $ WTBDone False return $ front bs else push $ front bs where push bs = 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 else return toEmit PartialBound -> do writeIORef ref $ WTBWorking $ S.append bs go ref sinkTillBound :: S.ByteString -> (x -> S.ByteString -> IO x) -> x -> Source -> IO (Bool, x) sinkTillBound bound iter seed0 src = do (next, final) <- wrapTillBound bound src 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.13.1/Network/Wai/Request.hs0000644000000000000000000000374112640677145016202 0ustar0000000000000000-- | Some helpers for interrogating a WAI 'Request'. module Network.Wai.Request ( appearsSecure , guessApproot ) where import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Network.HTTP.Types (HeaderName) import Network.Wai (Request, isSecure, requestHeaders, requestHeaderHost) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C -- | 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) wai-extra-3.0.13.1/Network/Wai/Test.hs0000644000000000000000000002416512640677145015474 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.13.1/Network/Wai/UrlMap.hs0000644000000000000000000000625012640677145015750 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.13.1/Network/Wai/EventSource/0000755000000000000000000000000012640677145016453 5ustar0000000000000000wai-extra-3.0.13.1/Network/Wai/EventSource/EventStream.hs0000644000000000000000000000373512640677145021254 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.13.1/Network/Wai/Handler/0000755000000000000000000000000012640677145015566 5ustar0000000000000000wai-extra-3.0.13.1/Network/Wai/Handler/CGI.hs0000644000000000000000000001624212640677145016531 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 } 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.13.1/Network/Wai/Handler/SCGI.hs0000644000000000000000000000560012640677145016650 0ustar0000000000000000{-# LANGUAGE 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 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 wai-extra-3.0.13.1/Network/Wai/Middleware/0000755000000000000000000000000012640677145016266 5ustar0000000000000000wai-extra-3.0.13.1/Network/Wai/Middleware/AcceptOverride.hs0000644000000000000000000000117212640677145021522 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.13.1/Network/Wai/Middleware/AddHeaders.hs0000644000000000000000000000122212640677145020603 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.13.1/Network/Wai/Middleware/Approot.hs0000644000000000000000000001063212640677145020250 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.13.1/Network/Wai/Middleware/Autohead.hs0000644000000000000000000000104012640677145020347 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.13.1/Network/Wai/Middleware/CleanPath.hs0000644000000000000000000000201312640677145020455 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.13.1/Network/Wai/Middleware/ForceSSL.hs0000644000000000000000000000216012640677145020241 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) import qualified Data.ByteString as S import Data.Word8 (_colon) -- | 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, _) <- S.break (== _colon) <$> 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.13.1/Network/Wai/Middleware/Gzip.hs0000644000000000000000000001753612640677145017547 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 } data GzipFiles = GzipIgnore | GzipCompress | GzipCacheFolder FilePath deriving (Show, Eq, Read) instance Default GzipSettings where def = GzipSettings GzipIgnore defaultCheckMime 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" ] -- | Use gzip to compress the body of the response. -- -- Analyzes the \"Accept-Encoding\" header from the client to determine -- if gzip is supported. -- -- Possible future enhancements: -- -- * Only compress if the response is above a certain size. gzip :: GzipSettings -> Middleware gzip set app env 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 case (res, gzipFiles set) of (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 _ -> compressE set res sendResponse 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.13.1/Network/Wai/Middleware/HttpAuth.hs0000644000000000000000000000726412640677145020374 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 , 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 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 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.13.1/Network/Wai/Middleware/Jsonp.hs0000644000000000000000000000632012640677145017714 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.13.1/Network/Wai/Middleware/Local.hs0000644000000000000000000000146712640677145017664 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.13.1/Network/Wai/Middleware/MethodOverride.hs0000644000000000000000000000121012640677145021534 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.13.1/Network/Wai/Middleware/MethodOverridePost.hs0000644000000000000000000000321712640677145022413 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.13.1/Network/Wai/Middleware/RequestLogger.hs0000644000000000000000000003040512640677145021414 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. {-# NOINLINE logStdout #-} logStdout :: Middleware logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket } -- | Development request logger middleware. -- -- Flushes 'stdout' on each request, which would be inefficient in production use. -- Use "logStdout" in production. {-# 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.13.1/Network/Wai/Middleware/Rewrite.hs0000644000000000000000000000230512640677145020243 0ustar0000000000000000module Network.Wai.Middleware.Rewrite ( rewrite, rewritePure ) where import Network.Wai import Control.Monad.IO.Class (liftIO) import Data.Text (Text) import qualified Data.Text.Encoding as TE import qualified Data.Text as T import Network.HTTP.Types as H -- | rewrite based on your own conversion rules rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware rewrite convert app req sendResponse = do newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req) let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo } sendResponse -- | rewrite based on your own conversion rules -- Example convert function: -- staticConvert :: [Text] -> H.RequestHeaders -> [Text] -- staticConvert pieces _ = piecesConvert pieces -- where -- piecesConvert [] = ["static", "html", "pages.html"] -- piecesConvert route@("pages":_) = "static":"html":route rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware rewritePure convert app req = let pInfo = convert (pathInfo req) (requestHeaders req) rawPInfo = TE.encodeUtf8 $ T.intercalate "/" pInfo in app req { pathInfo = pInfo, rawPathInfo = rawPInfo } wai-extra-3.0.13.1/Network/Wai/Middleware/Routed.hs0000644000000000000000000000233112640677145020063 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.13.1/Network/Wai/Middleware/StreamFile.hs0000644000000000000000000000260012640677145020653 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.13.1/Network/Wai/Middleware/StripHeaders.hs0000644000000000000000000000322312640677145021217 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.13.1/Network/Wai/Middleware/Vhost.hs0000644000000000000000000000236312640677145017731 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.13.1/Network/Wai/Middleware/RequestLogger/0000755000000000000000000000000012640677145021056 5ustar0000000000000000wai-extra-3.0.13.1/Network/Wai/Middleware/RequestLogger/Internal.hs0000644000000000000000000000164012640677145023167 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.13.1/Network/Wai/Middleware/RequestLogger/JSON.hs0000644000000000000000000000642212640677145022167 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.13.1/test/0000755000000000000000000000000012640677145013017 5ustar0000000000000000wai-extra-3.0.13.1/test/json0000644000000000000000000000003512640677145013711 0ustar0000000000000000{"data":"this is some data"} wai-extra-3.0.13.1/test/sample.hs0000644000000000000000000000164612640677145014643 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.13.1/test/Spec.hs0000644000000000000000000000005412640677145014244 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} wai-extra-3.0.13.1/test/test.html0000644000000000000000000000060112640677145014661 0ustar0000000000000000 There should be some content loaded below:
wai-extra-3.0.13.1/test/WaiExtraSpec.hs0000644000000000000000000003457312640677145015726 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.13.1/test/Network/0000755000000000000000000000000012640677145014450 5ustar0000000000000000wai-extra-3.0.13.1/test/Network/Wai/0000755000000000000000000000000012640677145015170 5ustar0000000000000000wai-extra-3.0.13.1/test/Network/Wai/ParseSpec.hs0000644000000000000000000001741512640677145017421 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) 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 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" 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) wai-extra-3.0.13.1/test/Network/Wai/RequestSpec.hs0000644000000000000000000000345112640677145017772 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) import Network.Wai.Request main :: IO () main = hspec spec spec :: Spec spec = 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.13.1/test/Network/Wai/TestSpec.hs0000644000000000000000000001605412640677145017264 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.13.1/test/Network/Wai/Middleware/0000755000000000000000000000000012640677145017245 5ustar0000000000000000wai-extra-3.0.13.1/test/Network/Wai/Middleware/ApprootSpec.hs0000644000000000000000000000211412640677145022036 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.13.1/test/Network/Wai/Middleware/ForceSSLSpec.hs0000644000000000000000000000323412640677145022036 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.ForceSSLSpec ( main , spec ) where import Test.Hspec import Network.Wai.Middleware.ForceSSL 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" $ do let host = "example.com" 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 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 <> ":80" }) $ mw app where app _ respond = respond $ responseLBS status200 [] "" wai-extra-3.0.13.1/test/Network/Wai/Middleware/RoutedSpec.hs0000644000000000000000000000271412640677145021662 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.13.1/test/Network/Wai/Middleware/StripHeadersSpec.hs0000644000000000000000000000363712640677145023022 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.13.1/test/requests/0000755000000000000000000000000012640677145014672 5ustar0000000000000000wai-extra-3.0.13.1/test/requests/dalvik-request0000644000000000000000000002760612640677145017570 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 --*****--