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