WIP: Propagate consensus protocol in block type

cardano-api/src/Cardano/Api/Block.hs

@@ -60,15 +60,17 @@ import           Data.String (IsString)
 import           Cardano.Slotting.Block (BlockNo)
 import           Cardano.Slotting.Slot (EpochNo, SlotNo, WithOrigin (..))
 
-import qualified Cardano.Crypto.Hash.Class
+import qualified Cardano.Crypto.Hash.Class as Crypto
 import qualified Cardano.Crypto.Hashing
 import qualified Ouroboros.Consensus.Block as Consensus
 import qualified Ouroboros.Consensus.Byron.Ledger as Consensus
 import qualified Ouroboros.Consensus.Cardano.Block as Consensus
 import qualified Ouroboros.Consensus.Cardano.ByronHFC as Consensus
 import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus
 import qualified Ouroboros.Consensus.HardFork.Combinator.Degenerate as Consensus
+import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus
 import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
+import qualified Ouroboros.Consensus.Shelley.Protocol.Abstract as Consensus
 import qualified Ouroboros.Consensus.Shelley.ShelleyHFC as Consensus
 import qualified Ouroboros.Network.Block as Consensus
 
@@ -102,7 +104,7 @@ data Block era where
                 -> Block ByronEra
 
      ShelleyBlock :: ShelleyBasedEra era
-                  -> Consensus.ShelleyBlock (ShelleyLedgerEra era)
+                  -> Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
                   -> Block era
 
 -- | A block consists of a header and a body containing transactions.
@@ -181,15 +183,15 @@ obtainConsensusShelleyBasedEra
   :: forall era ledgerera a.
      ledgerera ~ ShelleyLedgerEra era
   => ShelleyBasedEra era
-  -> (Consensus.ShelleyBasedEra ledgerera => a) -> a
+  -> (( Consensus.ShelleyBasedEra ledgerera
+      , Consensus.ShelleyProtocolHeader (ConsensusProtocol era) ~ TPraos.BHeader (Ledger.Crypto (ShelleyLedgerEra era)))
+      => a) -> a
 obtainConsensusShelleyBasedEra ShelleyBasedEraShelley f = f
 obtainConsensusShelleyBasedEra ShelleyBasedEraAllegra f = f
 obtainConsensusShelleyBasedEra ShelleyBasedEraMary    f = f
 obtainConsensusShelleyBasedEra ShelleyBasedEraAlonzo  f = f
-obtainConsensusShelleyBasedEra ShelleyBasedEraBabbage _f =
-  error "TODO: Babbage era - depends on consensus exposing a babbage era"
-
-
+obtainConsensusShelleyBasedEra ShelleyBasedEraBabbage _f = error "f"
+-- Consensus.ShelleyProtocolHeader (ConsensusProtocol era) ~ TPraos.BHeader (Ledger.Crypto (ShelleyLedgerEra era))
 -- ----------------------------------------------------------------------------
 -- Block in a consensus mode
 --
