cbd3862 · typeable/servant

servant-client-core/src/Servant/Client/Core.hs+1

@@ -43,6 +43,7 @@ module Servant.Client.Core

4343 , Response(..)

4444 , RunClient(..)

4545 , module Servant.Client.Core.Internal.BaseUrl

46+ , StreamingResponse(..)

4647

4748 -- * Writing HasClient instances

4849 -- | These functions need not be re-exported by backend libraries.

servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+55

@@ -17,8 +17,11 @@ module Servant.Client.Core.Internal.HasClient where

1717import Prelude ()

1818import Prelude.Compat

1919

20+import Control.Concurrent (newMVar, modifyMVar)

2021import Data.Foldable (toList)

22+import qualified Data.ByteString.Lazy as BL

2123import Data.List (foldl')

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

2225import Data.Proxy (Proxy (Proxy))

2326import Data.Sequence (fromList)

2427import Data.String (fromString)

@@ -29,8 +32,11 @@ import Servant.API ((:<|>) ((:<|>)), (:>),

2932 AuthProtect, BasicAuth,

3033 BasicAuthData,

3134 BuildHeadersTo (..),

35+ BuildFromStream (..),

36+ ByteStringParser (..),

3237 Capture, CaptureAll,

3338 Description, EmptyAPI,

39+ FramingUnrender (..),

3440 Header, Headers (..),

3541 HttpVersion, IsSecure,

3642 MimeRender (mimeRender),

@@ -40,6 +46,8 @@ import Servant.API ((:<|>) ((:<|>)), (:>),

4046 QueryParams, Raw,

4147 ReflectMethod (..),

4248 RemoteHost, ReqBody,

49+ ResultStream(..),

50+ Stream,

4351 Summary, ToHttpApiData,

4452 Vault, Verb,

4553 WithNamedContext,

@@ -244,6 +252,53 @@ instance OVERLAPPING_

244252 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

245253 }

246254

255+instance OVERLAPPABLE_

256+ ( RunClient m, MimeUnrender ct a, ReflectMethod method,

257+ FramingUnrender framing a, BuildFromStream a (f a)

258+ ) => HasClient m (Stream method framing ct (f a)) where

259+

260+ type Client m (Stream method framing ct (f a)) = m (f a)

261+

262+ clientWithRoute _pm Proxy req = do

263+ sresp <- streamingRequest req

264+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]

265+ , requestMethod = reflectMethod (Proxy :: Proxy method)

266+ }

267+ return . buildFromStream $ ResultStream $ \k ->

268+ runStreamingResponse sresp $ \(_status,_headers,_httpversion,reader) -> do

269+ let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)

270+ loop bs = do

271+ res <- BL.fromStrict <$> reader

272+ if BL.null res

273+ then return $ parseEOF unrender res

274+ else let sofar = (bs <> res)

275+ in case parseIncremental unrender sofar of

276+ Just x -> return x

277+ Nothing -> loop sofar

278+ (frameParser, remainder) <- loop BL.empty

279+ state <- newMVar remainder

280+ let frameLoop bs = do

281+ res <- BL.fromStrict <$> reader

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

283+ if BL.null res

284+ then if BL.null bs

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

286+ else return . addIsEmptyInfo $ parseEOF frameParser bs

287+ else let sofar = (bs <> res)

288+ in case parseIncremental frameParser sofar of

289+ Just x -> return $ addIsEmptyInfo x

290+ Nothing -> frameLoop sofar

291+

292+ go = processResult <$> modifyMVar state frameLoop

293+ processResult (Right bs,isDone) =

294+ if BL.null bs && isDone

295+ then Nothing

296+ else Just $ case mimeUnrender (Proxy :: Proxy ct) bs :: Either String a of

297+ Left err -> Left err

298+ Right x -> Right x

299+ processResult (Left err, _) = Just (Left err)

300+ k go

301+

247302

248303-- | If you use a 'Header' in one of your endpoints in your API,

249304-- the corresponding querying function will automatically take

servant-client-core/src/Servant/Client/Core/Internal/Request.hs+4

@@ -4,6 +4,7 @@

