38e8739 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

add tests, fix to make tests work

38e8739Gershom9 years ago

servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+6−4

compare with master

unifiedsplit

@@ -267,7 +267,7 @@ instance OVERLAPPABLE_

267 }

268 return . buildFromStream $ ResultStream $ \k ->

269 runStreamingResponse sresp $ \(status,_headers,_httpversion,reader) -> do

270− when (H.statusCode status /= 200) $ error "bad status" --fixme

270+ when (H.statusCode status /= 200) $ error "bad status" -- TODO fixme

271 let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)

272 loop bs = do

273 res <- BL.fromStrict <$> reader

@@ -283,10 +283,12 @@ instance OVERLAPPABLE_

283 res <- BL.fromStrict <$> reader

284 let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res))

285 if BL.null res

286+ then if BL.null bs

287+ then return ("", (Right "", True))

286− then return . addIsEmptyInfo $ parseEOF frameParser res

288+ else return . addIsEmptyInfo $ parseEOF frameParser bs

287 else let sofar = (bs <> res)

289 else let sofar = (bs <> res)

288− in case parseIncremental frameParser res of

290+ in case parseIncremental frameParser sofar of

289− Just x -> return $ addIsEmptyInfo x

291+ Just x -> return $ addIsEmptyInfo x

290 Nothing -> frameLoop sofar

292 Nothing -> frameLoop sofar

291

293

292 go = processResult <$> modifyMVar state frameLoop

294 go = processResult <$> modifyMVar state frameLoop

servant-client/servant-client.cabal+1

@@ -66,6 +66,7 @@ test-suite spec

66 main-is: Spec.hs

67 other-modules:

68 Servant.ClientSpec

69+ Servant.StreamSpec

69 build-depends:

70 build-depends:

70 base == 4.*

71 base == 4.*

71 , aeson

72 , aeson

servant-client/test/Servant/ClientSpec.hs+1−1

@@ -24,7 +24,7 @@

