Preprare for the HFC

cardano-db-sync/src/Cardano/DbSync.hs

@@ -54,14 +54,12 @@ import           Cardano.Prelude hiding (atomically, option, (%), Nat)
 import           Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
 
 import qualified Codec.CBOR.Term as CBOR
-import           Control.Monad.Class.MonadSTM.Strict (MonadSTM, StrictTMVar,
-                    atomically, newEmptyTMVarM, readTMVar)
+import           Control.Monad.Class.MonadSTM.Strict (atomically)
 import           Control.Monad.Class.MonadTimer (MonadTimer)
 import           Control.Monad.IO.Class (liftIO)
 import           Control.Monad.Trans.Except.Exit (orDie)
 
 import qualified Data.ByteString.Lazy as BSL
-import           Data.Functor.Contravariant (contramap)
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import           Data.Void (Void)
@@ -73,24 +71,25 @@ import           Network.Mux.Types (MuxMode (..))
 import           Ouroboros.Network.Driver.Simple (runPipelinedPeer)
 import           Network.TypedProtocol.Pipelined (Nat(Zero, Succ))
 
-import           Ouroboros.Consensus.Block.Abstract (ConvertRawHash (..))
-import           Ouroboros.Consensus.Byron.Ledger (GenTx)
-import           Ouroboros.Consensus.Config (TopLevelConfig, configBlock, configCodec)
-import           Ouroboros.Consensus.Config.SupportsNode
+import           Ouroboros.Consensus.Block.Abstract (CodecConfig, ConvertRawHash (..))
+import           Ouroboros.Consensus.Byron.Ledger.Config (mkByronCodecConfig)
+import           Ouroboros.Consensus.Byron.Node ()
 import           Ouroboros.Consensus.Network.NodeToClient (ClientCodecs,
                     cChainSyncCodec, cStateQueryCodec, cTxSubmissionCodec)
 import           Ouroboros.Consensus.Node.ErrorPolicy (consensusErrorPolicy)
 import           Ouroboros.Consensus.Node.Run (RunNode)
-import qualified Ouroboros.Network.NodeToClient.Version as Network
 
+import           Ouroboros.Network.Magic (NetworkMagic)
+import qualified Ouroboros.Network.NodeToClient.Version as Network
 import           Ouroboros.Network.Block (BlockNo (..), HeaderHash, Point (..),
                     Tip, genesisPoint, getTipBlockNo, blockNo)
 import           Ouroboros.Network.Mux (MuxPeer (..),  RunMiniProtocol (..))
 import           Ouroboros.Network.NodeToClient (IOManager, ClientSubscriptionParams (..),
                     ConnectionId, ErrorPolicyTrace (..), Handshake, LocalAddress,
                     NetworkSubscriptionTracers (..), NodeToClientProtocols (..),
-                    TraceSendRecv, WithAddr (..),
-                    networkErrorPolicies, withIOManager, localSnocket, localStateQueryPeerNull)
+                    TraceSendRecv, WithAddr (..), localSnocket, localStateQueryPeerNull,
+                    localTxSubmissionPeerNull, networkErrorPolicies, withIOManager)
+import           Ouroboros.Consensus.Shelley.Ledger.Config (CodecConfig (ShelleyCodecConfig))
 
 import qualified Ouroboros.Network.Point as Point
 import           Ouroboros.Network.Point (withOrigin)
@@ -102,9 +101,6 @@ import           Ouroboros.Network.Protocol.ChainSync.ClientPipelined (ChainSync
 import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision (pipelineDecisionLowHighMark,
                         PipelineDecision (..), runPipelineDecision, MkPipelineDecision)
 import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync)
-import           Ouroboros.Network.Protocol.LocalTxSubmission.Client (LocalTxSubmissionClient (..),
-                    LocalTxClientStIdle (..), localTxSubmissionClientPeer)
-import           Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..))
 import qualified Ouroboros.Network.Snocket as Snocket
 import           Ouroboros.Network.Subscription (SubscriptionTrace)
 
@@ -145,30 +141,34 @@ runDbSyncNode plugin enp =
       liftIO $ do
         -- Must run plugin startup after the genesis distribution has been inserted/validate.
         runDbStartup trce plugin
