wai-extra-1.3.3.2/0000755000000000000000000000000012123513424011742 5ustar0000000000000000wai-extra-1.3.3.2/wai-extra.cabal0000644000000000000000000000702012123513424014626 0ustar0000000000000000Name: wai-extra Version: 1.3.3.2 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. 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: tests.hs test/requests/dalvik-request test/json test/test.html test/sample.hs test/WaiExtraTest.hs Library Build-Depends: base >= 4 && < 5 , bytestring >= 0.9.1.4 , wai >= 1.3 && < 1.5 , old-locale >= 1.0.0.2 && < 1.1 , time >= 1.1.4 , network >= 2.2.1.5 , directory >= 1.0.1 , transformers >= 0.2.2 && < 0.4 , blaze-builder >= 0.2.1.4 && < 0.4 , http-types >= 0.7 , text >= 0.7 && < 0.12 , case-insensitive >= 0.2 , data-default , date-cache >= 0.3 && < 0.4 , fast-logger >= 0.2 && < 0.4 , wai-logger >= 0.2 && < 0.4 , conduit >= 0.5 && < 1.1 , zlib-conduit >= 0.5 && < 1.1 , blaze-builder-conduit >= 0.5 && < 1.1 , ansi-terminal , resourcet >= 0.3 && < 0.5 , void >= 0.5 , stringsearch >= 0.3 && < 0.4 , containers Exposed-modules: Network.Wai.Handler.CGI Network.Wai.Middleware.AcceptOverride Network.Wai.Middleware.Autohead Network.Wai.Middleware.CleanPath Network.Wai.Middleware.RequestLogger Network.Wai.Middleware.Gzip Network.Wai.Middleware.Jsonp Network.Wai.Middleware.MethodOverride Network.Wai.Middleware.MethodOverridePost Network.Wai.Middleware.Rewrite Network.Wai.Middleware.Vhost Network.Wai.Parse ghc-options: -Wall test-suite tests hs-source-dirs: test main-is: ../tests.hs type: exitcode-stdio-1.0 build-depends: base >= 4 && < 5 , wai-extra , wai-test >= 1.3 , hspec >= 1.3 , HUnit , wai , http-types , transformers , zlib , text , bytestring , directory , zlib-bindings , blaze-builder >= 0.2.1.4 && < 0.4 , data-default , conduit , fast-logger ghc-options: -Wall source-repository head type: git location: git://github.com/yesodweb/wai.git wai-extra-1.3.3.2/LICENSE0000644000000000000000000000207512123513424012753 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-1.3.3.2/tests.hs0000644000000000000000000000014712123513424013442 0ustar0000000000000000import Test.Hspec.Monadic import qualified WaiExtraTest main :: IO () main = hspec WaiExtraTest.specs wai-extra-1.3.3.2/Setup.lhs0000644000000000000000000000016212123513424013551 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain wai-extra-1.3.3.2/Network/0000755000000000000000000000000012123513424013373 5ustar0000000000000000wai-extra-1.3.3.2/Network/Wai/0000755000000000000000000000000012123513424014113 5ustar0000000000000000wai-extra-1.3.3.2/Network/Wai/Parse.hs0000644000000000000000000003403612123513424015527 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# 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 , conduitRequestBody , 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) import System.Directory (removeFile, getTemporaryDirectory) import System.IO (hClose, openBinaryTempFile) import Network.Wai import Data.Conduit import Data.Conduit.Internal (sinkToPipe) import qualified Data.Conduit.List as CL import qualified Data.Conduit.Binary as CB import Control.Monad.IO.Class (liftIO) import qualified Network.HTTP.Types as H import Data.Either (partitionEithers) import Control.Monad (when, unless) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Resource (allocate, release, register) #if MIN_VERSION_conduit(1, 0, 0) import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, Sink (..), injectLeftovers, ConduitM (..)) import Data.Void (Void) #endif 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 -> Sink S.ByteString m L.ByteString lbsBackEnd _ _ = fmap L.fromChunks CL.consume -- | Save uploaded files on disk as temporary files tempFileBackEnd :: MonadResource m => ignored1 -> ignored2 -> Sink S.ByteString m FilePath tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf" -- | Same as 'tempFileSink', but use configurable temp folders and patterns. tempFileBackEndOpts :: MonadResource m => IO FilePath -- ^ get temporary directory -> String -- ^ filename pattern -> ignored1 -> ignored2 -> Sink S.ByteString m FilePath tempFileBackEndOpts getTmpDir pattern _ _ = do (key, (fp, h)) <- lift $ allocate (do tempDir <- getTmpDir openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h) _ <- lift $ register $ removeFile fp CB.sinkHandle h lift $ release key 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 content -- type, and returns a `Sink` for storing the contents. type BackEnd a = S.ByteString -- ^ parameter name -> FileInfo () -> Sink S.ByteString (ResourceT IO) a data RequestBodyType = UrlEncoded | Multipart S.ByteString getRequestBodyType :: Request -> Maybe RequestBodyType getRequestBodyType req = do ctype' <- lookup "Content-Type" $ 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 -> ResourceT IO ([Param], [File y]) parseRequestBody s r = case getRequestBodyType r of Nothing -> return ([], []) Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume sinkRequestBody :: BackEnd y -> RequestBodyType -> Sink S.ByteString (ResourceT IO) ([Param], [File y]) sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume conduitRequestBody :: BackEnd y -> RequestBodyType -> Conduit S.ByteString (ResourceT IO) (Either Param (File y)) conduitRequestBody _ UrlEncoded = do -- NOTE: in general, url-encoded data will be in a single chunk. -- Therefore, I'm optimizing for the usual case by sticking with -- strict byte strings here. bs <- CL.consume mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs conduitRequestBody backend (Multipart bound) = parsePieces backend $ S8.pack "--" `S.append` bound #if MIN_VERSION_conduit(1, 0, 0) takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString) #else takeLine :: Monad m => Pipe S.ByteString S.ByteString o u m (Maybe S.ByteString) #endif takeLine = go id where go front = await >>= maybe (close front) (push front) close front = leftover (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 $ S.drop 1 y return $ Just $ killCR x #if MIN_VERSION_conduit(1, 0, 0) takeLines :: Consumer S.ByteString (ResourceT IO) [S.ByteString] #else takeLines :: Pipe S.ByteString S.ByteString o u (ResourceT IO) [S.ByteString] #endif takeLines = do res <- takeLine case res of Nothing -> return [] Just l | S.null l -> return [] | otherwise -> do ls <- takeLines return $ l : ls parsePieces :: BackEnd y -> S.ByteString #if MIN_VERSION_conduit(1, 0, 0) -> ConduitM S.ByteString (Either Param (File y)) (ResourceT IO) () #else -> Pipe S.ByteString S.ByteString (Either Param (File y)) u (ResourceT IO) () #endif parsePieces sink bound = loop where loop = do _boundLine <- takeLine res' <- takeLines 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 yield $ Right (name, fi0 { fileContent = y }) when wasFound loop Just (_ct, name, Nothing) -> do let seed = id let iter front bs = return $ front . (:) bs (wasFound, front) <- sinkTillBound bound iter seed let bs = S.concat $ front [] let x' = (name, bs) yield $ Left x' when wasFound loop _ -> do -- ignore this part let seed = () iter () _ = return () (wasFound, ()) <- sinkTillBound bound iter seed when wasFound loop 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 #if MIN_VERSION_conduit(1, 0, 0) -> ConduitM S.ByteString o (ResourceT IO) (Bool, y) #else -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, y) #endif sinkTillBound' bound name fi sink = #if MIN_VERSION_conduit(1, 0, 0) ConduitM $ anyOutput $ #endif conduitTillBound bound >+> withUpstream (fix $ sink name fi) where #if MIN_VERSION_conduit(1, 0, 0) fix :: Sink S8.ByteString (ResourceT IO) y -> Pipe Void S8.ByteString Void Bool (ResourceT IO) y fix (ConduitM p) = ignoreTerm >+> injectLeftovers p ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm) await' = NeedInput (return . Just) (const $ return Nothing) yield' = HaveOutput (return ()) (return ()) anyOutput p = p >+> dropInput dropInput = NeedInput (const dropInput) return #else fix = sinkToPipe #endif conduitTillBound :: Monad m => S.ByteString -- bound #if MIN_VERSION_conduit(1, 0, 0) -> Pipe S.ByteString S.ByteString S.ByteString () m Bool #else -> Pipe S.ByteString S.ByteString S.ByteString u m Bool #endif conduitTillBound bound = #if MIN_VERSION_conduit(1, 0, 0) unConduitM $ #endif go id where go front = await >>= maybe (close front) (push front) close front = do let bs = front S.empty unless (S.null bs) $ yield bs return False push front bs' = do let bs = front bs' case findBound bound bs of FoundBound before after -> do let before' = killCRLF before yield before' leftover after return True NoBound -> do -- don't emit newlines, in case it's part of a bound let (toEmit, front') = if not (S8.null bs) && S8.last bs `elem` "\r\n" then let (x, y) = S.splitAt (S.length bs - 2) bs in (x, S.append y) else (bs, id) yield toEmit go front' PartialBound -> go $ S.append bs sinkTillBound :: S.ByteString -> (x -> S.ByteString -> IO x) -> x #if MIN_VERSION_conduit(1, 0, 0) -> Consumer S.ByteString (ResourceT IO) (Bool, x) #else -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, x) #endif sinkTillBound bound iter seed0 = #if MIN_VERSION_conduit(1, 0, 0) ConduitM $ #endif (conduitTillBound bound >+> (withUpstream $ ij $ CL.foldM iter' seed0)) where iter' a b = liftIO $ iter a b #if MIN_VERSION_conduit(1, 0, 0) ij (ConduitM p) = ignoreTerm >+> injectLeftovers p ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm) await' = NeedInput (return . Just) (const $ return Nothing) yield' = HaveOutput (return ()) (return ()) #else ij = id #endif 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-1.3.3.2/Network/Wai/Handler/0000755000000000000000000000000012123513424015470 5ustar0000000000000000wai-extra-1.3.3.2/Network/Wai/Handler/CGI.hs0000644000000000000000000001544612123513424016440 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE 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.Socket (getAddrInfo, addrAddress) import System.Environment (getEnvironment) 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 Data.Monoid (mconcat, mempty) import Blaze.ByteString.Builder (fromByteString, toLazyByteString) import Blaze.ByteString.Builder.Char8 (fromChar, fromString) import Data.Conduit.Blaze (builderToByteStringFlush) import Control.Monad.IO.Class (liftIO) import Data.ByteString.Lazy.Internal (defaultChunkSize) import System.IO (Handle) import Network.HTTP.Types (Status (..)) import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI import Data.Monoid (mappend) import Data.Conduit import qualified Data.Conduit.List as CL 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 -> Source (ResourceT IO) B.ByteString) -- ^ responseBody of input -> (B.ByteString -> IO ()) -- ^ destination for output -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header? -> Application -> IO () runGeneric vars inputH outputH xsendfile app = do let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars pinfo = lookup' "PATH_INFO" vars qstring = lookup' "QUERY_STRING" vars servername = lookup' "SERVER_NAME" vars serverport = safeRead 80 $ lookup' "SERVER_PORT" vars contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars remoteHost' = case lookup "REMOTE_ADDR" vars of Just x -> x Nothing -> case lookup "REMOTE_HOST" vars of Just x -> x Nothing -> "" isSecure' = case map toLower $ lookup' "SERVER_PROTOCOL" vars of "https" -> True _ -> False addrs <- getAddrInfo Nothing (Just remoteHost') Nothing let addr = case addrs of a:_ -> addrAddress a [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost' runResourceT $ do let env = Request { requestMethod = rmethod , rawPathInfo = B.pack pinfo , pathInfo = H.decodePathSegments $ B.pack pinfo , rawQueryString = B.pack qstring , queryString = H.parseQuery $ B.pack qstring , serverName = B.pack servername , serverPort = serverport , requestHeaders = map (cleanupVarName *** B.pack) vars , isSecure = isSecure' , remoteHost = addr , httpVersion = H.http11 -- FIXME , requestBody = inputH contentLength , vault = mempty #if MIN_VERSION_wai(1, 4, 0) , requestBodyLength = KnownLength $ fromIntegral contentLength #endif } -- FIXME worry about exception? res <- app env case (xsendfile, res) of (Just sf, ResponseFile s hs fp Nothing) -> liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp _ -> do let (s, hs, b) = responseSource res src = CL.sourceList [Chunk $ headers s hs `mappend` fromChar '\n'] `mappend` b src $$ builderSink where headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs)) status (Status i m) = (fromByteString "Status", mconcat [ fromString $ show i , fromChar ' ' , fromByteString m ]) header' (x, y) = (fromByteString $ CI.original x, fromByteString y) header (x, y) = mconcat [ x , fromByteString ": " , y , fromChar '\n' ] sfBuilder s hs sf fp = mconcat [ headers s hs , header $ (fromByteString sf, fromString fp) , fromChar '\n' , fromByteString sf , fromByteString " not supported" ] bsSink = await >>= maybe (return ()) push push (Chunk bs) = do liftIO $ outputH bs bsSink -- FIXME actually flush? push Flush = bsSink builderSink = builderToByteStringFlush =$ bsSink fixHeaders h = case lookup "content-type" h of Nothing -> ("Content-Type", "text/html; charset=utf-8") : h Just _ -> h cleanupVarName :: String -> CI.CI B.ByteString cleanupVarName "CONTENT_TYPE" = "Content-Type" cleanupVarName "CONTENT_LENGTH" = "Content-Length" cleanupVarName "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 -> Source (ResourceT IO) B.ByteString requestBodyHandle h = requestBodyFunc $ \i -> do bs <- B.hGet h i return $ if B.null bs then Nothing else Just bs requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source (ResourceT IO) B.ByteString requestBodyFunc get = loop where loop 0 = return () loop count = do mbs <- liftIO $ get $ min count defaultChunkSize let count' = count - maybe 0 B.length mbs case mbs of Nothing -> return () Just bs -> yield bs >> loop count' wai-extra-1.3.3.2/Network/Wai/Middleware/0000755000000000000000000000000012123513424016170 5ustar0000000000000000wai-extra-1.3.3.2/Network/Wai/Middleware/Jsonp.hs0000644000000000000000000000621612123513424017622 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} --------------------------------------------------------- -- | -- 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 Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 import Blaze.ByteString.Builder (copyByteString) import Blaze.ByteString.Builder.Char8 (fromChar) import Data.Monoid (mappend) import Control.Monad (join) import Data.Maybe (fromMaybe) import qualified Data.ByteString as S import qualified Data.Conduit as C import qualified Data.Conduit.List as CL -- | Wrap json responses in a jsonp callback. -- -- Basically, if the user requested a \"text\/javascript\" and supplied a -- \"callback\" GET parameter, ask the application for an -- \"application/json\" response, then convern that into a JSONP response, -- having a content type of \"text\/javascript\" and calling the specified -- callback function. jsonp :: Middleware jsonp app env = do let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env 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 "Accept" "application/json" $ requestHeaders env } res <- app env' case callback of Nothing -> return res Just c -> go c res where go c r@(ResponseBuilder s hs b) = case checkJSON hs of Nothing -> return r Just hs' -> return $ ResponseBuilder s hs' $ copyByteString c `mappend` fromChar '(' `mappend` b `mappend` fromChar ')' go c r = case checkJSON hs of Just hs' -> addCallback c s hs' b Nothing -> return r where (s, hs, b) = responseSource r checkJSON hs = case lookup "Content-Type" hs of Just x | B8.pack "application/json" `S.isPrefixOf` x -> Just $ fixHeaders hs _ -> Nothing fixHeaders = changeVal "Content-Type" "text/javascript" addCallback cb s hs b = return $ ResponseSource s hs $ CL.sourceList [C.Chunk $ copyByteString cb `mappend` fromChar '('] `mappend` b `mappend` CL.sourceList [C.Chunk $ fromChar ')'] changeVal :: Eq a => a -> ByteString -> [(a, ByteString)] -> [(a, ByteString)] changeVal key val old = (key, val) : filter (\(k, _) -> k /= key) old wai-extra-1.3.3.2/Network/Wai/Middleware/Rewrite.hs0000644000000000000000000000231612123513424020147 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module 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 = do newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req) let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo } -- | 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-1.3.3.2/Network/Wai/Middleware/AcceptOverride.hs0000644000000000000000000000123612123513424021425 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module 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-1.3.3.2/Network/Wai/Middleware/MethodOverridePost.hs0000644000000000000000000000315212123513424022313 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------- -- | 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) import Data.Monoid (mconcat) import Data.Conduit.Lazy (lazyConsume) import Control.Monad.Trans.Resource (ResourceT) import Data.Conduit.List (sourceList) -- | Allows overriding of the HTTP request method via the _method post string parameter. -- -- * 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 middlware only applies when the initial request method is POST. -- methodOverridePost :: Middleware methodOverridePost app req = case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= app _ -> app req setPost :: Request -> ResourceT IO Request setPost req = do body <- lazyConsume (requestBody req) case parseQuery (mconcat body) of (("_method", Just newmethod):_) -> return $ req {requestBody = sourceList body, requestMethod = newmethod} _ -> return $ req {requestBody = sourceList body} wai-extra-1.3.3.2/Network/Wai/Middleware/Vhost.hs0000644000000000000000000000133712123513424017633 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.Vhost (vhost, redirectWWW) 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 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 app req = if BS.isPrefixOf "www" $ serverName req then return $ responseLBS H.status301 [ ("Content-Type", "text/plain") , ("Location", TE.encodeUtf8 home) ] "Redirect" else app req wai-extra-1.3.3.2/Network/Wai/Middleware/CleanPath.hs0000644000000000000000000000171212123513424020364 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} 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) import Data.Text (Text) import Data.Monoid (mconcat) cleanPath :: ([Text] -> Either B.ByteString [Text]) -> B.ByteString -> ([Text] -> Application) -> Application cleanPath splitter prefix app env = case splitter $ pathInfo env of Right pieces -> app pieces env Left p -> return $ responseLBS status301 [("Location", mconcat [prefix, p, suffix])] $ L.empty where -- include the query string if present suffix = case B.uncons $ rawQueryString env of Nothing -> B.empty Just ('?', _) -> rawQueryString env _ -> B.cons '?' $ rawQueryString env wai-extra-1.3.3.2/Network/Wai/Middleware/Gzip.hs0000644000000000000000000001137212123513424017441 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- | -- 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) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString as S import Data.Default import Network.HTTP.Types (Status, Header) import Control.Monad.IO.Class (liftIO) import System.Directory (doesFileExist, createDirectoryIfMissing) import qualified Data.Conduit as C import qualified Data.Conduit.Zlib as CZ import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Blaze (builderToByteStringFlush) import Blaze.ByteString.Builder (fromByteString) import Control.Exception (try, SomeException) import qualified Data.Set as Set 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.breakByte 59 bs -- semicolon 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 = do res <- app env case res of ResponseFile{} | gzipFiles set == GzipIgnore -> return res _ -> if "gzip" `elem` enc && not isMSIE6 then case (res, gzipFiles set) of (ResponseFile s hs file Nothing, GzipCacheFolder cache) -> case lookup "content-type" hs of Just m | gzipCheckMime set m -> liftIO $ compressFile s hs file cache _ -> return res _ -> return $ compressE set res else return res where enc = fromMaybe [] $ (splitCommas . S8.unpack) `fmap` lookup "Accept-Encoding" (requestHeaders env) ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env isMSIE6 = "MSIE 6" `S.isInfixOf` ua compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response compressFile s hs file cache = do e <- doesFileExist tmpfile if e then onSucc else do createDirectoryIfMissing True cache x <- try $ C.runResourceT $ CB.sourceFile file C.$$ CZ.gzip C.=$ CB.sinkFile tmpfile either onErr (const onSucc) x where onSucc = return $ ResponseFile s (fixHeaders hs) tmpfile Nothing onErr :: SomeException -> IO Response onErr = const $ return $ 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 compressE set res = case lookup "content-type" hs of Just m | gzipCheckMime set m -> let hs' = fixHeaders hs in ResponseSource s hs' $ b C.$= builderToByteStringFlush C.$= CZ.compressFlush 1 (CZ.WindowBits 31) C.$= CL.map (fmap fromByteString) _ -> res where (s, hs, b) = responseSource res -- Remove Content-Length header, since we will certainly have a -- different length after gzip compression. fixHeaders :: [Header] -> [Header] fixHeaders = (("Content-Encoding", "gzip") :) . filter notLength where notLength (x, _) = x /= "content-length" splitCommas :: String -> [String] splitCommas [] = [] splitCommas x = let (y, z) = break (== ',') x in y : splitCommas (dropWhile (== ' ') $ drop 1 z) wai-extra-1.3.3.2/Network/Wai/Middleware/MethodOverride.hs0000644000000000000000000000125212123513424021444 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module 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 middlware only applies when the initial request method is POST. This -- allow submitting of normal HTML forms, without worries of semantics -- mismatches in the HTTP spec. 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-1.3.3.2/Network/Wai/Middleware/RequestLogger.hs0000644000000000000000000002143412123513424021320 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Network.Wai.Middleware.RequestLogger ( -- * Basic stdout logging logStdout , logStdoutDev -- * Create more versions , mkRequestLogger , RequestLoggerSettings , outputFormat , autoFlush , destination , OutputFormat (..) , OutputFormatter , Destination (..) , Callback , IPAddrSource (..) ) where import System.IO (Handle, stdout) import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack, unpack) import Control.Monad.IO.Class (liftIO) import Network.Wai (Request(..), Middleware, responseStatus, Response) import System.Log.FastLogger import Network.HTTP.Types as H import Data.Maybe (fromMaybe) import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType) import qualified Data.ByteString.Lazy as LBS import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import System.Console.ANSI import Data.IORef import System.IO.Unsafe import Data.Default (Default (def)) import Network.Wai.Logger.Format (apacheFormat, IPAddrSource (..)) #if MIN_VERSION_fast_logger(0,3,0) import System.Date.Cache (ondemandDateCacher) #else import System.Log.FastLogger.Date (getDate, dateInit, ZonedDate) #endif data OutputFormat = Apache IPAddrSource | Detailed Bool -- ^ use colors? | CustomOutputFormat OutputFormatter type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> [LogStr] data Destination = Handle Handle | Logger Logger | Callback Callback type Callback = [LogStr] -> IO () 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 (callback, mgetdate) <- case destination of Handle h -> fmap fromLogger $ mkLogger autoFlush h Logger l -> return $ fromLogger l Callback c -> return (c, Nothing) case outputFormat of Apache ipsrc -> do getdate <- dateHelper mgetdate return $ apacheMiddleware callback ipsrc getdate Detailed useColors -> detailedMiddleware callback useColors CustomOutputFormat formatter -> do getdate <- dateHelper mgetdate return $ customMiddleware callback getdate formatter where fromLogger l = (loggerPutStr l, Just $ loggerDate l) dateHelper mgetdate = do case mgetdate of Just x -> return x #if MIN_VERSION_fast_logger(0, 3, 0) Nothing -> do (getter,_) <- ondemandDateCacher zonedDateCacheConf return getter #else Nothing -> fmap getDate dateInit #endif apacheMiddleware :: Callback -> IPAddrSource -> IO ZonedDate -> Middleware apacheMiddleware cb ipsrc getdate = customMiddleware cb getdate $ apacheFormat ipsrc customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware customMiddleware cb getdate formatter app req = do res <- app req date <- liftIO getdate -- We use Nothing for the response size since we generally don't know it liftIO $ cb $ formatter date req (responseStatus res) Nothing return res -- | Production request logger middleware. -- Implemented on top of "logCallback", but prints to 'stdout' logStdout :: Middleware logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket } -- | Development request logger middleware. -- Implemented on top of "logCallbackDev", but prints to 'stdout' -- -- Flushes 'stdout' on each request, which would be inefficient in production use. -- Use "logStdout" in production. logStdoutDev :: Middleware logStdoutDev = unsafePerformIO $ mkRequestLogger def -- no black or white which are expected to be existing terminal colors. colors0 :: [Color] colors0 = [ Red , Green , Yellow , Blue , Magenta , Cyan ] rotateColors :: [Color] -> ([Color], Color) rotateColors [] = error "Impossible! There must be colors!" rotateColors (c:cs) = (cs ++ [c], c) -- | 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. -- The request and response are connected by color on Unix and also by the request path. -- -- This is lower-level - use 'logStdoutDev' unless you need greater control. -- -- Example ouput: -- -- > GET search -- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8 -- > -- > Status: 200 OK. search -- > -- > GET static/css/normalize.css -- > Accept: text/css,*/*;q=0.1 -- > GET [("LXwioiBG","")] -- > -- > Status: 304 Not Modified. static/css/normalize.css detailedMiddleware :: Callback -> Bool -> IO Middleware detailedMiddleware cb useColors = do getAddColor <- if useColors then do icolors <- newIORef colors0 return $ do color <- liftIO $ atomicModifyIORef icolors rotateColors return $ ansiColor color else return (return return) return $ detailedMiddleware' cb getAddColor where ansiColor color bs = [ pack $ setSGRCode [SetColor Foreground Vivid color] , bs , pack $ setSGRCode [Reset] ] detailedMiddleware' :: Callback -> (C.ResourceT IO (BS.ByteString -> [BS.ByteString])) -> Middleware detailedMiddleware' cb getAddColor app req = do let mlen = lookup "content-length" (requestHeaders req) >>= readInt (req', body) <- case mlen of -- log the request body if it is small Just len | len <= 2048 -> do body <- requestBody req C.$$ CL.consume -- logging the body here consumes it, so fill it back up -- obviously not efficient, but this is the development logger let req' = req { requestBody = CL.sourceList body } return (req', body) _ -> return (req, []) postParams <- if requestMethod req `elem` ["GET", "HEAD"] then return [] else do postParams <- liftIO $ allPostParams body return $ collectPostParams postParams let getParams = map emptyGetParam $ queryString req addColor <- getAddColor -- log the request immediately. liftIO $ cb $ map LB $ addColor (requestMethod req) ++ [ " " , rawPathInfo req , "\n" , "Accept: " , fromMaybe "" $ lookup "Accept" $ requestHeaders req , paramsToBS "GET " getParams , paramsToBS "POST " postParams , "\n" ] rsp <- app req' -- log the status of the response -- this is color coordinated with the request logging -- also includes the request path to connect it to the request liftIO $ cb $ map LB $ addColor "Status: " ++ [ statusBS rsp , " " , msgBS rsp , ". " , rawPathInfo req -- if you need help matching the 2 logging statements , "\n" ] return rsp where paramsToBS prefix params = if null params then "" else BS.concat ["\n", prefix, pack (show params)] allPostParams body = case getRequestBodyType req of Nothing -> return ([], []) Just rbt -> C.runResourceT $ CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString) emptyGetParam (k, Just v) = (k,v) emptyGetParam (k, Nothing) = (k,"") collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param] collectPostParams (postParams, files) = postParams ++ map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files readInt bs = case reads $ unpack bs of (i, _):_ -> Just (i :: Int) [] -> Nothing statusBS :: Response -> BS.ByteString statusBS = pack . show . statusCode . responseStatus msgBS :: Response -> BS.ByteString msgBS = statusMessage . responseStatus wai-extra-1.3.3.2/Network/Wai/Middleware/Autohead.hs0000644000000000000000000000120612123513424020255 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | Automatically produce responses to HEAD requests based on the underlying -- applications GET response. module Network.Wai.Middleware.Autohead (autohead) where import Network.Wai import Data.Monoid (mempty) autohead :: Middleware autohead app req | requestMethod req == "HEAD" = do res <- app req { requestMethod = "GET" } case res of ResponseFile s hs _ _ -> return $ ResponseBuilder s hs mempty ResponseBuilder s hs _ -> return $ ResponseBuilder s hs mempty ResponseSource s hs _ -> return $ ResponseBuilder s hs mempty | otherwise = app req wai-extra-1.3.3.2/test/0000755000000000000000000000000012123513424012721 5ustar0000000000000000wai-extra-1.3.3.2/test/json0000644000000000000000000000003512123513424013613 0ustar0000000000000000{"data":"this is some data"} wai-extra-1.3.3.2/test/WaiExtraTest.hs0000644000000000000000000004724612123513424015656 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module WaiExtraTest (specs) where import Test.Hspec import Test.HUnit hiding (Test) import Network.Wai import Network.Wai.Test import Network.Wai.Parse import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy as L import qualified Data.Text.Lazy as T import qualified Data.Text as TS import qualified Data.Text.Encoding as TE import Control.Arrow import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Vhost import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.MethodOverride import Network.Wai.Middleware.MethodOverridePost import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.RequestLogger import Codec.Compression.GZip (decompress) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Data.Conduit.Binary (sourceFile) import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) import Network.HTTP.Types (parseSimpleQuery, status200) import System.Log.FastLogger import qualified Data.IORef as I specs :: Spec specs = do describe "Network.Wai.Parse" $ do describe "parseContentType" $ do let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z) mapM_ go [ ("text/plain", "text/plain", []) , ("text/plain; charset=UTF-8 ", "text/plain", [("charset", "UTF-8")]) , ("text/plain; charset=UTF-8 ; boundary = foo", "text/plain", [("charset", "UTF-8"), ("boundary", "foo")]) ] it "parseQueryString" caseParseQueryString it "parseQueryString with question mark" caseParseQueryStringQM it "parseHttpAccept" caseParseHttpAccept it "parseRequestBody" caseParseRequestBody it "multipart with plus" caseMultipartPlus it "multipart with multiple attributes" caseMultipartAttrs it "urlencoded with plus" caseUrlEncPlus {- , it "findBound" caseFindBound , it "sinkTillBound" caseSinkTillBound , it "killCR" caseKillCR , it "killCRLF" caseKillCRLF , it "takeLine" caseTakeLine -} it "jsonp" caseJsonp it "gzip" caseGzip it "gzip not for MSIE" caseGzipMSIE it "defaultCheckMime" caseDefaultCheckMime it "vhost" caseVhost it "autohead" caseAutohead it "method override" caseMethodOverride it "method override post" caseMethodOverridePost it "accept override" caseAcceptOverride describe "dalvik multipart" $ do it "non-chunked" $ dalvikHelper True it "chunked" $ dalvikHelper False it "debug request body" caseDebugRequestBody caseParseQueryString :: Assertion caseParseQueryString = do let go l r = map (S8.pack *** S8.pack) l @=? parseSimpleQuery (S8.pack r) go [] "" go [("foo", "")] "foo" go [("foo", "bar")] "foo=bar" go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin" go [("%Q", "")] "%Q" go [("%1Q", "")] "%1Q" go [("%1", "")] "%1" go [("/", "")] "%2F" go [("/", "")] "%2f" go [("foo bar", "")] "foo+bar" caseParseQueryStringQM :: Assertion caseParseQueryStringQM = do let go l r = map (S8.pack *** S8.pack) l @=? parseSimpleQuery (S8.pack $ '?' : r) go [] "" go [("foo", "")] "foo" go [("foo", "bar")] "foo=bar" go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin" go [("%Q", "")] "%Q" go [("%1Q", "")] "%1Q" go [("%1", "")] "%1" go [("/", "")] "%2F" go [("/", "")] "%2f" go [("foo bar", "")] "foo+bar" caseParseHttpAccept :: Assertion caseParseHttpAccept = do let input = "text/plain; q=0.5, text/html;charset=utf-8, text/*;q=0.8;ext=blah, text/x-dvi; q=0.8, text/x-c" expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"] expected @=? parseHttpAccept input parseRequestBody' :: BackEnd L.ByteString -> SRequest -> C.ResourceT IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)]) parseRequestBody' sink (SRequest req bod) = case getRequestBodyType req of Nothing -> return ([], []) Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody sink rbt caseParseRequestBody :: Assertion caseParseRequestBody = C.runResourceT t where content2 = S8.pack $ "--AaB03x\n" ++ "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ "This is a file.\n" ++ "It has two lines.\n" ++ "--AaB03x\n" ++ "Content-Disposition: form-data; name=\"title\"\n" ++ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ "A File\n" ++ "--AaB03x\n" ++ "Content-Disposition: form-data; name=\"summary\"\n" ++ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ "This is my file\n" ++ "file test\n" ++ "--AaB03x--" content3 = S8.pack "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\nContent-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\nContent-Type: application/octet-stream\r\n\r\nPhoto blog using Hack.\n\r\n------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n" t = do let content1 = "foo=bar&baz=bin" let ctype1 = "application/x-www-form-urlencoded" result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1 liftIO $ assertEqual "parsing post x-www-form-urlencoded" (map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], []) result1 let ctype2 = "multipart/form-data; boundary=AaB03x" result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2 let expectedsmap2 = [ ("title", "A File") , ("summary", "This is my file\nfile test") ] let textPlain = S8.pack $ "text/plain; charset=iso-8859-1" let expectedfile2 = [(S8.pack "document", FileInfo (S8.pack "b.txt") textPlain $ L8.pack "This is a file.\nIt has two lines.")] let expected2 = (map (S8.pack *** S8.pack) expectedsmap2, expectedfile2) liftIO $ assertEqual "parsing post multipart/form-data" expected2 result2 let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh" result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3 let expectedsmap3 = [] let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $ L8.pack "Photo blog using Hack.\n")] let expected3 = (expectedsmap3, expectedfile3) liftIO $ assertEqual "parsing actual post multipart/form-data" expected3 result3 result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2 liftIO $ assertEqual "parsing post multipart/form-data 2" expected2 result2' result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3 liftIO $ assertEqual "parsing actual post multipart/form-data 2" expected3 result3' caseMultipartPlus :: Assertion caseMultipartPlus = do result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content liftIO $ result @?= ([("email", "has+plus")], []) where content = S8.pack $ "--AaB03x\n" ++ "Content-Disposition: form-data; name=\"email\"\n" ++ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ "has+plus\n" ++ "--AaB03x--" ctype = "multipart/form-data; boundary=AaB03x" caseMultipartAttrs :: Assertion caseMultipartAttrs = do result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content liftIO $ result @?= ([("email", "has+plus")], []) where content = S8.pack $ "--AaB03x\n" ++ "Content-Disposition: form-data; name=\"email\"\n" ++ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ "has+plus\n" ++ "--AaB03x--" ctype = "multipart/form-data; charset=UTF-8; boundary=AaB03x" caseUrlEncPlus :: Assertion caseUrlEncPlus = do result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content liftIO $ result @?= ([("email", "has+plus")], []) where content = S8.pack $ "email=has%2Bplus" ctype = "application/x-www-form-urlencoded" toRequest :: S8.ByteString -> S8.ByteString -> SRequest toRequest ctype content = SRequest defaultRequest { requestHeaders = [("Content-Type", ctype)] , requestMethod = "POST" , rawPathInfo = "/" , rawQueryString = "" , queryString = [] } (L.fromChunks [content]) toRequest' :: S8.ByteString -> S8.ByteString -> SRequest toRequest' ctype content = SRequest defaultRequest { requestHeaders = [("Content-Type", ctype)] } (L.fromChunks $ map S.singleton $ S.unpack content) {- caseFindBound :: Assertion caseFindBound = do findBound (S8.pack "def") (S8.pack "abcdefghi") @?= FoundBound (S8.pack "abc") (S8.pack "ghi") findBound (S8.pack "def") (S8.pack "ABC") @?= NoBound findBound (S8.pack "def") (S8.pack "abcd") @?= PartialBound findBound (S8.pack "def") (S8.pack "abcdE") @?= NoBound findBound (S8.pack "def") (S8.pack "abcdEdef") @?= FoundBound (S8.pack "abcdE") (S8.pack "") caseSinkTillBound :: Assertion caseSinkTillBound = do let iter () _ = return () let src = S8.pack "this is some text" bound1 = S8.pack "some" bound2 = S8.pack "some!" let enum = enumList 1 [src] let helper _ _ = return () (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper () res1 @?= True (_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper () res2 @?= False caseKillCR :: Assertion caseKillCR = do "foo" @=? killCR "foo" "foo" @=? killCR "foo\r" "foo\r\n" @=? killCR "foo\r\n" "foo\r'" @=? killCR "foo\r'" caseKillCRLF :: Assertion caseKillCRLF = do "foo" @=? killCRLF "foo" "foo\r" @=? killCRLF "foo\r" "foo" @=? killCRLF "foo\r\n" "foo\r'" @=? killCRLF "foo\r'" "foo" @=? killCRLF "foo\n" caseTakeLine :: Assertion caseTakeLine = do helper "foo\nbar\nbaz" "foo" helper "foo\r\nbar\nbaz" "foo" helper "foo\nbar\r\nbaz" "foo" helper "foo\rbar\r\nbaz" "foo\rbar" where helper haystack needle = do x <- run_ $ enumList 1 [haystack] $$ takeLine Just needle @=? x -} jsonpApp :: Application jsonpApp = jsonp $ const $ return $ responseLBS status200 [("Content-Type", "application/json")] "{\"foo\":\"bar\"}" caseJsonp :: Assertion caseJsonp = flip runSession jsonpApp $ do sres1 <- request defaultRequest { queryString = [("callback", Just "test")] , requestHeaders = [("Accept", "text/javascript")] } assertContentType "text/javascript" sres1 assertBody "test({\"foo\":\"bar\"})" sres1 sres2 <- request defaultRequest { queryString = [("call_back", Just "test")] , requestHeaders = [("Accept", "text/javascript")] } assertContentType "application/json" sres2 assertBody "{\"foo\":\"bar\"}" sres2 sres3 <- request defaultRequest { queryString = [("callback", Just "test")] , requestHeaders = [("Accept", "text/html")] } assertContentType "application/json" sres3 assertBody "{\"foo\":\"bar\"}" sres3 gzipApp :: Application gzipApp = gzip def $ const $ return $ responseLBS status200 [("Content-Type", "text/plain")] "test" 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" vhostApp1, vhostApp2, vhostApp :: Application vhostApp1 = const $ return $ responseLBS status200 [] "app1" vhostApp2 = const $ return $ responseLBS status200 [] "app2" vhostApp = vhost [ ((== "foo.com") . serverName, vhostApp1) ] vhostApp2 caseVhost :: Assertion caseVhost = flip runSession vhostApp $ do sres1 <- request defaultRequest { serverName = "foo.com" } assertBody "app1" sres1 sres2 <- request defaultRequest { serverName = "bar.com" } assertBody "app2" sres2 autoheadApp :: Application autoheadApp = autohead $ const $ return $ responseLBS status200 [("Foo", "Bar")] "body" caseAutohead :: Assertion caseAutohead = flip runSession autoheadApp $ do sres1 <- request defaultRequest { requestMethod = "GET" } assertHeader "Foo" "Bar" sres1 assertBody "body" sres1 sres2 <- request defaultRequest { requestMethod = "HEAD" } assertHeader "Foo" "Bar" sres2 assertBody "" sres2 moApp :: Application moApp = methodOverride $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] "" caseMethodOverride :: Assertion caseMethodOverride = flip runSession moApp $ do sres1 <- request defaultRequest { requestMethod = "GET" , queryString = [] } assertHeader "Method" "GET" sres1 sres2 <- request defaultRequest { requestMethod = "POST" , queryString = [] } assertHeader "Method" "POST" sres2 sres3 <- request defaultRequest { requestMethod = "POST" , queryString = [("_method", Just "PUT")] } assertHeader "Method" "PUT" sres3 mopApp :: Application mopApp = methodOverridePost $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] "" caseMethodOverridePost :: Assertion caseMethodOverridePost = flip runSession mopApp $ do -- Get Request are unmodified sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin" s = simpleRequest r m = s { requestMethod = "GET" } b = r { simpleRequest = m } in srequest b assertHeader "Method" "GET" sres1 -- Post requests are modified if _method comes first sres2 <- srequest $ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin" assertHeader "Method" "PUT" sres2 -- Post requests are unmodified if _method doesn't come first sres3 <- srequest $ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin" assertHeader "Method" "POST" sres3 -- Post requests are unmodified if Content-Type header isn't set to "application/x-www-form-urlencoded" sres4 <- srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin" assertHeader "Method" "POST" sres4 aoApp :: Application aoApp = acceptOverride $ \req -> return $ responseLBS status200 [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] "" caseAcceptOverride :: Assertion caseAcceptOverride = flip runSession aoApp $ do sres1 <- request defaultRequest { queryString = [] , requestHeaders = [("Accept", "foo")] } assertHeader "Accept" "foo" sres1 sres2 <- request defaultRequest { queryString = [] , requestHeaders = [("Accept", "bar")] } assertHeader "Accept" "bar" sres2 sres3 <- request defaultRequest { queryString = [("_accept", Just "baz")] , requestHeaders = [("Accept", "bar")] } assertHeader "Accept" "baz" sres3 dalvikHelper :: Bool -> Assertion dalvikHelper includeLength = do let headers' = [ ("content-type", "multipart/form-data;boundary=*****") , ("GATEWAY_INTERFACE", "CGI/1.1") , ("PATH_INFO", "/") , ("QUERY_STRING", "") , ("REMOTE_ADDR", "192.168.1.115") , ("REMOTE_HOST", "ganjizza") , ("REQUEST_URI", "http://192.168.1.115:3000/") , ("REQUEST_METHOD", "POST") , ("HTTP_CONNECTION", "Keep-Alive") , ("HTTP_COOKIE", "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD") , ("HTTP_USER_AGENT", "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)") , ("HTTP_HOST", "192.168.1.115:3000") , ("HTTP_ACCEPT", "*, */*") , ("HTTP_VERSION", "HTTP/1.1") , ("REQUEST_PATH", "/") ] headers | includeLength = ("content-length", "12098") : headers' | otherwise = headers' let request' = defaultRequest { requestHeaders = headers } (params, files) <- case getRequestBodyType request' of Nothing -> return ([], []) Just rbt -> C.runResourceT $ sourceFile "test/requests/dalvik-request" C.$$ sinkRequestBody lbsBackEnd rbt lookup "scannedTime" params @?= Just "1.298590056748E9" lookup "geoLong" params @?= Just "0" lookup "geoLat" params @?= Just "0" length files @?= 1 caseDebugRequestBody :: Assertion caseDebugRequestBody = do flip runSession (debugApp postOutput) $ do let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin" res <- srequest req assertStatus 200 res let qs = "?foo=bar&baz=bin" flip runSession (debugApp $ getOutput params) $ do assertStatus 200 =<< request defaultRequest { requestMethod = "GET" , queryString = map (\(k,v) -> (k, Just v)) params , rawQueryString = qs , requestHeaders = [] , rawPathInfo = "/location" } where params = [("foo", "bar"), ("baz", "bin")] -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params) postOutput = T.pack $ "POST /\nAccept: \nStatus: 200 OK. /\n" getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n" debugApp output' req = do iactual <- liftIO $ I.newIORef [] middleware <- liftIO $ mkRequestLogger def { destination = Callback $ \strs -> I.modifyIORef iactual $ (++ strs) , outputFormat = Detailed False } res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req actual <- liftIO $ I.readIORef iactual liftIO $ assertEqual "debug" output $ logsToBs actual return res where output = TE.encodeUtf8 $ T.toStrict output' logsToBs = S.concat . map logToBs logToBs (LB bs) = bs logToBs (LS s) = S8.pack s {-debugApp = debug $ \req -> do-} {-return $ responseLBS status200 [ ] ""-} wai-extra-1.3.3.2/test/test.html0000644000000000000000000000060112123513424014563 0ustar0000000000000000 There should be some content loaded below:
wai-extra-1.3.3.2/test/sample.hs0000644000000000000000000000166612123513424014547 0ustar0000000000000000import Data.ByteString.Char8 (unpack, pack) import Data.ByteString.Lazy (fromChunks) import Network.Wai import Network.Wai.Enumerator import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.CleanPath import Network.Wai.Handler.SimpleServer app :: [String] -> Application app [] _ = return $ Response Status200 [] $ Right $ fromLBS $ fromChunks $ flip map [1..10000] $ \i -> pack $ concat [ "

Just this same paragraph again. " , show i , "

" ] app ["test.html"] _ = return $ Response Status200 [] $ Left "test.html" app ["json"] _ =return $ Response Status200 [(ContentType, pack "application/json")] $ Left "json" app _ _ = return $ Response Status404 [] $ Left "../LICENSE" main :: IO () main = run 3000 $ jsonp $ gzip $ cleanPath app wai-extra-1.3.3.2/test/requests/0000755000000000000000000000000012123513424014574 5ustar0000000000000000wai-extra-1.3.3.2/test/requests/dalvik-request0000644000000000000000000002760612123513424017472 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 --*****--