From 8a9d69ddbbd7fe44f54a2824ddcf844d288cb3d4 Mon Sep 17 00:00:00 2001
From: Marcin Szamotulski <coot@coot.me>
Date: Tue, 8 Nov 2022 11:02:28 +0100
Subject: [PATCH] block-forging: updated upstream dependencies

* ouroboros-consensus-test
* ouroboros-consensus-cardano-tools
---
 .../src/Cardano/Api/Protocol/Types.hs                      | 2 +-
 .../src/Cardano/Tools/DBSynthesizer/Forging.hs             | 7 +++----
 .../test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs   | 2 +-
 .../Test/Ouroboros/Storage/ChainDB/StateMachine.hs         | 5 +++--
 4 files changed, 8 insertions(+), 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
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