44{-# LANGUAGE DeriveGeneric #-}

55{-# LANGUAGE GeneralizedNewtypeDeriving #-}

66{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE RankNTypes #-}

78{-# LANGUAGE OverloadedStrings #-}

89{-# LANGUAGE ScopedTypeVariables #-}

910{-# LANGUAGE TypeFamilies #-}

@@ -15,6 +16,7 @@ import Prelude.Compat

1516

1617import Control.Monad.Catch (Exception)

1718import qualified Data.ByteString.Builder as Builder

19+import qualified Data.ByteString as BS

1820import qualified Data.ByteString.Lazy as LBS

1921import Data.Semigroup ((<>))

2022import qualified Data.Sequence as Seq

@@ -70,6 +72,8 @@ data Response = Response

7072 , responseHttpVersion :: HttpVersion

7173 } deriving (Eq, Show, Generic, Typeable)

7274

75+data StreamingResponse = StreamingResponse { runStreamingResponse :: forall a. ((Status, Seq.Seq Header, HttpVersion, IO BS.ByteString) -> IO a) -> IO a }

76+

7377-- A GET request to the top-level path

7478defaultRequest :: Request

7579defaultRequest = Request

servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs+2

@@ -19,11 +19,13 @@ import Servant.API (MimeUnrender,

1919 contentTypes,

2020 mimeUnrender)

2121import Servant.Client.Core.Internal.Request (Request, Response (..),

22+ StreamingResponse (..),

2223 ServantError (..))

2324

2425class (Monad m) => RunClient m where

2526 -- | How to make a request.

2627 runRequest :: Request -> m Response

28+ streamingRequest :: Request -> m StreamingResponse

2729 throwServantError :: ServantError -> m a

2830 catchServantError :: m a -> (ServantError -> m a) -> m a

2931

servant-client/servant-client.cabal+1

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

7272 hspec-discover:hspec-discover

7373 other-modules:

7474 Servant.ClientSpec

75+ Servant.StreamSpec

7576 build-depends:

7677 base == 4.*

7778 , aeson

servant-client/src/Servant/Client/Internal/HttpClient.hs+19−3

@@ -89,6 +89,7 @@ instance Alt ClientM where

8989

9090instance RunClient ClientM where

9191 runRequest = performRequest

92+ streamingRequest = performStreamingRequest

9293 throwServantError = throwError

9394 catchServantError = catchError

9495

@@ -111,13 +112,28 @@ performRequest req = do

111112 Right response -> do

112113 let status = Client.responseStatus response

113114 status_code = statusCode status

114− ourResponse = clientResponseToReponse response

115+ ourResponse = clientResponseToResponse response

115116 unless (status_code >= 200 && status_code < 300) $

116117 throwError $ FailureResponse ourResponse

117118 return ourResponse

118119

119−clientResponseToReponse :: Client.Response BSL.ByteString -> Response

120−clientResponseToReponse r = Response

120+performStreamingRequest :: Request -> ClientM StreamingResponse

121+performStreamingRequest req = do

122+ m <- asks manager

123+ burl <- asks baseUrl

124+ let request = requestToClientRequest burl req

125+ return $ StreamingResponse $

126+ \k -> Client.withResponse request m $

127+ \r -> do

128+ let status = Client.responseStatus r

129+ status_code = statusCode status

130+ unless (status_code >= 200 && status_code < 300) $ do

131+ b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody r)

132+ throw $ FailureResponse $ Response status b (fromList $ Client.responseHeaders r) (Client.responseVersion r)

133+ k (status, fromList $ Client.responseHeaders r, Client.responseVersion r, Client.responseBody r)

134+

135+clientResponseToResponse :: Client.Response BSL.ByteString -> Response

136+clientResponseToResponse r = Response

121137 { responseStatusCode = Client.responseStatus r

122138 , responseBody = Client.responseBody r

123139 , responseHeaders = fromList $ Client.responseHeaders r

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

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

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

2525

2626#include "overlapping-compat.h"

27−module Servant.ClientSpec (spec) where

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

2828

2929import Prelude ()

3030import 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-server/servant-server.cabal+1

@@ -64,6 +64,7 @@ library

6464 , containers >= 0.5 && < 0.6

6565 , exceptions >= 0.8 && < 0.9

6666 , http-api-data >= 0.3 && < 0.4

67+ , http-media >= 0.4 && < 0.8

6768 , http-types >= 0.8 && < 0.11

6869 , network-uri >= 2.6 && < 2.7

6970 , monad-control >= 1.0.0.4 && < 1.1

servant-server/src/Servant/Server/Internal.hs+78−4

@@ -26,12 +26,15 @@ module Servant.Server.Internal

2626 , module Servant.Server.Internal.ServantErr

2727 ) where

2828

29+import Control.Monad (when)

2930import Control.Monad.Trans (liftIO)

3031import Control.Monad.Trans.Resource (runResourceT)

3132import qualified Data.ByteString as B

33+import qualified Data.ByteString.Builder as BB

3234import qualified Data.ByteString.Char8 as BC8

3335import qualified Data.ByteString.Lazy as BL

34−import Data.Maybe (fromMaybe, mapMaybe)

36+import Data.Maybe (fromMaybe, mapMaybe,

37+ isNothing, maybeToList)

3538import Data.Either (partitionEithers)

3639import Data.String (fromString)

3740import Data.String.Conversions (cs, (<>))

@@ -41,13 +44,15 @@ import Data.Typeable

4144import GHC.TypeLits (KnownNat, KnownSymbol, natVal,

4245 symbolVal)

4346import Network.HTTP.Types hiding (Header, ResponseHeaders)

47+import qualified Network.HTTP.Media as NHM

4448import Network.Socket (SockAddr)

4549import Network.Wai (Application, Request,

4650 httpVersion, isSecure,

4751 lazyRequestBody,

4852 rawQueryString, remoteHost,

4953 requestHeaders, requestMethod,

50− responseLBS, vault)

54+ responseLBS, responseStream,

55+ vault)

5156import Prelude ()

5257import Prelude.Compat

5358import Web.HttpApiData (FromHttpApiData, parseHeader,

@@ -61,11 +66,16 @@ import Servant.API ((:<|>) (..), (:>), BasicAuth, Capt

6166 QueryParam, QueryParams, Raw,

6267 RemoteHost, ReqBody, Vault,

6368 WithNamedContext,

64− Description, Summary)

69+ Description, Summary,

70+ Accept(..),

71+ FramingRender(..), Stream,

72+ StreamGenerator(..), ToStreamGenerator(..),

73+ BoundaryStrategy(..))

6574import Servant.API.ContentTypes (AcceptHeader (..),

6675 AllCTRender (..),

6776 AllCTUnrender (..),

6877 AllMime,

78+ MimeRender(..),

6979 canHandleAcceptH)

7080import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

7181 getResponse)

@@ -257,6 +267,70 @@ instance OVERLAPPING_

257267 where method = reflectMethod (Proxy :: Proxy method)

258268 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

259269

270+

271+instance OVERLAPPABLE_

272+ ( MimeRender ctype a, ReflectMethod method,

273+ FramingRender framing ctype, ToStreamGenerator f a

274+ ) => HasServer (Stream method framing ctype (f a)) context where

275+

276+ type ServerT (Stream method framing ctype (f a)) m = m (f a)

277+ hoistServerWithContext _ _ nt s = nt s

278+

279+ route Proxy _ = streamRouter ([],) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

280+ where method = reflectMethod (Proxy :: Proxy method)

281+

282+instance OVERLAPPING_

283+ ( MimeRender ctype a, ReflectMethod method,

284+ FramingRender framing ctype, ToStreamGenerator f a,

285+ GetHeaders (Headers h (f a))

286+ ) => HasServer (Stream method framing ctype (Headers h (f a))) context where

287+

288+ type ServerT (Stream method framing ctype (Headers h (f a))) m = m (Headers h (f a))

289+ hoistServerWithContext _ _ nt s = nt s

290+

291+ route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

292+ where method = reflectMethod (Proxy :: Proxy method)

293+

294+

295+streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator f a) =>

296+ (b -> ([(HeaderName, B.ByteString)], f a))

297+ -> Method

298+ -> Proxy framing

299+ -> Proxy ctype

300+ -> Delayed env (Handler b)

301+ -> Router env

302+streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \env request respond ->

303+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

304+ cmediatype = NHM.matchAccept [contentType ctypeproxy] accH

305+ accCheck = when (isNothing cmediatype) $ delayedFail err406

306+ contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)