@@ -211,11 +213,11 @@ fromConsensusBlock ByronMode =
       Consensus.DegenBlock b' ->
         BlockInMode (ByronBlock b') ByronEraInByronMode
 
-fromConsensusBlock ShelleyMode =
-    \b -> case b of
-      Consensus.DegenBlock b' ->
-        BlockInMode (ShelleyBlock ShelleyBasedEraShelley b')
-                     ShelleyEraInShelleyMode
+fromConsensusBlock ShelleyMode = error "TODO: Babbage"
+  --  \b -> case b of
+  --    Consensus.DegenBlock b' ->
+  --      BlockInMode (ShelleyBlock ShelleyBasedEraShelley b')
+  --                   ShelleyEraInShelleyMode
 
 fromConsensusBlock CardanoMode =
     \b -> case b of
@@ -238,23 +240,26 @@ fromConsensusBlock CardanoMode =
         BlockInMode (ShelleyBlock ShelleyBasedEraAlonzo b')
                      AlonzoEraInCardanoMode
 
+      Consensus.BlockBabbage b' ->
+        BlockInMode (ShelleyBlock ShelleyBasedEraBabbage b')
+                     BabbageEraInCardanoMode
+
 toConsensusBlock :: ConsensusBlockForMode mode ~ block => BlockInMode mode -> block
 toConsensusBlock bInMode =
   case bInMode of
     -- Byron mode
     BlockInMode (ByronBlock b') ByronEraInByronMode -> Consensus.DegenBlock b'
 
     -- Shelley mode
-    BlockInMode (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInShelleyMode -> Consensus.DegenBlock b'
+    BlockInMode (ShelleyBlock ShelleyBasedEraShelley _b') ShelleyEraInShelleyMode -> error "Consensus.DegenBlock b'"
 
     -- Cardano mode
     BlockInMode (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b'
     BlockInMode (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode -> Consensus.BlockShelley b'
     BlockInMode (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode -> Consensus.BlockAllegra b'
     BlockInMode (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode -> Consensus.BlockMary b'
     BlockInMode (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode -> Consensus.BlockAlonzo b'
-    BlockInMode (ShelleyBlock ShelleyBasedEraBabbage _b') BabbageEraInCardanoMode ->
-      error "TODO: Babbage era - depends on consensus exposing a babbage era"
+    BlockInMode (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode -> Consensus.BlockBabbage b'
 
 -- ----------------------------------------------------------------------------
 -- Block headers
@@ -285,21 +290,22 @@ instance HasTypeProxy BlockHeader where
     data AsType BlockHeader = AsBlockHeader
     proxyToAsType _ = AsBlockHeader
 
-getBlockHeader :: forall era . Block era -> BlockHeader
+getBlockHeader
+  :: forall era . Block era -> BlockHeader
 getBlockHeader (ShelleyBlock shelleyEra block) = case shelleyEra of
   ShelleyBasedEraShelley -> go
   ShelleyBasedEraAllegra -> go
   ShelleyBasedEraMary -> go
   ShelleyBasedEraAlonzo -> go
-  ShelleyBasedEraBabbage ->
-    error "TODO: Babbage era - depends on consensus exposing a babbage era"
+  ShelleyBasedEraBabbage -> go
   where
-    go :: Consensus.ShelleyBasedEra (ShelleyLedgerEra era) => BlockHeader
+    go :: Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era)
+       => BlockHeader
     go = BlockHeader headerFieldSlot (HeaderHash hashSBS) headerFieldBlockNo
       where
         Consensus.HeaderFields {
             Consensus.headerFieldHash
-              = Consensus.ShelleyHash (TPraos.HashHeader (Cardano.Crypto.Hash.Class.UnsafeHash hashSBS)),
+              = Consensus.ShelleyHash (Crypto.UnsafeHash hashSBS),
             Consensus.headerFieldSlot,
             Consensus.headerFieldBlockNo
           } = Consensus.getHeaderFields block
@@ -361,28 +367,28 @@ fromConsensusPointHF (Consensus.BlockPoint slot (Consensus.OneEraHash h)) =
 
 -- | Convert a 'Consensus.Point' for single Shelley-era block type
 --
-toConsensusPoint :: forall ledgerera.
-                      Consensus.ShelleyBasedEra ledgerera
+toConsensusPoint :: forall ledgerera protocol.
+                      Consensus.ShelleyCompatible protocol ledgerera
                    => ChainPoint
-                   -> Consensus.Point (Consensus.ShelleyBlock ledgerera)
+                   -> Consensus.Point (Consensus.ShelleyBlock protocol ledgerera)
 toConsensusPoint ChainPointAtGenesis = Consensus.GenesisPoint
 toConsensusPoint (ChainPoint slot (HeaderHash h)) =
     Consensus.BlockPoint slot (Consensus.fromShortRawHash proxy h)
   where
-    proxy :: Proxy (Consensus.ShelleyBlock ledgerera)
+    proxy :: Proxy (Consensus.ShelleyBlock protocol ledgerera)
     proxy = Proxy
 
 -- | Convert a 'Consensus.Point' for single Shelley-era block type
 --
-fromConsensusPoint :: forall ledgerera.
-                      Consensus.ShelleyBasedEra ledgerera
-                   => Consensus.Point (Consensus.ShelleyBlock ledgerera)
+fromConsensusPoint :: forall protocol ledgerera.
+                      Consensus.ShelleyCompatible protocol ledgerera
+                   => Consensus.Point (Consensus.ShelleyBlock protocol ledgerera)
                    -> ChainPoint
 fromConsensusPoint Consensus.GenesisPoint = ChainPointAtGenesis
 fromConsensusPoint (Consensus.BlockPoint slot h) =
     ChainPoint slot (HeaderHash (Consensus.toShortRawHash proxy h))
   where
-    proxy :: Proxy (Consensus.ShelleyBlock ledgerera)
+    proxy :: Proxy (Consensus.ShelleyBlock protocol ledgerera)
     proxy = Proxy
 
 chainPointToSlotNo :: ChainPoint -> Maybe SlotNo
@@ -439,11 +445,11 @@ fromConsensusTip ByronMode = conv
 
 fromConsensusTip ShelleyMode = conv
   where
-    conv :: Consensus.Tip (Consensus.ShelleyBlockHFC Consensus.StandardShelley)
+    conv :: Consensus.Tip (Consensus.ShelleyBlockHFC (Consensus.TPraos Consensus.StandardCrypto) Consensus.StandardShelley)
          -> ChainTip
     conv Consensus.TipGenesis = ChainTipAtGenesis
-    conv (Consensus.Tip slot (Consensus.OneEraHash h) block) =
-      ChainTip slot (HeaderHash h) block
+    conv (Consensus.Tip slot (Consensus.OneEraHash hashSBS) block) =
+      ChainTip slot (HeaderHash hashSBS) block
 
 fromConsensusTip CardanoMode = conv
   where

cardano-api/src/Cardano/Api/IPC.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -91,6 +92,14 @@ import           Control.Concurrent.STM (TMVar, atomically, newEmptyTMVarIO, put
 import           Control.Monad (void)
 import           Control.Tracer (nullTracer)
 
+import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus
+import qualified Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork as Consensus
+import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus
+import           Ouroboros.Consensus.Protocol.Praos.Translate ()
+import qualified Ouroboros.Consensus.Shelley.Eras as Consensus
+import           Ouroboros.Consensus.Shelley.Ledger.Block
+import           Ouroboros.Consensus.Shelley.Node ()
+import           Ouroboros.Consensus.Shelley.ShelleyHFC ()
 import qualified Ouroboros.Network.Block as Net
 import qualified Ouroboros.Network.Mux as Net
 import           Ouroboros.Network.NodeToClient (NodeToClientProtocols (..),
@@ -112,13 +121,18 @@ import           Ouroboros.Network.Protocol.LocalTxSubmission.Client (LocalTxSub
 import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Client as Net.Tx
 import           Ouroboros.Network.Util.ShowProxy (ShowProxy (..))
 
+import qualified Cardano.Ledger.Crypto as Ledger
 import qualified Ouroboros.Consensus.Block as Consensus
 import qualified Ouroboros.Consensus.Ledger.Query as Consensus
 import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Consensus
 import qualified Ouroboros.Consensus.Network.NodeToClient as Consensus
 import qualified Ouroboros.Consensus.Node.NetworkProtocolVersion as Consensus
 import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus
 import qualified Ouroboros.Consensus.Node.Run as Consensus
+import qualified Ouroboros.Consensus.Protocol.Praos as Praos
+import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos
+import qualified Ouroboros.Consensus.Protocol.Translate as Consensus
+import qualified Ouroboros.Consensus.Shelley.Eras as Consensus
 
 import           Cardano.Api.Block
 import           Cardano.Api.HasTypeProxy
@@ -352,7 +366,7 @@ data LocalNodeClientParams where
            ShowProxy block, ShowProxy (Consensus.ApplyTxErr block),
            ShowProxy (Consensus.GenTx block), ShowProxy (Consensus.Query block),
            Consensus.ShowQuery (Consensus.Query block),
-           ProtocolClient block
+           ProtocolClient block--, Consensus.LedgerSupportsProtocol block
            )
        => ProtocolClientInfoArgs block
        -> (NodeToClientVersion -> LocalNodeClientProtocolsForBlock block)
@@ -382,7 +396,6 @@ data LocalNodeClientProtocolsForBlock block =
                                         SlotNo IO ())
      }
 
-
 -- | Convert from the mode-parametrised style to the block-parametrised style.
 --
 mkLocalNodeClientParams :: forall mode block.
@@ -403,22 +416,21 @@ mkLocalNodeClientParams modeparams clients =
     -- block type monomorphic.
     --
     case modeparams of
-      ByronModeParams epochSlots ->
-        LocalNodeClientParams
-          (ProtocolClientInfoArgsByron epochSlots)
-          (convLocalNodeClientProtocols ByronMode . clients)
+      ByronModeParams epochSlots -> error "TODO: Babbage"
+        -- LocalNodeClientParams
+        --   (ProtocolClientInfoArgsByron epochSlots)
+        --   (convLocalNodeClientProtocols ByronMode . clients)
 
-      ShelleyModeParams ->
-        LocalNodeClientParams
-          ProtocolClientInfoArgsShelley
-          (convLocalNodeClientProtocols ShelleyMode . clients)
+      ShelleyModeParams -> error "TODO: Babbage"
+        -- LocalNodeClientParams
+        --   ProtocolClientInfoArgsShelley
+        --   (convLocalNodeClientProtocols ShelleyMode . clients)
 
       CardanoModeParams epochSlots ->
         LocalNodeClientParams
           (ProtocolClientInfoArgsCardano epochSlots)
           (convLocalNodeClientProtocols CardanoMode . clients)
 
-
 convLocalNodeClientProtocols :: forall mode block.
                                 ConsensusBlockForMode mode ~ block
                              => ConsensusMode mode
@@ -556,8 +568,8 @@ mapLocalTxMonitoringClient convTxid convTx ltxmc =
 -- | Establish a connection to a node and execute a single query using the
 -- local state query protocol.
 --
-queryNodeLocalState :: forall mode result.
-                       LocalNodeConnectInfo mode
+queryNodeLocalState :: forall mode result. Consensus.CardanoHardForkConstraints Consensus.StandardCrypto
+                     => LocalNodeConnectInfo mode
                     -> Maybe ChainPoint
                     -> QueryInMode mode result
                     -> IO (Either Net.Query.AcquireFailure result)
@@ -597,8 +609,8 @@ queryNodeLocalState connctInfo mpoint query = do
               pure $ Net.Query.SendMsgDone ()
           }
 
-submitTxToNodeLocal :: forall mode.
-                       LocalNodeConnectInfo mode
+submitTxToNodeLocal :: forall mode. Consensus.CardanoHardForkConstraints Consensus.StandardCrypto
+                    => LocalNodeConnectInfo mode
                     -> TxInMode mode
                     -> IO (Net.Tx.SubmitResult (TxValidationErrorInMode mode))
 submitTxToNodeLocal connctInfo tx = do

cardano-api/src/Cardano/Api/InMode.hs

@@ -33,13 +33,14 @@ import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus
 import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch)
 import qualified Ouroboros.Consensus.HardFork.Combinator.Degenerate as Consensus
 import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Consensus
+import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus
 import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
 import qualified Ouroboros.Consensus.TypeFamilyWrappers as Consensus
 
 import           Cardano.Api.Eras
 import           Cardano.Api.Modes
 import           Cardano.Api.Tx
-import           Cardano.Api.TxBody
+import           Cardano.Api.TxBody (TxId, toByronTxId, toShelleyTxId)
 
 
 -- ----------------------------------------------------------------------------
@@ -96,6 +97,10 @@ fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (
   let Consensus.ShelleyTx _txid shelleyEraTx = tx'
   in TxInMode (ShelleyTx ShelleyBasedEraAlonzo shelleyEraTx) AlonzoEraInCardanoMode
 
+fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx')))))))) =
+  let Consensus.ShelleyTx _txid shelleyEraTx = tx'
+  in TxInMode (ShelleyTx ShelleyBasedEraBabbage shelleyEraTx) BabbageEraInCardanoMode
+
 toConsensusGenTx :: ConsensusBlockForMode mode ~ block
                  => TxInMode mode
                  -> Consensus.GenTx block
@@ -142,10 +147,10 @@ toConsensusGenTx (TxInMode (ShelleyTx _ tx) AlonzoEraInCardanoMode) =
   where
     tx' = Consensus.mkShelleyTx tx
 
-toConsensusGenTx (TxInMode (ShelleyTx _ _tx) BabbageEraInCardanoMode) =
-    Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (Z tx'))))))
+toConsensusGenTx (TxInMode (ShelleyTx _ tx) BabbageEraInCardanoMode) =
+    Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx')))))))
   where
-    tx' = error "TODO: Babbage era - depends on consensus exposing a babbage era" -- Consensus.mkShelleyTx tx
+    tx' = Consensus.mkShelleyTx tx
 
 -- ----------------------------------------------------------------------------
 -- Transaction ids in the context of a consensus mode
@@ -171,9 +176,9 @@ toConsensusTxId (TxIdInMode txid ByronEraInByronMode) =
   txid' = Consensus.ByronTxId $ toByronTxId txid
 
 toConsensusTxId (TxIdInMode t ShelleyEraInShelleyMode) =
-  Consensus.HardForkGenTxId $ Consensus.OneEraGenTxId  $ Z  (Consensus.WrapGenTxId txid')
+    Consensus.HardForkGenTxId $ Consensus.OneEraGenTxId  $ Z  (Consensus.WrapGenTxId txid')
  where
-  txid' :: Consensus.TxId (Consensus.GenTx (Consensus.ShelleyBlock Consensus.StandardShelley))
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardShelleyBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId t
 
 toConsensusTxId (TxIdInMode txid ByronEraInCardanoMode) =
@@ -185,25 +190,25 @@ toConsensusTxId (TxIdInMode txid ByronEraInCardanoMode) =
 toConsensusTxId (TxIdInMode txid ShelleyEraInCardanoMode) =
   Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (Z (Consensus.WrapGenTxId txid'))))
  where
-  txid' :: Consensus.TxId (Consensus.GenTx (Consensus.ShelleyBlock Consensus.StandardShelley))
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardShelleyBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
 toConsensusTxId (TxIdInMode txid AllegraEraInCardanoMode) =
   Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (Z (Consensus.WrapGenTxId txid')))))
  where
-  txid' :: Consensus.TxId (Consensus.GenTx (Consensus.ShelleyBlock Consensus.StandardAllegra))
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardAllegraBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
 toConsensusTxId (TxIdInMode txid MaryEraInCardanoMode) =
   Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (Z (Consensus.WrapGenTxId txid'))))))
  where
-  txid' :: Consensus.TxId (Consensus.GenTx (Consensus.ShelleyBlock Consensus.StandardMary))
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardMaryBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
 toConsensusTxId (TxIdInMode txid AlonzoEraInCardanoMode) =
   Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (S (Z (Consensus.WrapGenTxId txid')))))))
  where
-  txid' :: Consensus.TxId (Consensus.GenTx (Consensus.ShelleyBlock Consensus.StandardAlonzo))
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardAlonzoBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
 toConsensusTxId (TxIdInMode _txid BabbageEraInCardanoMode) =
@@ -224,7 +229,7 @@ data TxValidationError era where
 
      ShelleyTxValidationError
        :: ShelleyBasedEra era
-       -> Consensus.ApplyTxErr (Consensus.ShelleyBlock (ShelleyLedgerEra era))
+       -> Consensus.ApplyTxErr (Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era))
        -> TxValidationError era
 
 -- The GADT in the ShelleyTxValidationError case requires a custom instance
@@ -290,10 +295,10 @@ fromConsensusApplyTxErr ByronMode (Consensus.DegenApplyTxErr err) =
       (ByronTxValidationError err)
       ByronEraInByronMode
 
-fromConsensusApplyTxErr ShelleyMode (Consensus.DegenApplyTxErr err) =
-    TxValidationErrorInMode
-      (ShelleyTxValidationError ShelleyBasedEraShelley err)
-      ShelleyEraInShelleyMode
+fromConsensusApplyTxErr ShelleyMode _  = error "TODO: Babbge (Consensus.DegenApplyTxErr err)"
+    --TxValidationErrorInMode
+    --  (ShelleyTxValidationError ShelleyBasedEraShelley err)
+    --  ShelleyEraInShelleyMode
 
 fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrByron err) =
     TxValidationErrorInMode
@@ -323,3 +328,4 @@ fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrAlonzo err) =
 fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrWrongEra err) =
     TxValidationEraMismatch err
 
+fromConsensusApplyTxErr CardanoMode _ = error "TODO: Babbage"