wai-extra 0.2.4.2 → 0.3.0
raw patch · 12 files changed
+370/−578 lines, 12 filesdep +blaze-builderdep +blaze-builder-enumeratordep +enumeratordep −utf8-stringdep ~wai
Dependencies added: blaze-builder, blaze-builder-enumerator, enumerator, transformers
Dependencies removed: utf8-string
Dependency ranges changed: wai
Files
- Network/Wai/Handler/CGI.hs +85/−50
- Network/Wai/Handler/Helper.hs +0/−25
- Network/Wai/Handler/SimpleServer.hs +0/−190
- Network/Wai/Middleware/Autohead.hs +23/−0
- Network/Wai/Middleware/CleanPath.hs +7/−70
- Network/Wai/Middleware/Debug.hs +16/−0
- Network/Wai/Middleware/Gzip.hs +24/−23
- Network/Wai/Middleware/Jsonp.hs +50/−18
- Network/Wai/Middleware/Vhost.hs +9/−0
- Network/Wai/Parse.hs +111/−150
- Network/Wai/Zlib.hs +35/−46
- wai-extra.cabal +10/−6
Network/Wai/Handler/CGI.hs view
@@ -1,21 +1,34 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} module Network.Wai.Handler.CGI ( run , run' , run'' , runSendfile+ , requestBodyFunc ) where import Network.Wai-import Network.Wai.Enumerator (fromResponseBody)-import Network.Wai.Handler.Helper+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 Data.String (fromString)+import qualified Data.String as String+import Data.Enumerator+ ( Enumerator, Step (..), Stream (..), continue, yield+ , enumList, ($$), joinI, returnI, (>>==), run_+ )+import Data.Monoid (mconcat)+import Blaze.ByteString.Builder (fromByteString, toLazyByteString)+import Blaze.ByteString.Builder.Char8 (fromChar, fromString)+import Blaze.ByteString.Builder.Enumerator (builderToByteString)+import Control.Monad.IO.Class (liftIO)+import Data.ByteString.Lazy.Internal (defaultChunkSize)+import System.IO (Handle) safeRead :: Read a => a -> String -> a safeRead d s =@@ -33,7 +46,7 @@ output = B.hPut System.IO.stdout run'' vars input output Nothing app -runSendfile :: String -- ^ sendfile header+runSendfile :: B.ByteString -- ^ sendfile header -> Application -> IO () runSendfile sf app = do vars <- getEnvironment@@ -52,9 +65,9 @@ run'' vars input output Nothing app run'' :: [(String, String)] -- ^ all variables- -> (Int -> Source) -- ^ responseBody of input+ -> (forall a. Int -> Enumerator B.ByteString IO a) -- ^ responseBody of input -> (B.ByteString -> IO ()) -- ^ destination for output- -> Maybe String -- ^ does the server support the X-Sendfile header?+ -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header? -> Application -> IO () run'' vars inputH outputH xsendfile app = do@@ -65,16 +78,21 @@ serverport = safeRead 80 $ lookup' "SERVER_PORT" vars contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars remoteHost' =- case lookup "REMOTE_HOST" vars of+ case lookup "REMOTE_ADDR" vars of Just x -> x Nothing ->- case lookup "REMOTE_ADDR" vars of+ 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' let env = Request { requestMethod = rmethod , pathInfo = B.pack pinfo@@ -83,53 +101,51 @@ , serverPort = serverport , requestHeaders = map (cleanupVarName *** B.pack) vars , isSecure = isSecure'- , requestBody = inputH contentLength , errorHandler = System.IO.hPutStr System.IO.stderr- , remoteHost = B.pack remoteHost'+ , remoteHost = addr , httpVersion = "1.1" -- FIXME }- res <- app env- let h = responseHeaders res- let h' = case lookup "Content-Type" h of- Nothing -> ("Content-Type", "text/html; charset=utf-8")- : h- Just _ -> h- let hPut = outputH- hPut $ B.pack $ "Status: " ++ (show $ statusCode $ status res) ++ " "- hPut $ statusMessage $ status res- hPut $ B.singleton '\n'- mapM_ (printHeader hPut) h'- case (xsendfile, responseBody res) of- (Just sf, ResponseFile fp) ->- hPut $ B.pack $ concat- [ sf- , ": "- , fp- , "\n\n"- , sf- , " not supported"- ]- _ -> do- hPut $ B.singleton '\n'- _ <- runEnumerator (fromResponseBody (responseBody res))- (myPut outputH) ()- return ()--myPut :: (B.ByteString -> IO ()) -> () -> B.ByteString -> IO (Either () ())-myPut output _ bs = output bs >> return (Right ())--printHeader :: (B.ByteString -> IO ())- -> (ResponseHeader, B.ByteString)- -> IO ()-printHeader f (x, y) = do- f $ ciOriginal x- f $ B.pack ": "- f y- f $ B.singleton '\n'+ -- FIXME worry about exception?+ res <- run_ $ inputH contentLength $$ app env+ case (xsendfile, res) of+ (Just sf, ResponseFile s hs fp) ->+ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp+ _ -> responseEnumerator res $ \s hs ->+ joinI $ enumList 1 [headers s hs, fromChar '\n'] $$ builderIter+ 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 $ ciOriginal 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"+ ]+ bsStep = Continue bsStep'+ bsStep' EOF = yield () EOF+ bsStep' (Chunks []) = continue bsStep'+ bsStep' (Chunks bss) = liftIO (mapM_ outputH bss) >> continue bsStep'+ builderIter = builderToByteString bsStep+ fixHeaders h =+ case lookup "content-type" h of+ Nothing -> ("Content-Type", "text/html; charset=utf-8") : h+ Just _ -> h cleanupVarName :: String -> RequestHeader cleanupVarName ('H':'T':'T':'P':'_':a:as) =- fromString $ a : helper' as+ String.fromString $ a : helper' as where helper' ('_':x:rest) = '-' : x : helper' rest helper' (x:rest) = toLower x : helper' rest@@ -137,4 +153,23 @@ cleanupVarName "CONTENT_TYPE" = "Content-Type" cleanupVarName "CONTENT_LENGTH" = "Content-Length" cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"-cleanupVarName x = fromString x -- FIXME remove?+cleanupVarName x = String.fromString x -- FIXME remove?++requestBodyHandle :: Handle -> Int -> Enumerator B.ByteString IO a+requestBodyHandle h =+ requestBodyFunc go+ where+ go i = Just `fmap` B.hGet h (min i defaultChunkSize)++requestBodyFunc :: (Int -> IO (Maybe B.ByteString))+ -> Int+ -> Enumerator B.ByteString IO a+requestBodyFunc _ 0 step = returnI step+requestBodyFunc h len (Continue k) = do+ mbs <- liftIO $ h len+ case mbs of+ Nothing -> continue k+ Just bs -> do+ let newLen = len - B.length bs+ k (Chunks [bs]) >>== requestBodyFunc h newLen+requestBodyFunc _ _ step = returnI step
− Network/Wai/Handler/Helper.hs
@@ -1,25 +0,0 @@-module Network.Wai.Handler.Helper- ( requestBodyHandle- , requestBodyFunc- ) where--import System.IO (Handle)-import qualified Data.ByteString as B-import Data.ByteString.Lazy.Internal (defaultChunkSize)-import Network.Wai (Source (..))--requestBodyHandle :: Handle -> Int -> Source-requestBodyHandle h =- requestBodyFunc go- where- go i = Just `fmap` B.hGet h (min i defaultChunkSize)--requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source-requestBodyFunc _ 0 = Source $ return Nothing-requestBodyFunc h len = Source $ do- mbs <- h len- case mbs of- Nothing -> return Nothing- Just bs -> do- let newLen = len - B.length bs- return $ Just (bs, requestBodyFunc h $ max 0 newLen)
− Network/Wai/Handler/SimpleServer.hs
@@ -1,190 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}------------------------------------------------------------- |--- Module : Network.Wai.Handler.SimpleServer--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Stable--- Portability : portable------ A simplistic HTTP server handler for Wai.--------------------------------------------------------------module Network.Wai.Handler.SimpleServer- ( run- , sendResponse- , parseRequest- ) where--import Network.Wai-import Network.Wai.Handler.Helper-import qualified System.IO--import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy as L-import Network- ( listenOn, accept, sClose, PortID(PortNumber), Socket- , withSocketsDo)-import Control.Exception (bracket, finally, Exception, throwIO)-import System.IO (Handle, hClose)-import Control.Concurrent (forkIO)-import Control.Monad (unless)-import Data.Maybe (isJust, fromJust, fromMaybe)--import Data.Typeable (Typeable)--import Control.Arrow (first)-import Numeric (showHex)--run :: Port -> Application -> IO ()-run port = withSocketsDo .- bracket- (listenOn $ PortNumber $ fromIntegral port)- sClose .- serveConnections port-type Port = Int--serveConnections :: Port -> Application -> Socket -> IO ()-serveConnections port app socket = do- (conn, remoteHost', _) <- accept socket- _ <- forkIO $ serveConnection port app conn remoteHost'- serveConnections port app socket--serveConnection :: Port -> Application -> Handle -> String -> IO ()-serveConnection port app conn remoteHost' =- finally- serveConnection'- (hClose conn)- where- serveConnection' = do- env <- parseRequest port conn remoteHost'- res <- app env- sendResponse (httpVersion env) conn res--parseRequest :: Port -> Handle -> String -> IO Request-parseRequest port conn remoteHost' = do- headers' <- takeUntilBlank conn id- parseRequest' port headers' conn remoteHost'--takeUntilBlank :: Handle- -> ([ByteString] -> [ByteString])- -> IO [ByteString]-takeUntilBlank h front = do- l <- stripCR `fmap` B.hGetLine h- if B.null l- then return $ front []- else takeUntilBlank h $ front . (:) l--stripCR :: ByteString -> ByteString-stripCR bs- | B.null bs = bs- | B.last bs == '\r' = B.init bs- | otherwise = bs--data InvalidRequest =- NotEnoughLines [String]- | HostNotIncluded- | BadFirstLine String- | NonHttp- deriving (Show, Typeable)-instance Exception InvalidRequest---- | Parse a set of header lines and body into a 'Request'.-parseRequest' :: Port- -> [ByteString]- -> Handle- -> String- -> IO Request-parseRequest' port lines' handle remoteHost' = do- case lines' of- (_:_:_) -> return ()- _ -> throwIO $ NotEnoughLines $ map B.unpack lines'- (method, rpath', gets, httpversion) <- parseFirst $ head lines'- let rpath = '/' : case B.unpack rpath' of- ('/':x) -> x- _ -> B.unpack rpath'- let heads = map (first mkCIByteString . parseHeaderNoAttr) $ tail lines'- let host' = lookup "Host" heads- unless (isJust host') $ throwIO HostNotIncluded- let host = fromJust host'- let len = fromMaybe 0 $ do- bs <- lookup "Content-Length" heads- let str = B.unpack bs- case reads str of- (x, _):_ -> Just x- _ -> Nothing- let (serverName', _) = B.break (== ':') host- return $ Request- { requestMethod = method- , httpVersion = httpversion- , pathInfo = B.pack rpath- , queryString = gets- , serverName = serverName'- , serverPort = port- , requestHeaders = heads- , isSecure = False- , requestBody = requestBodyHandle handle len- , errorHandler = System.IO.hPutStr System.IO.stderr- , remoteHost = B.pack remoteHost'- }--parseFirst :: ByteString- -> IO (ByteString, ByteString, ByteString, HttpVersion)-parseFirst s = do- let pieces = B.words s- (method, query, http') <-- case pieces of- [x, y, z] -> return (x, y, z)- _ -> throwIO $ BadFirstLine $ B.unpack s- let (hfirst, hsecond) = B.splitAt 5 http'- unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp- let (rpath, qstring) = B.break (== '?') query- return (method, rpath, qstring, hsecond)--sendResponse :: HttpVersion -> Handle -> Response -> IO ()-sendResponse httpversion h res = do- B.hPut h $ B.pack "HTTP/"- B.hPut h $ httpversion- B.hPut h $ B.pack " "- B.hPut h $ B.pack $ show $ statusCode $ status res- B.hPut h $ B.pack " "- B.hPut h $ statusMessage $ status res- B.hPut h $ B.pack "\r\n"- mapM_ putHeader $ responseHeaders res- B.hPut h $ B.pack "Transfer-Encoding: chunked\r\n\r\n"- case responseBody res of- ResponseFile fp -> do- -- FIXME this is lazy I/O- lbs <- L.readFile fp- mapM_ myPut $ L.toChunks lbs- ResponseEnumerator (Enumerator enum) ->- enum (const myPut) h >> return ()- ResponseLBS lbs -> mapM_ myPut $ L.toChunks lbs- B.hPut h $ B.pack "0\r\n\r\n"- where- myPut bs = do- B.hPut h $ B.pack $ showHex (B.length bs) " \r\n"- B.hPut h bs- B.hPut h $ B.pack "\r\n"- return (Right h)- putHeader (x, y) = do- B.hPut h $ ciOriginal x- B.hPut h $ B.pack ": "- B.hPut h y- B.hPut h $ B.pack "\r\n"--parseHeaderNoAttr :: ByteString -> (ByteString, ByteString)-parseHeaderNoAttr s =- let (k, rest) = B.span (/= ':') s- rest' = if not (B.null rest) &&- B.head rest == ':' &&- not (B.null $ B.tail rest) &&- B.head (B.tail rest) == ' '- then B.drop 2 rest- else rest- in (k, rest')
+ Network/Wai/Middleware/Autohead.hs view
@@ -0,0 +1,23 @@+{-# 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)+import Data.Enumerator (enumEOF, ($$))++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+ ResponseEnumerator e -> do+ let helper f =+ let helper' s hs = enumEOF $$ f s hs+ in e helper'+ return $ ResponseEnumerator helper+ | otherwise = app req+
Network/Wai/Middleware/CleanPath.hs view
@@ -1,29 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.CleanPath ( cleanPath- , cleanPathRel- , cleanPathFunc- , splitPath ) where import Network.Wai import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L-import Network.URI (unEscapeString)-import qualified Data.ByteString.UTF8 as BSU -cleanPathFunc :: (B.ByteString -> Either B.ByteString [String])- -> B.ByteString- -> ([String] -> Request -> IO Response)- -> Request- -> IO Response-cleanPathFunc splitter prefix app env =+cleanPath :: (B.ByteString -> Either B.ByteString [String])+ -> B.ByteString+ -> ([String] -> Application)+ -> Application+cleanPath splitter prefix app env = case splitter $ pathInfo env of Right pieces -> app pieces env Left p -> return- . Response status301+ $ responseLBS status301 [("Location", B.concat [prefix, p, suffix])]- $ ResponseLBS L.empty+ $ L.empty where -- include the query string if present suffix =@@ -31,60 +25,3 @@ Nothing -> B.empty Just ('?', _) -> queryString env _ -> B.cons '?' $ queryString env---- | Performs redirects as per 'splitPath'.-cleanPathRel :: B.ByteString -> ([String] -> Request -> IO Response)- -> Request -> IO Response-cleanPathRel = cleanPathFunc splitPath--cleanPath :: ([String] -> Request -> IO Response) -> Request -> IO Response-cleanPath = cleanPathRel B.empty---- | Given a certain requested path, return either a corrected path--- to redirect to or the tokenized path.------ This code corrects for the following issues:------ * It is missing a trailing slash, and there is no period after the--- last slash.------ * There are any doubled slashes.-splitPath :: B.ByteString -> Either B.ByteString [String]-splitPath s =- let corrected = B.pack $ rts $ ats $ rds $ B.unpack s- in if corrected == s- then Right $ map (BSU.toString . B.pack . unEscapeString . B.unpack)- $ filter (not . B.null)- $ B.split '/' s- else Left corrected---- | Remove double slashes-rds :: String -> String-rds [] = []-rds [x] = [x]-rds (a:b:c)- | a == '/' && b == '/' = rds (b:c)- | otherwise = a : rds (b:c)---- | Add a trailing slash if it is missing. Empty string is left alone.-ats :: String -> String-ats [] = []-ats s =- if last s == '/' || dbs (reverse s)- then s- else s ++ "/"---- | Remove a trailing slash if the last piece has a period.-rts :: String -> String-rts [] = []-rts s =- if last s == '/' && dbs (tail $ reverse s)- then init s- else s---- | Is there a period before a slash here?-dbs :: String -> Bool-dbs ('/':_) = False-dbs ('.':_) = True-dbs (_:x) = dbs x-dbs [] = False
+ Network/Wai/Middleware/Debug.hs view
@@ -0,0 +1,16 @@+module Network.Wai.Middleware.Debug (debug) where++import Network.Wai (Middleware, requestMethod, pathInfo)+import Data.ByteString.Char8 (unpack)+import System.IO (hPutStrLn, stderr)+import Control.Monad.IO.Class (liftIO)++-- | Prints a message to 'stderr' for each request.+debug :: Middleware+debug app req = do+ liftIO $ hPutStrLn stderr $ concat+ [ unpack $ requestMethod req+ , " "+ , unpack $ pathInfo req+ ]+ app req
Network/Wai/Middleware/Gzip.hs view
@@ -17,10 +17,10 @@ module Network.Wai.Middleware.Gzip (gzip) where import Network.Wai-import Network.Wai.Enumerator (fromResponseBody) import Network.Wai.Zlib import Data.Maybe (fromMaybe) import qualified Data.ByteString.Char8 as B+import Data.Enumerator (($$), joinI) -- | Use gzip to compress the body of the response. --@@ -31,30 +31,31 @@ -- -- * Only compress if the response is above a certain size. ----- * Add Content-Length.------ * I read somewhere that \"the beast\" (MSIE) can\'t support compression--- for Javascript files..-gzip :: Middleware-gzip app env = do+-- * I've read that IE can\'t support compression for Javascript files.+gzip :: Bool -- ^ should we gzip files?+ -> Middleware+gzip files app env = do res <- app env- case responseBody res of- ResponseFile _ -> return res- _ -> do- let enc = fromMaybe []- $ (splitCommas . B.unpack)- `fmap` lookup "Accept-Encoding"- (requestHeaders env)- if "gzip" `elem` enc- then return res- { responseBody = compressE $ responseBody res- , responseHeaders = ("Content-Encoding", "gzip")- : responseHeaders res- }- else return res+ return $+ case res of+ ResponseFile{} | not files -> res+ _ -> if "gzip" `elem` enc+ then ResponseEnumerator $ compressE $ responseEnumerator res+ else res+ where+ enc = fromMaybe [] $ (splitCommas . B.unpack)+ `fmap` lookup "Accept-Encoding" (requestHeaders env) -compressE :: ResponseBody -> ResponseBody-compressE = ResponseEnumerator . compress . fromResponseBody+compressE :: (forall a. ResponseEnumerator a)+ -> (forall a. ResponseEnumerator a)+compressE re f =+ re f'+ --e s hs'+ where+ f' s hs =+ joinI $ compress $$ f s hs'+ where+ hs' = ("Content-Encoding", "gzip") : hs splitCommas :: String -> [String] splitCommas [] = []
Network/Wai/Middleware/Jsonp.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Jsonp@@ -15,9 +16,12 @@ module Network.Wai.Middleware.Jsonp (jsonp) where import Network.Wai-import Network.Wai.Enumerator (fromResponseBody) import qualified Data.ByteString.Char8 as B8 import Data.Maybe (fromMaybe)+import Data.Enumerator (($$), enumList, Step (..), Enumerator, Iteratee, Enumeratee, joinI, checkDone, continue, Stream (..), (>>==))+import Blaze.ByteString.Builder (copyByteString, Builder)+import Blaze.ByteString.Builder.Char8 (fromChar)+import Data.Monoid (mappend) takeCallback :: B8.ByteString -> Maybe B8.ByteString takeCallback bs | B8.null bs = Nothing@@ -58,23 +62,51 @@ $ requestHeaders env } res <- app env'- case (fmap B8.unpack $ lookup "Content-Type" $ responseHeaders res, callback) of- (Just "application/json", Just c) -> return $ res- { responseHeaders = changeVal "Content-Type" "text/javascript" $ responseHeaders res- , responseBody = ResponseEnumerator $ addCallback c $ fromResponseBody $ responseBody res- }- _ -> return res--addCallback :: B8.ByteString -> Enumerator -> Enumerator-addCallback cb (Enumerator e) = Enumerator $ \iter a -> do- ea' <- iter a $ B8.snoc cb '('- case ea' of- Left a' -> return $ Left a'- Right a' -> do- ea'' <- e iter a'- case ea'' of- Left a'' -> return $ Left a''- Right a'' -> iter a'' $ B8.singleton ')'+ case callback of+ Nothing -> return res+ Just c -> go c res+ where+ go c r@(ResponseFile _ hs _) = go' c r hs+ 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 (ResponseEnumerator e) = addCallback c e+ go' c r hs =+ case checkJSON hs of+ Just _ -> addCallback c $ responseEnumerator r+ Nothing -> return r+ checkJSON hs =+ case fmap B8.unpack $ lookup "Content-Type" hs of+ Just "application/json" -> Just $ fixHeaders hs+ _ -> Nothing+ fixHeaders = changeVal "Content-Type" "text/javascript"+ addCallback :: B8.ByteString -> (forall a. ResponseEnumerator a)+ -> Iteratee B8.ByteString IO Response+ addCallback cb e =+ return $ ResponseEnumerator $ helper+ where+ helper f =+ e helper'+ where+ helper' s hs =+ case checkJSON hs of+ Just hs' -> wrap $$ f s hs'+ Nothing -> f s hs+ wrap :: Step Builder IO b -> Iteratee Builder IO b+ wrap step = joinI $ after (enumList 1 [fromChar ')'])+ $$ enumList 1 [copyByteString cb, fromChar '('] step+ after :: Enumerator Builder IO b -> Enumeratee Builder Builder IO b+ after enum =+ loop+ where+ loop = checkDone $ continue . step+ step k EOF = enum (Continue k) >>== return+ step k s = k s >>== loop changeVal :: Eq a => a
+ Network/Wai/Middleware/Vhost.hs view
@@ -0,0 +1,9 @@+module Network.Wai.Middleware.Vhost (vhost) where++import Network.Wai++vhost :: [(Request -> Bool, Application)] -> Application -> Application+vhost vhosts def req =+ case filter (\(b, _) -> b req) vhosts of+ [] -> def req+ (_, app):_ -> app req
Network/Wai/Parse.hs view
@@ -4,7 +4,6 @@ module Network.Wai.Parse ( parseQueryString- , parseCookies , parseHttpAccept , parseRequestBody , Sink (..)@@ -15,6 +14,9 @@ , Bound (..) , findBound , sinkTillBound+ , killCR+ , killCRLF+ , takeLine #endif ) where @@ -29,6 +31,9 @@ import System.Directory (removeFile, getTemporaryDirectory) import System.IO (hClose, openBinaryTempFile, Handle) import Network.Wai+import Data.Enumerator (Iteratee, yield)+import qualified Data.Enumerator as E+import Control.Monad.IO.Class (liftIO) uncons :: S.ByteString -> Maybe (Word8, S.ByteString) uncons s@@ -89,20 +94,6 @@ combine :: Word8 -> Word8 -> Word8 combine a b = shiftL a 4 .|. b --- | Decode the value of an HTTP_COOKIE header into key/value pairs.-parseCookies :: S.ByteString -> [(S.ByteString, S.ByteString)]-parseCookies s- | S.null s = []- | otherwise =- let (first, rest) = breakDiscard 59 s -- semicolon- in parseCookie first : parseCookies rest--parseCookie :: S.ByteString -> (S.ByteString, S.ByteString)-parseCookie s =- let (key, value) = breakDiscard 61 s -- equals sign- key' = S.dropWhile (== 32) key -- space- in (key', value)- -- | Parse the HTTP accept string to determine supported content types. parseHttpAccept :: S.ByteString -> [S.ByteString] parseHttpAccept = map fst@@ -162,138 +153,106 @@ parseRequestBody :: Sink x y -> Request- -> IO ([Param], [File y])+ -> Iteratee S.ByteString IO ([Param], [File y]) parseRequestBody sink req = do- let ctype = do- ctype' <- lookup "Content-Type" $ requestHeaders req- if urlenc `S.isPrefixOf` ctype'- then Just Nothing- else if formBound `S.isPrefixOf` ctype'- then Just $ Just $ S.drop (S.length formBound) ctype'- else Nothing case ctype of Nothing -> return ([], []) Just Nothing -> do -- url-encoded -- 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 <- sourceToBs $ requestBody req- return (parseQueryString bs, [])+ bs <- E.consume+ return (parseQueryString $ S.concat bs, []) Just (Just bound) -> -- multi-part let bound' = S8.pack "--" `S.append` bound- in parsePieces sink bound' (S.empty, Just $ requestBody req)+ in parsePieces sink bound' where urlenc = S8.pack "application/x-www-form-urlencoded" formBound = S8.pack "multipart/form-data; boundary="--sourceToBs :: Source -> IO S.ByteString-sourceToBs = fmap S.concat . go id- where- go front (Source src) = do- res <- src- case res of- Nothing -> return $ front []- Just (bs, src') -> go (front . (:) bs) src'--type Source' = (S.ByteString, Maybe Source)+ ctype = do+ ctype' <- lookup "Content-Type" $ requestHeaders req+ if urlenc `S.isPrefixOf` ctype'+ then Just Nothing+ else if formBound `S.isPrefixOf` ctype'+ then Just $ Just $ S.drop (S.length formBound) ctype'+ else Nothing -takeLine :: Source' -> IO (Maybe (S.ByteString, Source'))-takeLine (s, msrc)- | S.null s = case msrc of- Nothing -> return Nothing- Just (Source src) -> do- res <- src- case res of- Nothing -> return Nothing- Just (x, y) -> takeLine (x, Just y)-takeLine (s, msrc) =- let (x, y) = S.break (== 10) s -- newline- in if S.null y- then do- case msrc of- Nothing -> return $ Just (x, (y, msrc))- Just (Source src) -> do- res <- src- case res of- Nothing -> return $ Just (x, (y, Nothing))- Just (s', src') ->- takeLine (s `S.append` s', Just src')- else return $ Just (killCarriage x, (S.drop 1 y, msrc))- where- killCarriage bs- | S.null bs = bs- | S.last bs == 13 = S.init bs -- carriage return- | otherwise = bs+takeLine :: Iteratee S.ByteString IO (Maybe S.ByteString)+takeLine = do+ mbs <- E.head+ case mbs of+ Nothing -> return Nothing+ Just bs ->+ let (x, y) = S.break (== 10) bs -- LF+ in if S.null y+ then do+ x' <- takeLine+ case x' of+ Nothing -> return $ Just $ killCR x+ Just x'' -> return $ Just $ killCR $ S.append x x''+ else do+ E.yield () $ E.Chunks [S.drop 1 y]+ return $ Just $ killCR x -takeLines :: Source' -> IO (Maybe ([S.ByteString], Source'))-takeLines src = do- res <- takeLine src+takeLines :: Iteratee S.ByteString IO [S.ByteString]+takeLines = do+ res <- takeLine case res of- Nothing -> return Nothing- Just (l, src') ->- if S.null l- then return $ Just ([], src')- else do- res' <- takeLines src'- case res' of- Nothing -> return $ Just ([l], src')- Just (ls, src'') -> return $ Just (l : ls, src'')+ Nothing -> return []+ Just l+ | S.null l -> return []+ | otherwise -> do+ ls <- takeLines+ return $ l : ls -parsePieces :: Sink x y -> S.ByteString -> Source'- -> IO ([Param], [File y])-parsePieces sink bound src = do- res <- takeLine src- src' <- case res of- Nothing -> return (S.empty, Nothing)- -- The _bs here should only contain boundary information- Just (_bs, src') -> return src'- res' <- takeLines src'+parsePieces :: Sink x y -> S.ByteString+ -> Iteratee S.ByteString IO ([Param], [File y])+parsePieces sink bound = do+ _boundLine <- takeLine+ res' <- takeLines case res' of- Nothing -> return ([], [])- Just (ls, src'') -> do- let ls' = map parsePair ls+ [] -> return ([], [])+ _ -> do+ let ls' = map parsePair res' let x = do cd <- lookup contDisp ls' let ct = lookup contType ls' let attrs = parseAttrs cd- let nameBS = S8.pack "name"- name <- lookup nameBS attrs- let fnBS = S8.pack "filename"- return (ct, name, lookup fnBS attrs)+ 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- seed <- sinkInit sink- (seed', wasFound, msrc''') <-- sinkTillBound bound src'' (sinkAppend sink) seed- y <- sinkClose sink seed'+ seed <- liftIO $ sinkInit sink+ (seed', wasFound) <-+ sinkTillBound bound (sinkAppend sink) seed+ y <- liftIO $ sinkClose sink seed' let fi = FileInfo filename ct y let y' = (name, fi) (xs, ys) <- if wasFound- then parsePieces sink bound msrc'''+ then parsePieces sink bound else return ([], []) return (xs, y' : ys) Just (_ct, name, Nothing) -> do let seed = id let iter front bs = return $ front . (:) bs- (front, wasFound, msrc''') <-- sinkTillBound bound src'' iter seed+ (front, wasFound) <-+ sinkTillBound bound iter seed let bs = S.concat $ front [] let x' = (name, qsDecode bs) (xs, ys) <- if wasFound- then parsePieces sink bound msrc'''+ then parsePieces sink bound else return ([], []) return (x' : xs, ys) _ -> do -- ignore this part let seed = () iter () _ = return ()- ((), wasFound, msrc''') <-- sinkTillBound bound src'' iter seed+ ((), wasFound) <- sinkTillBound bound iter seed if wasFound- then parsePieces sink bound msrc'''+ then parsePieces sink bound else return ([], []) where contDisp = S8.pack "Content-Disposition"@@ -325,56 +284,58 @@ | otherwise = True sinkTillBound :: S.ByteString- -> Source' -> (x -> S.ByteString -> IO x) -> x- -> IO (x, Bool, Source')-sinkTillBound bound (bs, msrc) iter seed = do- case findBound bound bs of+ -> Iteratee S.ByteString IO (x, Bool)+sinkTillBound bound iter seed = do+ mbs <- E.head+ case mbs of+ Nothing -> return (seed, False)+ Just bs -> go bs+ where+ go bs =+ case findBound bound bs of+ FoundBound before after -> do+ let before' = killCRLF before+ seed' <- liftIO $ iter seed before'+ yield () $ E.Chunks [after]+ return (seed', True)+ PartialBound -> do+ mbs <- E.head+ case mbs of+ Nothing -> do+ seed' <- liftIO $ iter seed bs+ return (seed', False)+ Just bs2 -> do+ let bs' = bs `S.append` bs2+ yield () $ E.Chunks [bs']+ sinkTillBound bound iter seed+ NoBound -> do+ mbs <- E.head+ case mbs of+ Nothing -> do+ seed' <- liftIO $ iter seed bs+ sinkTillBound bound iter seed'+ Just bs' -> do+ -- this funny bit is to catch when there's a+ -- newline at the end of the previous chunk+ (seed', bs'') <-+ if not (S8.null bs) && S8.last bs `elem` "\n\r"+ then do+ let (front, back) =+ S.splitAt (S.length bs - 2) bs+ seed' <- liftIO $ iter seed front+ return (seed', back `S.append` bs')+ else do+ seed' <- liftIO $ iter seed bs+ return (seed', bs')+ yield () $ E.Chunks [bs'']+ sinkTillBound bound iter seed'+ {- NoBound -> do case msrc of- Nothing -> do- seed' <- iter seed bs- return (seed', False, (S.empty, Nothing))- Just (Source src) -> do- res <- src- case res of- Nothing -> do- seed' <- iter seed bs- return (seed', False, (S.empty, Nothing)) Just (bs', src') -> do- -- this funny bit is to catch when there's a- -- newline at the end of the previous chunk- (seed', bs'') <-- if not (S8.null bs) && S8.last bs `elem` "\n\r"- then do- let (front, back) =- S.splitAt (S.length bs - 2) bs- seed' <- iter seed front- return (seed', back `S.append` bs')- else do- seed' <- iter seed bs- return (seed', bs')- sinkTillBound bound (bs'', Just src') iter seed'- FoundBound before after -> do- let before' = killCRLF before- seed' <- iter seed before'- return (seed', True, (after, msrc))- PartialBound -> do- -- not so efficient, but hopefully the unusual case- case msrc of- Nothing -> do- seed' <- iter seed bs- return (seed', False, (S.empty, Nothing))- Just (Source src) -> do- res <- src- case res of- Nothing -> do- seed' <- iter seed bs- return (seed', False, (S.empty, Nothing))- Just (bs', src') -> do- let bs'' = bs `S.append` bs'- sinkTillBound bound (bs'', Just src') iter seed+ -} parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)] parseAttrs = map go . S.split 59 -- semicolon@@ -389,10 +350,10 @@ killCRLF :: S.ByteString -> S.ByteString killCRLF bs- | S.null bs || S8.last bs /= '\n' = 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 || S8.last bs /= '\r' = bs+ | S.null bs || S.last bs /= 13 = bs -- carriage return | otherwise = S.init bs
Network/Wai/Zlib.hs view
@@ -1,51 +1,40 @@ module Network.Wai.Zlib (compress) where -import Prelude-import Network.Wai-import Data.ByteString (ByteString)+import Prelude hiding (head)+import Data.Enumerator+ ( Enumeratee, checkDone, Stream (..)+ , (>>==), head, ($$), joinI+ )+import Blaze.ByteString.Builder (Builder, fromByteString)+import Blaze.ByteString.Builder.Enumerator (builderToByteString)+import Control.Monad.IO.Class (liftIO) import Codec.Zlib -compress :: Enumerator -> Enumerator-compress enum =- Enumerator $ \iter acc -> do- def <- initDeflate 7 $ WindowBits 31- compressInner iter acc enum def--compressInner :: (acc -> ByteString -> IO (Either acc acc))- -> acc- -> Enumerator- -> Deflate- -> IO (Either acc acc)-compressInner iter acc enum def = do- eacc <- runEnumerator enum (compressIter iter def) acc- case eacc of- Left acc' -> return $ Left acc'- Right acc' -> finishStream iter def acc'--finishStream :: (acc -> ByteString -> IO (Either acc acc))- -> Deflate- -> acc- -> IO (Either acc acc)-finishStream iter def acc = finishDeflate def $ drain iter acc--compressIter :: (acc -> ByteString -> IO (Either acc acc))- -> Deflate- -> acc- -> ByteString- -> IO (Either acc acc)-compressIter iter def acc bsI = withDeflateInput def bsI $ drain iter acc--drain :: (acc -> ByteString -> IO (Either acc acc))- -> acc- -> IO (Maybe ByteString)- -> IO (Either acc acc)-drain iter acc pop = do- mbs <- pop- case mbs of- Nothing -> return $ Right acc- Just bs -> do- eacc' <- iter acc bs- case eacc' of- Left acc' -> return $ Left acc'- Right acc' -> drain iter acc' pop+-- Note: this function really should return a stream of ByteStrings, but the+-- WAI protocol needs Builders anyway.+compress :: Enumeratee Builder Builder IO a+compress step0 = joinI $ builderToByteString $$ do+ def <- liftIO $ initDeflate 7 $ WindowBits 31+ loop def step0+ where+ loop def = checkDone $ step def+ step def k = do+ minput <- head+ case minput of+ Nothing -> do+ bss <- liftIO $ finishDeflate def drain+ k (Chunks bss) >>== return+ Just input -> do+ bss <- liftIO $ withDeflateInput def input drain+ case bss of+ [] -> step def k+ _ -> k (Chunks bss) >>== loop def+ drain =+ go id+ where+ go front mbs' = do+ mbs <- mbs'+ case mbs of+ Nothing -> return $ map fromByteString $ front []+ Just bs -> go (front . (:) bs) mbs'
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 0.2.4.2+Version: 0.3.0 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: BSD3@@ -15,21 +15,25 @@ Library Build-Depends: base >= 3 && < 5, bytestring >= 0.9 && < 0.10,- wai >= 0.2.0 && < 0.3,+ wai >= 0.3.0 && < 0.4, old-locale >= 1.0 && < 1.1, time >= 1.1.4 && < 1.3, network >= 2.2.1.5 && < 2.4, directory >= 1.0.1 && < 1.2,- utf8-string >= 0.3.4 && < 0.4,- zlib-bindings >= 0.0 && < 0.1+ zlib-bindings >= 0.0 && < 0.1,+ blaze-builder-enumerator >= 0.2 && < 0.3,+ transformers >= 0.2 && < 0.3,+ enumerator >= 0.4 && < 0.5,+ blaze-builder >= 0.2.1.3 && < 0.3 Exposed-modules: Network.Wai.Handler.CGI- Network.Wai.Handler.SimpleServer+ Network.Wai.Middleware.Autohead Network.Wai.Middleware.CleanPath+ Network.Wai.Middleware.Debug Network.Wai.Middleware.Gzip Network.Wai.Middleware.Jsonp+ Network.Wai.Middleware.Vhost Network.Wai.Zlib Network.Wai.Parse- Network.Wai.Handler.Helper ghc-options: -Wall source-repository head