WIP: push the changes

IntersectMBO · Jan 10, 2022 · 7a1d148 · 7a1d148
1 parent 9ad036a
commit 7a1d148
Show file tree

Hide file tree

Showing 10 changed files with 170 additions and 81 deletions.
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Basics.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Basics.hs
@@ -11,6 +11,7 @@
 {-# LANGUAGE StandaloneDeriving    #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 -- | Definition is 'IsLedger'
 --
@@ -57,6 +58,8 @@ module Ouroboros.Consensus.Ledger.Basics (
   , InMemory (..)
     -- * Misc
   , ShowLedgerState (..)
+    -- * Javier
+  , OldVsNew (..)
   ) where
 
 import           Data.Kind (Type)
@@ -378,6 +381,9 @@ type LedgerConfig      blk    = LedgerCfg (LedgerState blk)
 type LedgerError       blk    = LedgerErr (LedgerState blk)
 type TickedLedgerState blk mk = Ticked1   (LedgerState blk) mk
 
+class OldVsNew a b where
+  oldVsNew :: a -> b -> Bool
+
 {-------------------------------------------------------------------------------
   UTxO HD stubs
 -------------------------------------------------------------------------------}

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/Impl.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/Impl.hs
@@ -127,7 +127,7 @@ data LedgerInterface m blk = LedgerInterface
 
 -- | Create a 'LedgerInterface' from a 'ChainDB'.
 chainDBLedgerInterface ::
-     (IOLike m, IsLedger (LedgerState blk))
+     IOLike m
   => ChainDB m blk -> LedgerInterface m blk
 chainDBLedgerInterface chainDB = LedgerInterface
     { getCurrentLedgerState = ledgerState <$> ChainDB.getCurrentLedger chainDB

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs
@@ -9,6 +9,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving  #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE FlexibleContexts    #-}
 -- | Run the whole Node
 --
 -- Intended for qualified import.
@@ -89,7 +90,8 @@ import           Ouroboros.Consensus.Config.SupportsNode
 import           Ouroboros.Consensus.Fragment.InFuture (CheckInFuture,
                      ClockSkew)
 import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
-import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..), MapKind (EmptyMK))
+import           Ouroboros.Consensus.Ledger.Basics (GetTip, OldVsNew)
+import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..), MapKind (..))
 import qualified Ouroboros.Consensus.Network.NodeToClient as NTC
 import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
 import           Ouroboros.Consensus.Node.DbLock
@@ -118,6 +120,7 @@ import           Ouroboros.Consensus.Storage.ImmutableDB (ChunkInfo,
                      ValidationPolicy (..))
 import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
                      (SnapshotInterval (..), defaultDiskPolicy)
+import qualified Ouroboros.Consensus.Storage.LedgerDB.OnDisk as LgrDB
 import           Ouroboros.Consensus.Storage.VolatileDB
                      (BlockValidationPolicy (..))
 
@@ -261,7 +264,7 @@ deriving instance Show (NetworkP2PMode p2p)
 
 -- | Combination of 'runWith' and 'stdLowLevelRunArgsIO'
 run :: forall blk p2p.
