Cardano

IntersectMBO · Nov 28, 2023 · e6d6d3b · e6d6d3b
1 parent 9b18cb6
commit e6d6d3b
Show file tree

Hide file tree

Showing 9 changed files with 513 additions and 47 deletions.
diff --git a/ouroboros-consensus-cardano-legacy-block/ouroboros-consensus-cardano-legacy-block.cabal b/ouroboros-consensus-cardano-legacy-block/ouroboros-consensus-cardano-legacy-block.cabal
@@ -54,6 +54,7 @@ library
     Legacy.Cardano.CanHardFork
     Legacy.Cardano.CanonicalTxIn
     Legacy.Cardano.Ledger
+    Legacy.Cardano.Node
     Legacy.Convert
     Legacy.Shelley
     Legacy.Shelley.Ledger
@@ -67,7 +68,6 @@ library
     , bytestring
     , cardano-binary
     , cardano-crypto-class
-    , cardano-ledger-allegra
     , cardano-ledger-alonzo
     , cardano-ledger-babbage
     , cardano-ledger-byron

diff --git a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano.hs b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano.hs
@@ -5,8 +5,9 @@ module Legacy.Cardano (
   , LegacyCardanoShelleyEras
   ) where
 
-import           Legacy.Byron.Ledger ()
+import           Legacy.Byron ()
 import           Legacy.Cardano.Block
 import           Legacy.Cardano.CanHardFork
 import           Legacy.Cardano.Ledger ()
