diff --git a/Network/Wai.hs b/Network/Wai.hs --- a/Network/Wai.hs +++ b/Network/Wai.hs @@ -39,6 +39,7 @@ -- * Types Application , Middleware + , ResponseReceived -- * Request , Request , defaultRequest @@ -61,36 +62,35 @@ , lazyRequestBody -- * Response , Response + , StreamingBody , FilePart (..) - , WithSource -- ** Response composers , responseFile , responseBuilder , responseLBS - , responseSource - , responseSourceBracket + , responseStream , responseRaw -- * Response accessors , responseStatus , responseHeaders - , responseToSource + , responseToStream ) where import Blaze.ByteString.Builder (Builder, fromLazyByteString) import Blaze.ByteString.Builder (fromByteString) -import Control.Exception (bracket, bracketOnError) +import Control.Monad (unless) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as LI +import Data.ByteString.Lazy.Internal (defaultChunkSize) import Data.ByteString.Lazy.Char8 () -import qualified Data.Conduit as C -import qualified Data.Conduit.Binary as CB -import Data.Conduit.Lazy (lazyConsume) -import qualified Data.Conduit.List as CL +import Data.Function (fix) import Data.Monoid (mempty) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr (SockAddrInet)) import Network.Wai.Internal import qualified System.IO as IO +import System.IO.Unsafe (unsafeInterleaveIO) ---------------------------------------------------------------- @@ -130,29 +130,11 @@ responseLBS s h = ResponseBuilder s h . fromLazyByteString -- | Creating 'Response' from 'C.Source'. -responseSource :: H.Status -> H.ResponseHeaders -> C.Source IO (C.Flush Builder) -> Response -responseSource st hs src = ResponseSource st hs ($ src) - --- | Creating 'Response' with allocated resource safely released. --- --- * The first argument is an action to allocate resource. --- --- * The second argument is a function to release the resource. --- --- * The third argument is a function to create --- ('H.Status','H.ResponseHeaders','C.Source' 'IO' ('C.Flush' 'Builder')) --- from the resource. -responseSourceBracket :: IO a - -> (a -> IO ()) - -> (a -> IO (H.Status - ,H.ResponseHeaders - ,C.Source IO (C.Flush Builder))) - -> IO Response -responseSourceBracket setup teardown action = - bracketOnError setup teardown $ \resource -> do - (st,hdr,src) <- action resource - return $ ResponseSource st hdr $ \f -> - bracket (return resource) teardown (\_ -> f src) +responseStream :: H.Status + -> H.ResponseHeaders + -> StreamingBody + -> Response +responseStream = ResponseStream -- | Create a response for a raw application. This is useful for \"upgrade\" -- situations such as WebSockets, where an application requests for the server @@ -165,10 +147,10 @@ -- @responseRaw@, behavior is undefined. -- -- Since 2.1.0 -responseRaw :: (C.Source IO B.ByteString -> C.Sink B.ByteString IO () -> IO ()) +responseRaw :: (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()) -> Response -> Response -responseRaw rawApp fallback = ResponseRaw ($ rawApp) fallback +responseRaw = ResponseRaw ---------------------------------------------------------------- @@ -176,36 +158,55 @@ responseStatus :: Response -> H.Status responseStatus (ResponseFile s _ _ _) = s responseStatus (ResponseBuilder s _ _ ) = s -responseStatus (ResponseSource s _ _ ) = s +responseStatus (ResponseStream s _ _ ) = s responseStatus (ResponseRaw _ res ) = responseStatus res -- | Accessing 'H.ResponseHeaders' in 'Response'. responseHeaders :: Response -> H.ResponseHeaders responseHeaders (ResponseFile _ hs _ _) = hs responseHeaders (ResponseBuilder _ hs _ ) = hs -responseHeaders (ResponseSource _ hs _ ) = hs +responseHeaders (ResponseStream _ hs _ ) = hs responseHeaders (ResponseRaw _ res) = responseHeaders res -- | Converting the body information in 'Response' to 'Source'. -responseToSource :: Response - -> (H.Status, H.ResponseHeaders, WithSource IO (C.Flush Builder) b) -responseToSource (ResponseSource s h b) = (s, h, b) -responseToSource (ResponseFile s h fp (Just part)) = - (s, h, \f -> IO.withFile fp IO.ReadMode $ \handle -> f $ sourceFilePart handle part C.$= CL.map (C.Chunk . fromByteString)) -responseToSource (ResponseFile s h fp Nothing) = - (s, h, \f -> IO.withFile fp IO.ReadMode $ \handle -> f $ CB.sourceHandle handle C.$= CL.map (C.Chunk . fromByteString)) -responseToSource (ResponseBuilder s h b) = - (s, h, ($ CL.sourceList [C.Chunk b])) -responseToSource (ResponseRaw _ res) = responseToSource res - -sourceFilePart :: IO.Handle -> FilePart -> C.Source IO B.ByteString -sourceFilePart handle (FilePart offset count _) = - CB.sourceHandleRange handle (Just offset) (Just count) +responseToStream :: Response + -> ( H.Status + , H.ResponseHeaders + , (StreamingBody -> IO a) -> IO a + ) +responseToStream (ResponseStream s h b) = (s, h, ($ b)) +responseToStream (ResponseFile s h fp (Just part)) = + ( s + , h + , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle -> withBody $ \sendChunk _flush -> do + IO.hSeek handle IO.AbsoluteSeek $ filePartOffset part + let loop remaining | remaining <= 0 = return () + loop remaining = do + bs <- B.hGetSome handle defaultChunkSize + unless (B.null bs) $ do + let x = B.take remaining bs + sendChunk $ fromByteString x + loop $ remaining - B.length x + loop $ fromIntegral $ filePartByteCount part + ) +responseToStream (ResponseFile s h fp Nothing) = + ( s + , h + , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle -> + withBody $ \sendChunk _flush -> fix $ \loop -> do + bs <- B.hGetSome handle defaultChunkSize + unless (B.null bs) $ do + sendChunk $ fromByteString bs + loop + ) +responseToStream (ResponseBuilder s h b) = + (s, h, \withBody -> withBody $ \sendChunk _flush -> sendChunk b) +responseToStream (ResponseRaw _ res) = responseToStream res ---------------------------------------------------------------- -- | The WAI application. -type Application = Request -> IO Response +type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived -- | Middleware is a component that sits between the server and application. It -- can do such tasks as GZIP encoding or response caching. What follows is the @@ -237,7 +238,7 @@ , remoteHost = SockAddrInet 0 0 , pathInfo = [] , queryString = [] - , requestBody = return () + , requestBody = return B.empty , vault = mempty , requestBodyLength = KnownLength 0 , requestHeaderHost = Nothing @@ -249,4 +250,13 @@ -- -- Since 1.4.1 lazyRequestBody :: Request -> IO L.ByteString -lazyRequestBody = fmap L.fromChunks . lazyConsume . requestBody +lazyRequestBody req = + loop + where + loop = unsafeInterleaveIO $ do + bs <- requestBody req + if B.null bs + then return LI.Empty + else do + bss <- loop + return $ LI.Chunk bs bss diff --git a/Network/Wai/Internal.hs b/Network/Wai/Internal.hs --- a/Network/Wai/Internal.hs +++ b/Network/Wai/Internal.hs @@ -8,7 +8,6 @@ import Blaze.ByteString.Builder (Builder) import qualified Data.ByteString as B -import qualified Data.Conduit as C import Data.Text (Text) import Data.Typeable (Typeable) import Data.Vault.Lazy (Vault) @@ -51,8 +50,9 @@ , pathInfo :: [Text] -- | Parsed query string information , queryString :: H.Query - -- | A request body provided as 'Source'. - , requestBody :: C.Source IO B.ByteString + -- | Get the next chunk of the body. Returns an empty bytestring when the + -- body is fully consumed. + , requestBody :: IO B.ByteString -- | A location for arbitrary data to be shared by applications and middleware. , vault :: Vault -- | The size of the request body. In the case of a chunked request body, @@ -84,15 +84,17 @@ data Response = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart) | ResponseBuilder H.Status H.ResponseHeaders Builder - | ResponseSource H.Status H.ResponseHeaders (forall b. WithSource IO (C.Flush Builder) b) - | ResponseRaw (forall b. WithRawApp b) Response + | ResponseStream H.Status H.ResponseHeaders StreamingBody + | ResponseRaw (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()) Response deriving Typeable -type RawApp = C.Source IO B.ByteString -> C.Sink B.ByteString IO () -> IO () -type WithRawApp b = (RawApp -> IO b) -> IO b - --- | Auxiliary type for 'ResponseSource'. -type WithSource m a b = (C.Source m a -> m b) -> m b +-- | Represents a streaming HTTP response body. It's a function of two +-- parameters; the first parameter provides a means of sending another chunk of +-- data, and the second parameter provides a means of flushing the data to the +-- client. +-- +-- Since 3.0.0 +type StreamingBody = (Builder -> IO ()) -> IO () -> IO () -- | The size of the request body. In the case of chunked bodies, the size will -- not be known. @@ -108,3 +110,14 @@ , filePartByteCount :: Integer , filePartFileSize :: Integer } deriving Show + +-- | A special datatype to indicate that the WAI handler has received the +-- response. This is to avoid the need for Rank2Types in the definition of +-- Application. +-- +-- It is /highly/ advised that only WAI handlers import and use the data +-- constructor for this data type. +-- +-- Since 3.0.0 +data ResponseReceived = ResponseReceived + deriving Typeable diff --git a/test/Network/WaiSpec.hs b/test/Network/WaiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/WaiSpec.hs @@ -0,0 +1,73 @@ +module Network.WaiSpec (spec) where + +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Network.Wai +import Network.Wai.Internal (Request (Request)) +import Data.IORef +import Data.Monoid +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder (toByteString, Builder, fromWord8) +import Control.Monad (forM_) + +spec :: Spec +spec = do + describe "responseToStream" $ do + let getBody res = do + let (_, _, f) = responseToStream res + f $ \streamingBody -> do + builderRef <- newIORef mempty + let add :: Builder -> IO () + add b = atomicModifyIORef builderRef $ \builder -> + (builder `mappend` b, ()) + flush :: IO () + flush = return () + streamingBody add flush + fmap toByteString $ readIORef builderRef + prop "responseLBS" $ \bytes -> do + body <- getBody $ responseLBS undefined undefined $ L.pack bytes + body `shouldBe` S.pack bytes + prop "responseBuilder" $ \bytes -> do + body <- getBody $ responseBuilder undefined undefined + $ mconcat $ map fromWord8 bytes + body `shouldBe` S.pack bytes + prop "responseStream" $ \chunks -> do + body <- getBody $ responseStream undefined undefined $ \sendChunk _ -> + forM_ chunks $ \chunk -> sendChunk $ mconcat $ map fromWord8 chunk + body `shouldBe` S.concat (map S.pack chunks) + it "responseFile total" $ do + let fp = "wai.cabal" + body <- getBody $ responseFile undefined undefined fp Nothing + expected <- S.readFile fp + body `shouldBe` expected + prop "responseFile partial" $ \offset' count' -> do + let fp = "wai.cabal" + totalBS <- S.readFile fp + let total = S.length totalBS + offset = abs offset' `mod` total + count = abs count' `mod` (total - offset) + body <- getBody $ responseFile undefined undefined fp $ Just FilePart + { filePartOffset = fromIntegral offset + , filePartByteCount = fromIntegral count + , filePartFileSize = fromIntegral total + } + let expected = S.take count $ S.drop offset totalBS + body `shouldBe` expected + describe "lazyRequestBody" $ do + prop "works" $ \chunks -> do + ref <- newIORef $ map S.pack $ filter (not . null) chunks + let req = Request + { requestBody = atomicModifyIORef ref $ \bss -> + case bss of + [] -> ([], S.empty) + x:y -> (y, x) + } + body <- lazyRequestBody req + body `shouldBe` L.fromChunks (map S.pack chunks) + it "is lazy" $ do + let req = Request + { requestBody = error "requestBody" + } + _ <- lazyRequestBody req + return () diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/wai.cabal b/wai.cabal --- a/wai.cabal +++ b/wai.cabal @@ -1,5 +1,5 @@ Name: wai -Version: 2.1.0.3 +Version: 3.0.0 Synopsis: Web Application Interface. Description: Provides a common protocol for communication between web applications and web servers. License: MIT @@ -9,7 +9,7 @@ Homepage: https://github.com/yesodweb/wai Category: Web Build-Type: Simple -Cabal-Version: >=1.6 +Cabal-Version: >=1.8 Stability: Stable Source-repository head @@ -20,13 +20,27 @@ Build-Depends: base >= 4 && < 5 , bytestring >= 0.9.1.4 , blaze-builder >= 0.2.1.4 && < 0.4 - , conduit >= 1.0.8 && < 1.2 - , conduit-extra >= 1.0 , network >= 2.2.1.5 , http-types >= 0.7 , text >= 0.7 - , transformers >= 0.2.2 , vault >= 0.3 && < 0.4 Exposed-modules: Network.Wai Network.Wai.Internal ghc-options: -Wall + +test-suite test + hs-source-dirs: test + main-is: Spec.hs + type: exitcode-stdio-1.0 + ghc-options: -threaded + cpp-options: -DTEST + build-depends: base + , wai + , hspec + , blaze-builder + , bytestring + other-modules: Network.WaiSpec + +source-repository head + type: git + location: git://github.com/yesodweb/wai.git