Catch all exceptions while pushing a block to the ledger db

ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/General.hs

@@ -48,7 +48,7 @@ import           Ouroboros.Network.Point (WithOrigin (..))
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.Config.SecurityParam
-import           Ouroboros.Consensus.Ledger.Extended (ExtValidationError)
+import           Ouroboros.Consensus.Ledger.Extended (SomeExtValidationError)
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Node.Run
 import           Ouroboros.Consensus.NodeId
@@ -252,7 +252,7 @@ runTestNetwork TestConfig
 data BlockRejection blk = BlockRejection
   { brBlockHash :: !(HeaderHash blk)
   , brBlockSlot :: !SlotNo
-  , brReason    :: !(ExtValidationError blk)
+  , brReason    :: !(SomeExtValidationError blk)
   , brRejector  :: !NodeId
   }
   deriving (Show)

ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Network.hs

@@ -571,7 +571,7 @@ runThreadNetwork ThreadNetworkArgs
            -> ResourceRegistry m
            -> TopLevelConfig blk
            -> ExtLedgerState blk
-           -> Tracer m (RealPoint blk, ExtValidationError blk)
+           -> Tracer m (RealPoint blk, SomeExtValidationError blk)
               -- ^ invalid block tracer
            -> Tracer m (RealPoint blk, BlockNo)
               -- ^ added block tracer
@@ -1075,7 +1075,7 @@ data NodeEvents blk ev = NodeEvents
     -- ^ every 'AddedBlockToVolDB' excluding EBBs
   , nodeEventsForges      :: ev (TraceForgeEvent blk)
     -- ^ every 'TraceForgeEvent'
-  , nodeEventsInvalids    :: ev (RealPoint blk, ExtValidationError blk)
+  , nodeEventsInvalids    :: ev (RealPoint blk, SomeExtValidationError blk)
     -- ^ the point of every 'ChainDB.InvalidBlock' event
   , nodeEventsTipBlockNos :: ev (SlotNo, WithOrigin BlockNo)
     -- ^ 'ChainDB.getTipBlockNo' for each node at the onset of each slot
@@ -1136,7 +1136,7 @@ data NodeOutput blk = NodeOutput
   , nodeOutputFinalChain  :: Chain blk
   , nodeOutputFinalLedger :: LedgerState blk
   , nodeOutputForges      :: Map SlotNo blk
-  , nodeOutputInvalids    :: Map (RealPoint blk) [ExtValidationError blk]
+  , nodeOutputInvalids    :: Map (RealPoint blk) [SomeExtValidationError blk]
   , nodeOutputNodeDBs     :: NodeDBs MockFS
   }
 

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

