Simplify InitChainDB

Merge `checkEmpty` and `addBlock` in `addBlockIfEmpty`. This is currently the
only use of this API and merging them expresses the intent better. Moreover,
this avoids the racy nature of the two (although there will be no race condition
in practice).

ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -10,7 +11,6 @@ module Ouroboros.Consensus.ByronDual.Node (
     protocolInfoDualByron
   ) where
 
-import           Control.Monad
 import           Data.Either (fromRight)
 import           Data.Map.Strict (Map)
 import           Data.Maybe (fromMaybe)
@@ -45,7 +45,7 @@ import           Ouroboros.Consensus.Node.Run
 import           Ouroboros.Consensus.NodeId
 import           Ouroboros.Consensus.Protocol.PBFT
 import qualified Ouroboros.Consensus.Protocol.PBFT.State as S
-import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB
+import           Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..))
 import           Ouroboros.Consensus.Util ((.....:))
 
 import           Ouroboros.Consensus.Byron.Ledger
@@ -218,9 +218,8 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss =
 
 instance NodeInitStorage DualByronBlock where
   -- Just like Byron, we need to start with an EBB
-  nodeInitChainDB cfg chainDB = do
-      empty <- InitChainDB.checkEmpty chainDB
-      when empty $ InitChainDB.addBlock chainDB genesisEBB
+  nodeInitChainDB cfg InitChainDB { addBlockIfEmpty } = do
+      addBlockIfEmpty (return genesisEBB)
     where
       genesisEBB :: DualByronBlock
       genesisEBB = DualBlock {

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node.hs

@@ -48,7 +48,7 @@ import           Ouroboros.Consensus.NodeId (CoreNodeId)
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Protocol.PBFT
 import qualified Ouroboros.Consensus.Protocol.PBFT.State as S
-import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB
+import           Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..))
 import           Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo)
 import           Ouroboros.Consensus.Util ((.....:))
 
@@ -264,9 +264,8 @@ instance NodeInitStorage ByronBlock where
 
   -- If the current chain is empty, produce a genesis EBB and add it to the
   -- ChainDB. Only an EBB can have Genesis (= empty chain) as its predecessor.
-  nodeInitChainDB cfg chainDB = do
-      empty <- InitChainDB.checkEmpty chainDB
-      when empty $ InitChainDB.addBlock chainDB genesisEBB
+  nodeInitChainDB cfg InitChainDB { addBlockIfEmpty } = do
+      addBlockIfEmpty (return genesisEBB)
     where
       genesisEBB = forgeEBB (getByronBlockConfig cfg) (SlotNo 0) (BlockNo 0) GenesisHash
 

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Unary.hs

@@ -37,6 +37,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Unary (
 
 import           Data.Bifunctor (first)
 import           Data.Coerce
+import           Data.Functor.Contravariant
 import           Data.Kind (Type)
 import           Data.Proxy
 import           Data.SOP.Strict
@@ -58,7 +59,6 @@ import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.TypeFamilyWrappers
 
 import           Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB)
-import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB
 
 import           Ouroboros.Consensus.HardFork.Combinator.Abstract
 import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
@@ -375,20 +375,14 @@ instance Isomorphic AnnTip where
 
   inject (AnnTip s b nfo) = AnnTip s b (OneEraTipInfo (Z (WrapTipInfo nfo)))
 
-instance Isomorphic (InitChainDB m) where
+instance Functor m => Isomorphic (InitChainDB m) where
   project :: forall blk. NoHardForks blk
           => InitChainDB m (HardForkBlock '[blk]) -> InitChainDB m blk
-  project initDB = InitChainDB.InitChainDB {
-        InitChainDB.checkEmpty = InitChainDB.checkEmpty initDB
-      , InitChainDB.addBlock   = InitChainDB.addBlock   initDB . inject' (Proxy @(I blk))
-      }
+  project = contramap (inject' (Proxy @(I blk)))
 
   inject :: forall blk. NoHardForks blk
          => InitChainDB m blk -> InitChainDB m (HardForkBlock '[blk])
-  inject initDB = InitChainDB.InitChainDB {
-        InitChainDB.checkEmpty = InitChainDB.checkEmpty initDB
-      , InitChainDB.addBlock   = InitChainDB.addBlock   initDB . project' (Proxy @(I blk))
-      }
+  inject = contramap (project' (Proxy @(I blk)))
 
 instance Isomorphic ProtocolClientInfo where
   project ProtocolClientInfo{..} = ProtocolClientInfo {

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

@@ -17,30 +17,28 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
 import           Ouroboros.Consensus.Util.IOLike
 
 -- | Restricted interface to the 'ChainDB' used on node initialization
-data InitChainDB m blk = InitChainDB {
-      -- | Check if the current chain is empty
-      checkEmpty :: m Bool
-
-      -- | Add a block to the DB
-    , addBlock   :: blk -> m ()
+newtype InitChainDB m blk = InitChainDB {
+      -- | Add a block to the DB when the current chain is empty.
+      --
+      -- The given action is only called when the current chain is empty.
+      addBlockIfEmpty :: m blk -> m ()
     }
 
-instance Contravariant (InitChainDB m) where
+instance Functor m => Contravariant (InitChainDB m) where
   contramap f db = InitChainDB {
-        checkEmpty = checkEmpty db
-      , addBlock   = addBlock   db . f
+        addBlockIfEmpty = addBlockIfEmpty db . (f <$>)
       }
 
 fromFull :: IOLike m => ChainDB m blk -> InitChainDB m blk
 fromFull db = InitChainDB {
-      checkEmpty = do
+      addBlockIfEmpty = \mkBlk -> do
           tip <- atomically $ ChainDB.getTipPoint db
-          return $ case tip of
-                     BlockPoint {} -> False
-                     GenesisPoint  -> True
-
-    , addBlock = ChainDB.addBlock_ db
+          case tip of
+            BlockPoint {} -> return ()
+            GenesisPoint  -> do
+              blk <- mkBlk
+              ChainDB.addBlock_ db blk
     }
 
-cast :: Coercible blk blk' => InitChainDB m blk -> InitChainDB m blk'
+cast :: (Functor m, Coercible blk blk') => InitChainDB m blk -> InitChainDB m blk'
 cast = contramap coerce