Merge pull request #966 from jvanbruegge/stream-code

Allow to specify a status for streaming endpoints

Author: phadej

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

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

servant-server/src/Servant/Server/Internal.hs

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

servant/src/Servant/API/Stream.hs

@@ -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 ()}