@@ -16,6 +16,7 @@ module Ouroboros.Consensus.Ledger.Extended (
     -- * Extended ledger state
     ExtLedgerState(..)
   , ExtValidationError(..)
+  , SomeExtValidationError
     -- * Serialisation
   , encodeExtLedgerState
   , decodeExtLedgerState
@@ -41,6 +42,7 @@ import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Protocol.Abstract
+import           Ouroboros.Consensus.Storage.LedgerDB.InMemory
 
 {-------------------------------------------------------------------------------
   Extended ledger state
@@ -60,6 +62,10 @@ data ExtValidationError blk =
   | ExtValidationErrorHeader !(HeaderError blk)
   deriving (Generic)
 
+-- This can be either `ExtValidationError` or other unknown errors we catch at
+-- monadic code.
+type SomeExtValidationError blk = SomePushLedgerError (ExtLedgerState blk)
+
 instance LedgerSupportsProtocol blk => NoUnexpectedThunks (ExtValidationError blk)
 
 deriving instance LedgerSupportsProtocol blk => Show (ExtLedgerState     blk)

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/API.hs

@@ -689,7 +689,7 @@ getPastLedger chainDB pt = do
 
 -- | The reason why a block is invalid.
 data InvalidBlockReason blk
-  = ValidationError !(ExtValidationError blk)
+  = ValidationError !(SomeExtValidationError blk)
     -- ^ The ledger found the block to be invalid.
   | InFutureExceedsClockSkew !(RealPoint blk)
     -- ^ The block's slot is in the future, exceeding the allowed clock skew.

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs

@@ -936,7 +936,7 @@ ledgerValidateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) =
         -- to the immutable tip.
         error "found candidate requiring rolling back past the immutable tip"
 
-      LgrDB.ValidateLedgerError (LgrDB.AnnLedgerError ledger' pt e) -> do
+      LgrDB.ValidateLedgerError (LgrDB.AnnLedgerPushError ledger' pt e) -> do
         let lastValid = LgrDB.currentPoint ledger'
         trace (InvalidBlock e pt)
         addInvalidBlock e pt
@@ -963,7 +963,8 @@ ledgerValidateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) =
     newBlocks = AF.toOldestFirst suffix
 
     -- | Record the invalid block in 'cdbInvalid' and change its fingerprint.
-    addInvalidBlock :: ExtValidationError blk -> RealPoint blk -> m ()
+    addInvalidBlock :: SomeExtValidationError blk
+                    -> RealPoint blk -> m ()
     addInvalidBlock e (RealPoint slot hash) = atomically $
       modifyTVar varInvalid $ \(WithFingerprint invalid fp) ->
         WithFingerprint

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs

@@ -43,7 +43,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB (
   , garbageCollectPrevApplied
     -- * Re-exports
   , ExceededRollback(..)
-  , LedgerDB.AnnLedgerError(..)
+  , LedgerDB.AnnLedgerPushError(..)
   , LedgerDbParams(..)
   , DiskPolicy (..)
   , DiskSnapshot
@@ -161,7 +161,7 @@ data LgrDbArgs m blk = forall h. Eq h => LgrDbArgs {
     , lgrParams         :: LedgerDbParams
     , lgrDiskPolicy     :: DiskPolicy
     , lgrGenesis        :: m (ExtLedgerState blk)
-    , lgrTracer         :: Tracer m (TraceEvent (RealPoint blk))
+    , lgrTracer         :: Tracer m (TraceEvent (ExtLedgerState blk) (RealPoint blk))
     , lgrTraceLedger    :: Tracer m (LedgerDB blk)
     }
   deriving NoUnexpectedThunks via OnlyCheckIsWHNF "LgrDbArgs" (LgrDbArgs m blk)
@@ -374,7 +374,11 @@ getDiskPolicy LgrDB{ args = LgrDbArgs{..} } = lgrDiskPolicy
   Validation
 -------------------------------------------------------------------------------}
 
-type AnnLedgerError blk = LedgerDB.AnnLedgerError
+type AnnLedgerError blk = LedgerDB.AnnLedgerPushError
+                             (ExtLedgerState blk)
+                             (RealPoint      blk)
+
+type SwitchLedgerError blk = LedgerDB.SomeSwitchLedgerError
                              (ExtLedgerState blk)
                              (RealPoint      blk)
 
@@ -404,21 +408,19 @@ validate LgrDB{..} ledgerDB blockCache numRollbacks = \hdrs -> do
       addPoints (validBlockPoints res (map headerRealPoint hdrs))
     return res
   where
-    rewrap :: Either (AnnLedgerError blk) (Either ExceededRollback (LedgerDB blk))
+    rewrap :: Either (SwitchLedgerError blk) (LedgerDB blk)
            -> ValidateResult blk
-    rewrap (Left         e)  = ValidateLedgerError      e
-    rewrap (Right (Left  e)) = ValidateExceededRollBack e
-    rewrap (Right (Right l)) = ValidateSuccessful       l
+    rewrap (Left (LedgerDB.SomePushError e)) = ValidateLedgerError      e
+    rewrap (Left (LedgerDB.RollbackError e)) = ValidateExceededRollBack e
+    rewrap (Right                         l) = ValidateSuccessful       l
 
     mkAps :: forall n r l b. (
                r ~ RealPoint      blk
-             , l ~ ExtLedgerState blk
              , b ~                blk
              )
           => [Header blk]
           -> Set r
           -> [Ap n l r b ( LedgerDB.ResolvesBlocks r b n
-                         , LedgerDB.ThrowsLedgerError l r n
                          )]
     mkAps hdrs prevApplied =
       [ case ( Set.member (headerRealPoint hdr) prevApplied
@@ -448,9 +450,9 @@ validate LgrDB{..} ledgerDB blockCache numRollbacks = \hdrs -> do
 -------------------------------------------------------------------------------}
 
 streamAPI
-  :: forall m blk.
+  :: forall m blk e.
      (IOLike m, HasHeader blk, ImmDbSerialiseConstraints blk)
-  => ImmDB m blk -> StreamAPI m (RealPoint blk) blk
+  => ImmDB m blk -> StreamAPI m (RealPoint blk) blk e
 streamAPI immDB = StreamAPI streamAfter
   where
     streamAfter :: HasCallStack

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs

@@ -83,7 +83,8 @@ import           Ouroboros.Network.Point (WithOrigin)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Fragment.InFuture (CheckInFuture)
-import           Ouroboros.Consensus.Ledger.Extended (ExtValidationError)
+import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState,
+                     SomeExtValidationError)
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Util.IOLike
 import           Ouroboros.Consensus.Util.ResourceRegistry
@@ -480,7 +481,7 @@ data TraceEvent blk
   | TraceInitChainSelEvent (TraceInitChainSelEvent       blk)
   | TraceOpenEvent         (TraceOpenEvent               blk)
   | TraceIteratorEvent     (TraceIteratorEvent           blk)
-  | TraceLedgerEvent       (LgrDB.TraceEvent (RealPoint  blk))
+  | TraceLedgerEvent       (LgrDB.TraceEvent (ExtLedgerState blk) (RealPoint  blk))
   | TraceLedgerReplayEvent (LgrDB.TraceLedgerReplayEvent blk)
   | TraceImmDBEvent        (ImmDB.TraceEvent             blk)
   | TraceVolDBEvent        (VolDB.TraceEvent             blk)
@@ -627,7 +628,7 @@ deriving instance
 data TraceValidationEvent blk =
     -- | A point was found to be invalid.
     InvalidBlock
-      (ExtValidationError blk)
+      (SomeExtValidationError blk)
       (RealPoint blk)
 
     -- | A candidate chain was invalid.