diff --git a/Network/Wai/Handler/CGI.hs b/Network/Wai/Handler/CGI.hs --- a/Network/Wai/Handler/CGI.hs +++ b/Network/Wai/Handler/CGI.hs @@ -11,9 +11,11 @@ ) where import Network.Wai +import Network.Wai.Internal import Network.Socket (getAddrInfo, addrAddress) import System.Environment (getEnvironment) import Data.Maybe (fromMaybe) +import Control.Exception (mask) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L import Control.Arrow ((***)) @@ -32,7 +34,6 @@ 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 = @@ -67,7 +68,7 @@ -- stick with 'run' or 'runSendfile'. runGeneric :: [(String, String)] -- ^ all variables - -> (Int -> Source (ResourceT IO) B.ByteString) -- ^ responseBody of input + -> (Int -> Source IO B.ByteString) -- ^ responseBody of input -> (B.ByteString -> IO ()) -- ^ destination for output -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header? -> Application @@ -76,8 +77,6 @@ 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 @@ -95,35 +94,36 @@ case addrs of a:_ -> addrAddress a [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost' - runResourceT $ do - let env = Request + mask $ \restore -> do + let reqHeaders = map (cleanupVarName *** B.pack) vars + env = Request { requestMethod = rmethod , rawPathInfo = B.pack pinfo , pathInfo = H.decodePathSegments $ B.pack pinfo , rawQueryString = B.pack qstring , queryString = H.parseQuery $ B.pack qstring - , serverName = B.pack servername - , serverPort = serverport - , requestHeaders = map (cleanupVarName *** B.pack) vars + , requestHeaders = reqHeaders , 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 + , requestHeaderHost = lookup "host" reqHeaders + , requestHeaderRange = lookup "range" reqHeaders } -- FIXME worry about exception? - res <- app env + res <- restore $ app env case (xsendfile, res) of (Just sf, ResponseFile s hs fp Nothing) -> - liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp + restore $ 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 + let (s, hs, wb) = responseToSource res + wb $ \b -> + let src = do + yield (Chunk $ headers s hs `mappend` fromChar '\n') + b + in src $$ builderSink where headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs)) status (Status i m) = (fromByteString "Status", mconcat @@ -170,12 +170,12 @@ helper' (x:rest) = toLower x : helper' rest helper' [] = [] -requestBodyHandle :: Handle -> Int -> Source (ResourceT IO) B.ByteString +requestBodyHandle :: Handle -> Int -> Source 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 :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source IO B.ByteString requestBodyFunc get = loop where diff --git a/Network/Wai/Middleware/Autohead.hs b/Network/Wai/Middleware/Autohead.hs --- a/Network/Wai/Middleware/Autohead.hs +++ b/Network/Wai/Middleware/Autohead.hs @@ -4,6 +4,7 @@ module Network.Wai.Middleware.Autohead (autohead) where import Network.Wai +import Network.Wai.Internal import Data.Monoid (mempty) autohead :: Middleware diff --git a/Network/Wai/Middleware/Gzip.hs b/Network/Wai/Middleware/Gzip.hs --- a/Network/Wai/Middleware/Gzip.hs +++ b/Network/Wai/Middleware/Gzip.hs @@ -40,6 +40,7 @@ import Blaze.ByteString.Builder (fromByteString) import Control.Exception (try, SomeException) import qualified Data.Set as Set +import Network.Wai.Internal data GzipSettings = GzipSettings { gzipFiles :: GzipFiles @@ -91,10 +92,6 @@ `fmap` lookup "Accept-Encoding" (requestHeaders env) ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env isMSIE6 = "MSIE 6" `S.isInfixOf` ua - responseHeaders res = case res of - ResponseFile _ h _ _ -> h - ResponseBuilder _ h _ -> h - ResponseSource _ h _ -> h isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response @@ -130,12 +127,13 @@ case lookup "content-type" hs of Just m | gzipCheckMime set m -> let hs' = fixHeaders hs - in ResponseSource s hs' $ b C.$= builderToByteStringFlush + in ResponseSource s hs' $ \f -> wb $ \b -> f $ + b C.$= builderToByteStringFlush C.$= CZ.compressFlush 1 (CZ.WindowBits 31) C.$= CL.map (fmap fromByteString) _ -> res where - (s, hs, b) = responseSource res + (s, hs, wb) = responseToSource res -- Remove Content-Length header, since we will certainly have a -- different length after gzip compression. diff --git a/Network/Wai/Middleware/HttpAuth.hs b/Network/Wai/Middleware/HttpAuth.hs --- a/Network/Wai/Middleware/HttpAuth.hs +++ b/Network/Wai/Middleware/HttpAuth.hs @@ -16,14 +16,13 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.String (IsString (..)) -import Control.Monad.Trans.Resource (ResourceT) import Data.Word8 (isSpace, _colon, toLower) import Data.ByteString.Base64 (decodeLenient) -- | Check if a given username and password is valid. type CheckCreds = ByteString -> ByteString - -> ResourceT IO Bool + -> IO Bool -- | Perform basic authentication. -- @@ -73,7 +72,7 @@ -- authentication is not provided. -- -- Since 1.3.4 - , authIsProtected :: !(Request -> ResourceT IO Bool) + , authIsProtected :: !(Request -> IO Bool) -- ^ Determine if access to the requested resource is restricted. -- -- Default: always returns @True@. diff --git a/Network/Wai/Middleware/Jsonp.hs b/Network/Wai/Middleware/Jsonp.hs --- a/Network/Wai/Middleware/Jsonp.hs +++ b/Network/Wai/Middleware/Jsonp.hs @@ -16,16 +16,18 @@ module Network.Wai.Middleware.Jsonp (jsonp) where import Network.Wai +import Network.Wai.Internal import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 -import Blaze.ByteString.Builder (copyByteString) +import Blaze.ByteString.Builder (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 +import Data.CaseInsensitive (CI) +import Network.HTTP.Types (Status) -- | Wrap json responses in a jsonp callback. -- @@ -51,24 +53,24 @@ $ requestHeaders env } res <- app env' - case callback of - Nothing -> return res + return $ case callback of + Nothing -> 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' $ + Nothing -> r + Just hs' -> ResponseBuilder s hs' $ copyByteString c `mappend` fromChar '(' `mappend` b `mappend` fromChar ')' go c r = case checkJSON hs of - Just hs' -> addCallback c s hs' b - Nothing -> return r + Just hs' -> addCallback c s hs' wb + Nothing -> r where - (s, hs, b) = responseSource r + (s, hs, wb) = responseToSource r checkJSON hs = case lookup "Content-Type" hs of @@ -78,11 +80,16 @@ _ -> Nothing fixHeaders = changeVal "Content-Type" "text/javascript" - addCallback cb s hs b = - return $ ResponseSource s hs $ - CL.sourceList [C.Chunk $ copyByteString cb `mappend` fromChar '('] + addCallback :: ByteString + -> Status + -> [(CI ByteString, ByteString)] + -> (forall b. WithSource IO (C.Flush Builder) b) + -> Response + addCallback cb s hs wb = + ResponseSource s hs $ \f -> wb $ \b -> f $ + C.yield (C.Chunk $ copyByteString cb `mappend` fromChar '(') `mappend` b - `mappend` CL.sourceList [C.Chunk $ fromChar ')'] + `mappend` C.yield (C.Chunk $ fromChar ')') changeVal :: Eq a => a diff --git a/Network/Wai/Middleware/MethodOverridePost.hs b/Network/Wai/Middleware/MethodOverridePost.hs --- a/Network/Wai/Middleware/MethodOverridePost.hs +++ b/Network/Wai/Middleware/MethodOverridePost.hs @@ -12,7 +12,6 @@ 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. @@ -31,7 +30,7 @@ ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= app _ -> app req -setPost :: Request -> ResourceT IO Request +setPost :: Request -> IO Request setPost req = do body <- lazyConsume (requestBody req) case parseQuery (mconcat body) of diff --git a/Network/Wai/Middleware/RequestLogger.hs b/Network/Wai/Middleware/RequestLogger.hs --- a/Network/Wai/Middleware/RequestLogger.hs +++ b/Network/Wai/Middleware/RequestLogger.hs @@ -24,13 +24,17 @@ 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 Network.Wai (Request(..), Middleware, responseStatus, Response, responseHeaders) import System.Log.FastLogger import Network.HTTP.Types as H import Data.Maybe (fromMaybe) +import Control.Monad.Trans.Resource (withInternalState) +import Data.Monoid (mconcat) +import Blaze.ByteString.Builder (toByteString) import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType) import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Char8 as S8 import qualified Data.Conduit as C import qualified Data.Conduit.List as CL @@ -40,20 +44,20 @@ import System.IO.Unsafe import Data.Default (Default (def)) -import Network.Wai.Logger.Format (apacheFormat, IPAddrSource (..)) +import Network.Wai.Logger import Network.Wai.Middleware.RequestLogger.Internal data OutputFormat = Apache IPAddrSource | Detailed Bool -- ^ use colors? | CustomOutputFormat OutputFormatter -type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> [LogStr] +type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr data Destination = Handle Handle - | Logger Logger + | Logger LoggerSet | Callback Callback -type Callback = [LogStr] -> IO () +type Callback = LogStr -> IO () data RequestLoggerSettings = RequestLoggerSettings { @@ -76,28 +80,31 @@ mkRequestLogger :: RequestLoggerSettings -> IO Middleware mkRequestLogger RequestLoggerSettings{..} = do - (callback, mgetdate) <- + callback <- case destination of - Handle h -> fmap fromLogger $ mkLogger autoFlush h - Logger l -> return $ fromLogger l - Callback c -> return (c, Nothing) + Handle h -> return $ BS.hPutStr h . toByteString . logStrBuilder + Logger l -> return $ pushLogStr l + Callback c -> return c case outputFormat of Apache ipsrc -> do - getdate <- dateHelper mgetdate - return $ apacheMiddleware callback ipsrc getdate + getdate <- getDateGetter + apache <- initLogger ipsrc (LogCallback callback (return ())) getdate + return $ apacheMiddleware apache Detailed useColors -> detailedMiddleware callback useColors CustomOutputFormat formatter -> do - getdate <- dateHelper mgetdate + getdate <- getDateGetter return $ customMiddleware callback getdate formatter - where - fromLogger l = (loggerPutStr l, Just $ loggerDate l) - dateHelper mgetdate = do - case mgetdate of - Just x -> return x - Nothing -> getDateGetter -apacheMiddleware :: Callback -> IPAddrSource -> IO ZonedDate -> Middleware -apacheMiddleware cb ipsrc getdate = customMiddleware cb getdate $ apacheFormat ipsrc +apacheMiddleware :: ApacheLoggerActions -> Middleware +apacheMiddleware ala app req = do + res <- app req + let msize = lookup "content-length" (responseHeaders res) >>= readInt' + readInt' bs = + case S8.readInteger bs of + Just (i, "") -> Just i + _ -> Nothing + apacheLogger ala req (responseStatus res) msize + return res customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware customMiddleware cb getdate formatter app req = do @@ -179,7 +186,7 @@ ] detailedMiddleware' :: Callback - -> (C.ResourceT IO (BS.ByteString -> [BS.ByteString])) + -> IO (BS.ByteString -> [BS.ByteString]) -> Middleware detailedMiddleware' cb getAddColor app req = do let mlen = lookup "content-length" (requestHeaders req) >>= readInt @@ -221,7 +228,7 @@ addColor <- getAddColor -- log the request immediately. - liftIO $ cb $ map LB $ addColor (requestMethod req) ++ + liftIO $ cb $ mconcat $ map toLogStr $ addColor (requestMethod req) ++ [ " " , rawPathInfo req , "\n" @@ -237,7 +244,7 @@ -- 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: " ++ [ + liftIO $ cb $ mconcat $ map toLogStr $ addColor "Status: " ++ [ statusBS rsp , " " , msgBS rsp @@ -254,7 +261,8 @@ allPostParams body = case getRequestBodyType req of Nothing -> return ([], []) - Just rbt -> C.runResourceT $ CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt + Just rbt -> C.runResourceT $ withInternalState $ \internalState -> + CL.sourceList body C.$$ sinkRequestBody internalState lbsBackEnd rbt emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString) emptyGetParam (k, Just v) = (k,v) diff --git a/Network/Wai/Middleware/RequestLogger/Internal.hs b/Network/Wai/Middleware/RequestLogger/Internal.hs --- a/Network/Wai/Middleware/RequestLogger/Internal.hs +++ b/Network/Wai/Middleware/RequestLogger/Internal.hs @@ -5,16 +5,7 @@ module Network.Wai.Middleware.RequestLogger.Internal where import Data.ByteString (ByteString) -import System.Log.FastLogger -#if MIN_VERSION_fast_logger(0,3,0) -import System.Date.Cache (ondemandDateCacher) -#else -import System.Log.FastLogger.Date (getDate, dateInit, ZonedDate) -#endif +import Network.Wai.Logger (clockDateCacher) getDateGetter :: IO (IO ByteString) -#if MIN_VERSION_fast_logger(0, 3, 0) -getDateGetter = fmap fst $ ondemandDateCacher zonedDateCacheConf -#else -getDateGetter = fmap getDate dateInit -#endif +getDateGetter = fmap fst clockDateCacher diff --git a/Network/Wai/Middleware/Vhost.hs b/Network/Wai/Middleware/Vhost.hs --- a/Network/Wai/Middleware/Vhost.hs +++ b/Network/Wai/Middleware/Vhost.hs @@ -16,7 +16,7 @@ redirectWWW :: Text -> Application -> Application -- W.MiddleWare redirectWWW home app req = - if BS.isPrefixOf "www" $ serverName req + if maybe True (BS.isPrefixOf "www") $ lookup "host" $ requestHeaders req then return $ responseLBS H.status301 [ ("Content-Type", "text/plain") , ("Location", TE.encodeUtf8 home) ] "Redirect" else app req diff --git a/Network/Wai/Parse.hs b/Network/Wai/Parse.hs --- a/Network/Wai/Parse.hs +++ b/Network/Wai/Parse.hs @@ -51,13 +51,9 @@ 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 Control.Monad.Trans.Resource (allocate, release, register, InternalState, withInternalState, runInternalState) import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, injectLeftovers, ConduitM (..)) import Data.Void (Void) -#else -import Data.Conduit.Internal (sinkToPipe) -#endif breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s = @@ -169,34 +165,33 @@ parseRequestBody :: BackEnd y -> Request - -> ResourceT IO ([Param], [File y]) + -> IO ([Param], [File y]) parseRequestBody s r = case getRequestBodyType r of Nothing -> return ([], []) - Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume + Just rbt -> runResourceT $ withInternalState $ \internalState -> + fmap partitionEithers $ requestBody r $$ conduitRequestBody internalState s rbt =$ CL.consume -sinkRequestBody :: BackEnd y +sinkRequestBody :: InternalState + -> BackEnd y -> RequestBodyType - -> Sink S.ByteString (ResourceT IO) ([Param], [File y]) -sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume + -> Sink S.ByteString IO ([Param], [File y]) +sinkRequestBody internalState s r = fmap partitionEithers $ conduitRequestBody internalState s r =$ CL.consume -conduitRequestBody :: BackEnd y +conduitRequestBody :: InternalState + -> BackEnd y -> RequestBodyType - -> Conduit S.ByteString (ResourceT IO) (Either Param (File y)) -conduitRequestBody _ UrlEncoded = do + -> Conduit S.ByteString 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 +conduitRequestBody internalState backend (Multipart bound) = + parsePieces internalState 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 @@ -211,11 +206,7 @@ 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 :: Consumer S.ByteString IO [S.ByteString] takeLines = do res <- takeLine case res of @@ -226,14 +217,11 @@ ls <- takeLines return $ l : ls -parsePieces :: BackEnd y +parsePieces :: InternalState + -> 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 = + -> ConduitM S.ByteString (Either Param (File y)) IO () +parsePieces internalState sink bound = loop where loop = do @@ -251,7 +239,7 @@ Just (mct, name, Just filename) -> do let ct = fromMaybe "application/octet-stream" mct fi0 = FileInfo filename ct () - (wasFound, y) <- sinkTillBound' bound name fi0 sink + (wasFound, y) <- sinkTillBound' internalState bound name fi0 sink yield $ Right (name, fi0 { fileContent = y }) when wasFound loop Just (_ct, name, Nothing) -> do @@ -303,45 +291,30 @@ | S.index b x == S.index bs y = mismatch xs ys | otherwise = True -sinkTillBound' :: S.ByteString +sinkTillBound' :: InternalState -> 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 S.ByteString o IO (Bool, y) +sinkTillBound' internalState bound name fi sink = 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 + fix :: Sink S8.ByteString (ResourceT IO) y -> Pipe Void S8.ByteString Void Bool IO y + fix p = ignoreTerm >+> injectLeftovers (unConduitM $ transPipe (flip runInternalState internalState) 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) @@ -371,26 +344,16 @@ 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 + -> Consumer S.ByteString IO (Bool, x) 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 diff --git a/test/WaiExtraTest.hs b/test/WaiExtraTest.hs --- a/test/WaiExtraTest.hs +++ b/test/WaiExtraTest.hs @@ -3,6 +3,8 @@ import Test.Hspec import Test.HUnit hiding (Test) +import Data.Monoid (mappend, mempty) +import Blaze.ByteString.Builder (toByteString) import Network.Wai import Network.Wai.Test @@ -15,6 +17,7 @@ import qualified Data.Text as TS import qualified Data.Text.Encoding as TE import Control.Arrow +import Control.Monad.Trans.Resource (getInternalState, withInternalState, runResourceT) import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip @@ -116,15 +119,16 @@ parseRequestBody' :: BackEnd L.ByteString -> SRequest - -> C.ResourceT IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)]) + -> 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 + Just rbt -> runResourceT $ withInternalState $ \is -> + CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody is sink rbt caseParseRequestBody :: Assertion caseParseRequestBody = - C.runResourceT t + t where content2 = S8.pack $ "--AaB03x\n" ++ @@ -188,7 +192,7 @@ caseMultipartPlus :: Assertion caseMultipartPlus = do - result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content + result <- parseRequestBody' lbsBackEnd $ toRequest ctype content liftIO $ result @?= ([("email", "has+plus")], []) where content = S8.pack $ @@ -201,7 +205,7 @@ caseMultipartAttrs :: Assertion caseMultipartAttrs = do - result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content + result <- parseRequestBody' lbsBackEnd $ toRequest ctype content liftIO $ result @?= ([("email", "has+plus")], []) where content = S8.pack $ @@ -214,7 +218,7 @@ caseUrlEncPlus :: Assertion caseUrlEncPlus = do - result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content + result <- parseRequestBody' lbsBackEnd $ toRequest ctype content liftIO $ result @?= ([("email", "has+plus")], []) where content = S8.pack $ "email=has%2Bplus" @@ -374,19 +378,19 @@ vhostApp1 = const $ return $ responseLBS status200 [] "app1" vhostApp2 = const $ return $ responseLBS status200 [] "app2" vhostApp = vhost - [ ((== "foo.com") . serverName, vhostApp1) + [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1) ] vhostApp2 caseVhost :: Assertion caseVhost = flip runSession vhostApp $ do sres1 <- request defaultRequest - { serverName = "foo.com" + { requestHeaders = [("Host", "foo.com")] } assertBody "app1" sres1 sres2 <- request defaultRequest - { serverName = "bar.com" + { requestHeaders = [("Host", "bar.com")] } assertBody "app2" sres2 @@ -510,8 +514,10 @@ (params, files) <- case getRequestBodyType request' of Nothing -> return ([], []) - Just rbt -> C.runResourceT $ sourceFile "test/requests/dalvik-request" - C.$$ sinkRequestBody lbsBackEnd rbt + Just rbt -> C.runResourceT $ do + internalState <- getInternalState + sourceFile "test/requests/dalvik-request" + C.$$ C.transPipe liftIO (sinkRequestBody internalState lbsBackEnd rbt) lookup "scannedTime" params @?= Just "1.298590056748E9" lookup "geoLong" params @?= Just "0" lookup "geoLat" params @?= Just "0" @@ -540,21 +546,19 @@ getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n" debugApp output' req = do - iactual <- liftIO $ I.newIORef [] + iactual <- liftIO $ I.newIORef mempty middleware <- liftIO $ mkRequestLogger def - { destination = Callback $ \strs -> I.modifyIORef iactual $ (++ strs) + { destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs) , outputFormat = Detailed False } res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req actual <- liftIO $ I.readIORef iactual - liftIO $ assertEqual "debug" output $ logsToBs actual + liftIO $ assertEqual "debug" output $ logToBs 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 + logToBs = toByteString . logStrBuilder {-debugApp = debug $ \req -> do-} {-return $ responseLBS status200 [ ] ""-} diff --git a/tests.hs b/tests.hs --- a/tests.hs +++ b/tests.hs @@ -1,4 +1,4 @@ -import Test.Hspec.Monadic +import Test.Hspec import qualified WaiExtraTest main :: IO () diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -1,5 +1,5 @@ Name: wai-extra -Version: 1.3.4.6 +Version: 2.0.0 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: MIT @@ -22,7 +22,7 @@ Library Build-Depends: base >= 4 && < 5 , bytestring >= 0.9.1.4 - , wai >= 1.3 && < 1.5 + , wai >= 2.0 && < 2.1 , old-locale >= 1.0.0.2 && < 1.1 , time >= 1.1.4 , network >= 2.2.1.5 @@ -33,10 +33,9 @@ , 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 + , fast-logger >= 2.0 && < 2.1 + , wai-logger >= 2.0 && < 2.1 + , conduit >= 1.0 && < 1.1 , zlib-conduit >= 0.5 && < 1.1 , blaze-builder-conduit >= 0.5 && < 1.1 , ansi-terminal @@ -88,6 +87,7 @@ , data-default , conduit , fast-logger + , resourcet ghc-options: -Wall source-repository head