module Control.TimeWarp.Rpc.Message
(
MessageName
, Message (..)
, PackingType (..)
, Packable (..)
, Unpackable (..)
, BinaryP (..)
, plainBinaryP
, ContentData (..)
, NameData (..)
, RawData (..)
, WithHeaderData (..)
, messageName'
, runGetOrThrow
) where
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.Extra (unlessM)
import Data.Binary (Binary (..))
import Data.Binary.Get (Get, isEmpty, label, runGetOrFail)
import Data.Binary.Put (runPut)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (Conduit, (=$=))
import qualified Data.Conduit.List as CL
import Data.Conduit.Serialization.Binary (ParseError (..), conduitGet,
conduitPut)
import Data.Data (Data, dataTypeName, dataTypeOf)
import Data.Proxy (Proxy (..), asProxyTypeOf)
import qualified Data.Text as T
import Data.Text.Buildable (Buildable)
import Data.Typeable (Typeable)
import qualified Formatting as F
type MessageName = T.Text
class Typeable m => Message m where
messageName :: Proxy m -> MessageName
default messageName :: Data m => Proxy m -> MessageName
messageName proxy =
T.pack . dataTypeName . dataTypeOf $ undefined `asProxyTypeOf` proxy
formatMessage :: m -> T.Text
default formatMessage :: Buildable m => m -> T.Text
formatMessage = F.sformat F.build
data ContentData r = ContentData r
data RawData = RawData ByteString
data NameData = NameData MessageName
data WithHeaderData h r = WithHeaderData h r
messageName' :: Message m => m -> MessageName
messageName' = messageName . proxyOf
where
proxyOf :: a -> Proxy a
proxyOf _ = Proxy
runGetOrThrow :: MonadThrow m => Get a -> BL.ByteString -> m a
runGetOrThrow p s =
either (\(bs, off, err) -> throwM $ ParseError (BL.toStrict bs) off err)
(\(_, _, a) -> return a)
$ runGetOrFail p s
class PackingType p where
type IntermediateForm p :: *
unpackMsg :: MonadThrow m => p -> Conduit ByteString m (IntermediateForm p)
class PackingType p => Packable p r where
packMsg :: MonadThrow m => p -> Conduit r m ByteString
class PackingType p => Unpackable p r where
extractMsgPart :: MonadThrow m => p -> IntermediateForm p -> m r
data BinaryP header = BinaryP
plainBinaryP :: BinaryP ()
plainBinaryP = BinaryP
instance Binary h => PackingType (BinaryP h) where
type IntermediateForm (BinaryP h) = WithHeaderData h RawData
unpackMsg _ = conduitGet $ WithHeaderData <$> get <*> (RawData <$> get)
instance (Binary h, Binary r, Message r)
=> Packable (BinaryP h) (WithHeaderData h (ContentData r)) where
packMsg p = CL.map packToRaw =$= packMsg p
where
packToRaw (WithHeaderData h (ContentData r)) =
WithHeaderData h . RawData . BL.toStrict . runPut $ do
put $ messageName' r
put r
instance Binary h
=> Packable (BinaryP h) (WithHeaderData h RawData) where
packMsg _ = CL.map doPut =$= conduitPut
where
doPut (WithHeaderData h (RawData r)) = put h >> put r
instance Binary h
=> Unpackable (BinaryP h) (WithHeaderData h RawData) where
extractMsgPart _ = return
instance Binary h
=> Unpackable (BinaryP h) NameData where
extractMsgPart _ (WithHeaderData _ (RawData raw)) =
runGetOrThrow (NameData <$> label lname get) $ BL.fromStrict raw
where
lname = "(in parseNameData)"
instance (Binary h, Binary r)
=> Unpackable (BinaryP h) (ContentData r) where
extractMsgPart _ (WithHeaderData _ (RawData raw)) =
runGetOrThrow parser $ BL.fromStrict raw
where
parser = label lname $ checkAllConsumed $
(get :: Get MessageName) *> (ContentData <$> get)
checkAllConsumed p = p <* unlessM isEmpty (fail "unconsumed input")
lname = "(in parseNameNContentData)"