307+ in runAction (action `addMethodCheck` methodCheck method request

308+ `addAcceptCheck` accCheck

309+ ) env request respond $ \ output ->

310+ let (headers, fa) = splitHeaders output

311+ k = getStreamGenerator . toStreamGenerator $ fa in

312+ Route $ responseStream status200 (contentHeader : headers) $ \write flush -> do

313+ write . BB.lazyByteString $ header framingproxy ctypeproxy

314+ case boundary framingproxy ctypeproxy of

315+ BoundaryStrategyBracket f ->

316+ let go x = let bs = mimeRender ctypeproxy $ x

317+ (before, after) = f bs

318+ in write ( BB.lazyByteString before

319+ <> BB.lazyByteString bs

320+ <> BB.lazyByteString after) >> flush

321+ in k go go

322+ BoundaryStrategyIntersperse sep -> k

323+ (\x -> do

324+ write . BB.lazyByteString . mimeRender ctypeproxy $ x

325+ flush)

326+ (\x -> do

327+ write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender ctypeproxy $ x

328+ flush)

329+ BoundaryStrategyGeneral f ->

330+ let go = (>> flush) . write . BB.lazyByteString . f . mimeRender ctypeproxy

331+ in k go go

332+ write . BB.lazyByteString $ trailer framingproxy ctypeproxy

