Skip to content
Permalink
Browse files

Use embedded CBOR encoding in the central codec definitions

Currently the use of the CBOR encoding is spread out where these codecs
are used, and this leads to confusion and accidental incompatability,
plus an inablity to point to a concrete CDDL spec for the protocols.

This puts the embedded CBOR-in-CBOR format within the centrally defined
codecs. This formulation should still make it possible to use
annotations with the full bytes, by fmaping over the decoder result.

Using this efficiently in some places may require using encodePreEncoded
from cborg-0.2.2. This allows one to use a bytestring containing CBOR
format data directly in an Encoding. This would be used to provide the
encoding side of things but still use the annotations with the raw
bytes, rather than re-encoding.

The tests will need updating to follow the type changes.
  • Loading branch information...
dcoutts committed Aug 13, 2019
1 parent 9f432f4 commit 6b69e7b79eb754eb712ea29da1ca1318966f4ed0
@@ -12,13 +12,15 @@ module Ouroboros.Network.Protocol.BlockFetch.Codec
, codecBlockFetchId
) where

import Control.Monad (when)
import Control.Monad.Class.MonadST

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LBS

import qualified Codec.CBOR.Encoding as CBOR (Encoding, encodeListLen, encodeWord)
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Decoding as CBOR (Decoder, decodeListLen, decodeWord)
import qualified Codec.CBOR.Write as CBOR

import Network.TypedProtocol.Codec
import Network.TypedProtocol.Codec.Cbor
@@ -29,38 +31,31 @@ import Ouroboros.Network.Protocol.BlockFetch.Type

codecBlockFetch
:: forall block m.
( Monad m
, MonadST m
)
MonadST m
=> (block -> CBOR.Encoding)
-> (forall s. CBOR.Decoder s (LBS.ByteString -> block))
-> (HeaderHash block -> CBOR.Encoding)
-> (forall s. CBOR.Decoder s block)
-> (forall s. CBOR.Decoder s (HeaderHash block))
-> Codec (BlockFetch block) CBOR.DeserialiseFailure m ByteString
codecBlockFetch encodeBody encodeHeaderHash
decodeBody decodeHeaderHash =
-> Codec (BlockFetch block) CBOR.DeserialiseFailure m LBS.ByteString
codecBlockFetch encodeBlock decodeBlock
encodeBlockHash decodeBlockHash =
mkCodecCborLazyBS encode decode
where
encodePoint' :: Point block -> CBOR.Encoding
encodePoint' = Block.encodePoint encodeHeaderHash

decodePoint' :: forall s. CBOR.Decoder s (Point block)
decodePoint' = Block.decodePoint decodeHeaderHash

encode :: forall (pr :: PeerRole) st st'.
PeerHasAgency pr st
-> Message (BlockFetch block) st st'
-> CBOR.Encoding
encode (ClientAgency TokIdle) (MsgRequestRange (ChainRange from to)) =
CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> encodePoint' from <> encodePoint' to
CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> encodePoint from
<> encodePoint to
encode (ClientAgency TokIdle) MsgClientDone =
CBOR.encodeListLen 1 <> CBOR.encodeWord 1
encode (ServerAgency TokBusy) MsgStartBatch =
CBOR.encodeListLen 1 <> CBOR.encodeWord 2
encode (ServerAgency TokBusy) MsgNoBlocks =
CBOR.encodeListLen 1 <> CBOR.encodeWord 3
encode (ServerAgency TokStreaming) (MsgBlock body) =
CBOR.encodeListLen 2 <> CBOR.encodeWord 4 <> encodeBody body
encode (ServerAgency TokStreaming) (MsgBlock block) =
CBOR.encodeListLen 2 <> CBOR.encodeWord 4 <> encodeBlockWrapped block
encode (ServerAgency TokStreaming) MsgBatchDone =
CBOR.encodeListLen 1 <> CBOR.encodeWord 5

@@ -72,13 +67,14 @@ codecBlockFetch encodeBody encodeHeaderHash
key <- CBOR.decodeWord
case (stok, key) of
(ClientAgency TokIdle, 0) -> do
from <- decodePoint'
to <- decodePoint'
from <- decodePoint
to <- decodePoint
return $ SomeMessage $ MsgRequestRange (ChainRange from to)
(ClientAgency TokIdle, 1) -> return $ SomeMessage MsgClientDone
(ServerAgency TokBusy, 2) -> return $ SomeMessage MsgStartBatch
(ServerAgency TokBusy, 3) -> return $ SomeMessage MsgNoBlocks
(ServerAgency TokStreaming, 4) -> SomeMessage . MsgBlock <$> decodeBody
(ServerAgency TokStreaming, 4) -> SomeMessage . MsgBlock
<$> decodeBlockWrapped
(ServerAgency TokStreaming, 5) -> return $ SomeMessage MsgBatchDone

-- TODO proper exceptions
@@ -87,6 +83,33 @@ codecBlockFetch encodeBody encodeHeaderHash
(ServerAgency TokStreaming, _) -> fail "codecBlockFetch.Streaming: unexpected key"


encodePoint :: Point block -> CBOR.Encoding
encodePoint = Block.encodePoint encodeBlockHash

decodePoint :: forall s. CBOR.Decoder s (Point block)
decodePoint = Block.decodePoint decodeBlockHash

