eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #966 from jvanbruegge/stream-code

Browse source 
Allow to specify a status for streaming endpoints
This commit is contained in:
Oleg Grenrus 2018-06-09 08:42:54 +03:00 committed by GitHub
commit f53370b361
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
3 changed files with 20 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs
View file

@ -285,9 +285,9 @@ instance OVERLAPPING_
instance OVERLAPPABLE_
( RunClient m, MimeUnrender ct a, ReflectMethod method,
FramingUnrender framing a, BuildFromStream a (f a)
) => HasClient m (Stream method framing ct (f a)) where
) => HasClient m (Stream method status framing ct (f a)) where
type Client m (Stream method framing ct (f a)) = m (f a)
type Client m (Stream method status framing ct (f a)) = m (f a)
clientWithRoute _pm Proxy req = do
sresp <- streamingRequest req

23
servant-server/src/Servant/Server/Internal.hs
View file

@ -283,37 +283,40 @@ instance OVERLAPPING_
instance OVERLAPPABLE_
( MimeRender ctype a, ReflectMethod method,
( MimeRender ctype a, ReflectMethod method, KnownNat status,
FramingRender framing ctype, ToStreamGenerator b a
) => HasServer (Stream method framing ctype b) context where
) => HasServer (Stream method status framing ctype b) context where
type ServerT (Stream method framing ctype b) m = m b
type ServerT (Stream method status framing ctype b) m = m b
hoistServerWithContext _ _ nt s = nt s
route Proxy _ = streamRouter ([],) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance OVERLAPPING_
( MimeRender ctype a, ReflectMethod method,
( MimeRender ctype a, ReflectMethod method, KnownNat status,
FramingRender framing ctype, ToStreamGenerator b a,
GetHeaders (Headers h b)
) => HasServer (Stream method framing ctype (Headers h b)) context where
) => HasServer (Stream method status framing ctype (Headers h b)) context where
type ServerT (Stream method framing ctype (Headers h b)) m = m (Headers h b)
type ServerT (Stream method status framing ctype (Headers h b)) m = m (Headers h b)
hoistServerWithContext _ _ nt s = nt s
route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) =>
(c -> ([(HeaderName, B.ByteString)], b))
-> Method
-> Status
-> Proxy framing
-> Proxy ctype
-> Delayed env (Handler c)
-> Router env
streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \env request respond ->
streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
accCheck = when (isNothing cmediatype) $ delayedFail err406
@ -323,7 +326,7 @@ streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \
) env request respond $ \ output ->
let (headers, fa) = splitHeaders output
k = getStreamGenerator . toStreamGenerator $ fa in
Route $ responseStream status200 (contentHeader : headers) $ \write flush -> do
Route $ responseStream status (contentHeader : headers) $ \write flush -> do
write . BB.lazyByteString $ header framingproxy ctypeproxy
case boundary framingproxy ctypeproxy of
BoundaryStrategyBracket f ->

8
servant/src/Servant/API/Stream.hs
View file

@ -26,17 +26,19 @@ import Data.Typeable
(Typeable)
import GHC.Generics
(Generic)
import GHC.TypeLits
(Nat)
import Network.HTTP.Types.Method
(StdMethod (..))
import Text.Read
(readMaybe)
-- | A Stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy. Stream endpoints always return response code 200 on success. Type synonyms are provided for standard methods.
data Stream (method :: k1) (framing :: *) (contentType :: *) (a :: *)
data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)
deriving (Typeable, Generic)
type StreamGet = Stream 'GET
type StreamPost = Stream 'POST
type StreamGet = Stream 'GET 200
type StreamPost = Stream 'POST 200
-- | 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).
newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO ()}