333+

260334-- | If you use 'Header' in one of the endpoints for your API,

261335-- this automatically requires your server-side handler to be a function

262336-- that takes an argument of the type specified by 'Header'.

@@ -299,7 +373,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

299373 <> fromString headerName

300374 <> " failed: " <> e

301375 }

302− Right header -> return $ Just header

376+ Right hdr -> return $ Just hdr

303377

304378-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

305379-- this automatically requires your server-side handler to be a function

servant/servant.cabal+1

@@ -51,6 +51,7 @@ library

5151 Servant.API.IsSecure

5252 Servant.API.QueryParam

5353 Servant.API.Raw

54+ Servant.API.Stream

5455 Servant.API.RemoteHost

5556 Servant.API.ReqBody

5657 Servant.API.ResponseHeaders

servant/src/Servant/API.hs+12

@@ -31,6 +31,9 @@ module Servant.API (

3131 -- * Actual endpoints, distinguished by HTTP method

3232 module Servant.API.Verbs,

3333

34+ -- * Streaming endpoints, distinguished by HTTP method

35+ module Servant.API.Stream,

36+

3437 -- * Authentication

3538 module Servant.API.BasicAuth,

3639

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

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

8184 QueryParams)

8285import Servant.API.Raw (Raw)

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

87+ StreamGenerator (..),

88+ ToStreamGenerator (..),

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

90+ ByteStringParser (..),

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

92+ FramingUnrender (..),

93+ NewlineFraming,

94+ NetstringFraming)

8395import Servant.API.RemoteHost (RemoteHost)

8496import Servant.API.ReqBody (ReqBody)

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

servant/src/Servant/API/Stream.hsnew file+117

@@ -0,0 +1,117 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE KindSignatures #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE TupleSections #-}

11+{-# OPTIONS_HADDOCK not-home #-}

12+

13+module Servant.API.Stream where

14+

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

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

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

18+import Data.Proxy (Proxy)

19+import Data.Typeable (Typeable)

20+import GHC.Generics (Generic)

21+import Text.Read (readMaybe)

22+import Control.Arrow (first)

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

24+

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.

26+data Stream (method :: k1) (framing :: *) (contentType :: *) a

27+ deriving (Typeable, Generic)

28+

29+type StreamGet = Stream 'GET

30+type StreamPost = Stream 'POST

31+

32+-- | Stream endpoints may be implemented as producing a @StreamGenerator@ -- a function that itself takes two emit functions -- the first to be used on the first value the stream emits, and the second to be used on all subsequent values (to allow interspersed framing strategies such as comma separation).

33+newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO ()}

34+

35+-- | ToStreamGenerator is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly as endpoints.

36+class ToStreamGenerator f a where

37+ toStreamGenerator :: f a -> StreamGenerator a

38+

39+instance ToStreamGenerator StreamGenerator a

40+ where toStreamGenerator x = x

41+

42+-- | Clients reading from streaming endpoints can be implemented as producing a @ResultStream@ that captures the setup, takedown, and incremental logic for a read, being an IO continuation that takes a producer of Just either values or errors that terminates with a Nothing.

43+data ResultStream a = ResultStream ((forall b. (IO (Maybe (Either String a)) -> IO b) -> IO b))

44+

45+-- | BuildFromStream is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly on the client side for talking to streaming endpoints.

46+class BuildFromStream a b where

