diff --git a/ouroboros-consensus-cardano-tools/src/Cardano/Api/Protocol/Types.hs b/ouroboros-consensus-cardano-tools/src/Cardano/Api/Protocol/Types.hs index bd28fe05c33..cb108fb770d 100644 --- a/ouroboros-consensus-cardano-tools/src/Cardano/Api/Protocol/Types.hs +++ b/ouroboros-consensus-cardano-tools/src/Cardano/Api/Protocol/Types.hs @@ -19,7 +19,7 @@ module Cardano.Api.Protocol.Types ( , ProtocolInfoArgs (..) ) where -import Data.Bifunctor (bimap, first) +import Data.Bifunctor (bimap) import Cardano.Chain.Slotting (EpochSlots) diff --git a/ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBSynthesizer/Forging.hs index f90eebb4c94..d843bdb90ac 100644 --- a/ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBSynthesizer/Forging.hs @@ -174,10 +174,9 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg = do -- Add the block to the chain DB (synchronously) and verify adoption let noPunish = InvalidBlockPunishment.noPunishment result <- lift $ ChainDB.addBlockAsync chainDB noPunish newBlock - curTip <- lift $ atomically $ ChainDB.blockProcessed result - - when (curTip /= blockPoint newBlock) $ - exitEarly' "block not adopted" + mbCurTip <- lift $ atomically $ ChainDB.blockProcessed result + when (mbCurTip /= Just (blockPoint newBlock)) $ + exitEarly' "block not adopted" -- | Context required to forge a block data BlockContext blk = BlockContext diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs index 03e464d0f45..d953bf187eb 100644 --- a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -569,7 +569,7 @@ addBlockPromise cfg blk m = (result, m') && Map.member (blockHash blk) (blocks m') result = AddBlockPromise { blockWrittenToDisk = return blockWritten - , blockProcessed = return $ tipPoint m' + , blockProcessed = return $ Just $ tipPoint m' } {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index e6c8aec7e66..93d74b9ff8f 100644 --- a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -35,7 +35,7 @@ import Data.Functor.Identity (Identity) import Data.List (sortOn) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromJust, fromMaybe) import Data.Ord (Down (..)) import Data.Proxy import Data.Sequence.Strict (StrictSeq) @@ -379,7 +379,8 @@ run env@ChainDBEnv { varDB, .. } cmd = advanceAndAdd :: ChainDBState m blk -> SlotNo -> blk -> m (Point blk) advanceAndAdd ChainDBState { chainDB } newCurSlot blk = do atomically $ modifyTVar varCurSlot (max newCurSlot) - addBlock chainDB InvalidBlockPunishment.noPunishment blk + -- `blockProcessed` always returns 'Just' + fromJust <$> addBlock chainDB InvalidBlockPunishment.noPunishment blk wipeVolatileDB :: ChainDBState m blk -> m (Point blk) wipeVolatileDB st = do