24{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

26#include "overlapping-compat.h"

27−module Servant.ClientSpec (spec) where

27+module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where

29import Prelude ()

30import Prelude.Compat

servant-client/test/Servant/StreamSpec.hsnew file+113

@@ -0,0 +1,113 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE FunctionalDependencies #-}

8+{-# LANGUAGE GADTs #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE OverloadedStrings #-}

11+{-# LANGUAGE PolyKinds #-}

12+{-# LANGUAGE RecordWildCards #-}

13+{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE StandaloneDeriving #-}

15+{-# LANGUAGE TypeFamilies #-}

16+{-# LANGUAGE TypeOperators #-}

17+{-# LANGUAGE UndecidableInstances #-}

18+#if __GLASGOW_HASKELL__ >= 800

19+{-# OPTIONS_GHC -freduction-depth=100 #-}

20+#else

21+{-# OPTIONS_GHC -fcontext-stack=100 #-}

22+#endif

23+{-# OPTIONS_GHC -fno-warn-orphans #-}

24+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

25+

26+#include "overlapping-compat.h"

27+module Servant.StreamSpec (spec) where

28+

29+import Prelude ()

30+import Prelude.Compat

31+import Data.Proxy

32+import qualified Network.HTTP.Client as C

33+import System.IO.Unsafe (unsafePerformIO)

34+import Test.Hspec

35+

36+import Servant.API ((:<|>) ((:<|>)),

37+ (:>),

38+ EmptyAPI, JSON,

39+ StreamGet,

40+ NewlineFraming,

41+ NetstringFraming,

42+ ResultStream(..),

43+ StreamGenerator(..))

44+import Servant.Client

45+import Servant.Server

46+import qualified Servant.ClientSpec as CS

47+import Servant.ClientSpec (Person(..))

48+

49+

50+spec :: Spec

51+spec = describe "Servant.Stream" $ do

52+ streamSpec

53+

54+type StreamApi f =

55+ "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)

56+ :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)

57+ :<|> EmptyAPI

58+

59+

60+capi :: Proxy (StreamApi ResultStream)

61+capi = Proxy

62+

63+sapi :: Proxy (StreamApi StreamGenerator)

64+sapi = Proxy

65+

66+

67+getGetNL :<|> getGetNS :<|> EmptyClient = client capi

68+

69+

70+getGetNL :: ClientM (ResultStream Person)

71+getGetNS :: ClientM (ResultStream Person)

72+

73+alice :: Person

74+alice = Person "Alice" 42

75+

76+bob :: Person

77+bob = Person "Bob" 25

78+

79+server :: Application

80+server = serve sapi (

81+ (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))

85+ :: Handler (StreamGenerator Person))

86+ :<|>

87+ emptyServer)

88+

89+

90+{-# NOINLINE manager' #-}

91+manager' :: C.Manager

92+manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

93+

94+runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)

95+runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')

96+

97+runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a))

98+runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act

99+

100+streamSpec :: Spec

101+streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do

102+

103+ it "Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do

104+ Right res <- runClient getGetNL baseUrl

105+ let jra = Just (Right alice)

106+ jrb = Just (Right bob)

107+ runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)

108+

109+ it "Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do

110+ Right res <- runClient getGetNS baseUrl

111+ let jra = Just (Right alice)

112+ jrb = Just (Right bob)

113+ runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)

servant/src/Servant/API.hs+4−2

@@ -83,13 +83,15 @@ import Servant.API.IsSecure (IsSecure (..))

83import Servant.API.QueryParam (QueryFlag, QueryParam,

84 QueryParams)

85import Servant.API.Raw (Raw)

86−import Servant.API.Stream (Stream, StreamGenerator (..),

86+import Servant.API.Stream (Stream, StreamGet, StreamPost,

87+ StreamGenerator (..),

87 ToStreamGenerator (..),

88 ToStreamGenerator (..),

88 ResultStream(..), BuildFromStream (..),

89 ResultStream(..), BuildFromStream (..),

89 ByteStringParser (..),

90 ByteStringParser (..),

90 FramingRender (..), BoundaryStrategy (..),

91 FramingRender (..), BoundaryStrategy (..),

91 FramingUnrender (..),

92 FramingUnrender (..),

92− NewlineFraming)

93+ NewlineFraming,

94+ NetstringFraming)

93import Servant.API.RemoteHost (RemoteHost)

95import Servant.API.RemoteHost (RemoteHost)

94import Servant.API.ReqBody (ReqBody)

96import Servant.API.ReqBody (ReqBody)

95import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,

97import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,

servant/src/Servant/API/Stream.hs+18−8

@@ -14,9 +14,12 @@ module Servant.API.Stream where

15import Data.ByteString.Lazy (ByteString, empty)

16import qualified Data.ByteString.Lazy.Char8 as LB

17+import Data.Monoid ((<>))

17import Data.Proxy (Proxy)

18import Data.Proxy (Proxy)

18import Data.Typeable (Typeable)

19import Data.Typeable (Typeable)

19import GHC.Generics (Generic)

20import GHC.Generics (Generic)

21+import Text.Read (readMaybe)

22+import Data.Bifunctor (first)

20import Network.HTTP.Types.Method (StdMethod (..))

23import Network.HTTP.Types.Method (StdMethod (..))

22-- | A Stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy. Steam endpoints always return response code 200 on success. Type synonyms are provided for standard methods.

25-- | A Stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy. Steam endpoints always return response code 200 on success. Type synonyms are provided for standard methods.

@@ -93,15 +96,22 @@ data NetstringFraming

94instance FramingRender NetstringFraming a where

97instance FramingRender NetstringFraming a where

95 header _ _ = empty

98 header _ _ = empty

96− boundary _ _ = BoundaryStrategyBracket $ \b -> (LB.pack . show . LB.length $ b, "")

99+ boundary _ _ = BoundaryStrategyBracket $ \b -> ((<> ":") . LB.pack . show . LB.length $ b, ",")

97 trailer _ _ = empty

100 trailer _ _ = empty

101

99−{-

100

102

101instance FramingUnrender NetstringFraming a where

103instance FramingUnrender NetstringFraming a where

104+ unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)

105+ where go = ByteStringParser

102− unrenderFrames _ _ = (, \b -> let (i,r) = LB.break (==':') b

106+ (\b -> let (i,r) = LB.break (==':') b

103− in case readMaybe (LB.unpack i) of

107+ in case readMaybe (LB.unpack i) of

108+ Just len -> if LB.length r > len

104− Just len -> first Right $ LB.splitAt len . LB.drop 1 $ r

109+ then Just . first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r

110+ else Nothing

105− Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r)

111+ Nothing -> Just (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))

106− )

112+ (\b -> let (i,r) = LB.break (==':') b

107−-}

113+ in case readMaybe (LB.unpack i) of

114+ Just len -> if LB.length r > len

115+ then first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r

116+ else (Right $ LB.take len r, LB.empty)

117+ Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))