Improve nodeBlockFetchSize estimates and test them

Fixes #2480.

Return the block size instead of the body size for Shelley.

Take CBOR-in-CBOR and the EBB tag into account for Byron.

Include a test in the serialisation roundtrip test skeleton.

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Block.hs

@@ -146,12 +146,14 @@ instance GetHeader ByronBlock where
         byronHeaderRaw           = CC.abobHdrFromBlock byronBlockRaw
       , byronHeaderSlotNo        = byronBlockSlotNo
       , byronHeaderHash          = byronBlockHash
-      , byronHeaderBlockSizeHint = fromIntegral . Strict.length $
+      , byronHeaderBlockSizeHint = (+ overhead) . fromIntegral . Strict.length $
           -- For some reason regular blocks lack a 'Decoded' instance
           case byronBlockRaw of
             CC.ABOBBlock    blk -> CC.blockAnnotation blk
             CC.ABOBBoundary blk -> recoverBytes       blk
       }
+    where
+      overhead = 5 {- CBOR-in-CBOR -} + 2 {- EBB tag -}
 
   -- Check if a block matches its header
   --

ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Serialisation.hs

@@ -15,6 +15,7 @@ import           Ouroboros.Consensus.Storage.Common (BinaryBlockInfo (..))
 import           Ouroboros.Consensus.Util (Dict (..))
 
 import           Ouroboros.Consensus.Shelley.Ledger
+import           Ouroboros.Consensus.Shelley.Node ()
 import           Ouroboros.Consensus.Shelley.Node.Serialisation ()
 
 import           Test.Tasty

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs

@@ -345,7 +345,11 @@ instance ConfigSupportsNode (ShelleyBlock c) where
 -------------------------------------------------------------------------------}
 
 instance TPraosCrypto c => RunNode (ShelleyBlock c) where
-  nodeBlockFetchSize = fromIntegral . SL.bsize . SL.bhbody . shelleyHeaderRaw
+  nodeBlockFetchSize hdr = overhead + headerSize + bodySize
+    where
+      overhead   = 5 {- CBOR-in-CBOR -} + 1 {- encodeListLen -}
+      bodySize   = fromIntegral . SL.bsize . SL.bhbody . shelleyHeaderRaw $ hdr
+      headerSize = fromIntegral . SL.bHeaderSize . shelleyHeaderRaw $ hdr
 
   -- We fix the chunk size to 10k
   nodeImmDbChunkInfo =

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs

@@ -112,8 +112,19 @@ data SimpleBlock' c ext ext' = SimpleBlock {
       simpleHeader :: Header (SimpleBlock' c ext ext')
     , simpleBody   :: SimpleBody
     }