-     RunNode blk
+     (RunNode blk, GetTip (LgrDB.LedgerDB' blk), OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK))
   => RunNodeArgs IO RemoteAddress LocalAddress blk p2p
   -> StdRunNodeArgs IO blk p2p
   -> IO ()
@@ -277,6 +280,8 @@ runWith :: forall m addrNTN addrNTC versionDataNTN versionDataNTC blk p2p.
      ( RunNode blk
      , IOLike m, MonadTime m, MonadTimer m
      , Hashable addrNTN, Ord addrNTN, Typeable addrNTN
+     , GetTip (LgrDB.LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => RunNodeArgs m addrNTN addrNTC blk p2p
   -> LowLevelRunNodeArgs m addrNTN addrNTC versionDataNTN versionDataNTC blk p2p
@@ -521,7 +526,7 @@ stdWithCheckedDB pb databasePath networkMagic body = do
     hasFS      = ioHasFS mountPoint
 
 openChainDB
-  :: forall m blk. (RunNode blk, IOLike m)
+  :: forall m blk. (RunNode blk, IOLike m, GetTip (LgrDB.LedgerDB' blk), OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK))
   => ResourceRegistry m
   -> CheckInFuture m blk
   -> TopLevelConfig blk

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/API.hs
@@ -341,7 +341,7 @@ getTipBlockNo = fmap Network.getTipBlockNo . getCurrentTip
 
 -- | Get current ledger
 getCurrentLedger ::
-     (Monad (STM m), IsLedger (LedgerState blk))
+     Monad (STM m)
   => ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
 getCurrentLedger = fmap LedgerDB.ledgerDbCurrent . getLedgerDB
 
@@ -374,6 +374,7 @@ getHeaderStateHistory = fmap toHeaderStateHistory . getLedgerDB
     toHeaderStateHistory =
           HeaderStateHistory
         . LedgerDB.ledgerDbBimap headerState headerState
+        . LedgerDB.ledgerDbCheckpoints
 
 {-------------------------------------------------------------------------------
   Adding a block

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE PatternSynonyms          #-}
 {-# LANGUAGE RecordWildCards          #-}
 {-# LANGUAGE ScopedTypeVariables      #-}
+{-# LANGUAGE DataKinds                #-}
 
 module Ouroboros.Consensus.Storage.ChainDB.Impl (
     -- * Initialization
@@ -41,6 +42,8 @@ import           Data.Functor ((<&>))
 import           Data.Functor.Identity (Identity)
 import qualified Data.Map.Strict as Map
 import           GHC.Stack (HasCallStack)
+import           System.Environment (lookupEnv)
+import           System.IO.Unsafe (unsafePerformIO)
 
 import qualified Ouroboros.Network.AnchoredFragment as AF
 
@@ -72,6 +75,9 @@ import           Ouroboros.Consensus.Storage.ChainDB.Impl.Types
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 
+import           Ouroboros.Consensus.Ledger.Basics (GetTip, OldVsNew, MapKind(..))
+import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState)
+
 {-------------------------------------------------------------------------------
   Initialization
 -------------------------------------------------------------------------------}
@@ -84,6 +90,8 @@ withDB
      , HasHardForkHistory blk
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
+     , GetTip (LgrDB.LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => ChainDbArgs Identity m blk
   -> (ChainDB m blk -> m a)
@@ -98,6 +106,8 @@ openDB
      , HasHardForkHistory blk
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
+     , GetTip (LgrDB.LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => ChainDbArgs Identity m blk
   -> m (ChainDB m blk)
@@ -111,6 +121,8 @@ openDBInternal
      , HasHardForkHistory blk
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
+     , GetTip (LgrDB.LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => ChainDbArgs Identity m blk
   -> Bool -- ^ 'True' = Launch background tasks
@@ -150,6 +162,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
 
       let initChainSelTracer = contramap TraceInitChainSelEvent tracer
 
+      let runDual = maybe False (== "1") $ unsafePerformIO (lookupEnv "DUAL_LEDGER")
       traceWith initChainSelTracer StartedInitChainSelection
       chainAndLedger <- ChainSel.initialChainSelection
                           immutableDB

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE PatternSynonyms     #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DataKinds           #-}
 
 -- | Background tasks:
 --
@@ -58,6 +59,7 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.HardFork.Abstract
 import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.Inspect
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Protocol.Abstract
@@ -89,6 +91,8 @@ launchBgTasks
      , InspectLedger blk
      , HasHardForkHistory blk
      , LgrDbSerialiseConstraints blk
+     , GetTip (LgrDB.LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => ChainDbEnv m blk
   -> Word64 -- ^ Number of immutable blocks replayed on ledger DB startup
@@ -538,6 +542,8 @@ addBlockRunner
      , InspectLedger blk
      , HasHardForkHistory blk
      , HasCallStack
+     , GetTip (LgrDB.LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => ChainDbEnv m blk
   -> m Void

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
@@ -87,7 +87,7 @@ import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 --
 -- See "## Initialization" in ChainDB.md.
 initialChainSelection
-  :: forall m blk. (IOLike m, LedgerSupportsProtocol blk)
+  :: forall m blk. (IOLike m, LedgerSupportsProtocol blk, GetTip (LedgerDB' blk), OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK))
   => ImmutableDB m blk
   -> VolatileDB m blk
   -> LgrDB m blk
@@ -244,6 +244,8 @@ addBlockSync
      , InspectLedger blk
      , HasHardForkHistory blk
      , HasCallStack
+     , GetTip (LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => ChainDbEnv m blk
   -> BlockToAdd m blk
@@ -358,6 +360,8 @@ chainSelectionForFutureBlocks
      , InspectLedger blk
      , HasHardForkHistory blk
      , HasCallStack
+     , GetTip (LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
 chainSelectionForFutureBlocks cdb@CDB{..} blockCache = do
@@ -416,6 +420,8 @@ chainSelectionForBlock
      , InspectLedger blk
      , HasHardForkHistory blk
      , HasCallStack
+     , GetTip (LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => ChainDbEnv m blk
   -> BlockCache blk
@@ -774,7 +780,8 @@ chainSelection
      ( IOLike m
      , LedgerSupportsProtocol blk
      , HasCallStack
-     )
+     , GetTip (LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK))
   => ChainSelEnv m blk
   -> NonEmpty (ChainDiff (Header blk))
   -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
@@ -911,6 +918,8 @@ ledgerValidateCandidate
      ( IOLike m
      , LedgerSupportsProtocol blk
      , HasCallStack
+     , GetTip (LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => ChainSelEnv m blk
   -> ChainDiff (Header blk)
@@ -964,7 +973,7 @@ ledgerValidateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) =
 --
 -- When truncation happened, 'Left' is returned, otherwise 'Right'.
 futureCheckCandidate
-  :: forall m blk. (IOLike m, LedgerSupportsProtocol blk)
+  :: forall m blk. (IOLike m, LedgerSupportsProtocol blk, GetTip (LedgerDB' blk))
   => ChainSelEnv m blk
   -> ValidatedChainDiff (Header blk) (LedgerDB' blk)
   -> m (Either (ChainDiff (Header blk))
@@ -1027,6 +1036,8 @@ validateCandidate
   :: ( IOLike m
      , LedgerSupportsProtocol blk
      , HasCallStack
+     , GetTip (LedgerDB' blk)
+     , OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK)
      )
   => ChainSelEnv m blk
   -> ChainDiff (Header blk)

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
@@ -329,11 +329,9 @@ getCurrent LgrDB{..} = readTVar varDB
 setCurrent :: IOLike m => LgrDB m blk -> LedgerDB' blk -> STM m ()
 setCurrent LgrDB{..} = writeTVar $! varDB
 
-currentPoint :: forall blk. UpdateLedger blk => LedgerDB' blk -> Point blk
+currentPoint :: LedgerSupportsProtocol blk => LedgerDB' blk -> Point blk
 currentPoint = castPoint
-             . ledgerTipPoint (Proxy @blk)
-             . ledgerState
-             . LedgerDB.ledgerDbCurrent
+             . LedgerDB.ledgerDbTip
 
 takeSnapshot ::
      forall m blk.
@@ -390,7 +388,7 @@ data ValidateResult blk =
   | ValidateLedgerError      (AnnLedgerError' blk)
   | ValidateExceededRollBack ExceededRollback
 
-validate :: forall m blk. (IOLike m, LedgerSupportsProtocol blk, HasCallStack)
+validate :: forall m blk. (OldVsNew (ExtLedgerState blk ValuesMK) (ExtLedgerState blk TrackingMK), IOLike m, LedgerSupportsProtocol blk, HasCallStack)
          => LgrDB m blk
          -> LedgerDB' blk
             -- ^ This is used as the starting point for validation, not the one