@@ -1,6 +1,7 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE KindSignatures #-}
@@ -8,39 +9,41 @@
8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE RankNTypes #-}
11−{-# LANGUAGE TupleSections #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
12−{-# OPTIONS_HADDOCK not-home #-}
13+{-# OPTIONS_HADDOCK not-home #-}
14module Servant.API.Stream (
15module Servant.API.Stream (
16− StreamGet,
17+ StreamGet,
17− StreamPost,
18+ StreamPost,
18− -- * Sources
19+ StreamBody,
20− -- | Both 'StreamGenerator' and 'ResultStream' are equivalent
21− -- to some *source* in streaming libraries.
22+ -- | 'SourceIO' are equivalent to some *source* in streaming libraries.
22− StreamGenerator (..),
23+ SourceIO,
23− ToStreamGenerator (..),
24+ ToSourceIO (..),
24− ResultStream (..),
25+ FromSourceIO (..),
25− FromResultStream (..),
26+ -- ** Auxiliary classes
27+ SourceToSourceIO (..),
26− -- * Framing
28+ -- * Framing
27− FramingRender (..),
29+ FramingRender (..),
28− FramingUnrender (..),
30+ FramingUnrender (..),
29− BoundaryStrategy (..),
30− ByteStringParser (..),
31− -- ** Strategies
31+ -- ** Strategies
32− NoFraming,
32+ NoFraming,
33− NewlineFraming,
33+ NewlineFraming,
34− NetstringFraming,
34+ NetstringFraming,
37−import Control.Arrow
38+import Control.Applicative
39−import Data.ByteString.Lazy
40+import Control.Monad.IO.Class
40− (ByteString, empty)
41+ (MonadIO (..))
41−import qualified Data.ByteString.Lazy.Char8 as LB
42+import qualified Data.Attoparsec.ByteString as A
42−import Data.Foldable
43+import qualified Data.Attoparsec.ByteString.Char8 as A8
43− (traverse_)
44+import qualified Data.ByteString as BS
45+import qualified Data.ByteString.Lazy as LBS
46+import qualified Data.ByteString.Lazy.Char8 as LBS8
44import Data.List.NonEmpty
47import Data.List.NonEmpty
45 (NonEmpty (..))
48 (NonEmpty (..))
46import Data.Monoid
49import Data.Monoid
@@ -55,158 +58,185 @@ import GHC.TypeLits
56import Network.HTTP.Types.Method
59import Network.HTTP.Types.Method
57 (StdMethod (..))
60 (StdMethod (..))
58−import System.IO.Unsafe
61+import Servant.Types.SourceT
63-- | A Stream endpoint for a given method emits a stream of encoded values at a
63-- | A Stream endpoint for a given method emits a stream of encoded values at a
64−-- given Content-Type, delimited by a framing strategy. Stream endpoints always
64+-- given @Content-Type@, delimited by a @framing@ strategy.
65−-- return response code 200 on success. Type synonyms are provided for standard
65+-- Type synonyms are provided for standard methods.
67data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)
67data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)
68 deriving (Typeable, Generic)
68 deriving (Typeable, Generic)
70type StreamGet = Stream 'GET 200
70type StreamGet = Stream 'GET 200
71type StreamPost = Stream 'POST 200
71type StreamPost = Stream 'POST 200
73+-- | A stream request body.
76+data StreamBody (framing :: *) (contentType :: *) (a :: *)
77+ deriving (Typeable, Generic)
79+-------------------------------------------------------------------------------
81+-------------------------------------------------------------------------------
73−-- | Stream endpoints may be implemented as producing a @StreamGenerator@ a
83+-- | Stream endpoints may be implemented as producing a @'SourceIO' chunk@.
74−-- function that itself takes two emit functions the first to be used on the
84+--
75−-- first value the stream emits, and the second to be used on all subsequent
76−-- values (to allow interspersed framing strategies such as comma separation).
77−newtype StreamGenerator a = StreamGenerator { getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO () }
79−-- | 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.
80−class ToStreamGenerator a b | a -> b where
81− toStreamGenerator :: a -> StreamGenerator b
83−instance ToStreamGenerator (StreamGenerator a) a where
84− toStreamGenerator x = x
86−instance ToStreamGenerator (NonEmpty a) a where
87− toStreamGenerator (x :| xs) = StreamGenerator $ \f g -> f x >> traverse_ g xs
89−instance ToStreamGenerator [a] a where
90− toStreamGenerator [] = StreamGenerator $ \_ _ -> return ()
91− toStreamGenerator (x : xs) = StreamGenerator $ \f g -> f x >> traverse_ g xs
93−-- | Clients reading from streaming endpoints can be implemented as producing a
85+-- Clients reading from streaming endpoints can be implemented as consuming a
94−-- @ResultStream@ that captures the setup, takedown, and incremental logic for
86+-- @'SourceIO' chunk@.
95−-- a read, being an IO continuation that takes a producer of Just either values
87+--
96−-- or errors that terminates with a Nothing.
88+type SourceIO = SourceT IO
97−newtype ResultStream a = ResultStream { runResultStream :: forall b. (IO (Maybe (Either String a)) -> IO b) -> IO b }
89+
98−
90+-- | 'ToSourceIO' is intended to be implemented for types such as Conduit, Pipe,
91+-- etc. By implementing this class, all such streaming abstractions can be used
92+-- directly as endpoints.
93+class ToSourceIO chunk a | a -> chunk where
94+ toSourceIO :: a -> SourceIO chunk
96+-- | Auxiliary class for @'ToSourceIO' x ('SourceT' m x)@ instance.
97+class SourceToSourceIO m where
98+ sourceToSourceIO :: SourceT m a -> SourceT IO a
100+instance SourceToSourceIO IO where
101+ sourceToSourceIO = id
103+-- | Relax to use auxiliary class, have m
104+instance SourceToSourceIO m => ToSourceIO chunk (SourceT m chunk) where
105+ toSourceIO = sourceToSourceIO
107+instance ToSourceIO a (NonEmpty a) where
108+ toSourceIO (x :| xs) = fromStepT (Yield x (foldr Yield Stop xs))
110+instance ToSourceIO a [a] where
113+-- | 'FromSourceIO' is intended to be implemented for types such as Conduit,
99−-- | FromResultStream 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.
114+-- Pipe, etc. By implementing this class, all such streaming abstractions can
100−class FromResultStream a b | b -> a where
115+-- be used directly on the client side for talking to streaming endpoints.
101− fromResultStream :: ResultStream a -> IO b
116+class FromSourceIO chunk a | a -> chunk where
102−
117+ fromSourceIO :: SourceIO chunk -> a
103−instance FromResultStream a (ResultStream a) where
118+
104− fromResultStream = return
119+instance MonadIO m => FromSourceIO a (SourceT m a) where
105−
120+ fromSourceIO = sourceFromSourceIO
106−-- | Uses 'unsafeInterleaveIO'
121+
107−instance FromResultStream a [a] where
122+sourceFromSourceIO :: forall m a. MonadIO m => SourceT IO a -> SourceT m a
108− fromResultStream x = runResultStream x lazyRead
123+sourceFromSourceIO src =
110−-- | Uses 'unsafeInterleaveIO'
125+ k $ Effect $ liftIO $ unSourceT src (return . go)
111−instance FromResultStream a (NonEmpty a) where
112− fromResultStream x = runResultStream x $ \r -> do
115− Nothing -> fail "Empty stream"
116− Just (Left er) -> fail er
117− Just (Right y) -> do
121−lazyRead :: IO (Maybe (Either String a)) -> IO [a]
124− go = unsafeInterleaveIO loop
127+ go :: StepT IO a -> StepT m a
126− loop = do
129+ go (Error err) = Error err
127− e <- r
130+ go (Skip s) = Skip (go s)
128− case e of
131+ go (Effect ms) = Effect (liftIO (fmap go ms))
129− Nothing -> return []
132+ go (Yield x s) = Yield x (go s)
130− Just (Left er) -> fail er
133+
131− Just (Right y) -> do
134+-- This fires e.g. in Client.lhs
132− ys <- go
135+-- {-# OPTIONS_GHC -ddump-simpl -ddump-rule-firings -ddump-to-file #-}
133− return (y : ys)
136+{-# NOINLINE [2] sourceFromSourceIO #-}
134−
137+{-# RULES "sourceFromSourceIO @IO" sourceFromSourceIO = id :: SourceT IO a -> SourceT IO a #-}
139+-------------------------------------------------------------------------------
141+-------------------------------------------------------------------------------
135−-- | 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.
143+-- | The 'FramingRender' class provides the logic for emitting a framing strategy.
136−class FramingRender strategy a where
144+-- The strategy transforms a @'SourceT' m a@ into @'SourceT' m 'LBS.ByteString'@,
137− header :: Proxy strategy -> Proxy a -> ByteString
145+-- therefore it can prepend, append and intercalate /framing/ structure
138− boundary :: Proxy strategy -> Proxy a -> BoundaryStrategy
146+-- around chunks.
139− trailer :: Proxy strategy -> Proxy a -> ByteString
147+--
140−
148+-- /Note:/ as the @'Monad' m@ is generic, this is pure transformation.
141−-- | The bracketing strategy generates things to precede and follow the content, as with netstrings.
149+--
142−-- The intersperse strategy inserts seperators between things, as with newline framing.
150+class FramingRender strategy where
143−-- Finally, the general strategy performs an arbitrary rewrite on the content, to allow escaping rules and such.
151+ framingRender :: Monad m => Proxy strategy -> (a -> LBS.ByteString) -> SourceT m a -> SourceT m LBS.ByteString
144−data BoundaryStrategy = BoundaryStrategyBracket (ByteString -> (ByteString,ByteString))
152+
145− | BoundaryStrategyIntersperse ByteString
153+-- | The 'FramingUnrender' class provides the logic for parsing a framing
146− | BoundaryStrategyGeneral (ByteString -> ByteString)
154+-- strategy.
148−-- | 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.
149−data ByteStringParser a = ByteStringParser
150− { parseIncremental :: ByteString -> Maybe (a, ByteString)
151− , parseEOF :: ByteString -> (a, ByteString)
154−-- | 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.
155−class FramingUnrender strategy a where
155+class FramingUnrender strategy where
156− unrenderFrames :: Proxy strategy -> Proxy a -> ByteStringParser (ByteStringParser (Either String ByteString))
156+ framingUnrender :: Monad m => Proxy strategy -> (LBS.ByteString -> Either String a) -> SourceT m BS.ByteString -> SourceT m a
158+-------------------------------------------------------------------------------
160+-------------------------------------------------------------------------------
158−-- | A framing strategy that does not do any framing at all, it just passes the input data
162+-- | A framing strategy that does not do any framing at all, it just passes the
159−-- This will be used most of the time with binary data, such as files
163+-- input data This will be used most of the time with binary data, such as
160data NoFraming
165data NoFraming
162−instance FramingRender NoFraming a where
167+instance FramingRender NoFraming where
163− header _ _ = empty
168+ framingRender _ = fmap
164− boundary _ _ = BoundaryStrategyGeneral id
169+
165− trailer _ _ = empty
170+-- | As 'NoFraming' doesn't have frame separators, we take the chunks
166−
171+-- as given and try to convert them one by one.
173+-- That works well when @a@ is a 'ByteString'.
167−instance FramingUnrender NoFraming a where
174+instance FramingUnrender NoFraming where
168− unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)
175+ framingUnrender _ f = mapStepT go
169− where go = ByteStringParser (Just . (, empty) . Right) ((, empty) . Right)
176+ where
178+ go (Error err) = Error err
179+ go (Skip s) = Skip (go s)
180+ go (Effect ms) = Effect (fmap go ms)
181+ go (Yield x s) = case f (LBS.fromStrict x) of
182+ Right y -> Yield y (go s)
183+ Left err -> Error err
185+-------------------------------------------------------------------------------
187+-------------------------------------------------------------------------------
171−-- | A simple framing strategy that has no header or termination, and inserts a newline character between each frame.
189+-- | A simple framing strategy that has no header or termination, and inserts a
190+-- newline character between each frame. This assumes that it is used with a
172−-- This assumes that it is used with a Content-Type that encodes without newlines (e.g. JSON).
191+-- Content-Type that encodes without newlines (e.g. JSON).
173data NewlineFraming
192data NewlineFraming
175−instance FramingRender NewlineFraming a where
194+instance FramingRender NewlineFraming where
176− header _ _ = empty
195+ framingRender _ f = mapStepT go0 where
177− boundary _ _ = BoundaryStrategyIntersperse "\n"
196+ go0 Stop = Stop
178− trailer _ _ = empty
197+ go0 (Error err) = Error err
179−
198+ go0 (Skip s) = Skip (go0 s)
199+ go0 (Yield x s) = Yield (f x) (go s)
200+ go0 (Effect ms) = Effect (fmap go0 ms)
202+ go = fmap (\x -> "\n" <> f x)
180−instance FramingUnrender NewlineFraming a where
204+instance FramingUnrender NewlineFraming where
181− unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)
205+ framingUnrender _ f = transformWithAtto $ do
182− where go = ByteStringParser
206+ bs <- A.takeWhile (/= 10)
183− (\x -> case LB.break (== '\n') x of
207+ () <$ A.word8 10 <|> A.endOfInput
184− (h,r) -> if not (LB.null r) then Just (Right h, LB.drop 1 r) else Nothing
208+ either fail pure (f (LBS.fromStrict bs))
186− (\x -> case LB.break (== '\n') x of
210+-------------------------------------------------------------------------------
187− (h,r) -> (Right h, LB.drop 1 r)
211+-- NetstringFraming
188− )
212+-------------------------------------------------------------------------------
189−-- | The netstring framing strategy as defined by djb: <http://cr.yp.to/proto/netstrings.txt>
214+-- | The netstring framing strategy as defined by djb:
215+-- <http://cr.yp.to/proto/netstrings.txt>
217+-- Any string of 8-bit bytes may be encoded as @[len]":"[string]","@. Here
218+-- @[string]@ is the string and @[len]@ is a nonempty sequence of ASCII digits
219+-- giving the length of @[string]@ in decimal. The ASCII digits are @<30>@ for
220+-- 0, @<31>@ for 1, and so on up through @<39>@ for 9. Extra zeros at the front
221+-- of @[len]@ are prohibited: @[len]@ begins with @<30>@ exactly when
222+-- @[string]@ is empty.
224+-- For example, the string @"hello world!"@ is encoded as
225+-- @<31 32 3a 68 65 6c 6c 6f 20 77 6f 72 6c 64 21 2c>@,
226+-- i.e., @"12:hello world!,"@.
227+-- The empty string is encoded as @"0:,"@.
190data NetstringFraming
229data NetstringFraming
192−instance FramingRender NetstringFraming a where
231+instance FramingRender NetstringFraming where
193− header _ _ = empty
232+ framingRender _ f = fmap $ \x ->
194− boundary _ _ = BoundaryStrategyBracket $ \b -> ((<> ":") . LB.pack . show . LB.length $ b, ",")
233+ let bs = f x
195− trailer _ _ = empty
234+ in LBS8.pack (show (LBS8.length bs)) <> ":" <> bs <> ","
198−instance FramingUnrender NetstringFraming a where
236+instance FramingUnrender NetstringFraming where
199− unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)
237+ framingUnrender _ f = transformWithAtto $ do
200− where go = ByteStringParser
238+ len <- A8.decimal
201− (\b -> let (i,r) = LB.break (==':') b
239+ _ <- A8.char ':'
202− in case readMaybe (LB.unpack i) of
240+ bs <- A.take len
203− Just len -> if LB.length r > len
241+ _ <- A8.char ','
204− then Just . first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r
242+ either fail pure (f (LBS.fromStrict bs))
206− Nothing -> Just (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))
207− (\b -> let (i,r) = LB.break (==':') b
208− in case readMaybe (LB.unpack i) of
209− Just len -> if LB.length r > len
210− then first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r
211− else (Right $ LB.take len r, LB.empty)
212− Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))