diff --git a/Network/Wai/Application/Classic/CGI.hs b/Network/Wai/Application/Classic/CGI.hs --- a/Network/Wai/Application/Classic/CGI.hs +++ b/Network/Wai/Application/Classic/CGI.hs @@ -4,7 +4,6 @@ cgiApp ) where -import Control.Applicative import Control.Exception (SomeException) import Control.Exception.Lifted (catch) import Control.Monad (when) @@ -72,15 +71,14 @@ fromCGI :: Handle -> ClassicAppSpec -> Application fromCGI rhdl cspec req = do - bsrc <- bufferSource $ CB.sourceHandle rhdl - m <- (check <$> (bsrc $$ parseHeader)) `catch` recover - let (st, hdr, hasBody) = case m of + (src', hs) <- (CB.sourceHandle rhdl $$+ parseHeader) `catch` recover + let (st, hdr, hasBody) = case check hs of Nothing -> (internalServerError500,[],False) Just (s,h) -> (s,h,True) hdr' = addServer cspec hdr liftIO $ logger cspec req st Nothing - let src = if hasBody then toSource bsrc else CL.sourceNull - return $ ResponseSource st hdr' (Chunk <$> src) + let src = if hasBody then src' else CL.sourceNull + return $ ResponseSource st hdr' (toResponseSource src) where check hs = lookup fkContentType hs >> case lookup "status" hs of Nothing -> Just (ok200, hs) @@ -88,7 +86,8 @@ where hs' = filter (\(k,_) -> k /= "status") hs toStatus s = BS.readInt s >>= \x -> Just (Status (fst x) s) - recover (_ :: SomeException) = return Nothing + emptyHeader = [] + recover (_ :: SomeException) = return (CL.sourceNull, emptyHeader) ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/Conduit.hs b/Network/Wai/Application/Classic/Conduit.hs --- a/Network/Wai/Application/Classic/Conduit.hs +++ b/Network/Wai/Application/Classic/Conduit.hs @@ -2,7 +2,7 @@ module Network.Wai.Application.Classic.Conduit ( byteStringToBuilder - , toSource + , toResponseSource , parseHeader ) where @@ -14,6 +14,7 @@ import Data.CaseInsensitive (CI(..), mk) import Data.Conduit import Data.Conduit.Attoparsec +import qualified Data.Conduit.List as CL import Data.Word import Network.HTTP.Types @@ -24,12 +25,13 @@ ---------------------------------------------------------------- -toSource :: BufferedSource IO ByteString -> Source IO Builder -toSource = fmap byteStringToBuilder . unbufferSource +toResponseSource :: Source (ResourceT IO) ByteString + -> Source (ResourceT IO) (Flush Builder) +toResponseSource = ($= CL.map (Chunk . byteStringToBuilder)) ---------------------------------------------------------------- -parseHeader :: Sink ByteString IO RequestHeaders +parseHeader :: Sink ByteString (ResourceT IO) RequestHeaders parseHeader = sinkParser parseHeader' parseHeader' :: Parser RequestHeaders diff --git a/Network/Wai/Application/Classic/RevProxy.hs b/Network/Wai/Application/Classic/RevProxy.hs --- a/Network/Wai/Application/Classic/RevProxy.hs +++ b/Network/Wai/Application/Classic/RevProxy.hs @@ -9,6 +9,7 @@ import qualified Data.ByteString.Char8 as BS hiding (uncons) import qualified Data.ByteString as BS (uncons) import Data.Conduit +import qualified Data.Conduit.List as CL import Data.Int import Data.Maybe import qualified Network.HTTP.Conduit as H @@ -20,7 +21,7 @@ import Network.Wai.Application.Classic.Types import Prelude hiding (catch) -toHTTPRequest :: Request -> RevProxyRoute -> Int64 -> H.Request IO +toHTTPRequest :: Request -> RevProxyRoute -> Int64 -> H.Request (ResourceT IO) toHTTPRequest req route len = H.def { H.host = revProxyDomain route , H.port = revProxyPort route @@ -45,10 +46,10 @@ Just (63, q') -> q' -- '?' is 63 _ -> q -getBody :: Request -> Int64 -> H.RequestBody IO +getBody :: Request -> Int64 -> H.RequestBody (ResourceT IO) getBody req len = H.RequestBodySource len (toBodySource req) where - toBodySource = (byteStringToBuilder <$>) . requestBody + toBodySource r = requestBody r $= CL.map byteStringToBuilder getLen :: Request -> Maybe Int64 getLen req = do @@ -71,10 +72,10 @@ let mlen = getLen req len = fromMaybe 0 mlen httpReq = toHTTPRequest req route len - H.Response status hdr downbody <- http httpReq mgr + H.Response status _ hdr downbody <- http httpReq mgr let hdr' = fixHeader hdr liftIO $ logger cspec req status (fromIntegral <$> mlen) - return $ ResponseSource status hdr' (Chunk . byteStringToBuilder <$> downbody) + return $ ResponseSource status hdr' (toResponseSource downbody) where mgr = revProxyManager spec fixHeader = addVia cspec req . filter p @@ -82,9 +83,9 @@ p ("Content-Length", _) = False p _ = True -type Resp = ResourceT IO (H.Response (Source IO BS.ByteString)) +type Resp = ResourceT IO (H.Response (Source (ResourceT IO) BS.ByteString)) -http :: H.Request IO -> H.Manager -> Resp +http :: H.Request (ResourceT IO) -> H.Manager -> Resp http req mgr = H.http req mgr badGateway :: ClassicAppSpec -> Request-> SomeException -> ResourceT IO Response diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -4,6 +4,7 @@ import Control.Exception.Lifted import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Conduit import Network.HTTP.Conduit import qualified Network.HTTP.Types as H import Prelude hiding (catch) @@ -25,7 +26,7 @@ case_post :: Assertion case_post = do - Response _ _ bdy <- sendPOST url "foo bar.\nbaz!\n" + Response _ _ _ bdy <- sendPOST url "foo bar.\nbaz!\n" ans <- BL.readFile "test/data/post" bdy @?= ans where @@ -33,7 +34,7 @@ case_post2 :: Assertion case_post2 = do - Response sc _ _ <- sendPOST url "foo bar.\nbaz!\n" + Response sc _ _ _ <- sendPOST url "foo bar.\nbaz!\n" sc @?= H.internalServerError500 where url = "http://localhost:8080/cgi-bin/broken" @@ -53,7 +54,7 @@ case_get2 :: Assertion case_get2 = do req <- parseUrl url - Response sc _ _ <- safeHttpLbs req + Response sc _ _ _ <- safeHttpLbs req sc @?= H.notFound404 where url = "http://localhost:8080/dummy" @@ -62,7 +63,7 @@ case_get_ja :: Assertion case_get_ja = do - Response _ _ bdy <- sendGET url [("Accept-Language", "ja, en;q=0.7")] + Response _ _ _ bdy <- sendGET url [("Accept-Language", "ja, en;q=0.7")] ans <- BL.readFile "test/html/ja/index.html.ja" bdy @?= ans where @@ -72,9 +73,9 @@ case_get_modified :: Assertion case_get_modified = do - Response _ hdr _ <- sendGET url [] + Response _ _ hdr _ <- sendGET url [] let Just lm = lookup "Last-Modified" hdr - Response sc _ _ <- sendGET url [("If-Modified-Since", lm)] + Response sc _ _ _ <- sendGET url [("If-Modified-Since", lm)] sc @?= H.notModified304 where url = "http://localhost:8080/" @@ -83,7 +84,7 @@ case_get_partial :: Assertion case_get_partial = do - Response _ _ bdy <- sendGET url [("Range", "bytes=10-20")] + Response _ _ _ bdy <- sendGET url [("Range", "bytes=10-20")] bdy @?= ans where url = "http://localhost:8080/" @@ -93,7 +94,7 @@ case_head :: Assertion case_head = do - Response sc _ _ <- sendHEAD url [] + Response sc _ _ _ <- sendHEAD url [] sc @?= H.ok200 where url = "http://localhost:8080/" @@ -102,7 +103,7 @@ case_head2 :: Assertion case_head2 = do - Response sc _ _ <- sendHEAD url [] + Response sc _ _ _ <- sendHEAD url [] sc @?= H.notFound404 where url = "http://localhost:8080/dummy" @@ -111,7 +112,7 @@ case_head_ja :: Assertion case_head_ja = do - Response sc _ _ <- sendHEAD url [("Accept-Language", "ja, en;q=0.7")] + Response sc _ _ _ <- sendHEAD url [("Accept-Language", "ja, en;q=0.7")] sc @?= H.ok200 where url = "http://localhost:8080/ja/" @@ -120,9 +121,9 @@ case_head_modified :: Assertion case_head_modified = do - Response _ hdr _ <- sendHEAD url [] + Response _ _ hdr _ <- sendHEAD url [] let Just lm = lookup "Last-Modified" hdr - Response sc _ _ <- sendHEAD url [("If-Modified-Since", lm)] + Response sc _ _ _ <- sendHEAD url [("If-Modified-Since", lm)] sc @?= H.notModified304 where url = "http://localhost:8080/" @@ -170,11 +171,11 @@ ---------------------------------------------------------------- -safeHttpLbs :: Request IO -> IO (Response BL.ByteString) +safeHttpLbs :: Request (ResourceT IO) -> IO (Response BL.ByteString) safeHttpLbs req = withManager (httpLbs req) `catch` httpHandler ---------------------------------------------------------------- httpHandler :: HttpException -> IO (Response BL.ByteString) -httpHandler (StatusCodeException sc hd) = return (Response sc hd BL.empty) +httpHandler (StatusCodeException sc hd) = return (Response sc H.http11 hd BL.empty) httpHandler _ = error "handler" diff --git a/wai-app-file-cgi.cabal b/wai-app-file-cgi.cabal --- a/wai-app-file-cgi.cabal +++ b/wai-app-file-cgi.cabal @@ -1,5 +1,5 @@ Name: wai-app-file-cgi -Version: 0.5.7 +Version: 0.5.8 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -36,21 +36,22 @@ , blaze-builder , bytestring , case-insensitive - , conduit >= 0.2 && < 0.3 + , conduit >= 0.4 && < 0.5 , containers , directory , filepath - , http-conduit >= 1.2 && < 1.3 + , http-conduit , http-date , http-types >= 0.6.9 , io-choice , lifted-base , network , process + , resourcet , static-hash , transformers , unix - , wai >= 1.1 + , wai >= 1.2 , wai-app-static >= 0.3 , wai-logger @@ -60,7 +61,8 @@ HS-Source-Dirs: test Build-Depends: base >= 4 && < 5 , bytestring - , http-conduit >= 1.2 && < 1.3 + , conduit >= 0.4 && < 0.5 + , http-conduit , http-types , lifted-base , HUnit