Allow allow EBBs when we expect them

Closes #1620

ouroboros-consensus/ouroboros-consensus.cabal

@@ -51,6 +51,7 @@ library
                        Ouroboros.Consensus.Ledger.Byron.Conversions
                        Ouroboros.Consensus.Ledger.Byron.DelegationHistory
                        Ouroboros.Consensus.Ledger.Byron.Forge
+                       Ouroboros.Consensus.Ledger.Byron.HeaderValidation
                        Ouroboros.Consensus.Ledger.Byron.Integrity
                        Ouroboros.Consensus.Ledger.Byron.Ledger
                        Ouroboros.Consensus.Ledger.Byron.Mempool

ouroboros-consensus/src/Ouroboros/Consensus/HeaderValidation.hs

@@ -50,6 +50,7 @@ import           Data.Foldable (toList)
 import           Data.Proxy
 import           Data.Sequence.Strict (StrictSeq ((:<|), (:|>), Empty))
 import qualified Data.Sequence.Strict as Seq
+import           Data.Text (Text)
 import           GHC.Generics (Generic)
 
 import           Cardano.Binary (enforceSize)
@@ -225,6 +226,12 @@ data HeaderEnvelopeError blk =
     --
     -- We record both the expected and actual hash
   | UnexpectedPrevHash !(ChainHash blk) !(ChainHash blk)
+
+    -- | Block specific envelope error
+    --
+    -- We record this simply as Text to avoid yet another type family;
+    -- we can't really pattern match on this anyway.
+  | OtherEnvelopeError !Text
   deriving (Generic)
 
 deriving instance SupportedBlock blk => Eq                 (HeaderEnvelopeError blk)
