diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index ab3fb688..29bafb13 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -267,7 +267,7 @@ instance OVERLAPPABLE_ } return . buildFromStream $ ResultStream $ \k -> runStreamingResponse sresp $ \(status,_headers,_httpversion,reader) -> do - when (H.statusCode status /= 200) $ error "bad status" --fixme + when (H.statusCode status /= 200) $ error "bad status" -- TODO fixme let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a) loop bs = do res <- BL.fromStrict <$> reader @@ -283,10 +283,12 @@ instance OVERLAPPABLE_ res <- BL.fromStrict <$> reader let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res)) if BL.null res - then return . addIsEmptyInfo $ parseEOF frameParser res + then if BL.null bs + then return ("", (Right "", True)) + else return . addIsEmptyInfo $ parseEOF frameParser bs else let sofar = (bs <> res) - in case parseIncremental frameParser res of - Just x -> return $ addIsEmptyInfo x + in case parseIncremental frameParser sofar of + Just x -> return $ addIsEmptyInfo x Nothing -> frameLoop sofar go = processResult <$> modifyMVar state frameLoop diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 14ea3ad2..06f770f0 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -66,6 +66,7 @@ test-suite spec main-is: Spec.hs other-modules: Servant.ClientSpec + Servant.StreamSpec build-depends: base == 4.* , aeson diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index fda25428..495fa860 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -24,7 +24,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} #include "overlapping-compat.h" -module Servant.ClientSpec (spec) where +module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where import Prelude () import Prelude.Compat diff --git a/servant-client/test/Servant/StreamSpec.hs b/servant-client/test/Servant/StreamSpec.hs new file mode 100644 index 00000000..df9003ab --- /dev/null +++ b/servant-client/test/Servant/StreamSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -freduction-depth=100 #-} +#else +{-# OPTIONS_GHC -fcontext-stack=100 #-} +#endif +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +#include "overlapping-compat.h" +module Servant.StreamSpec (spec) where + +import Prelude () +import Prelude.Compat +import Data.Proxy +import qualified Network.HTTP.Client as C +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec + +import Servant.API ((:<|>) ((:<|>)), + (:>), + EmptyAPI, JSON, + StreamGet, + NewlineFraming, + NetstringFraming, + ResultStream(..), + StreamGenerator(..)) +import Servant.Client +import Servant.Server +import qualified Servant.ClientSpec as CS +import Servant.ClientSpec (Person(..)) + + +spec :: Spec +spec = describe "Servant.Stream" $ do + streamSpec + +type StreamApi f = + "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person) + :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person) + :<|> EmptyAPI + + +capi :: Proxy (StreamApi ResultStream) +capi = Proxy + +sapi :: Proxy (StreamApi StreamGenerator) +sapi = Proxy + + +getGetNL :<|> getGetNS :<|> EmptyClient = client capi + + +getGetNL :: ClientM (ResultStream Person) +getGetNS :: ClientM (ResultStream Person) + +alice :: Person +alice = Person "Alice" 42 + +bob :: Person +bob = Person "Bob" 25 + +server :: Application +server = serve sapi ( + (return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) + :: Handler (StreamGenerator Person)) + :<|> + (return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) + :: Handler (StreamGenerator Person)) + :<|> + emptyServer) + + +{-# NOINLINE manager' #-} +manager' :: C.Manager +manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings + +runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a) +runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl') + +runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a)) +runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act + +streamSpec :: Spec +streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do + + it "Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do + Right res <- runClient getGetNL baseUrl + let jra = Just (Right alice) + jrb = Just (Right bob) + runResultStream res `shouldReturn` (jra, jrb, jra, Nothing) + + it "Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do + Right res <- runClient getGetNS baseUrl + let jra = Just (Right alice) + jrb = Just (Right bob) + runResultStream res `shouldReturn` (jra, jrb, jra, Nothing) diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index bb2a2875..84f3d861 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -83,13 +83,15 @@ import Servant.API.IsSecure (IsSecure (..)) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.Raw (Raw) -import Servant.API.Stream (Stream, StreamGenerator (..), +import Servant.API.Stream (Stream, StreamGet, StreamPost, + StreamGenerator (..), ToStreamGenerator (..), ResultStream(..), BuildFromStream (..), ByteStringParser (..), FramingRender (..), BoundaryStrategy (..), FramingUnrender (..), - NewlineFraming) + NewlineFraming, + NetstringFraming) import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody (ReqBody) import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader, diff --git a/servant/src/Servant/API/Stream.hs b/servant/src/Servant/API/Stream.hs index 01cd0898..50828c7c 100644 --- a/servant/src/Servant/API/Stream.hs +++ b/servant/src/Servant/API/Stream.hs @@ -14,9 +14,12 @@ module Servant.API.Stream where import Data.ByteString.Lazy (ByteString, empty) import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Monoid ((<>)) import Data.Proxy (Proxy) import Data.Typeable (Typeable) import GHC.Generics (Generic) +import Text.Read (readMaybe) +import Data.Bifunctor (first) import Network.HTTP.Types.Method (StdMethod (..)) -- | 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 instance FramingRender NetstringFraming a where header _ _ = empty - boundary _ _ = BoundaryStrategyBracket $ \b -> (LB.pack . show . LB.length $ b, "") + boundary _ _ = BoundaryStrategyBracket $ \b -> ((<> ":") . LB.pack . show . LB.length $ b, ",") trailer _ _ = empty -{- instance FramingUnrender NetstringFraming a where - unrenderFrames _ _ = (, \b -> let (i,r) = LB.break (==':') b - in case readMaybe (LB.unpack i) of - Just len -> first Right $ LB.splitAt len . LB.drop 1 $ r - Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r) - ) --} \ No newline at end of file + unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,) + where go = ByteStringParser + (\b -> let (i,r) = LB.break (==':') b + in case readMaybe (LB.unpack i) of + Just len -> if LB.length r > len + then Just . first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r + else Nothing + Nothing -> Just (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r)) + (\b -> let (i,r) = LB.break (==':') b + in case readMaybe (LB.unpack i) of + Just len -> if LB.length r > len + then first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r + else (Right $ LB.take len r, LB.empty) + Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))