git.iko.soy/servant
on master help sign in
Test that Stream combinator doesn't blow up memory.
37482d6Julian K. Arni
servant-client/servant-client.cabal+1−1
compare with master
unifiedsplit
@@ -82,7 +82,7 @@ library
82
82
83test-suite spec
83test-suite spec
84 type: exitcode-stdio-1.0
84 type: exitcode-stdio-1.0
85− ghc-options: -Wall
85+ ghc-options: -Wall -rtsopts -with-rtsopts=-T
86 default-language: Haskell2010
86 default-language: Haskell2010
87 hs-source-dirs: test
87 hs-source-dirs: test
88 main-is: Spec.hs
88 main-is: Spec.hs
servant-client/src/Servant/Client/Internal/HttpClient.hs+10−2
@@ -183,10 +183,18 @@ requestToClientRequest burl r = Client.defaultRequest
183 where
183 where
184 hs = toList $ requestAccept r
184 hs = toList $ requestAccept r
185
185
186+ convertBody bd = case bd of
187+ RequestBodyLBS body' -> Client.RequestBodyLBS body'
188+ RequestBodyBS body' -> Client.RequestBodyBS body'
189+ RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body'
190+ RequestBodyStream size body' -> Client.RequestBodyStream size body'
191+ RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body'
192+ RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body')
193+
186 (body, contentTypeHdr) = case requestBody r of
194 (body, contentTypeHdr) = case requestBody r of
187 Nothing -> (Client.RequestBodyLBS "", Nothing)
195 Nothing -> (Client.RequestBodyLBS "", Nothing)
188− Just (RequestBodyLBS body', typ)
196+ Just (body', typ)
189− -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))
197+ -> (convertBody body', Just (hContentType, renderHeader typ))
190
198
191 isSecure = case baseUrlScheme burl of
199 isSecure = case baseUrlScheme burl of
192 Http -> False
200 Http -> False
servant-client/test/Servant/ClientSpec.hs+3
@@ -103,6 +103,9 @@ instance FromJSON Person
103instance ToForm Person
103instance ToForm Person
104instance FromForm Person
104instance FromForm Person
105
105
106+instance Arbitrary Person where
107+ arbitrary = Person <$> arbitrary <*> arbitrary
108+
106alice :: Person
109alice :: Person
107alice = Person "Alice" 42
110alice = Person "Alice" 42
108
111
servant-client/test/Servant/StreamSpec.hs+56−33
@@ -26,25 +26,26 @@
26#include "overlapping-compat.h"
26#include "overlapping-compat.h"
27module Servant.StreamSpec (spec) where
27module Servant.StreamSpec (spec) where
28
28
29−import Prelude ()
29+import Control.Monad (replicateM_, void)
30−import Prelude.Compat
30+import qualified Data.ByteString as BS
31import Data.Proxy
31import Data.Proxy
32+import GHC.Stats (currentBytesUsed, getGCStats)
32−import qualified Network.HTTP.Client as C
33+import qualified Network.HTTP.Client as C
34+import Prelude ()
35+import Prelude.Compat
36+import System.IO (IOMode (ReadMode), withFile)
33−import System.IO.Unsafe (unsafePerformIO)
37+import System.IO.Unsafe (unsafePerformIO)
34import Test.Hspec
38import Test.Hspec
39+import Test.QuickCheck
35
40
36−import Servant.API ((:<|>) ((:<|>)),
41+import Servant.API ((:<|>) ((:<|>)), (:>), JSON,
37− (:>),
38− EmptyAPI, JSON,
39− StreamGet,
40− NewlineFraming,
42+ NetstringFraming, NewlineFraming,
41− NetstringFraming,
42− ResultStream(..),
43+ OctetStream, ResultStream (..),
43− StreamGenerator(..))
44+ StreamGenerator (..), StreamGet)
44import Servant.Client
45import Servant.Client
46+import Servant.ClientSpec (Person (..))
47+import qualified Servant.ClientSpec as CS
45import Servant.Server
48import Servant.Server
46−import qualified Servant.ClientSpec as CS
47−import Servant.ClientSpec (Person(..))
48
49
49
50
50spec :: Spec
51spec :: Spec
@@ -54,7 +55,7 @@ spec = describe "Servant.Stream" $ do
54type StreamApi f =
55type StreamApi f =
55 "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)
56 "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)
56 :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)
57 :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)
57− :<|> EmptyAPI
58+ :<|> "streamALot" :> StreamGet NewlineFraming OctetStream (f BS.ByteString)
58
59
59
60
60capi :: Proxy (StreamApi ResultStream)
61capi :: Proxy (StreamApi ResultStream)
@@ -63,12 +64,9 @@ capi = Proxy
63sapi :: Proxy (StreamApi StreamGenerator)
64sapi :: Proxy (StreamApi StreamGenerator)
64sapi = Proxy
65sapi = Proxy
65
66
66−
67+getGetNL, getGetNS :: ClientM (ResultStream Person)
68+getGetALot :: ClientM (ResultStream BS.ByteString)
67−getGetNL :<|> getGetNS :<|> EmptyClient = client capi
69+getGetNL :<|> getGetNS :<|> getGetALot = client capi
68−
69−
70−getGetNL :: ClientM (ResultStream Person)
71−getGetNS :: ClientM (ResultStream Person)
72
70
73alice :: Person
71alice :: Person
74alice = Person "Alice" 42
72alice = Person "Alice" 42
@@ -77,14 +75,24 @@ bob :: Person
77bob = Person "Bob" 25
75bob = Person "Bob" 25
78
76
79server :: Application
77server :: Application
80−server = serve sapi (
78+server = serve sapi
81− (return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
79+ $ return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
82− :: Handler (StreamGenerator Person))
83− :<|>
84− (return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
80+ :<|> return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
85− :: Handler (StreamGenerator Person))
81+ :<|> return (StreamGenerator lotsGenerator)
86− :<|>
82+ where
87− emptyServer)
83+ lotsGenerator f r = do
84+ f ""
85+ withFile "/dev/urandom" ReadMode $
86+ \handle -> streamFiveMBNTimes handle 1000 r
87+ return ()
88+
89+ streamFiveMBNTimes handle left sink
90+ | left <= 0 = return ""
91+ | otherwise = do
92+ msg <- BS.hGet handle (megabytes 5)
93+ sink msg
94+ streamFiveMBNTimes handle (left - 1) sink
95+
88
96
89
97
90{-# NOINLINE manager' #-}
98{-# NOINLINE manager' #-}
@@ -94,20 +102,35 @@ manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
94runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
102runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
95runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
103runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
96
104
97−runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a))
105+runResultStream :: ResultStream a
106+ -> IO ( Maybe (Either String a)
107+ , Maybe (Either String a)
108+ , Maybe (Either String a)
109+ , Maybe (Either String a))
98−runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act
110+runResultStream (ResultStream k)
111+ = k $ \act -> (,,,) <$> act <*> act <*> act <*> act
99
112
100streamSpec :: Spec
113streamSpec :: Spec
101streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
114streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
102
115
103− it "Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
116+ it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
104 Right res <- runClient getGetNL baseUrl
117 Right res <- runClient getGetNL baseUrl
105 let jra = Just (Right alice)
118 let jra = Just (Right alice)
106 jrb = Just (Right bob)
119 jrb = Just (Right bob)
107 runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
120 runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
108
121
109− it "Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
122+ it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
110 Right res <- runClient getGetNS baseUrl
123 Right res <- runClient getGetNS baseUrl
111 let jra = Just (Right alice)
124 let jra = Just (Right alice)
112 jrb = Just (Right bob)
125 jrb = Just (Right bob)
113 runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
126 runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
127+
128+ it "streams in constant memory" $ \(_, baseUrl) -> do
129+ Right (ResultStream res) <- runClient getGetALot baseUrl
130+ let consumeNChunks n = replicateM_ n (res void)
131+ consumeNChunks 900
132+ memUsed <- currentBytesUsed <$> getGCStats
133+ memUsed `shouldSatisfy` (< (megabytes 20))
134+
135+megabytes :: Num a => a -> a
136+megabytes n = n * (1000 ^ 2)