+        let networkMagic = genesisNetworkMagic genCfg
         case genCfg of
           GenesisByron bCfg ->
             runDbSyncNodeNodeClient ByronEnv
-                iomgr trce plugin (mkByronTopLevelConfig bCfg) (enpSocketPath enp)
+                iomgr trce plugin (mkByronCodecConfig bCfg) networkMagic (enpSocketPath enp)
           GenesisShelley sCfg ->
             runDbSyncNodeNodeClient (ShelleyEnv $ Shelley.sgNetworkId sCfg)
-                iomgr trce plugin (mkShelleyTopLevelConfig sCfg) (enpSocketPath enp)
+                iomgr trce plugin shelleyCodecConfig networkMagic (enpSocketPath enp)
+
+
+shelleyCodecConfig :: CodecConfig ShelleyBlock
+shelleyCodecConfig = ShelleyCodecConfig
 
 -- -------------------------------------------------------------------------------------------------
 
 runDbSyncNodeNodeClient
     :: forall blk. (MkDbAction blk, RunNode blk)
-    => DbSyncEnv -> IOManager -> Trace IO Text -> DbSyncNodePlugin -> TopLevelConfig blk -> SocketPath
+    => DbSyncEnv -> IOManager -> Trace IO Text -> DbSyncNodePlugin -> CodecConfig blk-> NetworkMagic -> SocketPath
     -> IO ()
-runDbSyncNodeNodeClient env iomgr trce plugin topLevelConfig (SocketPath socketPath) = do
+runDbSyncNodeNodeClient env iomgr trce plugin codecConfig magic (SocketPath socketPath) = do
   logInfo trce $ "localInitiatorNetworkApplication: connecting to node via " <> textShow socketPath
-  txv <- newEmptyTMVarM @_ @(GenTx blk)
   void $ subscribe
     (localSnocket iomgr socketPath)
-    (configCodec topLevelConfig)
-    (getNetworkMagic $ configBlock topLevelConfig)
+    codecConfig
+    magic
     networkSubscriptionTracers
     clientSubscriptionParams
-    (dbSyncProtocols trce env plugin topLevelConfig txv)
+    (dbSyncProtocols trce env plugin)
   where
     clientSubscriptionParams = ClientSubscriptionParams {
         cspAddress = Snocket.localAddressFromPath socketPath,
@@ -202,16 +202,14 @@ dbSyncProtocols
   => Trace IO Text
   -> DbSyncEnv
   -> DbSyncNodePlugin
-  -> TopLevelConfig blk
-  -> StrictTMVar IO (GenTx blk)
   -> Network.NodeToClientVersion
   -> ClientCodecs blk IO
   -> ConnectionId LocalAddress
   -> NodeToClientProtocols 'InitiatorMode BSL.ByteString IO () Void
-dbSyncProtocols trce env plugin _topLevelConfig txv _version codecs _connectionId =
+dbSyncProtocols trce env plugin _version codecs _connectionId =
     NodeToClientProtocols {
           localChainSyncProtocol = localChainSyncProtocol
-        , localTxSubmissionProtocol = localTxSubmissionProtocol
+        , localTxSubmissionProtocol = dummylocalTxSubmit
         , localStateQueryProtocol = dummyLocalQueryProtocol
         }
   where
@@ -243,14 +241,15 @@ dbSyncProtocols trce env plugin _topLevelConfig txv _version codecs _connectionI
         -- would like to restart a protocol on the same mux and thus bearer).
         pure ((), Nothing)
 
-    localTxSubmissionProtocol :: RunMiniProtocol 'InitiatorMode BSL.ByteString IO () Void
-    localTxSubmissionProtocol = InitiatorProtocolOnly $ MuxPeer
-        (contramap (Text.pack . show) . toLogObject $ appendName "db-sync-local-tx" trce)
+    dummylocalTxSubmit :: RunMiniProtocol 'InitiatorMode BSL.ByteString IO () Void
+    dummylocalTxSubmit = InitiatorProtocolOnly $ MuxPeer
+        Logging.nullTracer
         (cTxSubmissionCodec codecs)
