@@ -4,6 +4,7 @@
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE InstanceSigs #-}
66{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
78{-# LANGUAGE OverloadedStrings #-}
89{-# LANGUAGE PolyKinds #-}
910{-# LANGUAGE ScopedTypeVariables #-}
@@ -17,9 +18,12 @@ module Servant.Client.Core.Internal.HasClient where
1718import Prelude ()
1819import Prelude.Compat
1920
21+import Control.Concurrent (newMVar, modifyMVar)
22+import Control.Monad (when)
2023import Data.Foldable (toList)
2124import qualified Data.ByteString.Lazy as BL
2225import Data.List (foldl')
26+import Data.Monoid ((<>))
2327import Data.Proxy (Proxy (Proxy))
2428import Data.Sequence (fromList)
2529import Data.String (fromString)
@@ -31,6 +35,7 @@ import Servant.API ((:<|>) ((:<|>)), (:>),
3135 BasicAuthData,
3236 BuildHeadersTo (..),
3337 BuildFromStream (..),
38+ ByteStringParser (..),
3439 Capture, CaptureAll,
3540 Description, EmptyAPI,
3641 FramingUnrender (..),
@@ -248,44 +253,54 @@ instance OVERLAPPING_
248253 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
249254 }
250255
256+data ResultStream a = ResultStream ((forall b. (IO (Maybe (Either String a)) -> IO b) -> IO b))
257+
251258instance OVERLAPPABLE_
252259 ( RunClient m, MimeUnrender ct a, ReflectMethod method,
253260 FramingUnrender framing a, BuildFromStream a (f a)
254261 ) => HasClient m (Stream method framing ct (f a)) where
255− type Client m (Stream method framing ct (f a)) = m (f a)
256− clientWithRoute _pm Proxy req = do
257− response <- runRequest req
258− { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
259− , requestMethod = reflectMethod (Proxy :: Proxy method)
260− }
261− return $ decodeFramed (Proxy :: Proxy framing) (Proxy :: Proxy ct) (Proxy :: Proxy a) response
262262
263−instance OVERLAPPING_
264− ( RunClient m, BuildHeadersTo ls, MimeUnrender ct a, ReflectMethod method,
265− FramingUnrender framing a, BuildFromStream a (f a)
266− ) => HasClient m (Stream method framing ct (Headers ls (f a))) where
267− type Client m (Stream method framing ct (Headers ls (f a))) = m (Headers ls (f a))
263+ type Client m (Stream method framing ct (f a)) = m (ResultStream a)
264+
268265 clientWithRoute _pm Proxy req = do
269− response <- runRequest req
266+ sresp <- streamingRequest req
270267 { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
271268 , requestMethod = reflectMethod (Proxy :: Proxy method)
272269 }
273− return Headers { getResponse = decodeFramed (Proxy :: Proxy framing) (Proxy :: Proxy ct) (Proxy :: Proxy a) response
274− , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
275− }
276−
277−decodeFramed :: forall ctype strategy a b.
278− (MimeUnrender ctype a, FramingUnrender strategy a, BuildFromStream a b) =>
279− Proxy strategy -> Proxy ctype -> Proxy a -> Response -> b
280−decodeFramed framingproxy ctypeproxy typeproxy response =
281− let (body, uncons) = unrenderFrames framingproxy typeproxy (responseBody response)
282− loop b | BL.null b = []
283− | otherwise = case uncons b of
284− (Right x, r) -> case mimeUnrender ctypeproxy x :: Either String a of
285− Left err -> Left err : loop r
286− Right x' -> Right x' : loop r
287− (Left err, r) -> Left err : loop r
288− in buildFromStream $ loop body
270+ return $ ResultStream $ \k ->
271+ runStreamingResponse sresp $ \(status,_headers,_httpversion,reader) -> do
272+ when (H.statusCode status /= 200) $ error "bad status" --fixme
273+ let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)
274+ loop bs = do
275+ res <- BL.fromStrict <$> reader
276+ if BL.null res
277+ then return $ parseEOF unrender res
278+ else let sofar = (bs <> res)
279+ in case parseIncremental unrender sofar of
280+ Just x -> return x
281+ Nothing -> loop sofar
282+ (frameParser, remainder) <- loop BL.empty
283+ state <- newMVar remainder
284+ let frameLoop bs = do
285+ res <- BL.fromStrict <$> reader
286+ let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res))
287+ if BL.null res
288+ then return . addIsEmptyInfo $ parseEOF frameParser res
289+ else let sofar = (bs <> res)
290+ in case parseIncremental frameParser res of
291+ Just x -> return $ addIsEmptyInfo x
292+ Nothing -> frameLoop sofar
293+
294+ go = processResult <$> modifyMVar state frameLoop
295+ processResult (Right bs,isDone) =
296+ if BL.null bs && isDone
297+ then Nothing
298+ else Just $ case mimeUnrender (Proxy :: Proxy ct) bs :: Either String a of
299+ Left err -> Left err
300+ Right x -> Right x
301+ processResult (Left err, _) = Just (Left err)
302+ k go
303+
289304
290305-- | If you use a 'Header' in one of your endpoints in your API,
291306-- the corresponding querying function will automatically take