Introduce header validation as concept

ouroboros-consensus/ouroboros-consensus.cabal

@@ -42,6 +42,7 @@ library
                        Ouroboros.Consensus.ChainSyncClient
                        Ouroboros.Consensus.ChainSyncServer
                        Ouroboros.Consensus.Crypto.DSIGN.Cardano
+                       Ouroboros.Consensus.HeaderValidation
                        Ouroboros.Consensus.Ledger.Abstract
                        Ouroboros.Consensus.Ledger.Byron
                        Ouroboros.Consensus.Ledger.Byron.Block

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

@@ -25,7 +25,7 @@ module Ouroboros.Consensus.Block (
   , fromIsEBB
   ) where
 
-import           Codec.Serialise (Serialise)
+import           Codec.Serialise (Serialise (..))
 import           GHC.Generics (Generic)
 
 import           Cardano.Prelude (NoUnexpectedThunks)
@@ -123,7 +123,11 @@ class ( GetHeader blk
 data IsEBB
   = IsEBB
   | IsNotEBB
-  deriving (Eq, Show, Generic, NoUnexpectedThunks, Serialise)
+  deriving (Eq, Show, Generic, NoUnexpectedThunks)
+
+instance Serialise IsEBB where
+  encode = encode . fromIsEBB
+  decode = toIsEBB <$> decode
 
 instance Condense IsEBB where
   condense = show

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

@@ -53,6 +53,7 @@ import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime
+import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Protocol.Abstract
@@ -178,7 +179,7 @@ bracketChainSyncClient tracer ChainDbView { getIsInvalidBlock } varCandidates
 -- | State used when the intersection between the candidate and the current
 -- chain is unknown.
 data UnknownIntersectionState blk = UnknownIntersectionState
-  { ourFrag       :: !(AnchoredFragment (Header blk))
+  { ourFrag        :: !(AnchoredFragment (Header blk))
     -- ^ A view of the current chain fragment. Note that this might be
     -- temporarily out of date w.r.t. the actual current chain until we update
     -- it again.
@@ -187,10 +188,10 @@ data UnknownIntersectionState blk = UnknownIntersectionState
     -- with the candidate.
     --
     -- INVARIANT: 'ourFrag' contains @k@ headers, unless close to genesis.
-  , ourChainState :: !(ChainState (BlockProtocol blk))
-    -- ^ 'ChainState' corresponding to the tip (most recent block) of
+  , ourHeaderState :: !(HeaderState blk)
+    -- ^ 'HeaderState' corresponding to the tip (most recent block) of
     -- 'ourFrag'.
-  , ourTip        :: !(Our (Tip blk))
+  , ourTip         :: !(Our (Tip blk))
     -- ^ INVARIANT: must correspond to the tip of 'ourFrag'.
   }
   deriving (Generic)
@@ -202,12 +203,12 @@ instance ( ProtocolLedgerView blk
 -- | State used when the intersection between the candidate and the current
 -- chain is known.
 data KnownIntersectionState blk = KnownIntersectionState
-  { theirFrag       :: !(AnchoredFragment (Header blk))
+  { theirFrag        :: !(AnchoredFragment (Header blk))
     -- ^ The candidate, the synched fragment of their chain.
-  , theirChainState :: !(ChainState (BlockProtocol blk))
-    -- ^ 'ChainState' corresponding to the tip (most recent block) of
+  , theirHeaderState :: !(HeaderState blk)
+    -- ^ 'HeaderState' corresponding to the tip (most recent block) of
     -- 'theirFrag'.
-  , ourFrag         :: !(AnchoredFragment (Header blk))
+  , ourFrag          :: !(AnchoredFragment (Header blk))
     -- ^ A view of the current chain fragment used to maintain the invariants
     -- with. Note that this might be temporarily out of date w.r.t. the actual
     -- current chain until we update it again.
@@ -218,7 +219,7 @@ data KnownIntersectionState blk = KnownIntersectionState
     -- this follows that both fragments intersect. This also means that
     -- 'theirFrag' forks off within the last @k@ headers/blocks of the
     -- 'ourFrag'.
-  , ourTip          :: !(Our (Tip blk))
+  , ourTip           :: !(Our (Tip blk))
     -- ^ INVARIANT: must correspond to the tip of 'ourFrag'.
   }
   deriving (Generic)
@@ -272,9 +273,9 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
          -- ^ Exception to throw when no intersection is found.
       -> Stateful m blk () (ClientPipelinedStIdle Z)
     findIntersection mkEx = Stateful $ \() -> do
-      (ourFrag, ourChainState, ourTip) <- atomically $ (,,)
+      (ourFrag, ourHeaderState, ourTip) <- atomically $ (,,)
         <$> getCurrentChain
-        <*> (ouroborosChainState <$> getCurrentLedger)
+        <*> (headerState <$> getCurrentLedger)
         <*> (Our <$> getOurTip)
       -- We select points from the last @k@ headers of our current chain. This
       -- means that if an intersection is found for one of these points, it
@@ -285,9 +286,9 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
                         (map fromIntegral (offsets maxOffset))
                         ourFrag
           uis = UnknownIntersectionState
-            { ourFrag       = ourFrag
-            , ourChainState = ourChainState
-            , ourTip        = ourTip
+            { ourFrag        = ourFrag
+            , ourHeaderState = ourHeaderState
+            , ourTip         = ourTip
             }
       return $ SendMsgFindIntersect points $ ClientPipelinedStIntersect
         { recvMsgIntersectFound = \i theirTip' ->
@@ -307,7 +308,7 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
     intersectFound intersection theirTip
                  = Stateful $ \UnknownIntersectionState
                      { ourFrag
-                     , ourChainState
+                     , ourHeaderState
                      , ourTip = ourTip
                      } -> do
       traceWith tracer $ TraceFoundIntersection intersection ourTip theirTip
@@ -319,7 +320,7 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
         -- to fork", which means that a roll back is always followed by
         -- applying at least as many blocks that we rolled back.
         --
-        -- This is important for 'rewindChainState', which can only roll back
+        -- This is important for 'rewindHeaderState', which can only roll back
         -- up to @k@ blocks, /once/, i.e., we cannot keep rolling back the
         -- same chain state multiple times, because that would mean that we
         -- store the chain state for the /whole chain/, all the way to
@@ -329,10 +330,8 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
         -- it is followed by rolling forward again), but we need some
         -- guarantees that the ChainSync protocol /does/ in fact give us a
         -- switch-to-fork instead of a true rollback.
-        (theirFrag, theirChainState) <- do
-          let i = castPoint intersection
-          case (,) <$> AF.rollback i ourFrag
-                   <*> rewindChainState cfg ourChainState i of
+        (theirFrag, theirHeaderState) <- do
+          case attemptRollback cfg intersection (ourFrag, ourHeaderState) of
             Just (c, d) -> return (c, d)
             -- The @intersection@ is not on the candidate chain, even though
             -- we sent only points from the candidate chain to find an
@@ -345,10 +344,10 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
               }
         atomically $ writeTVar varCandidate theirFrag
         let kis = KnownIntersectionState
-              { theirFrag       = theirFrag
-              , theirChainState = theirChainState
-              , ourFrag         = ourFrag
-              , ourTip          = ourTip
+              { theirFrag        = theirFrag
+              , theirHeaderState = theirHeaderState
+              , ourFrag          = ourFrag
+              , ourTip           = ourTip
               }
         continueWithState kis $ nextStep mkPipelineDecision0 Zero theirTip
 
@@ -515,7 +514,7 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
                      (ClientPipelinedStIdle n)
     rollForward mkPipelineDecision n hdr theirTip
               = Stateful $ \kis@KnownIntersectionState
-                  { theirChainState
+                  { theirHeaderState
                   , theirFrag
                   , ourTip
                   } -> traceException $ do
@@ -551,24 +550,20 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
           , _theirTip         = theirTip
           }
 
-      theirChainState' <-
-        case runExcept $ applyChainState
-                           cfg
-                           ledgerView
-                           (validateView cfg hdr)
-                           theirChainState of
-          Right theirChainState' -> return theirChainState'
-          Left vErr              -> disconnect ChainError
-            { _newPoint           = hdrPoint
-            , _chainValidationErr = vErr
-            , _ourTip             = ourTip
-            , _theirTip           = theirTip
+      theirHeaderState' <-
+        case runExcept $ validateHeader cfg ledgerView hdr theirHeaderState of
+          Right theirHeaderState' -> return theirHeaderState'
+          Left  vErr              -> disconnect HeaderError
+            { _newPoint  = hdrPoint
+            , _headerErr = vErr
+            , _ourTip    = ourTip
+            , _theirTip  = theirTip
             }
 
       let theirFrag' = theirFrag :> hdr
           kis' = kis
-            { theirFrag       = theirFrag'
-            , theirChainState = theirChainState'
+            { theirFrag        = theirFrag'
+            , theirHeaderState = theirHeaderState'
             }
       atomically $ writeTVar varCandidate theirFrag'
 
@@ -621,13 +616,11 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
                  theirTip
                = Stateful $ \kis@KnownIntersectionState
                    { theirFrag
-                   , theirChainState
+                   , theirHeaderState
                    , ourTip
                    } -> traceException $ do
-      (theirFrag', theirChainState') <- do
-        let i = castPoint intersection
-        case (,) <$> AF.rollback i theirFrag
-                 <*> rewindChainState cfg theirChainState i of
+      (theirFrag', theirHeaderState') <- do
+        case attemptRollback cfg intersection (theirFrag, theirHeaderState) of
           Just (c, d) -> return (c,d)
           -- Remember that we use our current chain fragment as the starting
           -- point for the candidate's chain. Our fragment contained @k@
@@ -658,8 +651,8 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
             }
 
       let kis' = kis
-            { theirFrag       = theirFrag'
-            , theirChainState = theirChainState'
+            { theirFrag        = theirFrag'
+            , theirHeaderState = theirHeaderState'
             }
       atomically $ writeTVar varCandidate theirFrag'
 
@@ -705,6 +698,18 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
     k :: Word64
     k = maxRollbacks $ protocolSecurityParam cfg
 
+attemptRollback :: ( SupportedBlock blk
+                   , Serialise (HeaderHash blk)
+                   )
+                => NodeConfig (BlockProtocol blk)
+                -> Point blk
+                -> (AnchoredFragment (Header blk), HeaderState blk)
+                -> Maybe (AnchoredFragment (Header blk), HeaderState blk)
+attemptRollback cfg intersection (frag, state) = do
+    frag'  <- AF.rollback (castPoint intersection) frag
+    state' <- rewindHeaderState cfg  intersection state
+    return (frag', state')
+
 -- | Watch the invalid block checker function for changes (using its
 -- fingerprint). Whenever it changes, i.e., a new invalid block is detected,
 -- check whether the current candidate fragment contains any header that is
@@ -799,13 +804,13 @@ data ChainSyncClientException =
         , _theirTip     :: Their (Tip blk)
         }
 
-      -- | The chain validation threw an error.
+      -- | Header validation threw an error.
     | forall blk. SupportedBlock blk =>
-        ChainError
-        { _newPoint           :: Point blk
-        , _chainValidationErr :: ValidationErr (BlockProtocol blk)
-        , _ourTip             :: Our   (Tip blk)
-        , _theirTip           :: Their (Tip blk)
+        HeaderError
+        { _newPoint  :: Point       blk
+        , _headerErr :: HeaderError blk
+        , _ourTip    :: Our    (Tip blk)
+        , _theirTip  :: Their  (Tip blk)
         }
 
       -- | The upstream node rolled forward to a point too far in our past.
@@ -882,11 +887,11 @@ instance Eq ChainSyncClientException where
       Just Refl -> (a, b, c) == (a', b', c')
   ForkTooDeep{} == _ = False
 
-  ChainError (a :: Point blk) b c d == ChainError (a' :: Point blk') b' c' d' =
+  HeaderError (a :: Point blk) b c d == HeaderError (a' :: Point blk') b' c' d' =
     case eqT @blk @blk' of
       Nothing   -> False
       Just Refl -> (a, b, c, d) == (a', b', c', d')
-  ChainError{} == _ = False
+  HeaderError{} == _ = False
 
   InvalidRollForward (a :: Point blk) b c == InvalidRollForward (a' :: Point blk') b' c' =
     case eqT @blk @blk' of