-        (localTxSubmissionClientPeer (txSubmissionClient txv))
+        localTxSubmissionPeerNull
 
     dummyLocalQueryProtocol :: RunMiniProtocol 'InitiatorMode BSL.ByteString IO () Void
-    dummyLocalQueryProtocol = InitiatorProtocolOnly $ MuxPeer
+    dummyLocalQueryProtocol =
+      InitiatorProtocolOnly $ MuxPeer
         Logging.nullTracer
         (cStateQueryCodec codecs)
         localStateQueryPeerNull
@@ -303,26 +302,6 @@ getCurrentTipBlockNo = do
         Just blockno -> At (BlockNo blockno)
         Nothing -> Origin
 
--- | A 'LocalTxSubmissionClient' that submits transactions reading them from
--- a 'StrictTMVar'.  A real implementation should use a better synchronisation
--- primitive.  This demo creates and empty 'TMVar' in
--- 'muxLocalInitiatorNetworkApplication' above and never fills it with a tx.
---
-txSubmissionClient
-  :: forall tx reject m. (Monad m, MonadSTM m)
-  => StrictTMVar m tx -> LocalTxSubmissionClient tx reject m ()
-txSubmissionClient txv = LocalTxSubmissionClient $
-    atomically (readTMVar txv) >>= pure . client
-  where
-    client :: tx -> LocalTxClientStIdle tx reject m ()
-    client tx =
-      SendMsgSubmitTx tx $ \mbreject -> do
-        case mbreject of
-          SubmitSuccess -> return ()
-          SubmitFail _r -> return ()
-        tx' <- atomically $ readTMVar txv
-        pure $ client tx'
-
 -- | 'ChainSyncClient' which traces received blocks and ignores when it
 -- receives a request to rollbackwar.  A real wallet client should:
 --

cardano-db-sync/src/Cardano/DbSync/Era.hs

@@ -5,11 +5,10 @@
 
 module Cardano.DbSync.Era
   ( GenesisEra (..)
-  , MkConsensusConfig (..)
+  , genesisEnv
+  , genesisNetworkMagic
   , genesisProtocolMagic
   , insertValidateGenesisDist
-  , mkByronTopLevelConfig
-  , mkShelleyTopLevelConfig
   , readByronGenesisConfig
   , readGenesisConfig
   , readShelleyGenesisConfig
@@ -19,10 +18,9 @@ import           Cardano.Binary (Annotated (..))
 import           Cardano.BM.Data.Trace (Trace)
 
 import qualified Cardano.Chain.Genesis as Byron
-import qualified Cardano.Chain.Update as Byron
 import           Cardano.Crypto (decodeAbstractHash)
 import           Cardano.Crypto.ProtocolMagic (AProtocolMagic (..), ProtocolMagic,
-                    RequiresNetworkMagic (..))
+                    ProtocolMagicId (..), RequiresNetworkMagic (..))
 
 import           Cardano.DbSync.Config
 import qualified Cardano.DbSync.Era.Byron.Genesis as Byron
@@ -39,39 +37,47 @@ import           Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither, ne
 import qualified Data.Aeson as Aeson
 import qualified Data.Text as Text
 
-import           Ouroboros.Consensus.Block.Abstract (ConvertRawHash (..))
-import           Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
-import           Ouroboros.Consensus.Cardano (protocolInfoByron)
-import           Ouroboros.Consensus.Config (TopLevelConfig)
-import           Ouroboros.Consensus.Node (ProtocolInfo (..), pInfoConfig)
-import           Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..), protocolInfoShelley)
+import           Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..))
 import           Ouroboros.Consensus.Shelley.Protocol (TPraosStandardCrypto)
+import           Ouroboros.Network.Magic (NetworkMagic (..))
 
 import           Shelley.Spec.Ledger.BaseTypes (Network (..))
-import qualified Shelley.Spec.Ledger.BaseTypes as Shelley
 import qualified Shelley.Spec.Ledger.Genesis as Shelley
-import           Shelley.Spec.Ledger.PParams (ProtVer (..))
 
 data GenesisEra
   = GenesisByron !Byron.Config
   | GenesisShelley !(ShelleyGenesis TPraosStandardCrypto)
