diff --git a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs index 22d1721e..af69c4ac 100644 --- a/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs +++ b/typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs @@ -29,10 +29,10 @@ import Network.TypedProtocol.Core type DeserialiseFailure = CBOR.DeserialiseFailure --- | Construct a 'Codec' for a CBOR based serialisation format, using strict +-- | Construct a 'CodecF' for a CBOR based serialisation format, using strict -- 'BS.ByteString's. -- --- This is an adaptor between the @cborg@ library and the 'Codec' abstraction. +-- This is an adaptor between the @cborg@ library and the 'CodecF' abstraction. -- -- It takes encode and decode functions for the protocol messages that use the -- CBOR library encoder and decoder. @@ -42,7 +42,7 @@ type DeserialiseFailure = CBOR.DeserialiseFailure -- natively produces chunks). -- mkCodecCborStrictBS - :: forall ps m. MonadST m + :: forall ps m annotator. MonadST m => (forall (pr :: PeerRole) (st :: ps) (st' :: ps). PeerHasAgency pr st @@ -50,9 +50,9 @@ mkCodecCborStrictBS -> (forall (pr :: PeerRole) (st :: ps) s. PeerHasAgency pr st - -> CBOR.Decoder s (SomeMessage st)) + -> CBOR.Decoder s (annotator st)) - -> Codec ps DeserialiseFailure m BS.ByteString + -> Codec ps DeserialiseFailure m annotator BS.ByteString mkCodecCborStrictBS cborMsgEncode cborMsgDecode = Codec { encode = \stok msg -> convertCborEncoder (cborMsgEncode stok) msg, @@ -65,14 +65,15 @@ mkCodecCborStrictBS cborMsgEncode cborMsgDecode = . cborEncode convertCborDecoder - :: (forall s. CBOR.Decoder s a) - -> m (DecodeStep BS.ByteString DeserialiseFailure m a) + :: (forall s. CBOR.Decoder s (annotator st)) + -> m (DecodeStep BS.ByteString DeserialiseFailure m (annotator st)) convertCborDecoder cborDecode = withLiftST (convertCborDecoderBS cborDecode) + convertCborDecoderBS :: forall s m a. Functor m - => (CBOR.Decoder s a) + => CBOR.Decoder s a -> (forall b. ST s b -> m b) -> m (DecodeStep BS.ByteString DeserialiseFailure m a) convertCborDecoderBS cborDecode liftST = @@ -87,16 +88,16 @@ convertCborDecoderBS cborDecode liftST = go (CBOR.Partial k) = DecodePartial (fmap go . liftST . k) --- | Construct a 'Codec' for a CBOR based serialisation format, using lazy +-- | Construct a 'CodecF' for a CBOR based serialisation format, using lazy -- 'BS.ByteString's. -- --- This is an adaptor between the @cborg@ library and the 'Codec' abstraction. +-- This is an adaptor between the @cborg@ library and the 'CodecF' abstraction. -- -- It takes encode and decode functions for the protocol messages that use the -- CBOR library encoder and decoder. -- mkCodecCborLazyBS - :: forall ps m. MonadST m + :: forall ps m annotator. MonadST m => (forall (pr :: PeerRole) (st :: ps) (st' :: ps). PeerHasAgency pr st @@ -104,9 +105,9 @@ mkCodecCborLazyBS -> (forall (pr :: PeerRole) (st :: ps) s. PeerHasAgency pr st - -> CBOR.Decoder s (SomeMessage st)) + -> CBOR.Decoder s (annotator st)) - -> Codec ps CBOR.DeserialiseFailure m LBS.ByteString + -> Codec ps CBOR.DeserialiseFailure m annotator LBS.ByteString mkCodecCborLazyBS cborMsgEncode cborMsgDecode = Codec { encode = \stok msg -> convertCborEncoder (cborMsgEncode stok) msg, @@ -120,14 +121,15 @@ mkCodecCborLazyBS cborMsgEncode cborMsgDecode = . cborEncode convertCborDecoder - :: (forall s. CBOR.Decoder s a) - -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m a) + :: (forall s. CBOR.Decoder s (annotator st)) + -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m (annotator st)) convertCborDecoder cborDecode = withLiftST (convertCborDecoderLBS cborDecode) + convertCborDecoderLBS :: forall s m a. Monad m - => (CBOR.Decoder s a) + => CBOR.Decoder s a -> (forall b. ST s b -> m b) -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m a) convertCborDecoderLBS cborDecode liftST = diff --git a/typed-protocols/src/Network/TypedProtocol/Codec.hs b/typed-protocols/src/Network/TypedProtocol/Codec.hs index 2d548395..01f6c8d7 100644 --- a/typed-protocols/src/Network/TypedProtocol/Codec.hs +++ b/typed-protocols/src/Network/TypedProtocol/Codec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} @@ -6,6 +7,7 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -- @UndecidableInstances@ extension is required for defining @Show@ instance of -- @'AnyMessage'@ and @'AnyMessageAndAgency'@. @@ -14,6 +16,9 @@ module Network.TypedProtocol.Codec ( -- * Defining and using Codecs Codec (..) + , Annotator (..) + , hoistAnnotation + , unAnnotateCodec , hoistCodec , isoCodec , mapFailureCodec @@ -61,7 +66,9 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- * The peer role (client\/server) -- * the type of decoding failures -- * the monad in which the decoder runs --- * the type of the encoded data (typically strings or bytes) +-- * a functor which wraps the decoder result, e.g. `SomeMessage` or `Annotator`. +-- * the type of the encoded data (typically strings or bytes, or +-- `AnyMessage` for testing purposes with no codec overhead). -- -- It is expected that typical codec implementations will be polymorphic in -- the peer role. For example a codec for the ping\/pong protocol might have @@ -71,6 +78,15 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- -- A codec consists of a message encoder and a decoder. -- +-- The `CodecF` type comes with two useful type aliases: +-- * `Codec` - which can decode protocol messages +-- * `AnnotatedCodec` - which also has access to bytes which were fed to the +-- codec when decoding a message. +-- +-- `AnnotatedCodec` is useful if one wants to decode data structures and retain +-- their CBOR encoding (`decodeWithByteSpan` from `cborg` can be used for that +-- purpose). +-- -- The encoder is supplied both with the message to encode and the current -- protocol state (matching the message). The protocol state can be either -- a client or server state, but for either peer role it is a protocol state @@ -122,7 +138,7 @@ import Network.TypedProtocol.Driver (SomeMessage (..)) -- This toy example format uses newlines @\n@ as a framing format. See -- 'DecodeStep' for suggestions on how to use it for more realistic formats. -- -data Codec ps failure m bytes = Codec { +data Codec ps failure m annotator bytes = Codec { encode :: forall (pr :: PeerRole) (st :: ps) (st' :: ps). PeerHasAgency pr st -> Message ps st st' @@ -130,14 +146,44 @@ data Codec ps failure m bytes = Codec { decode :: forall (pr :: PeerRole) (st :: ps). PeerHasAgency pr st - -> m (DecodeStep bytes failure m (SomeMessage st)) + -> m (DecodeStep bytes failure m (annotator st)) } +-- | The Annotator type exposes the CBOR encoded bytestream to the codec when +-- decoding is done. +-- +data Annotator bytes st = Annotator { runAnnotator :: bytes -> SomeMessage st } + +-- | Transform annotation. +-- +hoistAnnotation :: forall ps failure m f g bytes. + Functor m + => (forall st. f st -> g st) + -> Codec ps failure m f bytes + -> Codec ps failure m g bytes +hoistAnnotation nat codec@Codec { decode } = codec { decode = decode' } + where + decode' :: forall (pr :: PeerRole) (st :: ps). + PeerHasAgency pr st + -> m (DecodeStep bytes failure m (g st)) + decode' tok = fmap nat <$> decode tok + + +-- | Remove annotation. It is only safe if the `Annotator` treats empty input +-- in a safe way. +-- +unAnnotateCodec :: forall ps failure m bytes. + (Functor m, Monoid bytes) + => Codec ps failure m (Annotator bytes) bytes + -> Codec ps failure m SomeMessage bytes +unAnnotateCodec = hoistAnnotation (($ mempty) . runAnnotator) + + hoistCodec :: ( Functor n ) => (forall x . m x -> n x) - -> Codec ps failure m bytes - -> Codec ps failure n bytes + -> Codec ps failure m annotator bytes + -> Codec ps failure n annotator bytes hoistCodec nat codec = codec { decode = fmap (hoistDecodeStep nat) . nat . decode codec } @@ -145,8 +191,8 @@ hoistCodec nat codec = codec isoCodec :: Functor m => (bytes -> bytes') -> (bytes' -> bytes) - -> Codec ps failure m bytes - -> Codec ps failure m bytes' + -> Codec ps failure m annotator bytes + -> Codec ps failure m annotator bytes' isoCodec f finv Codec {encode, decode} = Codec { encode = \tok msg -> f $ encode tok msg, decode = \tok -> isoDecodeStep f finv <$> decode tok @@ -155,8 +201,8 @@ isoCodec f finv Codec {encode, decode} = Codec { mapFailureCodec :: Functor m => (failure -> failure') - -> Codec ps failure m bytes - -> Codec ps failure' m bytes + -> Codec ps failure m annotator bytes + -> Codec ps failure' m annotator bytes mapFailureCodec f Codec {encode, decode} = Codec { encode = encode, decode = \tok -> mapFailureDecodeStep f <$> decode tok @@ -199,6 +245,8 @@ data DecodeStep bytes failure m a = -- @'fail'@ or was not provided enough input. | DecodeFail failure +deriving instance Functor m => Functor (DecodeStep bytes failure m) + isoDecodeStep :: Functor m => (bytes -> bytes') @@ -316,7 +364,7 @@ prop_codecM ( Monad m , Eq (AnyMessage ps) ) - => Codec ps failure m bytes + => Codec ps failure m SomeMessage bytes -> AnyMessageAndAgency ps -> m Bool prop_codecM Codec {encode, decode} (AnyMessageAndAgency stok msg) = do @@ -331,7 +379,7 @@ prop_codec :: forall ps failure m bytes. (Monad m, Eq (AnyMessage ps)) => (forall a. m a -> a) - -> Codec ps failure m bytes + -> Codec ps failure m SomeMessage bytes -> AnyMessageAndAgency ps -> Bool prop_codec runM codec msg = @@ -353,7 +401,7 @@ prop_codec_splitsM :: forall ps failure m bytes. (Monad m, Eq (AnyMessage ps)) => (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form - -> Codec ps failure m bytes + -> Codec ps failure m SomeMessage bytes -> AnyMessageAndAgency ps -> m Bool prop_codec_splitsM splits @@ -375,7 +423,7 @@ prop_codec_splits (Monad m, Eq (AnyMessage ps)) => (bytes -> [[bytes]]) -> (forall a. m a -> a) - -> Codec ps failure m bytes + -> Codec ps failure m SomeMessage bytes -> AnyMessageAndAgency ps -> Bool prop_codec_splits splits runM codec msg = @@ -411,8 +459,8 @@ prop_codec_binary_compatM ( Monad m , Eq (AnyMessage psA) ) - => Codec psA failure m bytes - -> Codec psB failure m bytes + => Codec psA failure m SomeMessage bytes + -> Codec psB failure m SomeMessage bytes -> (forall pr (stA :: psA). PeerHasAgency pr stA -> SamePeerHasAgency pr psB) -- ^ The states of A map directly of states of B. -> AnyMessageAndAgency psA @@ -444,8 +492,8 @@ prop_codec_binary_compat , Eq (AnyMessage psA) ) => (forall a. m a -> a) - -> Codec psA failure m bytes - -> Codec psB failure m bytes + -> Codec psA failure m SomeMessage bytes + -> Codec psB failure m SomeMessage bytes -> (forall pr (stA :: psA). PeerHasAgency pr stA -> SamePeerHasAgency pr psB) -> AnyMessageAndAgency psA -> Bool @@ -463,8 +511,8 @@ prop_codecs_compatM , Eq (AnyMessage ps) , forall a. Monoid a => Monoid (m a) ) - => Codec ps failure m bytes - -> Codec ps failure m bytes + => Codec ps failure m SomeMessage bytes + -> Codec ps failure m SomeMessage bytes -> AnyMessageAndAgency ps -> m Bool prop_codecs_compatM codecA codecB @@ -487,8 +535,8 @@ prop_codecs_compat , forall a. Monoid a => Monoid (m a) ) => (forall a. m a -> a) - -> Codec ps failure m bytes - -> Codec ps failure m bytes + -> Codec ps failure m SomeMessage bytes + -> Codec ps failure m SomeMessage bytes -> AnyMessageAndAgency ps -> Bool prop_codecs_compat run codecA codecB msg =