Merge #1677

1677: Use the IO instance of MonadRandom r=edsko a=mrBliss

Fixes #1616.

Previously, block production had to live in STM, but this is no longer the
case as of #1445. This means that we no longer need to run `MonadRandom`
computations in STM. To do that, we stored a DRG in a TVar.

Now, we can simply use IO's instance of `MonadRandom`. In the tests we still
use the DRG-in-a-TVar trick, but we split it whenever we get a DRG.

We use the `RunMonadRandom` record for this purpose.

---

Replace NodeState with MonadState

Previously, we need a separate `HasNodeState` class and `NodeStateT` monad
transformer because there was already a `StateT` in our stack, i.e., the one
containing the DRG. As that is gone, we can switch back to a regular
`MonadState` + `StateT`.

The cost is an orphan instance: `MonadRandom (StateT s m)`

Co-authored-by: Edsko de Vries <edsko@well-typed.com>

ouroboros-consensus-byron/ouroboros-consensus-byrondual/src/Ouroboros/Consensus/ByronDual/Ledger.hs

@@ -47,7 +47,7 @@ import           Ouroboros.Network.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Dual
 import           Ouroboros.Consensus.Ledger.Extended
-import           Ouroboros.Consensus.Protocol.Abstract
+import           Ouroboros.Consensus.Node.State
 import           Ouroboros.Consensus.Protocol.PBFT
 
 import           Ouroboros.Consensus.Byron.Crypto.DSIGN
@@ -207,19 +207,16 @@ bridgeTransactionIds = Spec.Test.transactionIds
 -------------------------------------------------------------------------------}
 
 forgeDualByronBlock
-  :: forall m.
-     ( HasNodeState_ () m  -- @()@ is the @NodeState@ of PBFT
-     , MonadRandom m
-     , HasCallStack
-     )
+  :: forall m. (MonadRandom m, HasCallStack)
   => TopLevelConfig DualByronBlock
+  -> Update m (NodeState DualByronBlock)
   -> SlotNo                          -- ^ Current slot
   -> BlockNo                         -- ^ Current block number
   -> ExtLedgerState DualByronBlock   -- ^ Ledger
   -> [GenTx DualByronBlock]          -- ^ Txs to add in the block
   -> PBftIsLeader PBftByronCrypto    -- ^ Leader proof ('IsLeader')
   -> m DualByronBlock
-forgeDualByronBlock cfg curSlotNo curBlockNo extLedger txs isLeader = do
+forgeDualByronBlock cfg updateState curSlotNo curBlockNo extLedger txs isLeader = do
     -- NOTE: We do not /elaborate/ the real Byron block from the spec one, but
     -- instead we /forge/ it. This is important, because we want to test that
     -- codepath. This does mean that we do not get any kind of "bridge" between
@@ -229,6 +226,7 @@ forgeDualByronBlock cfg curSlotNo curBlockNo extLedger txs isLeader = do
 
     main <- forgeByronBlock
               (dualTopLevelConfigMain cfg)
+              updateState
               curSlotNo
               curBlockNo
               (dualExtLedgerStateMain extLedger)

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Forge.hs

@@ -36,7 +36,7 @@ import           Ouroboros.Network.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Extended
-import           Ouroboros.Consensus.Protocol.Abstract
+import           Ouroboros.Consensus.Node.State
 import           Ouroboros.Consensus.Protocol.PBFT
 
 import           Ouroboros.Consensus.Byron.Crypto.DSIGN
@@ -47,12 +47,9 @@ import           Ouroboros.Consensus.Byron.Ledger.PBFT
 import           Ouroboros.Consensus.Byron.Protocol
 
 forgeByronBlock
-  :: forall m.
-     ( HasNodeState_ () m  -- @()@ is the @NodeState@ of PBFT
-     , MonadRandom m
-     , HasCallStack
-     )
+  :: forall m. (MonadRandom m, HasCallStack)
   => TopLevelConfig ByronBlock
+  -> Update m (NodeState ByronBlock)
   -> SlotNo                          -- ^ Current slot
   -> BlockNo                         -- ^ Current block number
   -> ExtLedgerState ByronBlock       -- ^ Ledger
