@@ -0,0 +1,109 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TupleSections #-}
5+{-# LANGUAGE TypeOperators #-}
6+
7+-- | This module tests whether streaming works from client to server
8+-- with a server implemented with servant-server.
9+module Servant.Server.StreamingSpec where
10+
11+import Control.Concurrent
12+import Control.Exception
13+import Control.Monad.IO.Class
14+import Control.Monad.Trans.Except
15+import qualified Data.ByteString as Strict
16+import qualified Data.ByteString.Lazy as Lazy
17+import Network.HTTP.Types
18+import Network.Wai
19+import Network.Wai.Internal
20+import Prelude ()
21+import Prelude.Compat
22+import Servant
23+import qualified System.Timeout
24+import Test.Hspec
25+
26+type TestAPI =
27+ ReqBody '[OctetStream] Lazy.ByteString :> Get '[JSON] NoContent
28+
29+testAPI :: Proxy TestAPI
30+testAPI = Proxy
31+
32+spec :: Spec
33+spec = do
34+ -- The idea of this test is this:
35+ --
36+ -- - The mock client will
37+ -- - send some data in the request body, but not all,
38+ -- - wait for the server to acknowledge (outside of http, through an MVar)
39+ -- that the server received some data,
40+ -- - send the rest of the request body.
41+ -- - The mock server will
42+ -- - receive some data,
43+ -- - notify the client that it received some data,
44+ -- - receive the rest of the data,
45+ -- - respond with an empty result.
46+ it "client to server can stream lazy ByteStrings" $ timeout $ do
47+ serverReceivedFirstChunk <- newWaiter
48+
49+ -- - streams some test data
50+ -- - waits for serverReceivedFirstChunk
51+ -- - streams some more test data
52+ streamTestData <- do
53+ mvar :: MVar [IO Strict.ByteString] <- newMVar $
54+ map return (replicate 1000 "foo") ++
55+ (waitFor serverReceivedFirstChunk >> return "foo") :
56+ map return (replicate 1000 "foo")
57+ return $ modifyMVar mvar $ \ actions -> case actions of
58+ (a : r) -> (r, ) <$> a
59+ [] -> return ([], "")
60+
61+ let request = defaultRequest {
62+ requestBody = streamTestData,
63+ requestBodyLength = ChunkedBody
64+ }
65+
66+ -- - receives the first chunk
67+ -- - notifies serverReceivedFirstChunk
68+ -- - receives the rest of the request
69+ let handler :: Lazy.ByteString -> ExceptT ServantErr IO NoContent
70+ handler input = liftIO $ do
71+ let prefix = Lazy.take 3 input
72+ prefix `shouldBe` "foo"
73+ notify serverReceivedFirstChunk ()
74+ input `shouldBe` mconcat (replicate 2001 "foo")
75+ return NoContent
76+
77+ app = serve testAPI handler
78+ response <- executeRequest app request
79+ statusCode (responseStatus response) `shouldBe` 200
80+
81+executeRequest :: Application -> Request -> IO Response
82+executeRequest app request = do
83+ responseMVar <- newEmptyMVar
84+ let respond response = do
85+ putMVar responseMVar response
86+ return ResponseReceived
87+ ResponseReceived <- app request respond
88+ takeMVar responseMVar
89+
90+timeout :: IO a -> IO a
91+timeout action = do
92+ result <- System.Timeout.timeout 1000000 action
93+ maybe (throwIO $ ErrorCall "timeout") return result
94+
95+-- * waiter
96+
97+data Waiter a
98+ = Waiter {
99+ notify :: a -> IO (),
100+ waitFor :: IO a
101+ }
102+
103+newWaiter :: IO (Waiter a)
104+newWaiter = do
105+ mvar <- newEmptyMVar
106+ return $ Waiter {
107+ notify = putMVar mvar,
108+ waitFor = readMVar mvar
109+ }