Skip to content

Support for exposing cbor encoded bytestream to the codec #55

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
wants to merge 2 commits into
base: main
Choose a base branch
from
Draft

Support for exposing cbor encoded bytestream to the codec #55

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
d0c0668
Generalised Codec to provide AnnotatedCodec
coot Aug 20, 2024
0d9a6db
Support for exposing cbor encoded bytestream to the codec
crocodile-dentist Sep 4, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
34 changes: 18 additions & 16 deletions typed-protocols-cborg/src/Network/TypedProtocol/Codec/CBOR.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand All @@ -42,17 +42,17 @@ 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
-> Message ps st st' -> CBOR.Encoding)

-> (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,
Expand All @@ -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 =
Expand All @@ -87,26 +88,26 @@ 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
-> Message ps st st' -> CBOR.Encoding)

-> (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,
Expand All @@ -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 =
Expand Down
90 changes: 69 additions & 21 deletions typed-protocols/src/Network/TypedProtocol/Codec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,11 +1,13 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
-- @UndecidableInstances@ extension is required for defining @Show@ instance of
-- @'AnyMessage'@ and @'AnyMessageAndAgency'@.
Expand All @@ -14,6 +16,9 @@
module Network.TypedProtocol.Codec
( -- * Defining and using Codecs
Codec (..)
, Annotator (..)
, hoistAnnotation
, unAnnotateCodec
, hoistCodec
, isoCodec
, mapFailureCodec
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -122,31 +138,61 @@ 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'
-> bytes,

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
}

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
Expand All @@ -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
Expand Down Expand Up @@ -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')
Expand Down Expand Up @@ -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
Expand All @@ -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 =
Expand All @@ -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
Expand All @@ -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 =
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 =
Expand Down
Loading