git.iko.soy/servant
on master help sign in
Merge pull request #836 from gbaz/gb-streaming
cbd3862Oleg Grenrus
servant-client-core/src/Servant/Client/Core.hs+1
compare with master
unifiedsplit
@@ -43,6 +43,7 @@ module Servant.Client.Core
43 , Response(..)
43 , Response(..)
44 , RunClient(..)
44 , RunClient(..)
45 , module Servant.Client.Core.Internal.BaseUrl
45 , module Servant.Client.Core.Internal.BaseUrl
46+ , StreamingResponse(..)
46
47
47 -- * Writing HasClient instances
48 -- * Writing HasClient instances
48 -- | These functions need not be re-exported by backend libraries.
49 -- | 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
17import Prelude ()
17import Prelude ()
18import Prelude.Compat
18import Prelude.Compat
19
19
20+import Control.Concurrent (newMVar, modifyMVar)
20import Data.Foldable (toList)
21import Data.Foldable (toList)
22+import qualified Data.ByteString.Lazy as BL
21import Data.List (foldl')
23import Data.List (foldl')
24+import Data.Monoid ((<>))
22import Data.Proxy (Proxy (Proxy))
25import Data.Proxy (Proxy (Proxy))
23import Data.Sequence (fromList)
26import Data.Sequence (fromList)
24import Data.String (fromString)
27import Data.String (fromString)
@@ -29,8 +32,11 @@ import Servant.API ((:<|>) ((:<|>)), (:>),
29 AuthProtect, BasicAuth,
32 AuthProtect, BasicAuth,
30 BasicAuthData,
33 BasicAuthData,
31 BuildHeadersTo (..),
34 BuildHeadersTo (..),
35+ BuildFromStream (..),
36+ ByteStringParser (..),
32 Capture, CaptureAll,
37 Capture, CaptureAll,
33 Description, EmptyAPI,
38 Description, EmptyAPI,
39+ FramingUnrender (..),
34 Header, Headers (..),
40 Header, Headers (..),
35 HttpVersion, IsSecure,
41 HttpVersion, IsSecure,
36 MimeRender (mimeRender),
42 MimeRender (mimeRender),
@@ -40,6 +46,8 @@ import Servant.API ((:<|>) ((:<|>)), (:>),
40 QueryParams, Raw,
46 QueryParams, Raw,
41 ReflectMethod (..),
47 ReflectMethod (..),
42 RemoteHost, ReqBody,
48 RemoteHost, ReqBody,
49+ ResultStream(..),
50+ Stream,
43 Summary, ToHttpApiData,
51 Summary, ToHttpApiData,
44 Vault, Verb,
52 Vault, Verb,
45 WithNamedContext,
53 WithNamedContext,
@@ -244,6 +252,53 @@ instance OVERLAPPING_
244 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
252 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
245 }
253 }
246
254
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+
247
302
248-- | If you use a 'Header' in one of your endpoints in your API,
303-- | If you use a 'Header' in one of your endpoints in your API,
249-- the corresponding querying function will automatically take
304-- the corresponding querying function will automatically take
servant-client-core/src/Servant/Client/Core/Internal/Request.hs+4
@@ -4,6 +4,7 @@
4{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
@@ -15,6 +16,7 @@ import Prelude.Compat
15
16
16import Control.Monad.Catch (Exception)
17import Control.Monad.Catch (Exception)
17import qualified Data.ByteString.Builder as Builder
18import qualified Data.ByteString.Builder as Builder
19+import qualified Data.ByteString as BS
18import qualified Data.ByteString.Lazy as LBS
20import qualified Data.ByteString.Lazy as LBS
19import Data.Semigroup ((<>))
21import Data.Semigroup ((<>))
20import qualified Data.Sequence as Seq
22import qualified Data.Sequence as Seq
@@ -70,6 +72,8 @@ data Response = Response
70 , responseHttpVersion :: HttpVersion
72 , responseHttpVersion :: HttpVersion
71 } deriving (Eq, Show, Generic, Typeable)
73 } deriving (Eq, Show, Generic, Typeable)
72
74
75+data StreamingResponse = StreamingResponse { runStreamingResponse :: forall a. ((Status, Seq.Seq Header, HttpVersion, IO BS.ByteString) -> IO a) -> IO a }
76+
73-- A GET request to the top-level path
77-- A GET request to the top-level path
74defaultRequest :: Request
78defaultRequest :: Request
75defaultRequest = Request
79defaultRequest = Request
servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs+2
@@ -19,11 +19,13 @@ import Servant.API (MimeUnrender,
19 contentTypes,
19 contentTypes,
20 mimeUnrender)
20 mimeUnrender)
21import Servant.Client.Core.Internal.Request (Request, Response (..),
21import Servant.Client.Core.Internal.Request (Request, Response (..),
22+ StreamingResponse (..),
22 ServantError (..))
23 ServantError (..))
23
24
24class (Monad m) => RunClient m where
25class (Monad m) => RunClient m where
25 -- | How to make a request.
26 -- | How to make a request.
26 runRequest :: Request -> m Response
27 runRequest :: Request -> m Response
28+ streamingRequest :: Request -> m StreamingResponse
27 throwServantError :: ServantError -> m a
29 throwServantError :: ServantError -> m a
28 catchServantError :: m a -> (ServantError -> m a) -> m a
30 catchServantError :: m a -> (ServantError -> m a) -> m a
29
31
servant-client/servant-client.cabal+1
@@ -72,6 +72,7 @@ test-suite spec
72 hspec-discover:hspec-discover
72 hspec-discover:hspec-discover
73 other-modules:
73 other-modules:
74 Servant.ClientSpec
74 Servant.ClientSpec
75+ Servant.StreamSpec
75 build-depends:
76 build-depends:
76 base == 4.*
77 base == 4.*
77 , aeson
78 , aeson
servant-client/src/Servant/Client/Internal/HttpClient.hs+19−3
@@ -89,6 +89,7 @@ instance Alt ClientM where
89
89
90instance RunClient ClientM where
90instance RunClient ClientM where
91 runRequest = performRequest
91 runRequest = performRequest
92+ streamingRequest = performStreamingRequest
92 throwServantError = throwError
93 throwServantError = throwError
93 catchServantError = catchError
94 catchServantError = catchError
94
95
@@ -111,13 +112,28 @@ performRequest req = do
111 Right response -> do
112 Right response -> do
112 let status = Client.responseStatus response
113 let status = Client.responseStatus response
113 status_code = statusCode status
114 status_code = statusCode status
114− ourResponse = clientResponseToReponse response
115+ ourResponse = clientResponseToResponse response
115 unless (status_code >= 200 && status_code < 300) $
116 unless (status_code >= 200 && status_code < 300) $
116 throwError $ FailureResponse ourResponse
117 throwError $ FailureResponse ourResponse
117 return ourResponse
118 return ourResponse
118
119
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+
119−clientResponseToReponse :: Client.Response BSL.ByteString -> Response
135+clientResponseToResponse :: Client.Response BSL.ByteString -> Response
120−clientResponseToReponse r = Response
136+clientResponseToResponse r = Response
121 { responseStatusCode = Client.responseStatus r
137 { responseStatusCode = Client.responseStatus r
122 , responseBody = Client.responseBody r
138 , responseBody = Client.responseBody r
123 , responseHeaders = fromList $ Client.responseHeaders r
139 , responseHeaders = fromList $ Client.responseHeaders r
servant-client/test/Servant/ClientSpec.hs+1−1
@@ -24,7 +24,7 @@
24{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
24{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
25
25
26#include "overlapping-compat.h"
26#include "overlapping-compat.h"
27−module Servant.ClientSpec (spec) where
27+module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
28
28
29import Prelude ()
29import Prelude ()
30import Prelude.Compat
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-server/servant-server.cabal+1
@@ -64,6 +64,7 @@ library
64 , containers >= 0.5 && < 0.6
64 , containers >= 0.5 && < 0.6
65 , exceptions >= 0.8 && < 0.9
65 , exceptions >= 0.8 && < 0.9
66 , http-api-data >= 0.3 && < 0.4
66 , http-api-data >= 0.3 && < 0.4
67+ , http-media >= 0.4 && < 0.8
67 , http-types >= 0.8 && < 0.11
68 , http-types >= 0.8 && < 0.11
68 , network-uri >= 2.6 && < 2.7
69 , network-uri >= 2.6 && < 2.7
69 , monad-control >= 1.0.0.4 && < 1.1
70 , 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
26 , module Servant.Server.Internal.ServantErr
26 , module Servant.Server.Internal.ServantErr
27 ) where
27 ) where
28
28
29+import Control.Monad (when)
29import Control.Monad.Trans (liftIO)
30import Control.Monad.Trans (liftIO)
30import Control.Monad.Trans.Resource (runResourceT)
31import Control.Monad.Trans.Resource (runResourceT)
31import qualified Data.ByteString as B
32import qualified Data.ByteString as B
33+import qualified Data.ByteString.Builder as BB
32import qualified Data.ByteString.Char8 as BC8
34import qualified Data.ByteString.Char8 as BC8
33import qualified Data.ByteString.Lazy as BL
35import qualified Data.ByteString.Lazy as BL
34−import Data.Maybe (fromMaybe, mapMaybe)
36+import Data.Maybe (fromMaybe, mapMaybe,
37+ isNothing, maybeToList)
35import Data.Either (partitionEithers)
38import Data.Either (partitionEithers)
36import Data.String (fromString)
39import Data.String (fromString)
37import Data.String.Conversions (cs, (<>))
40import Data.String.Conversions (cs, (<>))
@@ -41,13 +44,15 @@ import Data.Typeable
41import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
44import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
42 symbolVal)
45 symbolVal)
43import Network.HTTP.Types hiding (Header, ResponseHeaders)
46import Network.HTTP.Types hiding (Header, ResponseHeaders)
47+import qualified Network.HTTP.Media as NHM
44import Network.Socket (SockAddr)
48import Network.Socket (SockAddr)
45import Network.Wai (Application, Request,
49import Network.Wai (Application, Request,
46 httpVersion, isSecure,
50 httpVersion, isSecure,
47 lazyRequestBody,
51 lazyRequestBody,
48 rawQueryString, remoteHost,
52 rawQueryString, remoteHost,
49 requestHeaders, requestMethod,
53 requestHeaders, requestMethod,
50− responseLBS, vault)
54+ responseLBS, responseStream,
55+ vault)
51import Prelude ()
56import Prelude ()
52import Prelude.Compat
57import Prelude.Compat
53import Web.HttpApiData (FromHttpApiData, parseHeader,
58import Web.HttpApiData (FromHttpApiData, parseHeader,
@@ -61,11 +66,16 @@ import Servant.API ((:<|>) (..), (:>), BasicAuth, Capt
61 QueryParam, QueryParams, Raw,
66 QueryParam, QueryParams, Raw,
62 RemoteHost, ReqBody, Vault,
67 RemoteHost, ReqBody, Vault,
63 WithNamedContext,
68 WithNamedContext,
64− Description, Summary)
69+ Description, Summary,
70+ Accept(..),
71+ FramingRender(..), Stream,
72+ StreamGenerator(..), ToStreamGenerator(..),
73+ BoundaryStrategy(..))
65import Servant.API.ContentTypes (AcceptHeader (..),
74import Servant.API.ContentTypes (AcceptHeader (..),
66 AllCTRender (..),
75 AllCTRender (..),
67 AllCTUnrender (..),
76 AllCTUnrender (..),
68 AllMime,
77 AllMime,
78+ MimeRender(..),
69 canHandleAcceptH)
79 canHandleAcceptH)
70import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
80import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
71 getResponse)
81 getResponse)
@@ -257,6 +267,70 @@ instance OVERLAPPING_
257 where method = reflectMethod (Proxy :: Proxy method)
267 where method = reflectMethod (Proxy :: Proxy method)
258 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
268 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
259
269
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+
260-- | If you use 'Header' in one of the endpoints for your API,
334-- | If you use 'Header' in one of the endpoints for your API,
261-- this automatically requires your server-side handler to be a function
335-- this automatically requires your server-side handler to be a function
262-- that takes an argument of the type specified by 'Header'.
336-- that takes an argument of the type specified by 'Header'.
@@ -299,7 +373,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
299 <> fromString headerName
373 <> fromString headerName
300 <> " failed: " <> e
374 <> " failed: " <> e
301 }
375 }
302− Right header -> return $ Just header
376+ Right hdr -> return $ Just hdr
303
377
304-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
378-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
305-- this automatically requires your server-side handler to be a function
379-- this automatically requires your server-side handler to be a function
servant/servant.cabal+1
@@ -51,6 +51,7 @@ library
51 Servant.API.IsSecure
51 Servant.API.IsSecure
52 Servant.API.QueryParam
52 Servant.API.QueryParam
53 Servant.API.Raw
53 Servant.API.Raw
54+ Servant.API.Stream
54 Servant.API.RemoteHost
55 Servant.API.RemoteHost
55 Servant.API.ReqBody
56 Servant.API.ReqBody
56 Servant.API.ResponseHeaders
57 Servant.API.ResponseHeaders
servant/src/Servant/API.hs+12
@@ -31,6 +31,9 @@ module Servant.API (
31 -- * Actual endpoints, distinguished by HTTP method
31 -- * Actual endpoints, distinguished by HTTP method
32 module Servant.API.Verbs,
32 module Servant.API.Verbs,
33
33
34+ -- * Streaming endpoints, distinguished by HTTP method
35+ module Servant.API.Stream,
36+
34 -- * Authentication
37 -- * Authentication
35 module Servant.API.BasicAuth,
38 module Servant.API.BasicAuth,
36
39
@@ -80,6 +83,15 @@ import Servant.API.IsSecure (IsSecure (..))
80import Servant.API.QueryParam (QueryFlag, QueryParam,
83import Servant.API.QueryParam (QueryFlag, QueryParam,
81 QueryParams)
84 QueryParams)
82import Servant.API.Raw (Raw)
85import 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)
83import Servant.API.RemoteHost (RemoteHost)
95import Servant.API.RemoteHost (RemoteHost)
84import Servant.API.ReqBody (ReqBody)
96import Servant.API.ReqBody (ReqBody)
85import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,
97import 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 )
119import Servant.API.Verbs ( Verb )
119import Servant.API.Verbs ( Verb )
120import Servant.API.Sub ( type (:>) )
120import Servant.API.Sub ( type (:>) )
121import Servant.API.Raw ( Raw )
121import Servant.API.Raw ( Raw )
122+import Servant.API.Stream ( Stream )
122import Servant.API.TypeLevel
123import Servant.API.TypeLevel
123import Servant.API.Experimental.Auth ( AuthProtect )
124import Servant.API.Experimental.Auth ( AuthProtect )
124
125
@@ -337,6 +338,10 @@ instance HasLink Raw where
337 type MkLink Raw = Link
338 type MkLink Raw = Link
338 toLink _ = id
339 toLink _ = id
339
340
341+instance HasLink (Stream m fr ct a) where
342+ type MkLink (Stream m fr ct a) = Link
343+ toLink _ = id
344+
340-- AuthProtext instances
345-- AuthProtext instances
341instance HasLink sub => HasLink (AuthProtect tag :> sub) where
346instance HasLink sub => HasLink (AuthProtect tag :> sub) where
342 type MkLink (AuthProtect tag :> sub) = MkLink sub
347 type MkLink (AuthProtect tag :> sub) = MkLink sub