block-forging: updated upstream dependencies

* ouroboros-consensus-test * ouroboros-consensus-cardano-tools
IntersectMBO · Nov 9, 2022 · 8a9d69d · 8a9d69d
1 parent 8e9481c
commit 8a9d69d
Show file tree

Hide file tree

Showing 4 changed files with 8 additions and 8 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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