+  -- | GenesisCardano !Byron.Config !(ShelleyGenesis TPraosStandardCrypto)
 
 
-class ConvertRawHash blk => MkConsensusConfig cfg blk where
-  mkConsensusConfig :: cfg -> TopLevelConfig blk
-
-instance MkConsensusConfig Byron.Config ByronBlock where
-  mkConsensusConfig = mkByronTopLevelConfig
-
-instance MkConsensusConfig (ShelleyGenesis TPraosStandardCrypto) ShelleyBlock where
-  mkConsensusConfig = mkShelleyTopLevelConfig
+genesisEnv :: GenesisEra -> DbSyncEnv
+genesisEnv ge =
+  case ge of
+    GenesisByron _ -> ByronEnv
+    GenesisShelley sCfg -> ShelleyEnv $ Shelley.sgNetworkId sCfg
 
+genesisNetworkMagic :: GenesisEra -> NetworkMagic
+genesisNetworkMagic ge =
+  case ge of
+    GenesisByron bg ->
+      NetworkMagic $ unProtocolMagicId (Byron.configProtocolMagicId bg)
+    GenesisShelley sg -> NetworkMagic $ Shelley.sgNetworkMagic sg
 
 genesisProtocolMagic :: GenesisEra -> ProtocolMagic
 genesisProtocolMagic ge =
-  case ge of
-    GenesisByron bg -> Byron.configProtocolMagic bg
-    GenesisShelley sg -> mkShelleyProtocolMagic sg
+    case ge of
+      GenesisByron bg -> Byron.configProtocolMagic bg
+      GenesisShelley sg -> mkShelleyProtocolMagic sg
+  where
+    mkShelleyProtocolMagic :: ShelleyGenesis TPraosStandardCrypto -> ProtocolMagic
+    mkShelleyProtocolMagic sg =
+      AProtocolMagic
+        { getAProtocolMagicId = Annotated (Shelley.sgProtocolMagicId sg) ()
+        , getRequiresNetworkMagic =
+            if Shelley.sgNetworkId sg == Mainnet
+              then RequiresNoMagic
+              else RequiresMagic
+        }
 
 insertValidateGenesisDist
         :: Trace IO Text.Text -> NetworkName -> GenesisEra
@@ -85,38 +91,6 @@ insertValidateGenesisDist trce nname genCfg =
 
 -- -----------------------------------------------------------------------------
 
-mkByronTopLevelConfig :: Byron.Config -> TopLevelConfig ByronBlock
-mkByronTopLevelConfig bgc =
-    pInfoConfig byronInfo
-  where
-    byronInfo :: ProtocolInfo IO ByronBlock
-    byronInfo =
-      protocolInfoByron bgc Nothing (Byron.ProtocolVersion 0 2 0)
-        (Byron.SoftwareVersion (Byron.ApplicationName "cardano-sl") 1) Nothing
-
-
-mkShelleyTopLevelConfig :: ShelleyGenesis TPraosStandardCrypto -> TopLevelConfig ShelleyBlock
-mkShelleyTopLevelConfig sgc =
-    pInfoConfig shelleyInfo
-  where
-    -- Can use Nothing for the last field because that field will be dropped
-    -- by 'pInfoConfig' anyway.
-    shelleyInfo :: ProtocolInfo IO ShelleyBlock
-    -- TODO: IS @'maxMajorPV' = 0@ THIS RIGHT?
-    shelleyInfo = protocolInfoShelley sgc Shelley.NeutralNonce 2 (ProtVer 2 0) Nothing
-
-mkShelleyProtocolMagic :: ShelleyGenesis TPraosStandardCrypto -> ProtocolMagic
-mkShelleyProtocolMagic sg =
-  AProtocolMagic
-    { getAProtocolMagicId = Annotated (Shelley.sgProtocolMagicId sg) ()
-    , getRequiresNetworkMagic =
-        if Shelley.sgNetworkId sg == Mainnet
-          then RequiresNoMagic
-          else RequiresMagic
-    }
-
--- -----------------------------------------------------------------------------
-
 readGenesisConfig
         :: DbSyncNodeParams -> DbSyncNodeConfig
         -> ExceptT DbSyncNodeError IO GenesisEra