47+ buildFromStream :: ResultStream a -> b

48+

49+instance BuildFromStream a (ResultStream a)

50+ where buildFromStream x = x

51+

52+-- | The FramingRender class provides the logic for emitting a framing strategy. The strategy emits a header, followed by boundary-delimited data, and finally a termination character. For many strategies, some of these will just be empty bytestrings.

53+class FramingRender strategy a where

54+ header :: Proxy strategy -> Proxy a -> ByteString

55+ boundary :: Proxy strategy -> Proxy a -> BoundaryStrategy

56+ trailer :: Proxy strategy -> Proxy a -> ByteString

57+

58+-- | The bracketing strategy generates things to precede and follow the content, as with netstrings.

59+-- The intersperse strategy inserts seperators between things, as with newline framing.

60+-- Finally, the general strategy performs an arbitrary rewrite on the content, to allow escaping rules and such.

61+data BoundaryStrategy = BoundaryStrategyBracket (ByteString -> (ByteString,ByteString))

62+ | BoundaryStrategyIntersperse ByteString

63+ | BoundaryStrategyGeneral (ByteString -> ByteString)

64+

65+-- | A type of parser that can never fail, and has different parsing strategies (incremental, or EOF) depending if more input can be sent. The incremental parser should return `Nothing` if it would like to be sent a longer ByteString. If it returns a value, it also returns the remainder following that value.

66+data ByteStringParser a = ByteStringParser {

67+ parseIncremental :: ByteString -> Maybe (a, ByteString),

68+ parseEOF :: ByteString -> (a, ByteString)

69+}

70+

71+-- | The FramingUnrender class provides the logic for parsing a framing strategy. The outer @ByteStringParser@ strips the header from a stream of bytes, and yields a parser that can handle the remainder, stepwise. Each frame may be a ByteString, or a String indicating the error state for that frame. Such states are per-frame, so that protocols that can resume after errors are able to do so. Eventually this returns an empty ByteString to indicate termination.

72+class FramingUnrender strategy a where

73+ unrenderFrames :: Proxy strategy -> Proxy a -> ByteStringParser (ByteStringParser (Either String ByteString))

74+

75+

76+-- | A simple framing strategy that has no header or termination, and inserts a newline character between each frame.

77+-- This assumes that it is used with a Content-Type that encodes without newlines (e.g. JSON).

78+data NewlineFraming

79+

80+instance FramingRender NewlineFraming a where

81+ header _ _ = empty

82+ boundary _ _ = BoundaryStrategyIntersperse "\n"

83+ trailer _ _ = empty

84+

85+instance FramingUnrender NewlineFraming a where

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

87+ where go = ByteStringParser

88+ (\x -> case LB.break (== '\n') x of

89+ (h,r) -> if not (LB.null r) then Just (Right h, LB.drop 1 r) else Nothing

90+ )

91+ (\x -> case LB.break (== '\n') x of

92+ (h,r) -> (Right h, LB.drop 1 r)

93+ )

94+-- | The netstring framing strategy as defined by djb: <http://cr.yp.to/proto/netstrings.txt>

95+data NetstringFraming

96+

97+instance FramingRender NetstringFraming a where

98+ header _ _ = empty

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

100+ trailer _ _ = empty

101+

102+

103+instance FramingUnrender NetstringFraming a where

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

105+ where go = ByteStringParser

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

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

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

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

110+ else Nothing

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

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

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))

servant/src/Servant/Utils/Links.hs+5

@@ -119,6 +119,7 @@ import Servant.API.RemoteHost ( RemoteHost )

119119import Servant.API.Verbs ( Verb )

120120import Servant.API.Sub ( type (:>) )

121121import Servant.API.Raw ( Raw )

122+import Servant.API.Stream ( Stream )

122123import Servant.API.TypeLevel

123124import Servant.API.Experimental.Auth ( AuthProtect )

124125

@@ -337,6 +338,10 @@ instance HasLink Raw where

337338 type MkLink Raw = Link

338339 toLink _ = id

339340

341+instance HasLink (Stream m fr ct a) where

342+ type MkLink (Stream m fr ct a) = Link

343+ toLink _ = id

344+

340345-- AuthProtext instances

341346instance HasLink sub => HasLink (AuthProtect tag :> sub) where

342347 type MkLink (AuthProtect tag :> sub) = MkLink sub