{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Stream where
import Control.Arrow
(first)
import Data.ByteString.Lazy
(ByteString, empty)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Monoid
((<>))
import Data.Proxy
(Proxy)
import Data.Typeable
(Typeable)
import GHC.Generics
(Generic)
import GHC.TypeLits
(Nat)
import Network.HTTP.Types.Method
(StdMethod (..))
import Text.Read
(readMaybe)
data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)
deriving (Typeable, Generic)
type StreamGet = Stream 'GET 200
type StreamPost = Stream 'POST 200
newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO ()}
class ToStreamGenerator a b | a -> b where
toStreamGenerator :: a -> StreamGenerator b
instance ToStreamGenerator (StreamGenerator a) a
where toStreamGenerator x = x
newtype ResultStream a = ResultStream (forall b. (IO (Maybe (Either String a)) -> IO b) -> IO b)
class BuildFromStream a b where
buildFromStream :: ResultStream a -> b
instance BuildFromStream a (ResultStream a)
where buildFromStream x = x
class FramingRender strategy a where
header :: Proxy strategy -> Proxy a -> ByteString
boundary :: Proxy strategy -> Proxy a -> BoundaryStrategy
trailer :: Proxy strategy -> Proxy a -> ByteString
data BoundaryStrategy = BoundaryStrategyBracket (ByteString -> (ByteString,ByteString))
| BoundaryStrategyIntersperse ByteString
| BoundaryStrategyGeneral (ByteString -> ByteString)
data ByteStringParser a = ByteStringParser {
parseIncremental :: ByteString -> Maybe (a, ByteString),
parseEOF :: ByteString -> (a, ByteString)
}
class FramingUnrender strategy a where
unrenderFrames :: Proxy strategy -> Proxy a -> ByteStringParser (ByteStringParser (Either String ByteString))
data NoFraming
instance FramingRender NoFraming a where
header _ _ = empty
boundary _ _ = BoundaryStrategyGeneral id
trailer _ _ = empty
instance FramingUnrender NoFraming a where
unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)
where go = ByteStringParser (Just . (, empty) . Right) ((, empty) . Right)
data NewlineFraming
instance FramingRender NewlineFraming a where
header _ _ = empty
boundary _ _ = BoundaryStrategyIntersperse "\n"
trailer _ _ = empty
instance FramingUnrender NewlineFraming a where
unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)
where go = ByteStringParser
(\x -> case LB.break (== '\n') x of
(h,r) -> if not (LB.null r) then Just (Right h, LB.drop 1 r) else Nothing
)
(\x -> case LB.break (== '\n') x of
(h,r) -> (Right h, LB.drop 1 r)
)
data NetstringFraming
instance FramingRender NetstringFraming a where
header _ _ = empty
boundary _ _ = BoundaryStrategyBracket $ \b -> ((<> ":") . LB.pack . show . LB.length $ b, ",")
trailer _ _ = empty
instance FramingUnrender NetstringFraming a where
unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)
where go = ByteStringParser
(\b -> let (i,r) = LB.break (==':') b
in case readMaybe (LB.unpack i) of
Just len -> if LB.length r > len
then Just . first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r
else Nothing
Nothing -> Just (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))
(\b -> let (i,r) = LB.break (==':') b
in case readMaybe (LB.unpack i) of
Just len -> if LB.length r > len
then first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r
else (Right $ LB.take len r, LB.empty)
Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))