@@ -128,19 +125,16 @@ initBlockPayloads = BlockPayloads
   }
 
 forgeRegularBlock
-  :: forall m.
-     ( HasNodeState_ () m  -- @()@ is the @NodeState@ of PBFT
-     , MonadRandom m
-     , HasCallStack
-     )
+  :: forall m. (MonadRandom m, HasCallStack)
   => TopLevelConfig ByronBlock
+  -> Update m (NodeState ByronBlock)
   -> SlotNo                            -- ^ Current slot
   -> BlockNo                           -- ^ Current block number
   -> ExtLedgerState ByronBlock         -- ^ Ledger
   -> [GenTx ByronBlock]                -- ^ Txs to add in the block
   -> PBftIsLeader PBftByronCrypto    -- ^ Leader proof ('IsLeader')
   -> m ByronBlock
-forgeRegularBlock cfg curSlot curNo extLedger txs isLeader = do
+forgeRegularBlock cfg _updateState curSlot curNo extLedger txs isLeader = do
     ouroborosPayload <-
       forgePBftFields
         (mkByronContextDSIGN cfg)

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/PBFT.hs

@@ -28,6 +28,7 @@ import           Ouroboros.Network.Block (HasHeader (..))
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Node.State
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Protocol.PBFT
 import qualified Ouroboros.Consensus.Protocol.PBFT.ChainState as CS
@@ -38,6 +39,7 @@ import           Ouroboros.Consensus.Byron.Ledger.Config
 import           Ouroboros.Consensus.Byron.Ledger.Serialisation ()
 import           Ouroboros.Consensus.Byron.Protocol
 
+type instance NodeState     ByronBlock = ()
 type instance BlockProtocol ByronBlock = PBft PBftByronCrypto
 
 -- | Construct DSIGN required for Byron crypto

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/BFT.hs

@@ -33,6 +33,7 @@ import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Mock.Ledger.Block
 import           Ouroboros.Consensus.Mock.Node.Abstract
+import           Ouroboros.Consensus.Node.State
 import           Ouroboros.Consensus.Protocol.BFT
 import           Ouroboros.Consensus.Protocol.Signed
 import           Ouroboros.Consensus.Util.Condense
@@ -69,6 +70,7 @@ data instance BlockConfig (SimpleBftBlock c c') = SimpleBftBlockConfig {
     }
   deriving (Generic, NoUnexpectedThunks)
 