-  deriving stock    (Generic, Show, Eq)
-  deriving anyclass (Serialise)
+  deriving (Generic, Show, Eq)
+
+instance (SimpleCrypto c, Serialise ext') => Serialise (SimpleBlock' c ext ext') where
+  encode (SimpleBlock hdr body) = mconcat [
+        CBOR.encodeListLen 2
+      , encode hdr
+      , encode body
+      ]
+  decode = do
+      CBOR.decodeListLenOf 2
+      hdr  <- decode
+      body <- decode
+      return (SimpleBlock hdr body)
 
 instance (Typeable c, Typeable ext, Typeable ext')
     => ShowProxy (SimpleBlock' c ext ext') where
@@ -151,20 +162,23 @@ instance (SimpleCrypto c, Typeable ext, Typeable ext')
   headerIsEBB = const Nothing
 
 data SimpleStdHeader c ext = SimpleStdHeader {
-      simplePrev      :: ChainHash (SimpleBlock c ext)
-    , simpleSlotNo    :: SlotNo
-    , simpleBlockNo   :: BlockNo
-    , simpleBodyHash  :: Hash (SimpleHash c) SimpleBody
-    , simpleBlockSize :: Word64
+      simplePrev     :: ChainHash (SimpleBlock c ext)
+    , simpleSlotNo   :: SlotNo
+    , simpleBlockNo  :: BlockNo
+    , simpleBodyHash :: Hash (SimpleHash c) SimpleBody
+    , simpleBodySize :: Word32
     }
   deriving stock    (Generic, Show, Eq)
   deriving anyclass (Serialise, NoUnexpectedThunks)
 
 data SimpleBody = SimpleBody {
       simpleTxs :: [Mock.Tx]
     }
-  deriving stock    (Generic, Show, Eq)
-  deriving anyclass (Serialise)
+  deriving (Generic, Show, Eq)
+
+instance Serialise SimpleBody where
+  encode (SimpleBody txs) = encode txs
+  decode = SimpleBody <$> decode
 
 {-------------------------------------------------------------------------------
   Working with 'SimpleBlock'
@@ -565,6 +579,6 @@ simpleBlockBinaryBlockInfo ::
      (SimpleCrypto c, Serialise ext', Typeable ext, Typeable ext')
   => SimpleBlock' c ext ext' -> BinaryBlockInfo
 simpleBlockBinaryBlockInfo b = BinaryBlockInfo
-    { headerOffset = 2 -- For the 'encodeListLen'
+    { headerOffset = 1 -- For the 'encodeListLen'
     , headerSize   = fromIntegral $ Lazy.length $ serialise (getHeader b)
     }

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Forge.hs

@@ -59,15 +59,12 @@ forgeSimple ForgeExt { forgeExt } cfg forgeState curBlock curSlot tickedLedger t
 
     stdHeader :: SimpleStdHeader c ext
     stdHeader = SimpleStdHeader {
-          simplePrev      = castHash $ getTipHash tickedLedger
-        , simpleSlotNo    = curSlot
-        , simpleBlockNo   = curBlock
-        , simpleBodyHash  = hashWithSerialiser toCBOR body
-        , simpleBlockSize = bodySize
+          simplePrev     = castHash $ getTipHash tickedLedger
+        , simpleSlotNo   = curSlot
+        , simpleBlockNo  = curBlock
+        , simpleBodyHash = hashWithSerialiser toCBOR body
+        , simpleBodySize = bodySize
         }
 
-    -- We use the size of the body, not of the whole block (= header + body),
-    -- since the header size is fixed and this size is only used for
-    -- prioritisation.
-    bodySize :: Word64
+    bodySize :: Word32
     bodySize = fromIntegral $ Lazy.length $ serialise body

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node.hs

@@ -10,7 +10,8 @@ module Ouroboros.Consensus.Mock.Node (
     CodecConfig (..)
   ) where
 
-import           Codec.Serialise (Serialise)
+import           Codec.Serialise (Serialise, serialise)
+import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.Map.Strict as Map
 import           Data.Typeable (Typeable)
 
@@ -46,7 +47,13 @@ instance ( LedgerSupportsProtocol (SimpleBlock SimpleMockCrypto ext)
          , Serialise ext
          , RunMockBlock SimpleMockCrypto ext
          ) => RunNode (SimpleBlock SimpleMockCrypto ext) where
-  nodeBlockFetchSize        = fromIntegral . simpleBlockSize . simpleHeaderStd
-  nodeImmDbChunkInfo        = \cfg -> simpleChunkInfo $
-    EpochSize $ 10 * maxRollbacks (configSecurityParam cfg)
-  nodeCheckIntegrity        = \_ _ -> True
+  nodeBlockFetchSize hdr =
+      5 {- CBOR-in-CBOR -} + 1 {- encodeListLen 2 -} + hdrSize + bodySize
+    where
+      hdrSize  = fromIntegral (Lazy.length (serialise hdr))
+      bodySize = simpleBodySize (simpleHeaderStd hdr)
+
+  nodeImmDbChunkInfo = \cfg -> simpleChunkInfo $
+      EpochSize $ 10 * maxRollbacks (configSecurityParam cfg)
+
+  nodeCheckIntegrity = \_ _ -> True

ouroboros-consensus/ouroboros-consensus-mock/test/Test/Consensus/Ledger/Mock/Generators.hs

@@ -12,9 +12,10 @@
 
 module Test.Consensus.Ledger.Mock.Generators () where
 
-import           Codec.Serialise (Serialise, encode)
+import           Codec.Serialise (Serialise, encode, serialise)
 import           Control.Monad
 import qualified Data.ByteString as Strict
+import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import           Data.Typeable
@@ -63,18 +64,23 @@ instance Arbitrary (HeaderHash blk) => Arbitrary (Point blk) where
 -- These generators blindly create random values, so the block will not be
 -- valid, but this does not matter for serialisation tests.
 
-instance (HashAlgorithm (SimpleHash c), Arbitrary ext, Serialise ext)
+instance (SimpleCrypto c, Arbitrary ext, Serialise ext)
       => Arbitrary (SimpleBlock c ext) where
-  arbitrary = SimpleBlock <$> arbitrary <*> arbitrary
-
-instance (HashAlgorithm (SimpleHash c), Arbitrary ext, Serialise ext)
-      => Arbitrary (Header (SimpleBlock c ext)) where
   arbitrary = do
     simpleStdHeader <- arbitrary
-    ext <- arbitrary
-    let hdr     = SimpleHeader hdrHash simpleStdHeader ext
-        hdrHash = hashWithSerialiser (encodeSimpleHeader encode) hdr
-    return hdr
+    body            <- arbitrary
+    ext             <- arbitrary
+    let simpleStdHeader' = simpleStdHeader {
+            -- Fill in the right body size, because we rely on this in the
+            -- serialisation tests
+            simpleBodySize = fromIntegral $ Lazy.length $ serialise body
+          }
+        hdr = mkSimpleHeader encode simpleStdHeader' ext
+    return $ SimpleBlock hdr body
+
+instance (SimpleCrypto c, Arbitrary ext, Serialise ext, Typeable ext)
+      => Arbitrary (Header (SimpleBlock c ext)) where
+  arbitrary = getHeader <$> arbitrary
 
 instance (HashAlgorithm (SimpleHash c), Arbitrary ext, Serialise ext)
       => Arbitrary (SimpleStdHeader c ext) where

ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/Serialisation/Roundtrip.hs

@@ -46,7 +46,8 @@ import           Ouroboros.Consensus.Ledger.Abstract (LedgerState, Query)
 import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx,
                      GenTxId)
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
-import           Ouroboros.Consensus.Node.Run (SerialiseNodeToClientConstraints,
+import           Ouroboros.Consensus.Node.Run (RunNode (..),
+                     SerialiseNodeToClientConstraints,
                      SerialiseNodeToNodeConstraints)
 import           Ouroboros.Consensus.Node.Serialisation
 import           Ouroboros.Consensus.Protocol.Abstract (ChainDepState)
@@ -105,14 +106,7 @@ type Arbitrary' a = (Arbitrary a, Eq a, Show a)
 -- (real crypto) to Shelley (mock crypto) has differently sized hashes.
 roundtrip_all
   :: forall blk.
-     ( StandardHash blk
-
-     , SerialiseDiskConstraints blk
-     , SerialiseNodeToNodeConstraints blk
-     , SerialiseNodeToClientConstraints blk
-
-     , Show (BlockNodeToNodeVersion blk)
-     , Show (BlockNodeToClientVersion blk)
+     ( RunNode blk
 
      , Arbitrary' blk
      , Arbitrary' (Header blk)
@@ -143,6 +137,7 @@ roundtrip_all ccfg dictNestedHdr =
       , testGroup "SerialiseNodeToClient" $ roundtrip_SerialiseNodeToClient ccfg
       , testProperty "envelopes"          $ roundtrip_envelopes             ccfg
       , testProperty "ConvertRawHash"     $ roundtrip_ConvertRawHash        (Proxy @blk)
+      , testProperty "nodeBlockFetchSize" $ prop_nodeBlockFetchSize         ccfg
       ]
 
 -- TODO how can we ensure that we have a test for each constraint listed in
@@ -429,6 +424,51 @@ prop_hashSize
 prop_hashSize p h =
     hashSize p === fromIntegral (Short.length (toShortRawHash p h))
 
+{-------------------------------------------------------------------------------
+  nodeBlockFetchSize
+-------------------------------------------------------------------------------}
+
+prop_nodeBlockFetchSize ::
+     RunNode blk
+  => CodecConfig blk
+  -> WithVersion (BlockNodeToNodeVersion blk) blk
+  -> Property
+prop_nodeBlockFetchSize ccfg (WithVersion version blk)
+  | actualBlockSize > expectedBlockSize
+  = counterexample
+      ("actualBlockSize > expectedBlockSize: "
+         <> show actualBlockSize <> " > "
+         <> show expectedBlockSize)
+      (property False)
+  | actualBlockSize < expectedBlockSize - allowedUnderestimate
+  = counterexample
+      ("actualBlockSize < expectedBlockSize - allowedUnderestimate: "
+         <> show actualBlockSize <> " > "
+         <> show expectedBlockSize <> " - "
+         <> show allowedUnderestimate)
+      (property False)
+  | otherwise
+  = classify (actualBlockSize == expectedBlockSize) "exact"
+  $ classify (actualBlockSize <  expectedBlockSize) "underestimate"
+  $ property True
+  where
+    allowedUnderestimate :: SizeInBytes
+    allowedUnderestimate = 10
+
+    actualBlockSize :: SizeInBytes
+    actualBlockSize =
+          fromIntegral
+        . Lazy.length
+        . toLazyByteString
+        . encodeNodeToNode ccfg version
+        $ blk
+
+    expectedBlockSize :: SizeInBytes
+    expectedBlockSize =
+          nodeBlockFetchSize
+        . getHeader
+        $ blk
+
 {-------------------------------------------------------------------------------
   Serialised helpers
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/Ouroboros/Consensus/Node/Run.hs

@@ -91,6 +91,12 @@ class ( LedgerSupportsProtocol           blk
       , ShowProxy                        (Query blk)
       , ShowProxy                        (TxId (GenTx blk))
       ) => RunNode blk where
+  -- | An upper bound the size in bytes of the block corresponding to the
+  -- header. This can be an overestimate, but not an underestimate.
+  --
+  -- The block fetch client uses this to estimate how bytes will be in flight.
+  -- This is also used to limit the number of bytes accepted when downloading
+  -- a block.
   nodeBlockFetchSize      :: Header blk -> SizeInBytes
 
   nodeImmDbChunkInfo      :: TopLevelConfig blk -> ChunkInfo