@@ -234,6 +241,7 @@ deriving instance SupportedBlock blk => NoUnexpectedThunks (HeaderEnvelopeError
 castHeaderEnvelopeError :: HeaderHash blk ~ HeaderHash blk'
                         => HeaderEnvelopeError blk -> HeaderEnvelopeError blk'
 castHeaderEnvelopeError = \case
+    OtherEnvelopeError err             -> OtherEnvelopeError err
     UnexpectedBlockNo  expected actual -> UnexpectedBlockNo  expected  actual
     UnexpectedSlotNo   expected actual -> UnexpectedSlotNo   expected  actual
     UnexpectedPrevHash expected actual -> UnexpectedPrevHash expected' actual'

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

@@ -14,6 +14,7 @@ import           Ouroboros.Consensus.Ledger.Byron.ContainsGenesis as X
 import           Ouroboros.Consensus.Ledger.Byron.DelegationHistory as X
                      (DelegationHistory)
 import           Ouroboros.Consensus.Ledger.Byron.Forge as X
+import           Ouroboros.Consensus.Ledger.Byron.HeaderValidation as X ()
 import           Ouroboros.Consensus.Ledger.Byron.Integrity as X
 import           Ouroboros.Consensus.Ledger.Byron.Ledger as X
 import           Ouroboros.Consensus.Ledger.Byron.Mempool as X

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

@@ -79,6 +79,7 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Byron.Conversions
 import           Ouroboros.Consensus.Ledger.Byron.Orphans ()
+import           Ouroboros.Consensus.Protocol.ExtConfig
 import           Ouroboros.Consensus.Util.Condense
 
 import           Ouroboros.Storage.ImmutableDB (BinaryInfo (..), HashInfo (..))
@@ -254,56 +255,6 @@ byronHeaderIsEBB = go . byronHeaderRaw
 byronBlockIsEBB :: ByronBlock -> IsEBB
 byronBlockIsEBB = byronHeaderIsEBB . getHeader
 
-{-------------------------------------------------------------------------------
-  Envelope
--------------------------------------------------------------------------------}
-
-instance HasAnnTip ByronBlock where
-  type TipInfo ByronBlock = IsEBB
-  getTipInfo = byronHeaderIsEBB
-
-instance ValidateEnvelope ByronBlock where
-  validateEnvelope _cfg oldTip hdr = do
-      when (actualBlockNo /= expectedBlockNo) $
-        throwError $ UnexpectedBlockNo expectedBlockNo actualBlockNo
-      when (actualSlotNo < expectedSlotNo) $
-        throwError $ UnexpectedSlotNo expectedSlotNo actualSlotNo
-      when (actualPrevHash /= expectedPrevHash) $
-        throwError $ UnexpectedPrevHash expectedPrevHash actualPrevHash
-    where
-      newIsEBB :: IsEBB
-      newIsEBB = byronHeaderIsEBB hdr
-
-      actualSlotNo   :: SlotNo
-      actualBlockNo  :: BlockNo
-      actualPrevHash :: ChainHash ByronBlock
-
-      actualSlotNo   =            blockSlot     hdr
-      actualBlockNo  =            blockNo       hdr
-      actualPrevHash = castHash $ blockPrevHash hdr
-
-      expectedSlotNo   :: SlotNo           -- Lower bound only
-      expectedBlockNo  :: BlockNo
-      expectedPrevHash :: ChainHash ByronBlock
-
-      (expectedSlotNo, expectedBlockNo, expectedPrevHash) = (
-            nextSlotNo  ((annTipInfo &&& annTipSlotNo)  <$> oldTip) newIsEBB
-          , nextBlockNo ((annTipInfo &&& annTipBlockNo) <$> oldTip) newIsEBB
-          , withOrigin GenesisHash (BlockHash . annTipHash) oldTip
-          )
-
-      -- EBB shares its slot number with its successor
-      nextSlotNo :: WithOrigin (IsEBB, SlotNo) -> IsEBB -> SlotNo
-      nextSlotNo Origin          _        = SlotNo 0
-      nextSlotNo (At (IsEBB, s)) IsNotEBB = s
-      nextSlotNo (At (_    , s)) _        = succ s
-
-      -- EBB shares its block number with its predecessor
-      nextBlockNo :: WithOrigin (IsEBB, BlockNo) -> IsEBB -> BlockNo
-      nextBlockNo Origin             _     = BlockNo 0
-      nextBlockNo (At (IsNotEBB, b)) IsEBB = b
-      nextBlockNo (At (_       , b)) _     = succ b
-
 {-------------------------------------------------------------------------------
   Serialisation
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/HeaderValidation.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Ouroboros.Consensus.Ledger.Byron.HeaderValidation () where
+
+import           Control.Arrow ((&&&))
+import           Control.Monad.Except
+import qualified Data.Text as T
+import           Data.Word
+
+import           Cardano.Slotting.Slot (WithOrigin (..), withOrigin)
+
+import qualified Cardano.Chain.Slotting as CC
+
+import           Ouroboros.Network.Block
+
+import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.HeaderValidation
+import           Ouroboros.Consensus.Ledger.Byron.Block
+import           Ouroboros.Consensus.Ledger.Byron.Config
+import           Ouroboros.Consensus.Ledger.Byron.Orphans ()
+import           Ouroboros.Consensus.Ledger.Byron.PBFT ()
+import           Ouroboros.Consensus.Protocol.ExtConfig
+
+{-------------------------------------------------------------------------------
+  Envelope
+-------------------------------------------------------------------------------}
+
+instance HasAnnTip ByronBlock where
+  type TipInfo ByronBlock = IsEBB
+  getTipInfo = byronHeaderIsEBB
+
+instance ValidateEnvelope ByronBlock where
+  validateEnvelope cfg oldTip hdr = do
+      when (actualBlockNo /= expectedBlockNo) $
+        throwError $ UnexpectedBlockNo expectedBlockNo actualBlockNo
+      when (actualSlotNo < expectedSlotNo) $
+        throwError $ UnexpectedSlotNo expectedSlotNo actualSlotNo
+      when (actualPrevHash /= expectedPrevHash) $
+        throwError $ UnexpectedPrevHash expectedPrevHash actualPrevHash
+      when (fromIsEBB newIsEBB && not (canBeEBB actualSlotNo)) $
+        throwError $ OtherEnvelopeError . T.pack $
+          "Unexpected EBB in slot " ++ show actualSlotNo
+    where
+      newIsEBB :: IsEBB
+      newIsEBB = byronHeaderIsEBB hdr
+
+      actualSlotNo   :: SlotNo
+      actualBlockNo  :: BlockNo
+      actualPrevHash :: ChainHash ByronBlock
+
+      actualSlotNo   =            blockSlot     hdr
+      actualBlockNo  =            blockNo       hdr
+      actualPrevHash = castHash $ blockPrevHash hdr
+
+      expectedSlotNo   :: SlotNo           -- Lower bound only
+      expectedBlockNo  :: BlockNo
+      expectedPrevHash :: ChainHash ByronBlock
+
+      (expectedSlotNo, expectedBlockNo, expectedPrevHash) = (
+            nextSlotNo  ((annTipInfo &&& annTipSlotNo)  <$> oldTip) newIsEBB
+          , nextBlockNo ((annTipInfo &&& annTipBlockNo) <$> oldTip) newIsEBB
+          , withOrigin GenesisHash (BlockHash . annTipHash) oldTip
+          )
+
+      -- EBB shares its slot number with its successor
+      nextSlotNo :: WithOrigin (IsEBB, SlotNo) -> IsEBB -> SlotNo
+      nextSlotNo Origin          _        = SlotNo 0
+      nextSlotNo (At (IsEBB, s)) IsNotEBB = s
+      nextSlotNo (At (_    , s)) _        = succ s
+
+      -- EBB shares its block number with its predecessor
+      nextBlockNo :: WithOrigin (IsEBB, BlockNo) -> IsEBB -> BlockNo
+      nextBlockNo Origin             _     = BlockNo 0
+      nextBlockNo (At (IsNotEBB, b)) IsEBB = b
+      nextBlockNo (At (_       , b)) _     = succ b
+
+      canBeEBB :: SlotNo -> Bool
+      canBeEBB (SlotNo s) = s `mod` epochSlots == 0
+
+      epochSlots :: Word64
+      epochSlots = CC.unEpochSlots $ pbftEpochSlots $ extNodeConfig cfg

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

@@ -61,6 +61,7 @@ import           Ouroboros.Consensus.Ledger.Byron.Conversions
 import           Ouroboros.Consensus.Ledger.Byron.DelegationHistory
                      (DelegationHistory)
 import qualified Ouroboros.Consensus.Ledger.Byron.DelegationHistory as History
+import           Ouroboros.Consensus.Ledger.Byron.HeaderValidation ()
 import           Ouroboros.Consensus.Ledger.Byron.PBFT
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Protocol.ExtConfig