+type instance NodeState     (SimpleBftBlock c c') = ()
 type instance BlockProtocol (SimpleBftBlock c c') = Bft c'
 
 -- | Sanity check that block and header type synonyms agree
@@ -89,7 +91,7 @@ instance ( SimpleCrypto c
          , Signable (BftDSIGN c') (SignedSimpleBft c c')
          )
       => RunMockBlock c (SimpleBftExt c c') where
-  forgeExt cfg () SimpleBlock{..} = do
+  forgeExt cfg _updateState () SimpleBlock{..} = do
       ext :: SimpleBftExt c c' <- fmap SimpleBftExt $
         forgeBftFields (configConsensus cfg) $
           SignedSimpleBft {

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs

@@ -36,6 +36,7 @@ import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Mock.Ledger.Block
 import           Ouroboros.Consensus.Mock.Node.Abstract
+import           Ouroboros.Consensus.Node.State
 import           Ouroboros.Consensus.Protocol.PBFT
 import qualified Ouroboros.Consensus.Protocol.PBFT.ChainState as CS
 import           Ouroboros.Consensus.Protocol.Signed
@@ -83,6 +84,7 @@ data instance BlockConfig (SimplePBftBlock c c') = SimplePBftBlockConfig {
   }
   deriving (Generic, NoUnexpectedThunks)
 
+type instance NodeState     (SimplePBftBlock c c') = ()
 type instance BlockProtocol (SimplePBftBlock c c') = PBft c'
 
 -- | Sanity check that block and header type synonyms agree
@@ -104,7 +106,7 @@ instance ( SimpleCrypto c
          , ContextDSIGN (PBftDSIGN c') ~ ()
          , Serialise (PBftVerKeyHash c')
          ) => RunMockBlock c (SimplePBftExt c c') where
-  forgeExt _cfg isLeader SimpleBlock{..} = do
+  forgeExt _cfg _updateState isLeader SimpleBlock{..} = do
       ext :: SimplePBftExt c c' <- fmap SimplePBftExt $
         forgePBftFields
           (const ())

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs

@@ -39,6 +39,7 @@ import           Ouroboros.Consensus.Mock.Ledger.Block
 import           Ouroboros.Consensus.Mock.Ledger.Stake
 import           Ouroboros.Consensus.Mock.Node.Abstract
 import           Ouroboros.Consensus.Mock.Protocol.Praos
+import           Ouroboros.Consensus.Node.State
 import           Ouroboros.Consensus.Protocol.Signed
 import           Ouroboros.Consensus.Util.Condense
 
@@ -83,14 +84,15 @@ data instance BlockConfig (SimplePraosBlock c c') = SimplePraosBlockConfig {
     }
   deriving (Generic, NoUnexpectedThunks)
 
+type instance NodeState     (SimplePraosBlock c c') = PraosNodeState c'
 type instance BlockProtocol (SimplePraosBlock c c') = Praos c'
 
 -- | Sanity check that block and header type synonyms agree
 _simplePraosHeader :: SimplePraosBlock c c' -> SimplePraosHeader c c'
 _simplePraosHeader = simpleHeader
 
 {-------------------------------------------------------------------------------
-  Evidence that SimpleBlock can support BFT
+  Evidence that SimpleBlock can support Praos
 -------------------------------------------------------------------------------}
 
 type instance Signed (SimplePraosHeader c c') = SignedSimplePraos c c'
@@ -119,9 +121,10 @@ instance ( SimpleCrypto c
          , PraosCrypto c'
          , Signable (PraosKES c') (SignedSimplePraos c c')
          ) => RunMockBlock c (SimplePraosExt c c') where
-  forgeExt cfg isLeader SimpleBlock{..} = do
+  forgeExt cfg updateState isLeader SimpleBlock{..} = do
       ext :: SimplePraosExt c c' <- fmap SimplePraosExt $
         forgePraosFields (configConsensus cfg)
+                         updateState
                          isLeader
                          $ \praosExtraFields ->
           SignedSimplePraos {

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs

@@ -34,6 +34,7 @@ import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Mock.Ledger.Block
 import           Ouroboros.Consensus.Mock.Node.Abstract
 import           Ouroboros.Consensus.Mock.Protocol.Praos
+import           Ouroboros.Consensus.Node.State
 import           Ouroboros.Consensus.NodeId (CoreNodeId)
 import           Ouroboros.Consensus.Protocol.LeaderSchedule
 import           Ouroboros.Consensus.Util.Condense
@@ -71,8 +72,9 @@ data instance BlockConfig (SimplePraosRuleBlock c) = SimplePraosRuleBlockConfig
     }
   deriving (Generic, NoUnexpectedThunks)
 
+type instance NodeState     (SimplePraosRuleBlock c) = ()
 type instance BlockProtocol (SimplePraosRuleBlock c) =
-   WithLeaderSchedule (Praos PraosCryptoUnused)
+    WithLeaderSchedule (Praos PraosCryptoUnused)
 
 -- | Sanity check that block and header type synonyms agree
 _simplePraosRuleHeader :: SimplePraosRuleBlock c -> SimplePraosRuleHeader c
@@ -83,7 +85,7 @@ _simplePraosRuleHeader = simpleHeader
 -------------------------------------------------------------------------------}
 
 instance SimpleCrypto c => RunMockBlock c SimplePraosRuleExt where
-  forgeExt cfg () SimpleBlock{..} = do
+  forgeExt cfg _updateState () SimpleBlock{..} = do
       let ext = SimplePraosRuleExt $ lsNodeConfigNodeId (configConsensus cfg)
       return SimpleBlock {
           simpleHeader = mkSimpleHeader encode simpleHeaderStd ext

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Forge.hs

@@ -22,26 +22,27 @@ import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Mock.Ledger.Block
 import           Ouroboros.Consensus.Mock.Node.Abstract
+import           Ouroboros.Consensus.Node.State
 import           Ouroboros.Consensus.Protocol.Abstract
 
 forgeSimple :: forall p c m ext.
-               ( HasNodeState p m
-               , MonadRandom m
+               ( MonadRandom m
                , SimpleCrypto c
                , RunMockBlock c ext
                , BlockSupportsProtocol (SimpleBlock c ext)
                , Typeable ext
                , p ~ BlockProtocol (SimpleBlock c ext)
                )
             => TopLevelConfig (SimpleBlock c ext)
+            -> Update m (NodeState (SimpleBlock c ext))
             -> SlotNo                              -- ^ Current slot
             -> BlockNo                             -- ^ Current block number
             -> ExtLedgerState (SimpleBlock c ext)  -- ^ Current ledger
             -> [GenTx (SimpleBlock c ext)]         -- ^ Txs to add in the block
             -> IsLeader p                          -- ^ Proof we are slot leader
             -> m (SimpleBlock c ext)
-forgeSimple cfg curSlot curBlock extLedger txs proof = do
-    forgeExt cfg proof $ SimpleBlock {
+forgeSimple cfg updateState curSlot curBlock extLedger txs proof = do
+    forgeExt cfg updateState proof $ SimpleBlock {
         simpleHeader = mkSimpleHeader encode stdHeader ()
       , simpleBody   = body
       }

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node.hs

@@ -12,6 +12,8 @@ import           Data.Time.Calendar (fromGregorian)
 import           Data.Time.Clock (UTCTime (..))
 import           Data.Typeable (Typeable)
 
+import           Cardano.Prelude (NoUnexpectedThunks)
+
 import           Ouroboros.Network.Magic (NetworkMagic (..))
 
 import           Ouroboros.Consensus.Block
@@ -22,6 +24,7 @@ import           Ouroboros.Consensus.Mock.Ledger
 import           Ouroboros.Consensus.Mock.Node.Abstract
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 import           Ouroboros.Consensus.Node.Run
+import           Ouroboros.Consensus.Node.State
 import           Ouroboros.Consensus.Protocol.Abstract (SecurityParam (..))
 
 import           Ouroboros.Consensus.Storage.Common (EpochSize (..))
@@ -38,6 +41,7 @@ instance ( LedgerSupportsProtocol (SimpleBlock SimpleMockCrypto ext)
            -- some of the tests loop, but only when compiled with @-O2@ ; with
            -- @-O0@ it is perfectly fine. ghc bug?!
          , BlockSupportsProtocol (SimpleBlock SimpleMockCrypto ext)
+         , NoUnexpectedThunks (NodeState (SimpleBlock SimpleMockCrypto ext))
          , Typeable ext
          , Serialise ext
          , RunMockBlock SimpleMockCrypto ext

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Abstract.hs

@@ -19,6 +19,7 @@ import           Cardano.Crypto (ProtocolMagicId (..))
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Mock.Ledger.Block
+import           Ouroboros.Consensus.Node.State
 import           Ouroboros.Consensus.Protocol.Abstract
 
 -- | Protocol specific functionality required to run consensus with mock blocks
@@ -27,12 +28,10 @@ class RunMockBlock c ext where
   --
   -- This is used in 'forgeSimple', which takes care of the generic part of
   -- the mock block.
-  forgeExt :: ( HasNodeState p m
-              , MonadRandom m
-              , p ~ BlockProtocol (SimpleBlock c ext)
-              )
-           => TopLevelConfig (SimpleBlock c ext)
-           -> IsLeader p
+  forgeExt :: MonadRandom m
+           => TopLevelConfig          (SimpleBlock c ext)
+           -> Update m     (NodeState (SimpleBlock c ext))
+           -> IsLeader (BlockProtocol (SimpleBlock c ext))
            -> SimpleBlock' c ext ()
            -> m (SimpleBlock c ext)
 

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Praos.hs

@@ -45,7 +45,7 @@ protocolInfoPraos numCoreNodes nid params slotLengths =
             ledgerState = genesisSimpleLedgerState addrDist
           , headerState = genesisHeaderState []
           }
-      , pInfoInitState = PraosNodeState $ SignKeyMockKES
+      , pInfoInitState = PraosKeyAvailable $ SignKeyMockKES
            (fst $ verKeys Map.! nid)   -- key ID
            0                           -- KES initial slot
            (praosLifetimeKES params)   -- KES lifetime