encodeBlockWrapped :: block -> CBOR.Encoding
encodeBlockWrapped block =
--TODO: replace with encodeEmbeddedCBOR from cborg-0.2.4 once
-- it is available, since that will be faster.
CBOR.encodeTag 24
<> CBOR.encodeBytes (CBOR.toStrictByteString (encodeBlock block))

decodeBlockWrapped :: forall s. CBOR.Decoder s block
decodeBlockWrapped = do
--TODO: replace this with decodeEmbeddedCBOR from cborg-0.2.4 once
-- it is available, since that will be faster.
tag <- CBOR.decodeTag
when (tag /= 24) $ fail "expected tag 24 (CBOR-in-CBOR)"
payload <- LBS.fromStrict <$> CBOR.decodeBytes
case CBOR.deserialiseFromBytes decodeBlock payload of
Left (CBOR.DeserialiseFailure _ reason) -> fail reason
Right (trailing, block)
| not (LBS.null trailing) -> fail "trailing bytes in CBOR-in-CBOR"
| otherwise -> return (block payload)


codecBlockFetchId
:: forall block m. Monad m
=> Codec (BlockFetch block) CodecFailure m (AnyMessage (BlockFetch block))
@@ -11,35 +11,39 @@ module Ouroboros.Network.Protocol.ChainSync.Codec
, codecChainSyncId
) where

import Control.Monad (when)
import Control.Monad.Class.MonadST

import Network.TypedProtocol.Codec
import Network.TypedProtocol.Codec.Cbor
import Ouroboros.Network.Protocol.ChainSync.Type

import qualified Data.ByteString.Lazy as LBS

import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Decoding as CBOR
import Codec.CBOR.Encoding (encodeListLen, encodeWord)
import Codec.CBOR.Decoding (decodeListLen, decodeWord)
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Write as CBOR

import Data.ByteString.Lazy (ByteString)
import Codec.CBOR.Encoding (encodeListLen, encodeWord)
import Codec.CBOR.Decoding (decodeListLen, decodeWord)

-- | The main CBOR 'Codec' for the 'ChainSync' protocol.
--
codecChainSync :: forall header point m.
(MonadST m)
=> (header -> CBOR.Encoding)
-> (forall s . CBOR.Decoder s header)
-> (forall s . CBOR.Decoder s (LBS.ByteString -> header))
-> (point -> CBOR.Encoding)
-> (forall s . CBOR.Decoder s point)
-> Codec (ChainSync header point)
CBOR.DeserialiseFailure m ByteString
CBOR.DeserialiseFailure m LBS.ByteString
codecChainSync encodeHeader decodeHeader encodePoint decodePoint =
mkCodecCborLazyBS encode decode
where
encode :: forall (pr :: PeerRole) (st :: ChainSync header point) (st' :: ChainSync header point).
encode :: forall (pr :: PeerRole)
(st :: ChainSync header point)
(st' :: ChainSync header point).
PeerHasAgency pr st
-> Message (ChainSync header point) st st'
-> CBOR.Encoding
@@ -51,7 +55,7 @@ codecChainSync encodeHeader decodeHeader encodePoint decodePoint =
encodeListLen 1 <> encodeWord 1

encode (ServerAgency TokNext{}) (MsgRollForward h p) =
encodeListLen 3 <> encodeWord 2 <> encodeHeader h <> encodePoint p
encodeListLen 3 <> encodeWord 2 <> encodeHeaderWrapped h <> encodePoint p

encode (ServerAgency TokNext{}) (MsgRollBackward p1 p2) =
encodeListLen 3 <> encodeWord 3 <> encodePoint p1 <> encodePoint p2
@@ -82,7 +86,7 @@ codecChainSync encodeHeader decodeHeader encodePoint decodePoint =
return (SomeMessage MsgAwaitReply)

(2, 3, ServerAgency (TokNext _)) -> do
h <- decodeHeader
h <- decodeHeaderWrapped
p <- decodePoint
return (SomeMessage (MsgRollForward h p))

@@ -109,6 +113,27 @@ codecChainSync encodeHeader decodeHeader encodePoint decodePoint =

_ -> fail ("codecChainSync: unexpected key " ++ show (key, len))

encodeHeaderWrapped :: header -> CBOR.Encoding
encodeHeaderWrapped header =
--TODO: replace with encodeEmbeddedCBOR from cborg-0.2.4 once
-- it is available, since that will be faster.
CBOR.encodeTag 24
<> CBOR.encodeBytes (CBOR.toStrictByteString (encodeHeader header))

decodeHeaderWrapped :: forall s. CBOR.Decoder s header
decodeHeaderWrapped = do
--TODO: replace this with decodeEmbeddedCBOR from cborg-0.2.4 once
-- it is available, since that will be faster.
tag <- CBOR.decodeTag
when (tag /= 24) $ fail "expected tag 24 (CBOR-in-CBOR)"
payload <- LBS.fromStrict <$> CBOR.decodeBytes
case CBOR.deserialiseFromBytes decodeHeader payload of
Left (CBOR.DeserialiseFailure _ reason) -> fail reason
Right (trailing, header)
| not (LBS.null trailing) -> fail "trailing bytes in CBOR-in-CBOR"
| otherwise -> return (header payload)


encodeList :: (a -> CBOR.Encoding) -> [a] -> CBOR.Encoding
encodeList _ [] = CBOR.encodeListLen 0
encodeList enc xs = CBOR.encodeListLenIndef

0 comments on commit 6b69e7b

Please sign in to comment.
You can’t perform that action at this time.