-import           Legacy.Shelley.Ledger ()
+import           Legacy.Cardano.Node ()
+import           Legacy.Shelley ()
diff --git a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Block.hs b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Block.hs
@@ -1,20 +1,44 @@
 {-# LANGUAGE DataKinds                #-}
+{-# LANGUAGE PatternSynonyms          #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE ViewPatterns             #-}
 
 module Legacy.Cardano.Block (
-    LegacyCardanoBlock
-  , LegacyCardanoEras
+    -- * The eras of the Cardano blockchain
+    LegacyCardanoEras
   , LegacyCardanoShelleyEras
+    -- * The block type of the Cardano blockchain
+  , LegacyCardanoBlock
+  , pattern LegacyCardanoBlock
+    -- * Generalised transactions
+  , LegacyCardanoApplyTxErr
+  , LegacyCardanoGenTx
+  , LegacyCardanoGenTxId
+  , pattern LegacyCardanoApplyTxErr
+  , pattern LegacyCardanoGenTx
+  , pattern LegacyCardanoGenTxId
+    -- * LedgerConfig
+  , LegacyCardanoLedgerConfig
+  , pattern LegacyCardanoLedgerConfig
   ) where
 
 import           Data.Kind
+import           Data.SOP.Strict
 import           Ouroboros.Consensus.Byron.Ledger.Block
 import           Ouroboros.Consensus.Cardano.Block
+import           Ouroboros.Consensus.HardFork.Combinator
+import           Ouroboros.Consensus.HardFork.Trans
+import           Ouroboros.Consensus.Ledger.SupportsMempool
 import           Ouroboros.Consensus.Legacy.Block
 import           Ouroboros.Consensus.Protocol.Praos
 import           Ouroboros.Consensus.Protocol.TPraos
 import           Ouroboros.Consensus.Shelley.Ledger
+import           Ouroboros.Consensus.TypeFamilyWrappers
+
+{-------------------------------------------------------------------------------
+  The eras of the Cardano blockchain
+-------------------------------------------------------------------------------}
 
 type LegacyCardanoEras :: Type -> [Type]
 type LegacyCardanoEras c =  LegacyBlock ByronBlock
@@ -30,4 +54,54 @@ type LegacyCardanoShelleyEras c =
    , LegacyBlock (ShelleyBlock (Praos c)  (ConwayEra c))
    ]
 
+{-------------------------------------------------------------------------------
+  The block type of the Cardano blockchain
+-------------------------------------------------------------------------------}
+
 type LegacyCardanoBlock c = LegacyBlock (HardForkBlock (LegacyCardanoEras c))
+
+{-# COMPLETE LegacyCardanoBlock #-}
+
+pattern LegacyCardanoBlock :: CardanoBlock c -> LegacyCardanoBlock c
+pattern LegacyCardanoBlock b <- ( hcoerce_HardForkBlock . getLegacyBlock -> b)
+  where LegacyCardanoBlock b = LegacyBlock . hcoerce_HardForkBlock $ b
+
+{-------------------------------------------------------------------------------
+  Generalised transactions
+-------------------------------------------------------------------------------}
+
+type LegacyCardanoGenTx c = GenTx (LegacyCardanoBlock c)
+
+{-# COMPLETE LegacyCardanoGenTx #-}
+
+pattern LegacyCardanoGenTx :: CardanoGenTx c -> LegacyCardanoGenTx c
+pattern LegacyCardanoGenTx gentx <- (hcoerce_GenTx . getLegacyGenTx -> gentx)
+  where LegacyCardanoGenTx gentx = LegacyGenTx . hcoerce_GenTx $ gentx
+
+type LegacyCardanoGenTxId c = GenTxId (LegacyCardanoBlock c)
+
+{-# COMPLETE LegacyCardanoGenTxId #-}
+
+pattern LegacyCardanoGenTxId :: CardanoGenTxId c -> LegacyCardanoGenTxId c
+pattern LegacyCardanoGenTxId gtxid <- (hcoerce_GenTxId . getLegacyGenTxId -> gtxid)
+  where LegacyCardanoGenTxId gtxid = LegacyGenTxId . hcoerce_GenTxId $ gtxid
+
+type LegacyCardanoApplyTxErr c = HardForkApplyTxErr (LegacyCardanoEras c)
+
+{-# COMPLETE LegacyCardanoApplyTxErr #-}
+
+pattern LegacyCardanoApplyTxErr :: CardanoApplyTxErr c -> LegacyCardanoApplyTxErr c
+pattern LegacyCardanoApplyTxErr err <- (hcoerce_ApplyTxErr -> err)
+  where LegacyCardanoApplyTxErr err = hcoerce_ApplyTxErr err
+
+{-------------------------------------------------------------------------------
+  LedgerConfig
+-------------------------------------------------------------------------------}
+
+type LegacyCardanoLedgerConfig c = HardForkLedgerConfig (LegacyCardanoEras c)
+
+{-# COMPLETE LegacyCardanoLedgerConfig #-}
+
+pattern LegacyCardanoLedgerConfig :: CardanoLedgerConfig c -> LegacyCardanoLedgerConfig c
+pattern LegacyCardanoLedgerConfig cfg <- (hcoerce_LedgerConfig -> cfg)
+  where LegacyCardanoLedgerConfig cfg = hcoerce_LedgerConfig cfg
diff --git a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/CanHardFork.hs
@@ -17,8 +17,6 @@
 module Legacy.Cardano.CanHardFork (LegacyCardanoHardForkConstraints) where
 
 import           Cardano.Crypto.Hash.Blake2b (Blake2b_224, Blake2b_256)
-import           Cardano.Ledger.Allegra.Translation
-                     (shelleyToAllegraAVVMsToDelete)
 import           Cardano.Ledger.Alonzo.Translation ()
 import           Cardano.Ledger.Babbage.Translation ()
 import           Cardano.Ledger.Conway.Translation ()
@@ -337,36 +335,14 @@ translateLedgerStateShelleyToAllegraWrapper ::
 translateLedgerStateShelleyToAllegraWrapper =
     ignoringBoth $
       TranslateLedgerState {
-          translateLedgerStateWith = \_epochNo (LegacyLedgerState ls) -> LegacyLedgerState $
-              -- In the Shelley to Allegra transition, the AVVM addresses have
-              -- to be deleted, and their balance has to be moved to the
-              -- reserves. For this matter, the Ledger keeps track of these
-              -- small set of entries since the Byron to Shelley transition and
-              -- provides them to us through 'shelleyToAllegraAVVMsToDelete'.
-              --
-              -- In the long run, the ledger will already use ledger states
-              -- parametrized by the map kind and therefore will already provide
-              -- the differences in this translation.
-              let avvms           = SL.unUTxO
-                                  $ shelleyToAllegraAVVMsToDelete
-                                  $ shelleyLedgerState ls
-
-                  -- This 'stowLedgerTables' + 'withLedgerTables' injects the
-                  -- values provided by the Ledger so that the translation
-                  -- operation finds those entries in the UTxO and destroys
-                  -- them, modifying the reserves accordingly.
-                  stowedState = stowLedgerTables
-                              . withLedgerTables ls
-                              . LedgerTables
-                              . ValuesMK
-                              $ avvms
-
-                  resultingState = unFlip . unComp
-                                 . SL.translateEra' ()
-                                 . Comp   . Flip
-                                 $ stowedState
-
-              in resultingState `withLedgerTables` emptyLedgerTables
+          translateLedgerStateWith = \_epochNo ->
+                LegacyLedgerState
+              . unFlip
+              . unComp
+              . SL.translateEra' ()
+              . Comp
+              . Flip
+              . getLegacyLedgerState
         }
 
 translateTxShelleyToAllegraWrapper ::
@@ -415,8 +391,6 @@ translateLedgerStateAllegraToMaryWrapper =
       TranslateLedgerState {
           translateLedgerStateWith = \_epochNo ->
                 LegacyLedgerState
-              . forgetLedgerTables
-              . noNewTickingDiffs
               . unFlip
               . unComp
               . SL.translateEra' ()
@@ -471,8 +445,6 @@ translateLedgerStateMaryToAlonzoWrapper =
       TranslateLedgerState {
           translateLedgerStateWith = \_epochNo ->
                 LegacyLedgerState
-              . forgetLedgerTables
-              . noNewTickingDiffs
               . unFlip
               . unComp
               . SL.translateEra' (getAlonzoTranslationContext cfgAlonzo)
@@ -536,8 +508,6 @@ translateLedgerStateAlonzoToBabbageWrapper =
       TranslateLedgerState {
           translateLedgerStateWith = \_epochNo ->
                 LegacyLedgerState
-              . forgetLedgerTables
-              . noNewTickingDiffs
               . unFlip
               . unComp
               . SL.translateEra' ()
@@ -623,8 +593,6 @@ translateLedgerStateBabbageToConwayWrapper =
       TranslateLedgerState {
           translateLedgerStateWith = \_epochNo ->
                 LegacyLedgerState
-              . forgetLedgerTables
-              . noNewTickingDiffs
               . unFlip
               . unComp
               . SL.translateEra' (getConwayTranslationContext cfgConway)

diff --git a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Ledger.hs b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Ledger.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE EmptyCase             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE InstanceSigs          #-}
@@ -20,6 +21,8 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Cardano ()
 import           Ouroboros.Consensus.Cardano.Block
 import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Ledger.Query
+                     (BlockSupportsLedgerQuery (..))
 import           Ouroboros.Consensus.Ledger.Tables.Utils
 import           Ouroboros.Consensus.Legacy.Block
 
@@ -133,3 +136,13 @@ instance LegacyCardanoHardForkConstraints c
         LegacyCardanoBlock c
     -> LedgerTables (LedgerState (LegacyCardanoBlock c)) KeysMK
   getBlockKeySets = const trivialLedgerTables
+
+{-------------------------------------------------------------------------------
+  Queries
+-------------------------------------------------------------------------------}
+
+instance LegacyCardanoHardForkConstraints c
+      => BlockSupportsLedgerQuery (LegacyCardanoBlock c) where
+  answerPureBlockQuery _ = undefined -- TODO
+  answerBlockQueryLookup _cfg q _dlv = case q of {}
+  answerBlockQueryTraverse _cfg q _dlv = case q of {}