diff --git a/ouroboros-consensus-cardano/app/snapshot-converter.hs b/ouroboros-consensus-cardano/app/snapshot-converter.hs index 6802074a06..e2f53b008d 100644 --- a/ouroboros-consensus-cardano/app/snapshot-converter.hs +++ b/ouroboros-consensus-cardano/app/snapshot-converter.hs @@ -1,60 +1,16 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} module Main (main) where import Cardano.Crypto.Init (cryptoInit) import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo) -import Codec.Serialise -import qualified Control.Monad as Monad import Control.Monad.Except -import Control.Monad.Trans (lift) -import Control.ResourceRegistry import DBAnalyser.Parsers -import Data.Bifunctor -import Data.Char (toLower) -import qualified Data.Text.Lazy as T import Main.Utf8 import Options.Applicative import Options.Applicative.Help (Doc, line) -import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Cardano.Block -import Ouroboros.Consensus.Cardano.StreamingLedgerTables -import Ouroboros.Consensus.Config -import Ouroboros.Consensus.Ledger.Basics -import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Node.ProtocolInfo -import Ouroboros.Consensus.Storage.LedgerDB.API -import Ouroboros.Consensus.Storage.LedgerDB.Snapshots -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as V1 -import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM -import Ouroboros.Consensus.Util.CRC -import Ouroboros.Consensus.Util.IOLike hiding (yield) -import System.Console.ANSI -import qualified System.Directory as D +import Ouroboros.Consensus.Cardano.SnapshotConversion import System.Exit -import System.FS.API -import System.FS.CRC -import System.FS.IO -import System.FilePath (splitDirectories) -import qualified System.FilePath as F -import System.IO -import System.ProgressBar -import System.Random - -data Format - = Mem FilePath - | LMDB FilePath - | LSM FilePath FilePath - deriving (Show, Read) data Config = Config { from :: Format @@ -168,402 +124,14 @@ parsePath optName strHelp = ] ) -data Error blk - = SnapshotError (SnapshotFailure blk) - | BadDirectoryName FilePath - | WrongSlotDirectoryName FilePath SlotNo - | InvalidMetadata String - | BackendMismatch SnapshotBackend SnapshotBackend - | CRCMismatch CRC CRC - | ReadTablesError DeserialiseFailure - | Cancelled - deriving Exception - -instance StandardHash blk => Show (Error blk) where - show (SnapshotError err) = - "Couldn't deserialize the snapshot. Are you running the same node version that created the snapshot? " - <> show err - show (BadDirectoryName fp) = - mconcat - [ "Filepath " - , fp - , " is not an snapshot. The last fragment on the path should be" - , " named after the slot number of the state it contains and an" - , " optional suffix, such as `163470034` or `163470034_my-suffix`." - ] - show (InvalidMetadata s) = "Metadata is invalid: " <> s - show (BackendMismatch b1 b2) = - mconcat - [ "Mismatched backend in snapshot. Reading as " - , show b1 - , " but snapshot is " - , show b2 - ] - show (WrongSlotDirectoryName fp sl) = - mconcat - [ "The name of the snapshot (\"" - , fp - , "\") does not correspond to the slot number of the state (" - , (show . unSlotNo $ sl) - , ")." - ] - show (CRCMismatch c1 c2) = - mconcat - [ "The input snapshot seems corrupted. Metadata has CRC " - , show c1 - , " but reading it gives CRC " - , show c2 - ] - show (ReadTablesError df) = - mconcat - ["Error when reading entries in the UTxO tables: ", show df] - show Cancelled = "Cancelled" - -data InEnv backend = InEnv - { inState :: LedgerState (CardanoBlock StandardCrypto) EmptyMK - , inFilePath :: FilePath - , inStream :: - LedgerState (CardanoBlock StandardCrypto) EmptyMK -> - ResourceRegistry IO -> - IO (SomeBackend YieldArgs) - , inProgressMsg :: String - , inCRC :: CRC - , inSnapReadCRC :: Maybe CRC - } - -data SomeBackend c where - SomeBackend :: - StreamingBackend IO backend (LedgerState (CardanoBlock StandardCrypto)) => - c IO backend (LedgerState (CardanoBlock StandardCrypto)) -> SomeBackend c - -data OutEnv backend = OutEnv - { outFilePath :: FilePath - , outStream :: - LedgerState (CardanoBlock StandardCrypto) EmptyMK -> - ResourceRegistry IO -> - IO (SomeBackend SinkArgs) - , outCreateExtra :: Maybe FilePath - , outDeleteExtra :: Maybe FilePath - , outProgressMsg :: String - , outBackend :: SnapshotBackend - } - main :: IO () main = withStdTerminalHandles $ do - eRes <- runExceptT main' + cryptoInit + (conf, args) <- getCommandLineConfig + pInfo <- mkProtocolInfo args + eRes <- runExceptT (convertSnapshot True pInfo (from conf) (to conf)) case eRes of Left err -> do putStrLn $ show err exitFailure Right () -> exitSuccess - where - main' = do - lift $ cryptoInit - (conf, args) <- lift $ getCommandLineConfig - ccfg <- lift $ configCodec . pInfoConfig <$> mkProtocolInfo args - - InEnv{..} <- getInEnv ccfg (from conf) - - o@OutEnv{..} <- getOutEnv inState (to conf) - - wipeOutputPaths o - - lift $ putStr "Copying state file..." >> hFlush stdout - lift $ D.copyFile (inFilePath F. "state") (outFilePath F. "state") - lift $ putColored Green True "Done" - - lift $ putStr "Streaming ledger tables..." >> hFlush stdout >> saveCursor - - tid <- lift $ niceAnimatedProgressBar inProgressMsg outProgressMsg - - eRes <- lift $ runExceptT (stream inState inStream outStream) - - case eRes of - Left err -> throwError $ ReadTablesError err - Right (mCRCIn, mCRCOut) -> do - lift $ maybe (pure ()) cancel tid - lift $ clearLine >> restoreCursor >> cursorUp 1 >> putColored Green True "Done" - let crcIn = maybe inCRC (crcOfConcat inCRC) mCRCIn - maybe - ( lift $ - putColored Yellow True "The metadata file is missing, the snapshot is not guaranteed to be correct!" - ) - ( \cs -> - Monad.when (cs /= crcIn) $ throwError $ CRCMismatch cs crcIn - ) - inSnapReadCRC - - let crcOut = maybe inCRC (crcOfConcat inCRC) mCRCOut - - lift $ putStr "Generating new metadata file..." >> hFlush stdout - putMetadata outFilePath (SnapshotMetadata outBackend crcOut TablesCodecVersion1) - - lift $ putColored Green True "Done" - - wipeOutputPaths OutEnv{..} = do - wipePath outFilePath - lift $ maybe (pure ()) (D.createDirectory . (outFilePath F.)) outCreateExtra - maybe - (pure ()) - wipePath - outDeleteExtra - - getState ccfg fp@(pathToHasFS -> fs) = do - eState <- lift $ do - putStr $ "Reading ledger state from " <> (fp F. "state") <> "..." - hFlush stdout - runExceptT (readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (mkFsPath ["state"])) - case eState of - Left err -> - throwError . SnapshotError . InitFailureRead @(CardanoBlock StandardCrypto) . ReadSnapshotFailed $ - err - Right st -> lift $ do - putColored Green True " Done" - pure . first ledgerState $ st - - getMetadata fp bknd = do - (fs, ds) <- toDiskSnapshot fp - mtd <- - lift $ runExceptT $ loadSnapshotMetadata fs ds - (,ds) - <$> either - ( \case - MetadataFileDoesNotExist -> pure Nothing - MetadataInvalid s -> throwError $ InvalidMetadata s - MetadataBackendMismatch -> error "impossible" - ) - ( \mtd' -> do - if bknd /= snapshotBackend mtd' - then throwError $ BackendMismatch bknd (snapshotBackend mtd') - else pure $ Just $ snapshotChecksum mtd' - ) - mtd - - putMetadata fp bknd = do - (fs, ds) <- toDiskSnapshot fp - lift $ writeSnapshotMetadata fs ds bknd - - getInEnv ccfg = \case - Mem fp -> do - (mtd, ds) <- getMetadata fp UTxOHDMemSnapshot - (st, c) <- getState ccfg fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - ( withOrigin - ( error - "Impossible! the snapshot seems to be at Genesis but cardano-node would never create such an snapshot!" - ) - id - $ pointSlot (getTip st) - ) - ) - - pure $ - InEnv - st - fp - (\a b -> SomeBackend <$> mkInMemYieldArgs (fp F. "tables") a b) - ("InMemory@[" <> fp <> "]") - c - mtd - LMDB fp -> do - (mtd, ds) <- getMetadata fp UTxOHDLMDBSnapshot - (st, c) <- getState ccfg fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - (withOrigin undefined id $ pointSlot (getTip st)) - ) - - pure $ - InEnv - st - fp - (\a b -> SomeBackend <$> V1.mkLMDBYieldArgs (fp F. "tables") defaultLMDBLimits a b) - ("LMDB@[" <> fp <> "]") - c - mtd - LSM fp lsmDbPath -> do - (mtd, ds) <- getMetadata fp UTxOHDLSMSnapshot - (st, c) <- getState ccfg fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - (withOrigin undefined id $ pointSlot (getTip st)) - ) - - pure $ - InEnv - st - fp - ( \a b -> - SomeBackend <$> mkLSMYieldArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b - ) - ("LSM@[" <> lsmDbPath <> "]") - c - mtd - - getOutEnv st = \case - Mem fp -> do - (_, ds) <- toDiskSnapshot fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - (withOrigin undefined id $ pointSlot (getTip st)) - ) - pure $ - OutEnv - fp - (\a b -> SomeBackend <$> mkInMemSinkArgs (fp F. "tables") a b) - (Just "tables") - (Nothing) - ("InMemory@[" <> fp <> "]") - UTxOHDMemSnapshot - LMDB fp -> do - (_, ds) <- toDiskSnapshot fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - (withOrigin undefined id $ pointSlot (getTip st)) - ) - pure $ - OutEnv - fp - (\a b -> SomeBackend <$> V1.mkLMDBSinkArgs fp defaultLMDBLimits a b) - Nothing - Nothing - ("LMDB@[" <> fp <> "]") - UTxOHDLMDBSnapshot - LSM fp lsmDbPath -> do - (_, ds) <- toDiskSnapshot fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - (withOrigin undefined id $ pointSlot (getTip st)) - ) - pure $ - OutEnv - fp - ( \a b -> - SomeBackend <$> mkLSMSinkArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b - ) - Nothing - (Just lsmDbPath) - ("LSM@[" <> lsmDbPath <> "]") - UTxOHDLSMSnapshot - -stream :: - LedgerState (CardanoBlock StandardCrypto) EmptyMK -> - ( LedgerState (CardanoBlock StandardCrypto) EmptyMK -> - ResourceRegistry IO -> - IO (SomeBackend YieldArgs) - ) -> - ( LedgerState (CardanoBlock StandardCrypto) EmptyMK -> - ResourceRegistry IO -> - IO (SomeBackend SinkArgs) - ) -> - ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC) -stream st mYieldArgs mSinkArgs = - ExceptT $ - withRegistry $ \reg -> do - (SomeBackend (yArgs :: YieldArgs IO backend1 l)) <- mYieldArgs st reg - (SomeBackend (sArgs :: SinkArgs IO backend2 l)) <- mSinkArgs st reg - runExceptT $ yield (Proxy @backend1) yArgs st $ sink (Proxy @backend2) sArgs st - --- Helpers - --- UI -niceAnimatedProgressBar :: String -> String -> IO (Maybe (Async IO ())) -niceAnimatedProgressBar inMsg outMsg = do - stdoutSupportsANSI <- hNowSupportsANSI stdout - if stdoutSupportsANSI - then do - putStrLn "" - pb <- - newProgressBar - defStyle{stylePrefix = msg (T.pack inMsg), stylePostfix = msg (T.pack outMsg)} - 10 - (Progress 1 100 ()) - - fmap Just $ - async $ - let loop = do - threadDelay 0.2 - updateProgress pb (\prg -> prg{progressDone = (progressDone prg + 4) `mod` 100}) - in Monad.forever loop - else pure Nothing - -putColored :: Color -> Bool -> String -> IO () -putColored c b s = do - stdoutSupportsANSI <- hNowSupportsANSI stdout - Monad.when stdoutSupportsANSI $ setSGR [SetColor Foreground Vivid c] - if b - then - putStrLn s - else - putStr s - Monad.when stdoutSupportsANSI $ setSGR [Reset] - hFlush stdout - -askForConfirmation :: - ExceptT (Error (CardanoBlock StandardCrypto)) IO a -> - String -> - ExceptT (Error (CardanoBlock StandardCrypto)) IO a -askForConfirmation act infoMsg = do - lift $ putColored Yellow False $ "I'm going to " <> infoMsg <> ". Continue? (Y/n) " - answer <- lift $ getLine - case map toLower answer of - "y" -> act - _ -> throwError Cancelled - --- | Ask before deleting -wipePath :: FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO () -wipePath fp = do - exists <- lift $ D.doesDirectoryExist fp - ( if exists - then flip askForConfirmation ("wipe the path " <> fp) - else id - ) - (lift $ D.removePathForcibly fp >> D.createDirectoryIfMissing True fp) - -toDiskSnapshot :: - FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO (SomeHasFS IO, DiskSnapshot) -toDiskSnapshot fp@(F.splitFileName . maybeRemoveTrailingSlash -> (snapPath, snapName)) = - maybe - (throwError $ BadDirectoryName fp) - (pure . (pathToHasFS snapPath,)) - $ snapshotFromPath snapName - --- | Given a filepath pointing to a snapshot (with or without a trailing slash), produce: --- --- * A HasFS at the snapshot directory -pathToHasFS :: FilePath -> SomeHasFS IO -pathToHasFS (maybeRemoveTrailingSlash -> path) = - SomeHasFS $ ioHasFS $ MountPoint path - -maybeRemoveTrailingSlash :: String -> String -maybeRemoveTrailingSlash s = case last s of - '/' -> init s - '\\' -> init s - _ -> s - -defaultLMDBLimits :: V1.LMDBLimits -defaultLMDBLimits = - V1.LMDBLimits - { V1.lmdbMapSize = 16 * 1024 * 1024 * 1024 - , V1.lmdbMaxDatabases = 10 - , V1.lmdbMaxReaders = 16 - } diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 399435917f..f9a0e3c002 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -179,6 +179,40 @@ library validation, vector-map, +library snapshot-conversion + import: common-lib + visibility: public + hs-source-dirs: src/snapshot-conversion + other-modules: + Ouroboros.Consensus.Cardano.StreamingLedgerTables + + exposed-modules: + Ouroboros.Consensus.Cardano.SnapshotConversion + + build-depends: + ansi-terminal, + base, + cardano-ledger-binary, + cardano-ledger-core, + cardano-ledger-shelley, + cborg, + directory, + filepath, + fs-api, + microlens, + mtl, + optparse-applicative, + ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm}, + ouroboros-consensus-cardano, + random, + resource-registry, + serialise, + sop-core, + sop-extras, + strict-sop-core, + terminal-progress-bar, + text, + library unstable-byronspec import: common-lib visibility: public @@ -695,35 +729,14 @@ executable immdb-server executable snapshot-converter import: common-exe hs-source-dirs: app - other-modules: - Ouroboros.Consensus.Cardano.StreamingLedgerTables - main-is: snapshot-converter.hs build-depends: - ansi-terminal, base, cardano-crypto-class, - cardano-ledger-binary, - cardano-ledger-core, - cardano-ledger-shelley, - cborg, - directory, - filepath, - fs-api, - microlens, mtl, optparse-applicative, - ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm}, - ouroboros-consensus-cardano, - ouroboros-consensus-cardano:unstable-cardano-tools, - random, - resource-registry, - serialise, - sop-core, - sop-extras, - strict-sop-core, - terminal-progress-bar, - text, + ouroboros-consensus, + ouroboros-consensus-cardano:{ouroboros-consensus-cardano, snapshot-conversion, unstable-cardano-tools}, with-utf8, other-modules: diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/ByronHFC.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/ByronHFC.hs index d6146e1f70..2f24093e2a 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/ByronHFC.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/ByronHFC.hs @@ -3,14 +3,14 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Byron.ByronHFC @@ -25,9 +25,10 @@ import qualified Cardano.Chain.Update as CC.Update import Control.Monad import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe, mapMaybe) -import Data.MemPack +import Data.SOP.Constraint import Data.SOP.Index (Index (..)) -import Data.Void (Void, absurd) +import qualified Data.Singletons as S +import Data.Void (Void) import Data.Word import GHC.Generics import NoThunks.Class @@ -46,7 +47,6 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Serialisation import Ouroboros.Consensus.Protocol.PBFT (PBft, PBftCrypto) import Ouroboros.Consensus.Storage.Serialisation -import Ouroboros.Consensus.Util.IndexedMemPack {------------------------------------------------------------------------------- Synonym for convenience @@ -287,30 +287,19 @@ instance SerialiseNodeToClient ByronBlock ByronPartialLedgerConfig where Canonical TxIn -------------------------------------------------------------------------------} -instance HasCanonicalTxIn '[ByronBlock] where - newtype CanonicalTxIn '[ByronBlock] = ByronHFCTxIn - { getByronHFCTxIn :: Void - } - deriving stock (Show, Eq, Ord) - deriving newtype (NoThunks, MemPack) - - injectCanonicalTxIn IZ key = absurd key - injectCanonicalTxIn (IS idx') _ = case idx' of {} - - ejectCanonicalTxIn _ key = absurd $ getByronHFCTxIn key - -instance HasHardForkTxOut '[ByronBlock] where +instance + ( All (TableConstraints (HardForkBlock '[ByronBlock])) (TablesForBlock (HardForkBlock '[ByronBlock])) + , S.SingI + (TablesForBlock (HardForkBlock '[ByronBlock])) + ) => + HasHardForkTxOut '[ByronBlock] + where type HardForkTxOut '[ByronBlock] = Void - injectHardForkTxOut IZ txout = absurd txout + injectHardForkTxOut IZ txout = txout injectHardForkTxOut (IS idx') _ = case idx' of {} - ejectHardForkTxOut IZ txout = absurd txout + ejectHardForkTxOut IZ txout = txout ejectHardForkTxOut (IS idx') _ = case idx' of {} -deriving via - Void - instance - IndexedMemPack (LedgerState (HardForkBlock '[ByronBlock]) EmptyMK) Void - instance BlockSupportsHFLedgerQuery '[ByronBlock] where answerBlockQueryHFLookup IZ _cfg (q :: BlockQuery ByronBlock QFLookupTables result) _dlv = case q of {} answerBlockQueryHFLookup (IS is) _cfg _q _dlv = case is of {} @@ -320,8 +309,3 @@ instance BlockSupportsHFLedgerQuery '[ByronBlock] where queryLedgerGetTraversingFilter IZ (q :: BlockQuery ByronBlock QFTraverseTables result) = case q of {} queryLedgerGetTraversingFilter (IS is) _q = case is of {} - -deriving via - TrivialLedgerTables (LedgerState (HardForkBlock '[ByronBlock])) - instance - SerializeTablesWithHint (LedgerState (HardForkBlock '[ByronBlock])) diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index f57756fe0f..977600f23c 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -15,6 +15,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE TypeApplications #-} -- | Instances requires for consensus/ledger integration module Ouroboros.Consensus.Byron.Ledger.Ledger @@ -70,7 +71,8 @@ import qualified Control.State.Transition.Extended as STS import Data.ByteString (ByteString) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Void (Void) +import Data.SOP.Strict +import Data.Void import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block @@ -87,6 +89,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -123,8 +126,6 @@ data ByronTransition ByronTransitionInfo !(Map Update.ProtocolVersion BlockNo) deriving (Eq, Show, Generic, NoThunks) -instance UpdateLedger ByronBlock - type instance LedgerCfg (LedgerState ByronBlock) = Gen.Config initByronLedgerState :: @@ -200,46 +201,39 @@ instance IsLedger (LedgerState ByronBlock) where byronLedgerTransition } -type instance TxIn (LedgerState ByronBlock) = Void -type instance TxOut (LedgerState ByronBlock) = Void - -instance LedgerTablesAreTrivial (LedgerState ByronBlock) where - convertMapKind (ByronLedgerState x y z) = ByronLedgerState x y z -instance LedgerTablesAreTrivial (Ticked (LedgerState ByronBlock)) where - convertMapKind (TickedByronLedgerState x y) = TickedByronLedgerState x y - -deriving via - Void - instance - IndexedMemPack (LedgerState ByronBlock EmptyMK) Void - -deriving via - TrivialLedgerTables (LedgerState ByronBlock) - instance - HasLedgerTables (LedgerState ByronBlock) -deriving via - TrivialLedgerTables (Ticked (LedgerState ByronBlock)) - instance - HasLedgerTables (Ticked (LedgerState ByronBlock)) -deriving via - TrivialLedgerTables (LedgerState ByronBlock) - instance - CanStowLedgerTables (LedgerState ByronBlock) -deriving via - TrivialLedgerTables (LedgerState ByronBlock) - instance - SerializeTablesWithHint (LedgerState ByronBlock) +type instance TxOut ByronBlock = Void +type instance TablesForBlock ByronBlock = '[] + +instance IndexedMemPack LedgerState ByronBlock UTxOTable where + type IndexedValue LedgerState UTxOTable ByronBlock = Value UTxOTable ByronBlock + indexedPackM _ _ _ _ = absurd + indexedUnpackM _ _ _ _ = error "absurd" + indexedPackedByteCount _ _ _ _ = absurd + indexedTypeName _ _ _ = typeName @Void + +instance HasLedgerTables LedgerState ByronBlock where + projectLedgerTables _ = LedgerTables Nil + withLedgerTables ByronLedgerState{..} _ = ByronLedgerState{..} + +instance HasLedgerTables (TickedL LedgerState) ByronBlock where + projectLedgerTables _ = LedgerTables Nil + withLedgerTables (TickedL TickedByronLedgerState{..}) _ = TickedL TickedByronLedgerState{..} + +instance CanStowLedgerTables (LedgerState ByronBlock) where + stowLedgerTables ByronLedgerState{..} = ByronLedgerState{..} + unstowLedgerTables ByronLedgerState{..} = ByronLedgerState{..} {------------------------------------------------------------------------------- Supporting the various consensus interfaces -------------------------------------------------------------------------------} -instance ApplyBlock (LedgerState ByronBlock) ByronBlock where +instance ApplyBlock LedgerState ByronBlock where applyBlockLedgerResultWithValidation doValidation opts = fmap pureLedgerResult ..: applyByronBlock doValidation opts applyBlockLedgerResult = defaultApplyBlockLedgerResult reapplyBlockLedgerResult = defaultReapplyBlockLedgerResult validationErrorImpossible +instance GetBlockKeySets ByronBlock where getBlockKeySets _ = emptyLedgerTables data instance BlockQuery ByronBlock fp result where @@ -575,5 +569,5 @@ decodeByronResult :: decodeByronResult query = case query of GetUpdateInterfaceState -> fromByronCBOR -instance CanUpgradeLedgerTables (LedgerState ByronBlock) where +instance CanUpgradeLedgerTables LedgerState ByronBlock where upgradeTables _ _ = id diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs index 58b7587dc5..20bf733eb0 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -59,7 +61,7 @@ import Ouroboros.Consensus.Protocol.PBFT import qualified Ouroboros.Consensus.Protocol.PBFT.State as S import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..)) import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) -import Ouroboros.Consensus.Util ((....:)) +import Ouroboros.Consensus.Util import Ouroboros.Network.Magic (NetworkMagic (..)) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index ca4d5c03a7..0ba8be2c17 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -98,6 +98,19 @@ import Ouroboros.Consensus.Shelley.ShelleyHFC import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (coerceMapKeys, eitherToMaybe) +type instance TablesForBlock (HardForkBlock (CardanoEras c)) = '[UTxOTable, InstantStakeTable] +type instance TablesForBlock (HardForkBlock '[ShelleyBlock proto ShelleyEra]) = '[UTxOTable] +type instance TablesForBlock (HardForkBlock '[ShelleyBlock proto AllegraEra]) = '[UTxOTable] +type instance TablesForBlock (HardForkBlock '[ShelleyBlock proto MaryEra]) = '[UTxOTable] +type instance TablesForBlock (HardForkBlock '[ShelleyBlock proto AlonzoEra]) = '[UTxOTable] +type instance TablesForBlock (HardForkBlock '[ShelleyBlock proto BabbageEra]) = '[UTxOTable] +type instance TablesForBlock (HardForkBlock '[ShelleyBlock proto ConwayEra]) = '[UTxOTable] +type instance + TablesForBlock (HardForkBlock '[ShelleyBlock proto DijkstraEra]) = + '[UTxOTable, InstantStakeTable] + +type instance TablesForBlock (HardForkBlock '[ByronBlock]) = '[] + {------------------------------------------------------------------------------- CanHardFork -------------------------------------------------------------------------------} @@ -324,10 +337,7 @@ translateLedgerStateByronToShelleyWrapper = translateLedgerTablesByronToShelleyWrapper :: TranslateLedgerTables ByronBlock (ShelleyBlock (TPraos c) ShelleyEra) translateLedgerTablesByronToShelleyWrapper = - TranslateLedgerTables - { translateTxInWith = absurd - , translateTxOutWith = absurd - } + TranslateLedgerTables absurd translateChainDepStateByronToShelleyWrapper :: RequiringBoth @@ -468,6 +478,8 @@ translateLedgerStateShelleyToAllegraWrapper = -- translation. avvmsAsDeletions = LedgerTables + . (SOP.:* SOP.Nil) + . Table . DiffMK . Diff.fromMapDeletes . coerceMapKeys @@ -482,6 +494,8 @@ translateLedgerStateShelleyToAllegraWrapper = stowLedgerTables . withLedgerTables ls . LedgerTables + . (SOP.:* SOP.Nil) + . Table . ValuesMK . coerceMapKeys $ avvms @@ -501,10 +515,7 @@ translateLedgerTablesShelleyToAllegraWrapper :: (ShelleyBlock (TPraos c) ShelleyEra) (ShelleyBlock (TPraos c) AllegraEra) translateLedgerTablesShelleyToAllegraWrapper = - TranslateLedgerTables - { translateTxInWith = coerce - , translateTxOutWith = SL.upgradeTxOut - } + TranslateLedgerTables SL.upgradeTxOut translateTxShelleyToAllegraWrapper :: InjectTx @@ -549,10 +560,7 @@ translateLedgerTablesAllegraToMaryWrapper :: (ShelleyBlock (TPraos c) AllegraEra) (ShelleyBlock (TPraos c) MaryEra) translateLedgerTablesAllegraToMaryWrapper = - TranslateLedgerTables - { translateTxInWith = coerce - , translateTxOutWith = SL.upgradeTxOut - } + TranslateLedgerTables SL.upgradeTxOut translateTxAllegraToMaryWrapper :: InjectTx @@ -597,10 +605,7 @@ translateLedgerTablesMaryToAlonzoWrapper :: (ShelleyBlock (TPraos c) MaryEra) (ShelleyBlock (TPraos c) AlonzoEra) translateLedgerTablesMaryToAlonzoWrapper = - TranslateLedgerTables - { translateTxInWith = coerce - , translateTxOutWith = SL.upgradeTxOut - } + TranslateLedgerTables SL.upgradeTxOut getAlonzoTranslationContext :: WrapLedgerConfig (ShelleyBlock (TPraos c) AlonzoEra) -> @@ -653,23 +658,25 @@ translateLedgerStateAlonzoToBabbageWrapper = transPraosLS :: LedgerState (ShelleyBlock (TPraos c) AlonzoEra) mk -> LedgerState (ShelleyBlock (Praos c) AlonzoEra) mk - transPraosLS (ShelleyLedgerState wo nes st tb) = + transPraosLS (ShelleyLedgerState wo nes st tbs) = ShelleyLedgerState { shelleyLedgerTip = fmap castShelleyTip wo , shelleyLedgerState = nes , shelleyLedgerTransition = st - , shelleyLedgerTables = coerce tb + , shelleyLedgerTables = castLedgerTables tbs } +castLedgerTables :: + LedgerTables (ShelleyBlock (TPraos c) AlonzoEra) mk -> + LedgerTables (ShelleyBlock (Praos c) AlonzoEra) mk +castLedgerTables (LedgerTables tbs) = LedgerTables $ SOP.hcoerce tbs + translateLedgerTablesAlonzoToBabbageWrapper :: TranslateLedgerTables (ShelleyBlock (TPraos c) AlonzoEra) (ShelleyBlock (Praos c) BabbageEra) translateLedgerTablesAlonzoToBabbageWrapper = - TranslateLedgerTables - { translateTxInWith = coerce - , translateTxOutWith = SL.upgradeTxOut - } + TranslateLedgerTables SL.upgradeTxOut translateTxAlonzoToBabbageWrapper :: SL.TranslationContext BabbageEra -> @@ -735,10 +742,7 @@ translateLedgerTablesBabbageToConwayWrapper :: (ShelleyBlock (Praos c) BabbageEra) (ShelleyBlock (Praos c) ConwayEra) translateLedgerTablesBabbageToConwayWrapper = - TranslateLedgerTables - { translateTxInWith = coerce - , translateTxOutWith = SL.upgradeTxOut - } + TranslateLedgerTables SL.upgradeTxOut getConwayTranslationContext :: WrapLedgerConfig (ShelleyBlock (Praos c) ConwayEra) -> @@ -770,6 +774,7 @@ translateValidatedTxBabbageToConwayWrapper ctxt = -------------------------------------------------------------------------------} translateLedgerStateConwayToDijkstraWrapper :: + forall c. RequiringBoth WrapLedgerConfig TranslateLedgerState @@ -779,6 +784,13 @@ translateLedgerStateConwayToDijkstraWrapper = RequireBoth $ \_cfgConway cfgDijkstra -> TranslateLedgerState { translateLedgerStateWith = \_epochNo -> + -- ( `withLedgerTables` + -- ( LedgerTables $ + -- Table (DiffMK (mempty)) + -- SOP.:* Table (DiffMK (mempty)) + -- SOP.:* SOP.Nil + -- ) + -- ) noNewTickingDiffs . unFlip . unComp @@ -792,10 +804,7 @@ translateLedgerTablesConwayToDijkstraWrapper :: (ShelleyBlock (Praos c) ConwayEra) (ShelleyBlock (Praos c) DijkstraEra) translateLedgerTablesConwayToDijkstraWrapper = - TranslateLedgerTables - { translateTxInWith = coerce - , translateTxOutWith = SL.upgradeTxOut - } + TranslateLedgerTables SL.upgradeTxOut getDijkstraTranslationContext :: WrapLedgerConfig (ShelleyBlock (Praos c) DijkstraEra) -> diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs index 7dffcff9f0..d212195078 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs @@ -7,7 +7,6 @@ {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -44,20 +43,20 @@ import Data.SOP.Index import Data.SOP.Strict import qualified Data.SOP.Tails as Tails import qualified Data.SOP.Telescope as Telescope -import Data.Void import GHC.Generics (Generic) import Lens.Micro import NoThunks.Class +import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.CanHardFork import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.State.Types +import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Tables import Ouroboros.Consensus.Protocol.Praos (Praos) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger - ( BigEndianTxIn - , IsShelleyBlock + ( IsShelleyBlock , ShelleyBlock , ShelleyCompatible , shelleyLedgerState @@ -65,52 +64,14 @@ import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.IndexedMemPack -instance - CardanoHardForkConstraints c => - HasCanonicalTxIn (CardanoEras c) - where - newtype CanonicalTxIn (CardanoEras c) = CardanoTxIn - { getCardanoTxIn :: BigEndianTxIn - } - deriving stock (Show, Eq, Ord) - deriving newtype NoThunks - - injectCanonicalTxIn IZ byronTxIn = absurd byronTxIn - injectCanonicalTxIn (IS idx) shelleyTxIn = case idx of - IZ -> CardanoTxIn shelleyTxIn - IS IZ -> CardanoTxIn shelleyTxIn - IS (IS IZ) -> CardanoTxIn shelleyTxIn - IS (IS (IS IZ)) -> CardanoTxIn shelleyTxIn - IS (IS (IS (IS IZ))) -> CardanoTxIn shelleyTxIn - IS (IS (IS (IS (IS IZ)))) -> CardanoTxIn shelleyTxIn - IS (IS (IS (IS (IS (IS IZ))))) -> CardanoTxIn shelleyTxIn - IS (IS (IS (IS (IS (IS (IS idx')))))) -> case idx' of {} - - ejectCanonicalTxIn IZ _ = - error "ejectCanonicalTxIn: Byron has no TxIns" - ejectCanonicalTxIn (IS idx) cardanoTxIn = case idx of - IZ -> getCardanoTxIn cardanoTxIn - IS IZ -> getCardanoTxIn cardanoTxIn - IS (IS IZ) -> getCardanoTxIn cardanoTxIn - IS (IS (IS IZ)) -> getCardanoTxIn cardanoTxIn - IS (IS (IS (IS IZ))) -> getCardanoTxIn cardanoTxIn - IS (IS (IS (IS (IS IZ)))) -> getCardanoTxIn cardanoTxIn - IS (IS (IS (IS (IS (IS IZ))))) -> getCardanoTxIn cardanoTxIn - IS (IS (IS (IS (IS (IS (IS idx')))))) -> case idx' of {} - -instance CardanoHardForkConstraints c => MemPack (CanonicalTxIn (CardanoEras c)) where - packM = packM . getCardanoTxIn - packedByteCount = packedByteCount . getCardanoTxIn - unpackM = CardanoTxIn <$> unpackM - data CardanoTxOut c - = ShelleyTxOut {-# UNPACK #-} !(TxOut (LedgerState (ShelleyBlock (TPraos c) ShelleyEra))) - | AllegraTxOut {-# UNPACK #-} !(TxOut (LedgerState (ShelleyBlock (TPraos c) AllegraEra))) - | MaryTxOut {-# UNPACK #-} !(TxOut (LedgerState (ShelleyBlock (TPraos c) MaryEra))) - | AlonzoTxOut !(TxOut (LedgerState (ShelleyBlock (TPraos c) AlonzoEra))) - | BabbageTxOut !(TxOut (LedgerState (ShelleyBlock (Praos c) BabbageEra))) - | ConwayTxOut !(TxOut (LedgerState (ShelleyBlock (Praos c) ConwayEra))) - | DijkstraTxOut !(TxOut (LedgerState (ShelleyBlock (Praos c) DijkstraEra))) + = ShelleyTxOut {-# UNPACK #-} !(TxOut (ShelleyBlock (TPraos c) ShelleyEra)) + | AllegraTxOut {-# UNPACK #-} !(TxOut (ShelleyBlock (TPraos c) AllegraEra)) + | MaryTxOut {-# UNPACK #-} !(TxOut (ShelleyBlock (TPraos c) MaryEra)) + | AlonzoTxOut !(TxOut (ShelleyBlock (TPraos c) AlonzoEra)) + | BabbageTxOut !(TxOut (ShelleyBlock (Praos c) BabbageEra)) + | ConwayTxOut !(TxOut (ShelleyBlock (Praos c) ConwayEra)) + | DijkstraTxOut !(TxOut (ShelleyBlock (Praos c) DijkstraEra)) deriving stock (Show, Eq, Generic) deriving anyclass NoThunks @@ -123,7 +84,7 @@ eliminateCardanoTxOut :: -- TODO ProtoCrypto constraint should be in IsShelleyBlock IsShelleyBlock x => Index (CardanoEras c) x -> - TxOut (LedgerState x) -> + TxOut x -> r ) -> CardanoTxOut c -> @@ -154,7 +115,7 @@ instance CardanoHardForkConstraints c => HasHardForkTxOut (CardanoEras c) where forall y. Index (CardanoEras c) y -> HardForkTxOut (CardanoEras c) -> - TxOut (LedgerState y) + TxOut y ejectHardForkTxOut targetIdx = eliminateCardanoTxOut ( \origIdx -> @@ -166,12 +127,15 @@ instance CardanoHardForkConstraints c => HasHardForkTxOut (CardanoEras c) where instance CardanoHardForkConstraints c => - IndexedMemPack (LedgerState (HardForkBlock (CardanoEras c)) EmptyMK) (CardanoTxOut c) + IndexedMemPack LedgerState (HardForkBlock (CardanoEras c)) UTxOTable where - indexedTypeName _ = "CardanoTxOut" - indexedPackM _ = eliminateCardanoTxOut (const packM) - indexedPackedByteCount _ = eliminateCardanoTxOut (const packedByteCount) - indexedUnpackM (HardForkLedgerState (HardForkState idx)) = do + type + IndexedValue LedgerState UTxOTable (HardForkBlock (CardanoEras c)) = + Value UTxOTable (HardForkBlock (CardanoEras c)) + indexedTypeName _ _ _ = "CardanoTxOut" + indexedPackM _ _ _ _ = eliminateCardanoTxOut (const packM) + indexedPackedByteCount _ _ _ _ = eliminateCardanoTxOut (const packedByteCount) + indexedUnpackM _ _ _ (HardForkLedgerState (HardForkState idx)) = do let -- These could be made into a CAF to avoid recomputing it, but -- it is only used in serialization so it is not critical. @@ -190,9 +154,77 @@ instance instance CardanoHardForkConstraints c => - SerializeTablesWithHint (LedgerState (HardForkBlock (CardanoEras c))) + SerializeTablesWithHint LedgerState (HardForkBlock (CardanoEras c)) InstantStakeTable + where + encodeTablesWithHint (HardForkLedgerState (HardForkState idx)) (Table (ValuesMK tbs)) = + let + -- These could be made into a CAF to avoid recomputing it, but + -- it is only used in serialization so it is not critical. + np = + (Fn $ const $ K $ Codec.CBOR.Encoding.encodeMapLen 0) + :* (Fn $ const $ K $ encOne (Proxy @ShelleyEra)) + :* (Fn $ const $ K $ encOne (Proxy @AllegraEra)) + :* (Fn $ const $ K $ encOne (Proxy @MaryEra)) + :* (Fn $ const $ K $ encOne (Proxy @AlonzoEra)) + :* (Fn $ const $ K $ encOne (Proxy @BabbageEra)) + :* (Fn $ const $ K $ encOne (Proxy @ConwayEra)) + :* (Fn $ const $ K $ encOne (Proxy @DijkstraEra)) + :* Nil + in + hcollapse $ hap np $ Telescope.tip idx + where + encOne :: forall era. Era era => Proxy era -> Encoding + encOne _ = + toPlainEncoding (eraProtVerLow @era) $ encCBOR tbs + + decodeTablesWithHint :: forall s. + LedgerState (HardForkBlock (CardanoEras c)) EmptyMK -> + Decoder s (Table ValuesMK (HardForkBlock (CardanoEras c)) InstantStakeTable) + decodeTablesWithHint (HardForkLedgerState (HardForkState idx)) = + let + -- These could be made into a CAF to avoid recomputing it, but + -- it is only used in serialization so it is not critical. + np = + ( Fn $ + const $ + Comp $ + K . Table . ValuesMK + <$> (Codec.CBOR.Decoding.decodeMapLen >> pure Map.empty) + ) + :* (Fn $ Comp . fmap K . getOne . unFlip . currentState) + :* (Fn $ Comp . fmap K . getOne . unFlip . currentState) + :* (Fn $ Comp . fmap K . getOne . unFlip . currentState) + :* (Fn $ Comp . fmap K . getOne . unFlip . currentState) + :* (Fn $ Comp . fmap K . getOne . unFlip . currentState) + :* (Fn $ Comp . fmap K . getOne . unFlip . currentState) + :* (Fn $ Comp . fmap K . getOne . unFlip . currentState) + :* Nil + in + hcollapse <$> (hsequence' $ hap np $ Telescope.tip idx) + where + getOne :: + forall proto era. + ShelleyCompatible proto era => + LedgerState (ShelleyBlock proto era) EmptyMK -> + Decoder s (Table ValuesMK (HardForkBlock (CardanoEras c)) InstantStakeTable) + getOne st = + let certInterns = + internsFromMap $ + shelleyLedgerState st + ^. SL.nesEsL + . SL.esLStateL + . SL.lsCertStateL + . SL.certDStateL + . SL.accountsL + . SL.accountsMapL + in Table . ValuesMK + <$> eraDecoder @era (decShareCBOR (certInterns, mempty)) + +instance + CardanoHardForkConstraints c => + SerializeTablesWithHint LedgerState (HardForkBlock (CardanoEras c)) UTxOTable where - encodeTablesWithHint (HardForkLedgerState (HardForkState idx)) (LedgerTables (ValuesMK tbs)) = + encodeTablesWithHint (HardForkLedgerState (HardForkState idx)) (Table (ValuesMK tbs)) = let -- These could be made into a CAF to avoid recomputing it, but -- it is only used in serialization so it is not critical. @@ -217,7 +249,7 @@ instance decodeTablesWithHint :: forall s. LedgerState (HardForkBlock (CardanoEras c)) EmptyMK -> - Decoder s (LedgerTables (LedgerState (HardForkBlock (CardanoEras c))) ValuesMK) + Decoder s (Table ValuesMK (HardForkBlock (CardanoEras c)) UTxOTable) decodeTablesWithHint (HardForkLedgerState (HardForkState idx)) = let -- These could be made into a CAF to avoid recomputing it, but @@ -226,7 +258,7 @@ instance ( Fn $ const $ Comp $ - K . LedgerTables @(LedgerState (HardForkBlock (CardanoEras c))) . ValuesMK + K . Table . ValuesMK <$> (Codec.CBOR.Decoding.decodeMapLen >> pure Map.empty) ) :* (Fn $ Comp . fmap K . getOne ShelleyTxOut . unFlip . currentState) @@ -243,9 +275,9 @@ instance getOne :: forall proto era. ShelleyCompatible proto era => - (TxOut (LedgerState (ShelleyBlock proto era)) -> CardanoTxOut c) -> + (TxOut (ShelleyBlock proto era) -> CardanoTxOut c) -> LedgerState (ShelleyBlock proto era) EmptyMK -> - Decoder s (LedgerTables (LedgerState (HardForkBlock (CardanoEras c))) ValuesMK) + Decoder s (Table ValuesMK (HardForkBlock (CardanoEras c)) UTxOTable) getOne toCardanoTxOut st = let certInterns = internsFromMap $ @@ -256,5 +288,5 @@ instance . SL.certDStateL . SL.accountsL . SL.accountsMapL - in LedgerTables . ValuesMK + in Table . ValuesMK <$> eraDecoder @era (decodeMap decodeMemPack (toCardanoTxOut <$> decShareCBOR certInterns)) diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index 52a7e4f910..679150148f 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -65,12 +65,14 @@ import qualified Data.ByteString.Short as Short import Data.Functor.These (These1 (..)) import qualified Data.Map.Strict as Map import Data.SOP.BasicFunctors +import Data.SOP.Constraint (All) import Data.SOP.Counting import Data.SOP.Functors (Flip (..)) import Data.SOP.Index import Data.SOP.OptNP (NonEmptyOptNP, OptNP (OptSkip)) import qualified Data.SOP.OptNP as OptNP import Data.SOP.Strict +import Data.Singletons (SingI) import Data.Word (Word16, Word64) import Lens.Micro ((^.)) import Ouroboros.Consensus.Block @@ -949,7 +951,11 @@ protocolInfoCardano paramsCardano :* Nil injectIntoTestState :: - ShelleyBasedEra era => + ( ShelleyBasedEra era + , CanStowLedgerTables (LedgerState (ShelleyBlock proto era)) + , All (TableConstraints (ShelleyBlock proto era)) (TablesForBlock (ShelleyBlock proto era)) + , SingI (TablesForBlock (ShelleyBlock proto era)) + ) => WrapTransitionConfig (ShelleyBlock proto era) -> (Flip LedgerState ValuesMK -.-> Flip LedgerState ValuesMK) (ShelleyBlock proto era) injectIntoTestState (WrapTransitionConfig tcfg) = fn $ \(Flip st) -> diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs index cc1a248470..55c20828b1 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs @@ -1,25 +1,19 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Cardano.QueryHF () where -import Data.Coerce +import Ouroboros.Consensus.Ledger.Tables.Utils +import Lens.Micro ((.~), (&)) import Data.Functor.Product import Data.SOP.BasicFunctors import Data.SOP.Constraint @@ -88,25 +82,26 @@ shelleyCardanoFilter :: , ShelleyCompatible proto era ) => BlockQuery (ShelleyBlock proto era) QFTraverseTables result -> - TxOut (LedgerState (HardForkBlock (CardanoEras c))) -> + TxOut (HardForkBlock (CardanoEras c)) -> Bool shelleyCardanoFilter q = eliminateCardanoTxOut (\_ -> shelleyQFTraverseTablesPredicate q) -instance CardanoHardForkConstraints c => BlockSupportsHFLedgerQuery (CardanoEras c) where +instance + CardanoHardForkConstraints c => + BlockSupportsHFLedgerQuery (CardanoEras c) + where answerBlockQueryHFLookup = answerCardanoQueryHF ( \idx -> answerShelleyLookupQueries - (injectLedgerTables idx) + castKeys (ejectHardForkTxOut idx) - (coerce . ejectCanonicalTxIn idx) ) answerBlockQueryHFTraverse = answerCardanoQueryHF ( \idx -> answerShelleyTraversingQueries (ejectHardForkTxOut idx) - (coerce . ejectCanonicalTxIn idx) (queryLedgerGetTraversingFilter idx) ) @@ -123,8 +118,14 @@ instance CardanoHardForkConstraints c => BlockSupportsHFLedgerQuery (CardanoEras IS (IS (IS (IS (IS (IS (IS IZ)))))) -> shelleyCardanoFilter q IS (IS (IS (IS (IS (IS (IS (IS idx'))))))) -> case idx' of {} +castKeys :: forall blk blk'. (SListI (TablesForBlock blk), SingI (TablesForBlock blk), LedgerTablesConstraints blk') => LedgerTables blk KeysMK -> LedgerTables blk' KeysMK +castKeys np = + emptyLedgerTables + & onUTxOTable (Proxy @blk') .~ maybe (Table (KeysMK mempty)) (\(Table (KeysMK km)) -> Table (KeysMK km)) (getTableByTag (sing @UTxOTable) np) + & onInstantStakeTable (Proxy @blk') .~ maybe (Table (KeysMK mempty)) (\(Table (KeysMK km)) -> Table (KeysMK km)) (getTableByTag (sing @InstantStakeTable) np) + byronCardanoFilter :: BlockQuery ByronBlock QFTraverseTables result -> - TxOut (LedgerState (HardForkBlock (CardanoEras c))) -> + TxOut (HardForkBlock (CardanoEras c)) -> Bool byronCardanoFilter = \case {} diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs index 751d63ddd1..4d571e745c 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -70,6 +70,8 @@ import Ouroboros.Consensus.HardFork.Combinator ( HasPartialConsensusConfig ) import Ouroboros.Consensus.HeaderValidation +import Ouroboros.Consensus.Ledger.Abstract (GetBlockKeySets) +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Praos.Common ( PraosTiebreakerView @@ -96,6 +98,8 @@ import Ouroboros.Consensus.Storage.Serialisation ) import Ouroboros.Consensus.Util (ShowProxy (..), hashFromBytesShortE) import Ouroboros.Consensus.Util.Condense +import Ouroboros.Consensus.Ledger.Tables +import Data.SOP.Constraint {------------------------------------------------------------------------------- ShelleyCompatible @@ -129,6 +133,11 @@ class , -- Backwards compatibility Plain.FromCBOR (LegacyPParams era) , Plain.ToCBOR (LegacyPParams era) + , LedgerTablesConstraints (ShelleyBlock proto era) + , CanStowLedgerTables (LedgerState (ShelleyBlock proto era)) + , CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) + , GetBlockKeySets (ShelleyBlock proto era) + , All (Compose NoThunks (Table EmptyMK (ShelleyBlock proto era))) (TablesForBlock (ShelleyBlock proto era)) ) => ShelleyCompatible proto era diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 72871d95e8..7676b2c6da 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -11,6 +11,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -57,11 +58,10 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger -- * Low-level UTxO manipulations , slUtxoL - , BigEndianTxIn (..) ) where import qualified Cardano.Ledger.BHeaderView as SL (BHeaderView) -import qualified Cardano.Ledger.BaseTypes as SL (TxIx (..), epochInfoPure) +import qualified Cardano.Ledger.BaseTypes as SL (epochInfoPure) import Cardano.Ledger.BaseTypes.NonZero (unNonZero) import Cardano.Ledger.Binary.Decoding ( decShareCBOR @@ -80,6 +80,7 @@ import Cardano.Ledger.Binary.Plain , enforceSize ) import qualified Cardano.Ledger.Block as Core +import Cardano.Ledger.Compactible import Cardano.Ledger.Core ( Era , eraDecoder @@ -103,7 +104,11 @@ import Control.Monad.Except import qualified Control.State.Transition.Extended as STS import Data.Coerce import Data.Functor.Identity +import Data.Map.Strict (Map) import Data.MemPack +import Data.SOP.Constraint (All) +import Data.SOP.Strict +import Data.Singletons (SingI) import qualified Data.Text as T import qualified Data.Text as Text import Data.Word @@ -123,8 +128,10 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) +import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config import Ouroboros.Consensus.Shelley.Ledger.Protocol () @@ -231,7 +238,10 @@ deriving instance (NoThunks (Core.TranslationContext era), Core.Era era) => NoThunks (ShelleyPartialLedgerConfig era) -instance ShelleyCompatible proto era => HasPartialLedgerConfig (ShelleyBlock proto era) where +instance + ShelleyCompatible proto era => + HasPartialLedgerConfig (ShelleyBlock proto era) + where type PartialLedgerConfig (ShelleyBlock proto era) = ShelleyPartialLedgerConfig era -- Replace the dummy 'EpochInfo' with the real one @@ -276,18 +286,18 @@ data instance LedgerState (ShelleyBlock proto era) mk = ShelleyLedgerState { shelleyLedgerTip :: !(WithOrigin (ShelleyTip proto era)) , shelleyLedgerState :: !(SL.NewEpochState era) , shelleyLedgerTransition :: !ShelleyTransition - , shelleyLedgerTables :: !(LedgerTables (LedgerState (ShelleyBlock proto era)) mk) + , shelleyLedgerTables :: !(LedgerTables (ShelleyBlock proto era) mk) } deriving Generic deriving instance - (ShelleyBasedEra era, EqMK mk) => + (ShelleyBasedEra era, AllTables Eq mk (ShelleyBlock proto era)) => Eq (LedgerState (ShelleyBlock proto era) mk) deriving instance - (ShelleyBasedEra era, NoThunksMK mk) => + (ShelleyBasedEra era, AllTables NoThunks mk (ShelleyBlock proto era)) => NoThunks (LedgerState (ShelleyBlock proto era) mk) deriving instance - (ShelleyBasedEra era, ShowMK mk) => + (ShelleyBasedEra era, AllTables Show mk (ShelleyBlock proto era)) => Show (LedgerState (ShelleyBlock proto era) mk) -- | Information required to determine the hard fork point from Shelley to the @@ -320,52 +330,32 @@ shelleyLedgerTipPoint :: Point (ShelleyBlock proto era) shelleyLedgerTipPoint = shelleyTipToPoint . shelleyLedgerTip -instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era) - --- | The only purpose of this type is to modify the MemPack instance to use big --- endian serialization. This is necessary to ensure streaming functions of the --- UTxO set preserve the order of the entries, as otherwise we would get --- different sortings if sorting via the Serialized form and the Haskell Ord --- instance. --- --- TODO: fix this in the Ledger. See cardano-ledger#5336. -newtype BigEndianTxIn = BigEndianTxIn {getOriginalTxIn :: SL.TxIn} - deriving newtype (Eq, Show, Ord, NoThunks) - -newtype BigEndianTxIx = BigEndianTxIx {getOriginalTxIx :: SL.TxIx} - -instance MemPack BigEndianTxIx where - typeName = "BigEndianTxIx" - packedByteCount = packedByteCount . getOriginalTxIx - packM (BigEndianTxIx (SL.TxIx w)) = packM (byteSwap16 w) - unpackM = BigEndianTxIx . SL.TxIx . byteSwap16 <$> unpackM - -instance MemPack BigEndianTxIn where - typeName = "BigEndianTxIn" - packedByteCount = packedByteCount . getOriginalTxIn - packM (BigEndianTxIn (SL.TxIn txid txix)) = do - packM txid - packM (BigEndianTxIx txix) - unpackM = do - BigEndianTxIn <$> (SL.TxIn <$> unpackM <*> (getOriginalTxIx <$> unpackM)) - -type instance TxIn (LedgerState (ShelleyBlock proto era)) = BigEndianTxIn -type instance TxOut (LedgerState (ShelleyBlock proto era)) = Core.TxOut era +type instance TxOut (ShelleyBlock proto era) = Core.TxOut era +type instance TablesForBlock (ShelleyBlock proto DijkstraEra) = '[UTxOTable, InstantStakeTable] +type instance TablesForBlock (ShelleyBlock proto ShelleyEra) = '[UTxOTable] +type instance TablesForBlock (ShelleyBlock proto AllegraEra) = '[UTxOTable] +type instance TablesForBlock (ShelleyBlock proto MaryEra) = '[UTxOTable] +type instance TablesForBlock (ShelleyBlock proto AlonzoEra) = '[UTxOTable] +type instance TablesForBlock (ShelleyBlock proto BabbageEra) = '[UTxOTable] +type instance TablesForBlock (ShelleyBlock proto ConwayEra) = '[UTxOTable] instance - (txout ~ Core.TxOut era, MemPack txout) => - IndexedMemPack (LedgerState (ShelleyBlock proto era) EmptyMK) txout + MemPack (Value UTxOTable (ShelleyBlock proto era)) => + IndexedMemPack LedgerState (ShelleyBlock proto era) UTxOTable where - indexedTypeName _ = typeName @txout - indexedPackedByteCount _ = packedByteCount - indexedPackM _ = packM - indexedUnpackM _ = unpackM + type + IndexedValue LedgerState UTxOTable (ShelleyBlock proto era) = + Value UTxOTable (ShelleyBlock proto era) + indexedTypeName _ _ _ = typeName @(Value UTxOTable (ShelleyBlock proto era)) + indexedPackedByteCount _ _ _ _ = packedByteCount + indexedPackM _ _ _ _ = packM + indexedUnpackM _ _ _ _ = unpackM instance ShelleyCompatible proto era => - SerializeTablesWithHint (LedgerState (ShelleyBlock proto era)) + SerializeTablesWithHint LedgerState (ShelleyBlock proto era) UTxOTable where - encodeTablesWithHint _ (LedgerTables (ValuesMK tbs)) = + encodeTablesWithHint _ (Table (ValuesMK tbs)) = toPlainEncoding (Core.eraProtVerLow @era) $ encodeMap encodeMemPack encodeMemPack tbs decodeTablesWithHint st = let certInterns = @@ -377,11 +367,14 @@ instance . SL.certDStateL . SL.accountsL . SL.accountsMapL - in LedgerTables . ValuesMK <$> (eraDecoder @era $ decodeMap decodeMemPack (decShareCBOR certInterns)) + in Table . ValuesMK <$> (eraDecoder @era $ decodeMap decodeMemPack (decShareCBOR certInterns)) instance - ShelleyBasedEra era => - HasLedgerTables (LedgerState (ShelleyBlock proto era)) + ( ShelleyBasedEra era + , LedgerTablesConstraints (ShelleyBlock proto era) + -- All (TableConstraintsMK (ShelleyBlock proto era) DiffMK) (TablesForBlock (ShelleyBlock proto era)) + ) => + HasLedgerTables LedgerState (ShelleyBlock proto era) where projectLedgerTables = shelleyLedgerTables withLedgerTables st tables = @@ -399,17 +392,20 @@ instance } = st instance - ShelleyBasedEra era => - HasLedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) + ( ShelleyBasedEra era + , LedgerTablesConstraints (ShelleyBlock proto era) + ) => + HasLedgerTables (TickedL LedgerState) (ShelleyBlock proto era) where - projectLedgerTables = castLedgerTables . tickedShelleyLedgerTables - withLedgerTables st tables = - TickedShelleyLedgerState - { untickedShelleyLedgerTip - , tickedShelleyLedgerTransition - , tickedShelleyLedgerState - , tickedShelleyLedgerTables = castLedgerTables tables - } + projectLedgerTables = tickedShelleyLedgerTables . unTickedL + withLedgerTables (TickedL st) tables = + TickedL + TickedShelleyLedgerState + { untickedShelleyLedgerTip + , tickedShelleyLedgerTransition + , tickedShelleyLedgerState + , tickedShelleyLedgerTables = tables + } where TickedShelleyLedgerState { untickedShelleyLedgerTip @@ -417,75 +413,218 @@ instance , tickedShelleyLedgerState } = st -instance +instance CanStowLedgerTables (LedgerState (ShelleyBlock proto ShelleyEra)) where + stowLedgerTables = stowUTxOLedgerTables + unstowLedgerTables = unstowUTxOLedgerTables +instance CanStowLedgerTables (LedgerState (ShelleyBlock proto AllegraEra)) where + stowLedgerTables = stowUTxOLedgerTables + unstowLedgerTables = unstowUTxOLedgerTables +instance CanStowLedgerTables (LedgerState (ShelleyBlock proto MaryEra)) where + stowLedgerTables = stowUTxOLedgerTables + unstowLedgerTables = unstowUTxOLedgerTables +instance CanStowLedgerTables (LedgerState (ShelleyBlock proto AlonzoEra)) where + stowLedgerTables = stowUTxOLedgerTables + unstowLedgerTables = unstowUTxOLedgerTables +instance CanStowLedgerTables (LedgerState (ShelleyBlock proto BabbageEra)) where + stowLedgerTables = stowUTxOLedgerTables + unstowLedgerTables = unstowUTxOLedgerTables +instance CanStowLedgerTables (LedgerState (ShelleyBlock proto ConwayEra)) where + stowLedgerTables = stowUTxOLedgerTables + unstowLedgerTables = unstowUTxOLedgerTables +instance CanStowLedgerTables (LedgerState (ShelleyBlock proto DijkstraEra)) where + stowLedgerTables = stowUTxOAndInstantStakeLedgerTables + unstowLedgerTables = unstowUTxOAndInstantStakeLedgerTables + +stowUTxOAndInstantStakeLedgerTables :: + forall proto era. ShelleyBasedEra era => - CanStowLedgerTables (LedgerState (ShelleyBlock proto era)) - where - stowLedgerTables st = - ShelleyLedgerState - { shelleyLedgerTip = shelleyLedgerTip - , shelleyLedgerState = shelleyLedgerState' - , shelleyLedgerTransition = shelleyLedgerTransition - , shelleyLedgerTables = emptyLedgerTables - } - where - (_, shelleyLedgerState') = shelleyLedgerState `slUtxoL` SL.UTxO (coerceMapKeys m) - ShelleyLedgerState - { shelleyLedgerTip - , shelleyLedgerState - , shelleyLedgerTransition - , shelleyLedgerTables = LedgerTables (ValuesMK m) - } = st - unstowLedgerTables st = - ShelleyLedgerState - { shelleyLedgerTip = shelleyLedgerTip - , shelleyLedgerState = shelleyLedgerState' - , shelleyLedgerTransition = shelleyLedgerTransition - , shelleyLedgerTables = LedgerTables (ValuesMK (coerceMapKeys $ SL.unUTxO tbs)) - } - where - (tbs, shelleyLedgerState') = shelleyLedgerState `slUtxoL` mempty - ShelleyLedgerState - { shelleyLedgerTip - , shelleyLedgerState - , shelleyLedgerTransition - } = st + TablesForBlock (ShelleyBlock proto era) ~ '[UTxOTable, InstantStakeTable] => + LedgerState (ShelleyBlock proto era) ValuesMK -> LedgerState (ShelleyBlock proto era) EmptyMK +stowUTxOAndInstantStakeLedgerTables st = + ShelleyLedgerState + { shelleyLedgerTip + , shelleyLedgerState = shelleyLedgerState' + , shelleyLedgerTransition + , shelleyLedgerTables = emptyLedgerTables + } + where + (_, shelleyLedgerState') = shelleyLedgerState `slUtxoL` SL.UTxO (coerceMapKeys m) + ShelleyLedgerState + { shelleyLedgerTip + , shelleyLedgerState + , shelleyLedgerTransition + , shelleyLedgerTables = LedgerTables (Table (ValuesMK m) :* Table (ValuesMK _n) :* Nil) + } = st -instance +unstowUTxOAndInstantStakeLedgerTables :: ShelleyBasedEra era => - CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) - where - stowLedgerTables st = - TickedShelleyLedgerState - { untickedShelleyLedgerTip = untickedShelleyLedgerTip - , tickedShelleyLedgerTransition = tickedShelleyLedgerTransition - , tickedShelleyLedgerState = tickedShelleyLedgerState' - , tickedShelleyLedgerTables = emptyLedgerTables - } - where - (_, tickedShelleyLedgerState') = - tickedShelleyLedgerState `slUtxoL` SL.UTxO (coerceMapKeys tbs) - TickedShelleyLedgerState - { untickedShelleyLedgerTip - , tickedShelleyLedgerTransition - , tickedShelleyLedgerState - , tickedShelleyLedgerTables = LedgerTables (ValuesMK tbs) - } = st + TablesForBlock (ShelleyBlock proto era) ~ '[UTxOTable, InstantStakeTable] => + LedgerState (ShelleyBlock proto era) EmptyMK -> LedgerState (ShelleyBlock proto era) ValuesMK +unstowUTxOAndInstantStakeLedgerTables st = + ShelleyLedgerState + { shelleyLedgerTip = shelleyLedgerTip + , shelleyLedgerState = shelleyLedgerState' + , shelleyLedgerTransition = shelleyLedgerTransition + , shelleyLedgerTables = + LedgerTables (Table (ValuesMK (coerceMapKeys $ SL.unUTxO tbs)) :* Table (ValuesMK istake) :* Nil) + } + where + (tbs, shelleyLedgerState') = shelleyLedgerState `slUtxoL` mempty + istake = slInstantStakeL shelleyLedgerState' + ShelleyLedgerState + { shelleyLedgerTip + , shelleyLedgerState + , shelleyLedgerTransition + } = st - unstowLedgerTables st = - TickedShelleyLedgerState - { untickedShelleyLedgerTip = untickedShelleyLedgerTip - , tickedShelleyLedgerTransition = tickedShelleyLedgerTransition - , tickedShelleyLedgerState = tickedShelleyLedgerState' - , tickedShelleyLedgerTables = LedgerTables (ValuesMK (coerceMapKeys (SL.unUTxO tbs))) - } - where - (tbs, tickedShelleyLedgerState') = tickedShelleyLedgerState `slUtxoL` mempty - TickedShelleyLedgerState - { untickedShelleyLedgerTip - , tickedShelleyLedgerTransition - , tickedShelleyLedgerState - } = st +stowUTxOLedgerTables :: + ShelleyBasedEra era => + TablesForBlock (ShelleyBlock proto era) ~ '[UTxOTable] => + LedgerState (ShelleyBlock proto era) ValuesMK -> LedgerState (ShelleyBlock proto era) EmptyMK +stowUTxOLedgerTables st = + ShelleyLedgerState + { shelleyLedgerTip = shelleyLedgerTip + , shelleyLedgerState = shelleyLedgerState' + , shelleyLedgerTransition = shelleyLedgerTransition + , shelleyLedgerTables = emptyLedgerTables + } + where + (_, shelleyLedgerState') = shelleyLedgerState `slUtxoL` SL.UTxO (coerceMapKeys m) + ShelleyLedgerState + { shelleyLedgerTip + , shelleyLedgerState + , shelleyLedgerTransition + , shelleyLedgerTables = LedgerTables (Table (ValuesMK m) :* Nil) + } = st + +unstowUTxOLedgerTables :: + ShelleyBasedEra era => + TablesForBlock (ShelleyBlock proto era) ~ '[UTxOTable] => + LedgerState (ShelleyBlock proto era) EmptyMK -> LedgerState (ShelleyBlock proto era) ValuesMK +unstowUTxOLedgerTables st = + ShelleyLedgerState + { shelleyLedgerTip = shelleyLedgerTip + , shelleyLedgerState = shelleyLedgerState' + , shelleyLedgerTransition = shelleyLedgerTransition + , shelleyLedgerTables = LedgerTables (Table (ValuesMK (coerceMapKeys $ SL.unUTxO tbs)) :* Nil) + } + where + (tbs, shelleyLedgerState') = shelleyLedgerState `slUtxoL` mempty + ShelleyLedgerState + { shelleyLedgerTip + , shelleyLedgerState + , shelleyLedgerTransition + } = st + +instance CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto ShelleyEra))) where + stowLedgerTables = stowUTxOLedgerTablesTicked + unstowLedgerTables = unstowUTxOLedgerTablesTicked +instance CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto AllegraEra))) where + stowLedgerTables = stowUTxOLedgerTablesTicked + unstowLedgerTables = unstowUTxOLedgerTablesTicked +instance CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto MaryEra))) where + stowLedgerTables = stowUTxOLedgerTablesTicked + unstowLedgerTables = unstowUTxOLedgerTablesTicked +instance CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto AlonzoEra))) where + stowLedgerTables = stowUTxOLedgerTablesTicked + unstowLedgerTables = unstowUTxOLedgerTablesTicked +instance CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto BabbageEra))) where + stowLedgerTables = stowUTxOLedgerTablesTicked + unstowLedgerTables = unstowUTxOLedgerTablesTicked +instance CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto ConwayEra))) where + stowLedgerTables = stowUTxOLedgerTablesTicked + unstowLedgerTables = unstowUTxOLedgerTablesTicked +instance CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto DijkstraEra))) where + stowLedgerTables = stowUTxOAndInstantStakeLedgerTablesTicked + unstowLedgerTables = unstowUTxOAndInstantStakeLedgerTablesTicked + +stowUTxOAndInstantStakeLedgerTablesTicked :: + forall proto era. + ShelleyBasedEra era => + TablesForBlock (ShelleyBlock proto era) ~ '[UTxOTable, InstantStakeTable] => + Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK -> + Ticked (LedgerState (ShelleyBlock proto era)) EmptyMK +stowUTxOAndInstantStakeLedgerTablesTicked st = + TickedShelleyLedgerState + { untickedShelleyLedgerTip = untickedShelleyLedgerTip + , tickedShelleyLedgerTransition = tickedShelleyLedgerTransition + , tickedShelleyLedgerState = tickedShelleyLedgerState' + , tickedShelleyLedgerTables = + LedgerTables $ Table emptyMK :* Table emptyMK :* Nil + } + where + (_, tickedShelleyLedgerState') = + tickedShelleyLedgerState `slUtxoL` SL.UTxO (coerceMapKeys tbs) + TickedShelleyLedgerState + { untickedShelleyLedgerTip + , tickedShelleyLedgerTransition + , tickedShelleyLedgerState + , tickedShelleyLedgerTables = LedgerTables (Table (ValuesMK tbs) :* Table (ValuesMK _tbs') :* Nil) + } = st + +unstowUTxOAndInstantStakeLedgerTablesTicked :: + ShelleyBasedEra era => + TablesForBlock (ShelleyBlock proto era) ~ '[UTxOTable, InstantStakeTable] => + Ticked (LedgerState (ShelleyBlock proto era)) EmptyMK -> + Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK +unstowUTxOAndInstantStakeLedgerTablesTicked st = + TickedShelleyLedgerState + { untickedShelleyLedgerTip = untickedShelleyLedgerTip + , tickedShelleyLedgerTransition = tickedShelleyLedgerTransition + , tickedShelleyLedgerState = tickedShelleyLedgerState' + , tickedShelleyLedgerTables = + LedgerTables (Table (ValuesMK (coerceMapKeys (SL.unUTxO tbs))) :* Table (ValuesMK istake) :* Nil) + } + where + (tbs, tickedShelleyLedgerState') = tickedShelleyLedgerState `slUtxoL` mempty + istake = slInstantStakeL tickedShelleyLedgerState' + TickedShelleyLedgerState + { untickedShelleyLedgerTip + , tickedShelleyLedgerTransition + , tickedShelleyLedgerState + } = st + +stowUTxOLedgerTablesTicked :: + ShelleyBasedEra era => + TablesForBlock (ShelleyBlock proto era) ~ '[UTxOTable] => + Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK -> + Ticked (LedgerState (ShelleyBlock proto era)) EmptyMK +stowUTxOLedgerTablesTicked st = + TickedShelleyLedgerState + { untickedShelleyLedgerTip = untickedShelleyLedgerTip + , tickedShelleyLedgerTransition = tickedShelleyLedgerTransition + , tickedShelleyLedgerState = tickedShelleyLedgerState' + , tickedShelleyLedgerTables = emptyLedgerTables + } + where + (_, tickedShelleyLedgerState') = + tickedShelleyLedgerState `slUtxoL` SL.UTxO (coerceMapKeys tbs) + TickedShelleyLedgerState + { untickedShelleyLedgerTip + , tickedShelleyLedgerTransition + , tickedShelleyLedgerState + , tickedShelleyLedgerTables = LedgerTables (Table (ValuesMK tbs) :* Nil) + } = st + +unstowUTxOLedgerTablesTicked :: + ShelleyBasedEra era => + TablesForBlock (ShelleyBlock proto era) ~ '[UTxOTable] => + Ticked (LedgerState (ShelleyBlock proto era)) EmptyMK -> + Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK +unstowUTxOLedgerTablesTicked st = + TickedShelleyLedgerState + { untickedShelleyLedgerTip = untickedShelleyLedgerTip + , tickedShelleyLedgerTransition = tickedShelleyLedgerTransition + , tickedShelleyLedgerState = tickedShelleyLedgerState' + , tickedShelleyLedgerTables = LedgerTables (Table (ValuesMK (coerceMapKeys (SL.unUTxO tbs))) :* Nil) + } + where + (tbs, tickedShelleyLedgerState') = tickedShelleyLedgerState `slUtxoL` mempty + TickedShelleyLedgerState + { untickedShelleyLedgerTip + , tickedShelleyLedgerTransition + , tickedShelleyLedgerState + } = st slUtxoL :: SL.NewEpochState era -> SL.UTxO era -> (SL.UTxO era, SL.NewEpochState era) slUtxoL st vals = @@ -496,6 +635,20 @@ slUtxoL st vals = . SL.utxoL <<.~ vals +slInstantStakeL :: + ShelleyBasedEra era => + SL.NewEpochState era -> + Map + (Credential SL.Staking) + (Cardano.Ledger.Compactible.CompactForm Coin) +slInstantStakeL st = + st + ^. SL.nesEsL + . SL.esLStateL + . SL.lsUTxOStateL + . SL.instantStakeL + . SL.instantStakeCredentialsL + {------------------------------------------------------------------------------- GetTip -------------------------------------------------------------------------------} @@ -521,7 +674,7 @@ data instance Ticked (LedgerState (ShelleyBlock proto era)) mk = TickedShelleyLe -- must be reset when /ticking/, not when applying a block. , tickedShelleyLedgerState :: !(SL.NewEpochState era) , tickedShelleyLedgerTables :: - !(LedgerTables (LedgerState (ShelleyBlock proto era)) mk) + !(LedgerTables (ShelleyBlock proto era) mk) } deriving Generic @@ -530,7 +683,13 @@ untickedShelleyLedgerTipPoint :: Point (ShelleyBlock proto era) untickedShelleyLedgerTipPoint = shelleyTipToPoint . untickedShelleyLedgerTip -instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era)) where +instance + ( ShelleyBasedEra era + , All (TableConstraints (ShelleyBlock proto era)) (TablesForBlock (ShelleyBlock proto era)) + , SingI (TablesForBlock (ShelleyBlock proto era)) + ) => + IsLedger (LedgerState (ShelleyBlock proto era)) + where type LedgerErr (LedgerState (ShelleyBlock proto era)) = SL.BlockTransitionError era type AuxLedgerEvent (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerEvent era @@ -582,7 +741,7 @@ data ShelleyLedgerEvent era instance ShelleyCompatible proto era => - ApplyBlock (LedgerState (ShelleyBlock proto era)) (ShelleyBlock proto era) + ApplyBlock LedgerState (ShelleyBlock proto era) where -- Note: in the Shelley ledger, the @CHAIN@ rule is used to apply a whole -- block. In consensus, we split up the application of a block to the ledger @@ -612,12 +771,46 @@ instance reapplyBlockLedgerResult = defaultReapplyBlockLedgerResult (\err -> Exception.throw $! ShelleyReapplyException @era err) - getBlockKeySets = - LedgerTables - . KeysMK - . coerceSet - . Core.neededTxInsForBlock - . shelleyBlockRaw +instance ShelleyCompatible proto ShelleyEra => GetBlockKeySets (ShelleyBlock proto ShelleyEra) where + getBlockKeySets = getUTxOBlockKeySets +instance ShelleyCompatible proto AllegraEra => GetBlockKeySets (ShelleyBlock proto AllegraEra) where + getBlockKeySets = getUTxOBlockKeySets +instance ShelleyCompatible proto MaryEra => GetBlockKeySets (ShelleyBlock proto MaryEra) where + getBlockKeySets = getUTxOBlockKeySets +instance ShelleyCompatible proto AlonzoEra => GetBlockKeySets (ShelleyBlock proto AlonzoEra) where + getBlockKeySets = getUTxOBlockKeySets +instance ShelleyCompatible proto BabbageEra => GetBlockKeySets (ShelleyBlock proto BabbageEra) where + getBlockKeySets = getUTxOBlockKeySets +instance ShelleyCompatible proto ConwayEra => GetBlockKeySets (ShelleyBlock proto ConwayEra) where + getBlockKeySets = getUTxOBlockKeySets +instance ShelleyCompatible proto DijkstraEra => GetBlockKeySets (ShelleyBlock proto DijkstraEra) where + getBlockKeySets = getUTxOAndInstantStakeBlockKeySets + +getUTxOBlockKeySets :: + ShelleyCompatible proto era => + TablesForBlock (ShelleyBlock proto era) ~ '[UTxOTable] => + (ShelleyBlock proto era) -> LedgerTables (ShelleyBlock proto era) KeysMK +getUTxOBlockKeySets = + LedgerTables + . (:* Nil) + . Table + . KeysMK + . coerceSet + . Core.neededTxInsForBlock + . shelleyBlockRaw + +getUTxOAndInstantStakeBlockKeySets :: + ShelleyCompatible proto era => + TablesForBlock (ShelleyBlock proto era) ~ '[UTxOTable, InstantStakeTable] => + (ShelleyBlock proto era) -> LedgerTables (ShelleyBlock proto era) KeysMK +getUTxOAndInstantStakeBlockKeySets = + LedgerTables + . (:* Table emptyMK :* Nil) + . Table + . KeysMK + . coerceSet + . Core.neededTxInsForBlock + . shelleyBlockRaw data ShelleyReapplyException = forall era. @@ -653,14 +846,17 @@ applyHelper :: ) applyHelper f cfg blk stBefore = do let TickedShelleyLedgerState - { tickedShelleyLedgerTransition - , tickedShelleyLedgerState + { tickedShelleyLedgerTransition = transition + , tickedShelleyLedgerState = tState } = stowLedgerTables stBefore + -- (*) We extract the whole instant stake from the ledger state into the tables + let instantStakeBefore = slInstantStakeL $ tickedShelleyLedgerState stBefore + ledgerResult <- f globals - tickedShelleyLedgerState + tState ( let b = shelleyBlockRaw blk h' = mkHeaderView (SL.blockHeader b) in SL.Block h' (SL.blockBody b) @@ -669,12 +865,31 @@ applyHelper f cfg blk stBefore = do let track :: LedgerState (ShelleyBlock proto era) ValuesMK -> LedgerState (ShelleyBlock proto era) TrackingMK - track = calculateDifference stBefore + track = + calculateDifference + ( TickedL $ + stBefore + { -- We push the whole instant stake into the tables, see (*) + -- above. + -- + -- If the block doesn't have an InstantStakeTable, this + -- operation is void. + -- + -- This is only necessary because the Ledger doesn't tell us + -- which parts of the InstantStake it wants (in + -- @getBlockKeySets@). + tickedShelleyLedgerTables = + tickedShelleyLedgerTables stBefore + & onInstantStakeTable (Proxy @(ShelleyBlock proto era)) .~ Table (ValuesMK instantStakeBefore) + } + ) return $ ledgerResult <&> \newNewEpochState -> trackingToDiffs $ track $ + -- Unstowing the values __will__ get the instant stake from the state, + -- so calculating the difference will compare both instant stakes. unstowLedgerTables $ ShelleyLedgerState { shelleyLedgerTip = @@ -692,7 +907,7 @@ applyHelper f cfg blk stBefore = do -- We count the number of blocks that have been applied after the -- voting deadline has passed. (if blockSlot blk >= votingDeadline then succ else id) $ - shelleyAfterVoting tickedShelleyLedgerTransition + shelleyAfterVoting transition } , shelleyLedgerTables = emptyLedgerTables } @@ -861,5 +1076,18 @@ decodeShelleyLedgerState = , shelleyLedgerTables = emptyLedgerTables } -instance CanUpgradeLedgerTables (LedgerState (ShelleyBlock proto era)) where +instance CanUpgradeLedgerTable (ShelleyBlock proto era) UTxOTable where + type UpgradeIndex (ShelleyBlock proto era) = () + upgradeTable _ = id + +instance CanUpgradeLedgerTable (ShelleyBlock proto DijkstraEra) InstantStakeTable where + type UpgradeIndex (ShelleyBlock proto DijkstraEra) = () + upgradeTable _ = id + +instance + All + (CanUpgradeLedgerTable (ShelleyBlock proto era)) + (TablesForBlock (ShelleyBlock proto era)) => + CanUpgradeLedgerTables LedgerState (ShelleyBlock proto era) + where upgradeTables _ _ = id diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 8871e22df7..10c2e4dde1 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -9,6 +9,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -88,22 +89,23 @@ import Control.Monad.Identity (Identity (..)) import Data.DerivingVia (InstantiatedAt (..)) import Data.Foldable (toList) import Data.Measure (Measure) +import Data.Singletons import Data.Typeable (Typeable) import qualified Data.Validation as V import Data.Word (Word32) import GHC.Generics (Generic) import GHC.Natural (Natural) -import Lens.Micro ((^.)) +import Lens.Micro hiding (lens, set) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger - ( BigEndianTxIn (..) - , ShelleyLedgerConfig (shelleyLedgerGlobals) + ( ShelleyLedgerConfig (shelleyLedgerGlobals) , Ticked (TickedShelleyLedgerState, tickedShelleyLedgerState) , getPParams ) @@ -169,7 +171,12 @@ perTxOverhead :: Num a => a perTxOverhead = 4 instance - (ShelleyCompatible proto era, TxLimits (ShelleyBlock proto era)) => + ( ShelleyCompatible proto era + , TxLimits (ShelleyBlock proto era) + , LedgerTablesConstraints (ShelleyBlock proto era) + , CanStowLedgerTables (LedgerState (ShelleyBlock proto era)) + , CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) + ) => LedgerSupportsMempool (ShelleyBlock proto era) where txInvariant = const True @@ -181,10 +188,13 @@ instance txForgetValidated (ShelleyValidatedTx txid vtx) = ShelleyTx txid (SL.extractTx vtx) getTransactionKeySets (ShelleyTx _ tx) = - LedgerTables $ - KeysMK $ - coerceSet - (tx ^. bodyTxL . allInputsTxBodyF) + emptyLedgerTables + & onUTxOTable (Proxy @(ShelleyBlock proto era)) + .~ Table + ( KeysMK $ + coerceSet + (tx ^. bodyTxL . allInputsTxBodyF) + ) mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era) mkShelleyTx tx = ShelleyTx (txIdTx tx) tx @@ -267,7 +277,10 @@ instance Show (GenTxId (ShelleyBlock proto era)) where applyShelleyTx :: forall era proto. - ShelleyBasedEra era => + ( ShelleyBasedEra era + , LedgerTablesConstraints (ShelleyBlock proto era) + , CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) + ) => LedgerConfig (ShelleyBlock proto era) -> WhetherToIntervene -> SlotNo -> @@ -295,15 +308,20 @@ applyShelleyTx cfg wti slot (ShelleyTx _ tx) st0 = do let st' :: TickedLedgerState (ShelleyBlock proto era) DiffMK st' = - trackingToDiffs $ - calculateDifference st0 $ - unstowLedgerTables $ - set theLedgerLens mempoolState' st1 + unTickedL $ + trackingToDiffs $ + calculateDifference (TickedL st0) $ + TickedL $ + unstowLedgerTables $ + set theLedgerLens mempoolState' st1 pure (st', mkShelleyValidatedTx vtx) reapplyShelleyTx :: - ShelleyBasedEra era => + ( ShelleyBasedEra era + , LedgerTablesConstraints (ShelleyBlock proto era) + , CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) + ) => ComputeDiffs -> LedgerConfig (ShelleyBlock proto era) -> SlotNo -> @@ -323,10 +341,12 @@ reapplyShelleyTx doDiffs cfg slot vgtx st0 = do vtx pure + $ unTickedL $ ( case doDiffs of - ComputeDiffs -> calculateDifference st0 + ComputeDiffs -> calculateDifference (TickedL st0) IgnoreDiffs -> attachEmptyDiffs ) + $ TickedL $ unstowLedgerTables $ set theLedgerLens mempoolState' st1 where diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index f27c67032d..f24eb54a32 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -49,7 +49,7 @@ import Cardano.Binary ) import Cardano.Ledger.Address import qualified Cardano.Ledger.Api.State.Query as SL -import Cardano.Ledger.Coin (Coin) +-- import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Compactible (Compactible (fromCompact)) import qualified Cardano.Ledger.Conway.Governance as CG import qualified Cardano.Ledger.Conway.State as CG @@ -73,10 +73,16 @@ import Data.Bifunctor (second) import Data.Coerce import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.MemPack +import Data.Maybe (fromMaybe) +-- import Data.MemPack + +-- import Data.Function ((&)) + +import Data.SOP.Sing import Data.Sequence (Seq (..)) import Data.Set (Set) import qualified Data.Set as Set +import Data.Singletons import Data.Typeable (Typeable) import qualified Data.VMap as VMap import GHC.Generics (Generic) @@ -84,7 +90,6 @@ import Lens.Micro import Lens.Micro.Extras (view) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config -import Ouroboros.Consensus.HardFork.Combinator.Basics import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Basics @@ -92,6 +97,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) import Ouroboros.Consensus.Protocol.Praos.Common import qualified Ouroboros.Consensus.Shelley.Eras as SE @@ -109,8 +115,7 @@ import Ouroboros.Consensus.Shelley.Ledger.Query.Types import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) import Ouroboros.Consensus.Storage.LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB -import Ouroboros.Consensus.Util (ShowProxy (..), coerceSet) -import Ouroboros.Consensus.Util.IndexedMemPack +import Ouroboros.Consensus.Util (ShowProxy (..), coerceMapKeys, coerceSet) import Ouroboros.Network.Block ( Serialised (..) , decodePoint @@ -547,9 +552,9 @@ instance hst = headerState ext st = shelleyLedgerState lst - answerBlockQueryLookup = answerShelleyLookupQueries id id coerce + answerBlockQueryLookup = answerShelleyLookupQueries id coerce - answerBlockQueryTraverse = answerShelleyTraversingQueries id coerce shelleyQFTraverseTablesPredicate + answerBlockQueryTraverse = answerShelleyTraversingQueries id shelleyQFTraverseTablesPredicate -- \| Is the given query supported by the given 'ShelleyNodeToClientVersion'? blockQueryIsSupportedOnVersion = \case @@ -1203,20 +1208,20 @@ answerShelleyLookupQueries :: forall proto era m result blk. ( Monad m , ShelleyCompatible proto era + , SListI (TablesForBlock blk) + , SingI (TablesForBlock blk) ) => -- | Inject ledger tables - ( LedgerTables (LedgerState (ShelleyBlock proto era)) KeysMK -> - LedgerTables (LedgerState blk) KeysMK + ( LedgerTables (ShelleyBlock proto era) KeysMK -> + LedgerTables blk KeysMK ) -> -- | Eject TxOut - (TxOut (LedgerState blk) -> LC.TxOut era) -> - -- | Eject TxIn - (TxIn (LedgerState blk) -> SL.TxIn) -> + (TxOut blk -> LC.TxOut era) -> ExtLedgerCfg (ShelleyBlock proto era) -> BlockQuery (ShelleyBlock proto era) QFLookupTables result -> ReadOnlyForker' m blk -> m result -answerShelleyLookupQueries injTables ejTxOut ejTxIn cfg q forker = +answerShelleyLookupQueries injTables ejTxOut cfg q forker = case q of GetUTxOByTxIn txins -> answerGetUtxOByTxIn txins @@ -1226,32 +1231,40 @@ answerShelleyLookupQueries injTables ejTxOut ejTxIn cfg q forker = -- both client and server are running the same version; cf. the -- @GetCBOR@ Haddocks. mkSerialised (encodeShelleyResult maxBound q') - <$> answerShelleyLookupQueries injTables ejTxOut ejTxIn cfg q' forker + <$> answerShelleyLookupQueries injTables ejTxOut cfg q' forker where answerGetUtxOByTxIn :: Set.Set SL.TxIn -> m (SL.UTxO era) answerGetUtxOByTxIn txins = do - LedgerTables (ValuesMK values) <- + tbs <- LedgerDB.roforkerReadTables forker - (castLedgerTables $ injTables (LedgerTables $ KeysMK $ coerceSet txins)) - pure $ - SL.UTxO $ - Map.mapKeys ejTxIn $ - Map.mapMaybeWithKey - ( \k v -> - if ejTxIn k `Set.member` txins - then Just $ ejTxOut v - else Nothing + ( injTables + ( emptyLedgerTables + & onUTxOTable (Proxy @(ShelleyBlock proto era)) .~ Table (KeysMK $ coerceSet txins) ) - values + ) + pure + $ SL.UTxO + $ Map.mapMaybeWithKey + ( \k v -> + if k `Set.member` txins + then Just $ ejTxOut v + else Nothing + ) + $ coerceMapKeys + ( (\(ValuesMK v) -> v) $ + getTable $ + fromMaybe (error "Impossible, Shelley blocks always have UTxO table") $ + getTableByTag (sing @UTxOTable) tbs + ) shelleyQFTraverseTablesPredicate :: forall proto era proto' era' result. (ShelleyBasedEra era, ShelleyBasedEra era') => BlockQuery (ShelleyBlock proto era) QFTraverseTables result -> - TxOut (LedgerState (ShelleyBlock proto' era')) -> + TxOut (ShelleyBlock proto' era') -> Bool shelleyQFTraverseTablesPredicate q = case q of GetUTxOByAddress addr -> filterGetUTxOByAddressOne addr @@ -1275,27 +1288,22 @@ shelleyQFTraverseTablesPredicate q = case q of answerShelleyTraversingQueries :: forall proto era m result blk. ( ShelleyCompatible proto era - , Ord (TxIn (LedgerState blk)) - , Eq (TxOut (LedgerState blk)) - , MemPack (TxIn (LedgerState blk)) - , IndexedMemPack (LedgerState blk EmptyMK) (TxOut (LedgerState blk)) + , LedgerTablesConstraints blk ) => Monad m => -- | Eject TxOut - (TxOut (LedgerState blk) -> LC.TxOut era) -> - -- | Eject TxIn - (TxIn (LedgerState blk) -> SL.TxIn) -> + (TxOut blk -> LC.TxOut era) -> -- | Get filter by query ( forall result'. BlockQuery (ShelleyBlock proto era) QFTraverseTables result' -> - TxOut (LedgerState blk) -> + TxOut blk -> Bool ) -> ExtLedgerCfg (ShelleyBlock proto era) -> BlockQuery (ShelleyBlock proto era) QFTraverseTables result -> ReadOnlyForker' m blk -> m result -answerShelleyTraversingQueries ejTxOut ejTxIn filt cfg q forker = case q of +answerShelleyTraversingQueries ejTxOut filt cfg q forker = case q of GetUTxOByAddress{} -> loop (filt q) NoPreviousQuery emptyUtxo GetUTxOWhole -> loop (filt q) NoPreviousQuery emptyUtxo GetCBOR q' -> @@ -1304,25 +1312,29 @@ answerShelleyTraversingQueries ejTxOut ejTxIn filt cfg q forker = case q of -- both client and server are running the same version; cf. the -- @GetCBOR@ Haddocks. mkSerialised (encodeShelleyResult maxBound q') - <$> answerShelleyTraversingQueries ejTxOut ejTxIn filt cfg q' forker + <$> answerShelleyTraversingQueries ejTxOut filt cfg q' forker where emptyUtxo = SL.UTxO Map.empty combUtxo (SL.UTxO l) vs = SL.UTxO $ Map.union l vs partial :: - (TxOut (LedgerState blk) -> Bool) -> - LedgerTables (ExtLedgerState blk) ValuesMK -> + (TxOut blk -> Bool) -> + LedgerTables blk ValuesMK -> Map SL.TxIn (LC.TxOut era) - partial queryPredicate (LedgerTables (ValuesMK vs)) = - Map.mapKeys ejTxIn $ - Map.mapMaybeWithKey - ( \_k v -> - if queryPredicate v - then Just $ ejTxOut v - else Nothing + partial queryPredicate tbs = + Map.mapMaybeWithKey + ( \_k v -> + if queryPredicate v + then Just $ ejTxOut v + else Nothing + ) + $ coerceMapKeys + ( (\(ValuesMK m) -> m) $ + getTable $ + fromMaybe (error "impossible") $ + getTableByTag (sing @UTxOTable) tbs ) - vs loop queryPredicate !prev !acc = do (extValues, k) <- LedgerDB.roforkerRangeReadTables forker prev diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs index ef2215b417..fb399eb8de 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs @@ -8,6 +8,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs index ac9256e7cc..f32f374199 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs @@ -5,6 +5,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -50,6 +51,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto , pHeaderIssuer ) +import Ouroboros.Consensus.Storage.LedgerDB.API {------------------------------------------------------------------------------- ProtocolInfo @@ -121,5 +123,6 @@ instance , TxLimits (ShelleyBlock proto era) , SerialiseNodeToClientConstraints (ShelleyBlock proto era) , Crypto (ProtoCrypto proto) + , LedgerSupportsLedgerDB (ShelleyBlock proto era) ) => RunNode (ShelleyBlock proto era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs index 9c11ca9d99..73b4fc1231 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs @@ -38,7 +38,10 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId) import Ouroboros.Consensus.Ledger.SupportsProtocol -import Ouroboros.Consensus.Ledger.Tables (EmptyMK) +import Ouroboros.Consensus.Ledger.Tables + ( EmptyMK + , LedgerTablesConstraints + ) import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation import Ouroboros.Consensus.Protocol.Praos (PraosState) @@ -64,7 +67,11 @@ import Ouroboros.Network.Block instance ShelleyCompatible proto era => HasBinaryBlockInfo (ShelleyBlock proto era) where getBinaryBlockInfo = shelleyBinaryBlockInfo -instance ShelleyCompatible proto era => SerialiseDiskConstraints (ShelleyBlock proto era) +instance + ( ShelleyCompatible proto era + , LedgerTablesConstraints (ShelleyBlock proto era) + ) => + SerialiseDiskConstraints (ShelleyBlock proto era) instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) (ShelleyBlock proto era) where encodeDisk _ = encodeShelleyBlock diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index f03c7320ea..0527e728ac 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -3,11 +3,11 @@ {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -28,21 +28,19 @@ module Ouroboros.Consensus.Shelley.ShelleyHFC import qualified Cardano.Ledger.Api.Era as L import qualified Cardano.Ledger.BaseTypes as SL (mkVersion, unNonZero) -import Cardano.Ledger.Binary.Decoding +import Cardano.Ledger.Binary ( decShareCBOR , decodeMap , decodeMemPack - , internsFromMap - ) -import Cardano.Ledger.Binary.Encoding - ( encodeMap + , encodeMap , encodeMemPack + , internsFromMap , toPlainEncoding ) -import qualified Cardano.Ledger.Conway.State as SL import qualified Cardano.Ledger.Core as SL import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.LedgerState as SL +import qualified Cardano.Ledger.State as SL import Cardano.Protocol.Crypto (Crypto) import qualified Cardano.Protocol.TPraos.API as SL import Codec.CBOR.Decoding @@ -51,20 +49,19 @@ import Control.Monad (guard) import Control.Monad.Except (runExcept, throwError) import Data.Coerce import qualified Data.Map.Strict as Map -import Data.MemPack import Data.SOP.BasicFunctors +import Data.SOP.Constraint import Data.SOP.Functors (Flip (..)) import Data.SOP.InPairs (RequiringBoth (..), ignoringBoth) -import Data.SOP.Index (Index (..)) +import Data.SOP.Index import Data.SOP.Strict import qualified Data.SOP.Tails as Tails import qualified Data.SOP.Telescope as Telescope +import Data.Singletons import qualified Data.Text as T (pack) -import Data.Typeable import Data.Void (Void) import Data.Word import Lens.Micro ((^.)) -import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Forecast @@ -77,11 +74,13 @@ import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.History (Bound (boundSlot)) import Ouroboros.Consensus.HardFork.Simple import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol , ledgerViewForecastAt ) +import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Praos @@ -93,6 +92,7 @@ import Ouroboros.Consensus.Shelley.Node () import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.IndexedMemPack +import Ouroboros.Consensus.Util.TypeLevel {------------------------------------------------------------------------------- Synonym for convenience @@ -120,7 +120,10 @@ instance ( ShelleyCompatible proto era , LedgerSupportsProtocol (ShelleyBlock proto era) , TxLimits (ShelleyBlock proto era) + , GetBlockKeySets (ShelleyBlock proto era) , Crypto (ProtoCrypto proto) + , All SingI (TablesForBlock (ShelleyBlock proto era)) + , ToAllDict (TableConstraints (ShelleyBlock proto era)) (TablesForBlock (ShelleyBlock proto era)) ) => NoHardForks (ShelleyBlock proto era) where @@ -164,17 +167,23 @@ instance -- prepared for future hard forks without having to do any bit twiddling. instance ( ShelleyCompatible proto era + , GetBlockKeySets (ShelleyBlock proto era) , LedgerSupportsProtocol (ShelleyBlock proto era) , TxLimits (ShelleyBlock proto era) , Crypto (ProtoCrypto proto) + , All SingI (TablesForBlock (ShelleyBlock proto era)) + , ToAllDict (TableConstraints (ShelleyBlock proto era)) (TablesForBlock (ShelleyBlock proto era)) ) => SerialiseHFC '[ShelleyBlock proto era] instance ( ShelleyCompatible proto era + , GetBlockKeySets (ShelleyBlock proto era) , LedgerSupportsProtocol (ShelleyBlock proto era) , TxLimits (ShelleyBlock proto era) , Crypto (ProtoCrypto proto) + , All SingI (TablesForBlock (ShelleyBlock proto era)) + , ToAllDict (TableConstraints (ShelleyBlock proto era)) (TablesForBlock (ShelleyBlock proto era)) ) => SerialiseConstraintsHFC (ShelleyBlock proto era) @@ -226,8 +235,12 @@ shelleyTransition instance ( ShelleyCompatible proto era , LedgerSupportsProtocol (ShelleyBlock proto era) + , All SingI (TablesForBlock (ShelleyBlock proto era)) , TxLimits (ShelleyBlock proto era) + , GetBlockKeySets (ShelleyBlock proto era) , Crypto (ProtoCrypto proto) + , All SingI (TablesForBlock (ShelleyBlock proto era)) + , ToAllDict (TableConstraints (ShelleyBlock proto era)) (TablesForBlock (ShelleyBlock proto era)) ) => SingleEraBlock (ShelleyBlock proto era) where @@ -360,12 +373,12 @@ instance , SL.TranslateEra era (ShelleyTip proto) , SL.TranslateEra era SL.NewEpochState , SL.TranslationError era SL.NewEpochState ~ Void - , CanMapMK mk - , CanMapKeysMK mk + , SingI (TablesForBlock (ShelleyBlock proto era)) + , All (TableConstraints (ShelleyBlock proto era)) (TablesForBlock (ShelleyBlock proto era)) ) => - SL.TranslateEra era (Flip LedgerState mk :.: ShelleyBlock proto) + SL.TranslateEra era (Flip LedgerState EmptyMK :.: ShelleyBlock proto) where - translateEra ctxt (Comp (Flip (ShelleyLedgerState tip state _transition tables))) = do + translateEra ctxt (Comp (Flip (ShelleyLedgerState tip state _transition _tables))) = do tip' <- mapM (SL.translateEra ctxt) tip state' <- SL.translateEra ctxt state return $ @@ -375,19 +388,18 @@ instance { shelleyLedgerTip = tip' , shelleyLedgerState = state' , shelleyLedgerTransition = ShelleyTransitionInfo 0 - , shelleyLedgerTables = translateShelleyTables tables + , shelleyLedgerTables = emptyLedgerTables } -translateShelleyTables :: - ( CanMapMK mk - , CanMapKeysMK mk - , ShelleyBasedEra era - , ShelleyBasedEra (SL.PreviousEra era) - ) => - LedgerTables (LedgerState (ShelleyBlock proto (SL.PreviousEra era))) mk -> - LedgerTables (LedgerState (ShelleyBlock proto era)) mk -translateShelleyTables (LedgerTables utxoTable) = - LedgerTables $ mapKeysMK coerce $ mapMK SL.upgradeTxOut utxoTable +-- translateShelleyTables :: +-- ( CanMapMK mk +-- , ShelleyBasedEra era +-- , ShelleyBasedEra (SL.PreviousEra era) +-- ) => +-- LedgerTables (ShelleyBlock proto (SL.PreviousEra era)) mk -> +-- LedgerTables (ShelleyBlock proto era) mk +-- translateShelleyTables (LedgerTables utxoTable) = +-- tbs & crossEraForecastAcrossShelley $ mapMK SL.upgradeTxOut utxoTable instance ( ShelleyBasedEra era @@ -417,36 +429,24 @@ instance <$> SL.translateValidated @era @SL.Tx ctxt (SL.coerceValidated vtx) {------------------------------------------------------------------------------- - Canonical TxIn + HardForkTxOut -------------------------------------------------------------------------------} instance - (ShelleyCompatible proto era, ShelleyBasedEra era) => - HasCanonicalTxIn '[ShelleyBlock proto era] + ( ShelleyCompatible proto era + , LedgerSupportsProtocol (ShelleyBlock proto era) + , All SingI (TablesForBlock (ShelleyBlock proto era)) + , HasLedgerTables LedgerState (HardForkBlock '[ShelleyBlock proto era]) + ) => + HasHardForkTxOut '[ShelleyBlock proto era] where - newtype CanonicalTxIn '[ShelleyBlock proto era] = ShelleyBlockHFCTxIn - { getShelleyBlockHFCTxIn :: BigEndianTxIn - } - deriving stock (Show, Eq, Ord) - deriving newtype (NoThunks, MemPack) - - injectCanonicalTxIn IZ txIn = ShelleyBlockHFCTxIn txIn - injectCanonicalTxIn (IS idx') _ = case idx' of {} - - ejectCanonicalTxIn IZ txIn = getShelleyBlockHFCTxIn txIn - ejectCanonicalTxIn (IS idx') _ = case idx' of {} - -{------------------------------------------------------------------------------- - HardForkTxOut --------------------------------------------------------------------------------} - -instance ShelleyCompatible proto era => HasHardForkTxOut '[ShelleyBlock proto era] where type HardForkTxOut '[ShelleyBlock proto era] = SL.TxOut era injectHardForkTxOut IZ txOut = txOut injectHardForkTxOut (IS idx') _ = case idx' of {} ejectHardForkTxOut IZ txOut = txOut ejectHardForkTxOut (IS idx') _ = case idx' of {} - txOutEjections = fn (unZ . unK) :* Nil + + -- txOutEjections = fn (unZ . unK) :* Nil txOutTranslations = Tails.mk1 {------------------------------------------------------------------------------- @@ -456,20 +456,23 @@ instance ShelleyCompatible proto era => HasHardForkTxOut '[ShelleyBlock proto er instance ( ShelleyCompatible proto era , ShelleyBasedEra era - , TxOut (LedgerState (ShelleyBlock proto era)) ~ SL.TxOut era + , TxOut (ShelleyBlock proto era) ~ SL.TxOut era + , SListI (TablesForBlock (HardForkBlock '[ShelleyBlock proto era])) + , SingI (TablesForBlock (HardForkBlock '[ShelleyBlock proto era])) , HasHardForkTxOut '[ShelleyBlock proto era] + , HasLedgerTables LedgerState (HardForkBlock '[ShelleyBlock proto era]) + , InjectValues '[ShelleyBlock proto era] (ShelleyBlock proto era) ) => BlockSupportsHFLedgerQuery '[ShelleyBlock proto era] where answerBlockQueryHFLookup = \case - IZ -> answerShelleyLookupQueries (injectLedgerTables IZ) id (coerce . ejectCanonicalTxIn IZ) + IZ -> answerShelleyLookupQueries (injectLedgerTables IZ) id IS idx -> case idx of {} answerBlockQueryHFTraverse = \case IZ -> answerShelleyTraversingQueries id - (coerce . ejectCanonicalTxIn IZ) (queryLedgerGetTraversingFilter @('[ShelleyBlock proto era]) IZ) IS idx -> case idx of {} @@ -478,27 +481,28 @@ instance IS idx -> case idx of {} instance - (txout ~ SL.TxOut era, MemPack txout) => - IndexedMemPack (LedgerState (HardForkBlock '[ShelleyBlock proto era]) EmptyMK) txout + MemPack (Value table (HardForkBlock '[ShelleyBlock proto era])) => + IndexedMemPack LedgerState (HardForkBlock '[ShelleyBlock proto era]) (table :: TABLE) where - indexedTypeName _ = typeName @txout - indexedPackedByteCount _ = packedByteCount - indexedPackM _ = packM - indexedUnpackM _ = unpackM + type + IndexedValue LedgerState table (HardForkBlock '[ShelleyBlock proto era]) = + Value table (HardForkBlock '[ShelleyBlock proto era]) + indexedTypeName _ _ _ = typeName @(Value table (HardForkBlock '[ShelleyBlock proto era])) + indexedPackedByteCount _ _ _ _ = packedByteCount + indexedPackM _ _ _ _ = packM + indexedUnpackM _ _ _ _ = unpackM instance ShelleyCompatible proto era => - SerializeTablesWithHint (LedgerState (HardForkBlock '[ShelleyBlock proto era])) + SerializeTablesWithHint LedgerState (HardForkBlock '[ShelleyBlock proto era]) UTxOTable where encodeTablesWithHint :: LedgerState (HardForkBlock '[ShelleyBlock proto era]) EmptyMK -> - LedgerTables (LedgerState (HardForkBlock '[ShelleyBlock proto era])) ValuesMK -> + Table ValuesMK (HardForkBlock '[ShelleyBlock proto era]) UTxOTable -> Encoding - encodeTablesWithHint (HardForkLedgerState (HardForkState idx)) (LedgerTables (ValuesMK tbs)) = - let - np = (Fn $ const $ K encOne) :* Nil - in - hcollapse $ hap np $ Telescope.tip idx + encodeTablesWithHint (HardForkLedgerState (HardForkState idx)) (Table (ValuesMK tbs)) = + let np = (Fn $ const $ K encOne) :* Nil + in hcollapse $ hap np $ Telescope.tip idx where encOne :: Encoding encOne = toPlainEncoding (SL.eraProtVerLow @era) $ encodeMap encodeMemPack encodeMemPack tbs @@ -506,7 +510,7 @@ instance decodeTablesWithHint :: forall s. LedgerState (HardForkBlock '[ShelleyBlock proto era]) EmptyMK -> - Decoder s (LedgerTables (LedgerState (HardForkBlock '[ShelleyBlock proto era])) ValuesMK) + Decoder s (Table ValuesMK (HardForkBlock '[ShelleyBlock proto era]) UTxOTable) decodeTablesWithHint (HardForkLedgerState (HardForkState idx)) = let np = (Fn $ Comp . fmap K . getOne . unFlip . currentState) :* Nil @@ -515,7 +519,7 @@ instance where getOne :: LedgerState (ShelleyBlock proto era) EmptyMK -> - Decoder s (LedgerTables (LedgerState (HardForkBlock '[ShelleyBlock proto era])) ValuesMK) + Decoder s (Table ValuesMK (HardForkBlock '[ShelleyBlock proto era]) UTxOTable) getOne st = let certInterns = internsFromMap $ @@ -526,4 +530,4 @@ instance . SL.certDStateL . SL.accountsL . SL.accountsMapL - in LedgerTables . ValuesMK <$> SL.eraDecoder @era (decodeMap decodeMemPack (decShareCBOR certInterns)) + in Table . ValuesMK <$> SL.eraDecoder @era (decodeMap decodeMemPack (decShareCBOR certInterns)) diff --git a/ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/SnapshotConversion.hs b/ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/SnapshotConversion.hs new file mode 100644 index 0000000000..335266c575 --- /dev/null +++ b/ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/SnapshotConversion.hs @@ -0,0 +1,518 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Convert snapshots among different formats. This is exposed in +-- @cardano-node@ as a subcommand and also via the @snapshot-converter@ +-- executable. +module Ouroboros.Consensus.Cardano.SnapshotConversion + ( Format (..) + , parseFormat + , convertSnapshot + ) where + +import Codec.Serialise +import Control.Monad (when) +import qualified Control.Monad as Monad +import Control.Monad.Except +import Control.Monad.Trans (lift) +import Control.ResourceRegistry +import Data.Bifunctor +import Data.Char (toLower) +import qualified Data.Text.Lazy as T +import Options.Applicative +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Cardano.Node () +import Ouroboros.Consensus.Cardano.StreamingLedgerTables +import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Ledger.Basics +import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Storage.LedgerDB.API +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as V1 +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM +import Ouroboros.Consensus.Util.CRC +import Ouroboros.Consensus.Util.IOLike hiding (yield) +import System.Console.ANSI +import qualified System.Directory as D +import System.FS.API +import System.FS.CRC +import System.FS.IO +import System.FilePath (splitDirectories) +import qualified System.FilePath as F +import System.IO +import System.ProgressBar +import System.Random + +data Format + = Mem FilePath + | LMDB FilePath + | LSM FilePath FilePath + deriving (Show, Read) + +{------------------------------------------------------------------------------- + Optparse +-------------------------------------------------------------------------------} + +inoutForHelp :: String -> Bool -> String +inoutForHelp s b = + mconcat $ + ("Output " <> s) + : if b + then + [ ". Must be a filepath where the last fragment is named after the " + , "slot of the snapshotted state plus an optional suffix. Example: `1645330287_suffix`." + ] + else [] + +parsePath :: String -> String -> Parser FilePath +parsePath optName strHelp = + strOption + ( mconcat + [ long optName + , help strHelp + , metavar "PATH" + ] + ) + +parseFormat :: Parser Format +parseFormat = + ( Mem + <$> (parsePath "mem-out" (inoutForHelp "snapshot dir" True)) + ) + <|> ( LMDB + <$> (parsePath "lmdb-out" (inoutForHelp "snapshot dir" True)) + ) + <|> ( LSM + <$> (parsePath "lsm-snapshot-out" (inoutForHelp "snapshot dir" True)) + <*> (parsePath "lsm-database-out" (inoutForHelp "LSM database" False)) + ) + +{------------------------------------------------------------------------------- + Errors +-------------------------------------------------------------------------------} + +data Error blk + = SnapshotError (SnapshotFailure blk) + | BadDirectoryName FilePath + | WrongSlotDirectoryName FilePath SlotNo + | InvalidMetadata String + | BackendMismatch SnapshotBackend SnapshotBackend + | CRCMismatch CRC CRC + | ReadTablesError DeserialiseFailure + | Cancelled + deriving Exception + +instance StandardHash blk => Show (Error blk) where + show (SnapshotError err) = + "Couldn't deserialize the snapshot. Are you running the same node version that created the snapshot? " + <> show err + show (BadDirectoryName fp) = + mconcat + [ "Filepath " + , fp + , " is not an snapshot. The last fragment on the path should be" + , " named after the slot number of the state it contains and an" + , " optional suffix, such as `163470034` or `163470034_my-suffix`." + ] + show (InvalidMetadata s) = "Metadata is invalid: " <> s + show (BackendMismatch b1 b2) = + mconcat + [ "Mismatched backend in snapshot. Reading as " + , show b1 + , " but snapshot is " + , show b2 + ] + show (WrongSlotDirectoryName fp sl) = + mconcat + [ "The name of the snapshot (\"" + , fp + , "\") does not correspond to the slot number of the state (" + , (show . unSlotNo $ sl) + , ")." + ] + show (CRCMismatch c1 c2) = + mconcat + [ "The input snapshot seems corrupted. Metadata has CRC " + , show c1 + , " but reading it gives CRC " + , show c2 + ] + show (ReadTablesError df) = + mconcat + ["Error when reading entries in the UTxO tables: ", show df] + show Cancelled = "Cancelled" + +{------------------------------------------------------------------------------- + Environments +-------------------------------------------------------------------------------} + +data InEnv backend = InEnv + { inState :: LedgerState (CardanoBlock StandardCrypto) EmptyMK + -- ^ Ledger state (without tables) that will be used to index the snapshot. + , inFilePath :: FilePath + -- ^ The file path to the LedgerDB snapshot + , inStream :: + LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ResourceRegistry IO -> + IO (SomeBackend YieldArgs) + -- ^ Yield arguments for producing a stream of TxOuts + , inProgressMsg :: String + -- ^ A progress message (just for displaying) + , inCRC :: CRC + -- ^ The CRC of the input @state@ file as read + , inSnapReadCRC :: Maybe CRC + -- ^ The CRC of the input snapshot from the metadata file + } + +data OutEnv backend = OutEnv + { outFilePath :: FilePath + -- ^ The output snapshot directory + , outStream :: + LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ResourceRegistry IO -> + IO (SomeBackend SinkArgs) + -- ^ Sink arguments for consuming a stream of TxOuts + , outDeleteExtra :: Maybe FilePath + -- ^ In case some other directory needs to be wiped out + , outProgressMsg :: String + -- ^ A progress message (just for displaying) + , outBackend :: SnapshotBackend + -- ^ The backend used for the output snapshot, to write it in the metadata + } + +data SomeBackend c where + SomeBackend :: + StreamingBackend IO backend (LedgerState (CardanoBlock StandardCrypto)) => + c IO backend (LedgerState (CardanoBlock StandardCrypto)) -> SomeBackend c + +convertSnapshot :: + Bool -> + ProtocolInfo (CardanoBlock StandardCrypto) -> + Format -> + Format -> + ExceptT (Error (CardanoBlock StandardCrypto)) IO () +convertSnapshot interactive (configCodec . pInfoConfig -> ccfg) from to = do + InEnv{..} <- getInEnv + + o@OutEnv{..} <- getOutEnv inState + + wipeOutputPaths o + + when interactive $ lift $ putStr "Copying state file..." >> hFlush stdout + lift $ D.copyFile (inFilePath F. "state") (outFilePath F. "state") + when interactive $ lift $ putColored Green True "Done" + + when interactive $ lift $ putStr "Streaming ledger tables..." >> hFlush stdout >> saveCursor + + tid <- + if interactive + then lift $ niceAnimatedProgressBar inProgressMsg outProgressMsg + else pure Nothing + + eRes <- lift $ runExceptT (stream inState inStream outStream) + + case eRes of + Left err -> throwError $ ReadTablesError err + Right (mCRCIn, mCRCOut) -> do + lift $ maybe (pure ()) cancel tid + when interactive $ lift $ clearLine >> restoreCursor >> cursorUp 1 >> putColored Green True "Done" + let crcIn = maybe inCRC (crcOfConcat inCRC) mCRCIn + when interactive $ + maybe + ( lift $ + putColored Yellow True "The metadata file is missing, the snapshot is not guaranteed to be correct!" + ) + ( \cs -> + Monad.when (cs /= crcIn) $ throwError $ CRCMismatch cs crcIn + ) + inSnapReadCRC + + let crcOut = maybe inCRC (crcOfConcat inCRC) mCRCOut + + when interactive $ lift $ putStr "Generating new metadata file..." >> hFlush stdout + putMetadata outFilePath (SnapshotMetadata outBackend crcOut TablesCodecVersion1) + + when interactive $ lift $ putColored Green True "Done" + where + wipeOutputPaths OutEnv{..} = do + wipePath interactive outFilePath + maybe + (pure ()) + (wipePath interactive) + outDeleteExtra + + getState fp@(pathToHasFS -> fs) = do + eState <- lift $ do + when interactive $ putStr $ "Reading ledger state from " <> (fp F. "state") <> "..." + when interactive $ hFlush stdout + runExceptT (readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (mkFsPath ["state"])) + case eState of + Left err -> + throwError . SnapshotError . InitFailureRead @(CardanoBlock StandardCrypto) . ReadSnapshotFailed $ + err + Right st -> lift $ do + when interactive $ putColored Green True " Done" + pure . first ledgerState $ st + + -- Metadata management + getMetadata fp bknd = do + (fs, ds) <- toDiskSnapshot fp + mtd <- + lift $ runExceptT $ loadSnapshotMetadata fs ds + (,ds) + <$> either + ( \case + MetadataFileDoesNotExist -> pure Nothing + MetadataInvalid s -> throwError $ InvalidMetadata s + MetadataBackendMismatch -> error "impossible" + ) + ( \mtd' -> do + if bknd /= snapshotBackend mtd' + then throwError $ BackendMismatch bknd (snapshotBackend mtd') + else pure $ Just $ snapshotChecksum mtd' + ) + mtd + + putMetadata fp bknd = do + (fs, ds) <- toDiskSnapshot fp + lift $ writeSnapshotMetadata fs ds bknd + + -- Produce an InEnv from the given arguments + getInEnv = case from of + Mem fp -> do + (mtd, ds) <- getMetadata fp UTxOHDMemSnapshot + (st, c) <- getState fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + ( withOrigin + ( error + "Impossible! the snapshot seems to be at Genesis but cardano-node would never create such an snapshot!" + ) + id + $ pointSlot (getTip st) + ) + ) + + pure $ + InEnv + st + fp + (\a b -> SomeBackend <$> mkInMemYieldArgs (fp F. "tables") a b) + ("InMemory@[" <> fp <> "]") + c + mtd + LMDB fp -> do + (mtd, ds) <- getMetadata fp UTxOHDLMDBSnapshot + (st, c) <- getState fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + (withOrigin undefined id $ pointSlot (getTip st)) + ) + + pure $ + InEnv + st + fp + (\a b -> SomeBackend <$> V1.mkLMDBYieldArgs (fp F. "tables") defaultLMDBLimits a b) + ("LMDB@[" <> fp <> "]") + c + mtd + LSM fp lsmDbPath -> do + (mtd, ds) <- getMetadata fp UTxOHDLSMSnapshot + (st, c) <- getState fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + (withOrigin undefined id $ pointSlot (getTip st)) + ) + + pure $ + InEnv + st + fp + ( \a b -> + SomeBackend <$> mkLSMYieldArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b + ) + ("LSM@[" <> lsmDbPath <> "]") + c + mtd + + -- Produce an OutEnv from the given arguments + getOutEnv st = case to of + Mem fp -> do + (_, ds) <- toDiskSnapshot fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + (withOrigin undefined id $ pointSlot (getTip st)) + ) + pure $ + OutEnv + fp + (\a b -> SomeBackend <$> mkInMemSinkArgs (fp F. "tables") a b) + Nothing + ("InMemory@[" <> fp <> "]") + UTxOHDMemSnapshot + LMDB fp -> do + (_, ds) <- toDiskSnapshot fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + (withOrigin undefined id $ pointSlot (getTip st)) + ) + pure $ + OutEnv + fp + (\a b -> SomeBackend <$> V1.mkLMDBSinkArgs fp defaultLMDBLimits a b) + Nothing + ("LMDB@[" <> fp <> "]") + UTxOHDLMDBSnapshot + LSM fp lsmDbPath -> do + (_, ds) <- toDiskSnapshot fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + (withOrigin undefined id $ pointSlot (getTip st)) + ) + pure $ + OutEnv + fp + ( \a b -> + SomeBackend <$> mkLSMSinkArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b + ) + (Just lsmDbPath) + ("LSM@[" <> lsmDbPath <> "]") + UTxOHDLSMSnapshot + + stream :: + LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ( LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ResourceRegistry IO -> + IO (SomeBackend YieldArgs) + ) -> + ( LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ResourceRegistry IO -> + IO (SomeBackend SinkArgs) + ) -> + ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC) + stream st mYieldArgs mSinkArgs = + ExceptT $ + withRegistry $ \reg -> do + (SomeBackend (yArgs :: YieldArgs IO backend1 l)) <- mYieldArgs st reg + (SomeBackend (sArgs :: SinkArgs IO backend2 l)) <- mSinkArgs st reg + runExceptT $ yield (Proxy @backend1) yArgs st $ sink (Proxy @backend2) sArgs st + +{------------------------------------------------------------------------------- + User interaction +-------------------------------------------------------------------------------} + +niceAnimatedProgressBar :: String -> String -> IO (Maybe (Async IO ())) +niceAnimatedProgressBar inMsg outMsg = do + stdoutSupportsANSI <- hNowSupportsANSI stdout + if stdoutSupportsANSI + then do + putStrLn "" + pb <- + newProgressBar + defStyle{stylePrefix = msg (T.pack inMsg), stylePostfix = msg (T.pack outMsg)} + 10 + (Progress 1 100 ()) + + fmap Just $ + async $ + let loop = do + threadDelay 0.2 + updateProgress pb (\prg -> prg{progressDone = (progressDone prg + 4) `mod` 100}) + in Monad.forever loop + else pure Nothing + +putColored :: Color -> Bool -> String -> IO () +putColored c b s = do + stdoutSupportsANSI <- hNowSupportsANSI stdout + Monad.when stdoutSupportsANSI $ setSGR [SetColor Foreground Vivid c] + if b + then + putStrLn s + else + putStr s + Monad.when stdoutSupportsANSI $ setSGR [Reset] + hFlush stdout + +askForConfirmation :: + Bool -> + ExceptT (Error (CardanoBlock StandardCrypto)) IO a -> + String -> + ExceptT (Error (CardanoBlock StandardCrypto)) IO a +askForConfirmation False act _ = act +askForConfirmation True act infoMsg = do + lift $ putColored Yellow False $ "I'm going to " <> infoMsg <> ". Continue? (Y/n) " + answer <- lift $ getLine + case map toLower answer of + "y" -> act + _ -> throwError Cancelled + +-- | Ask before deleting +wipePath :: Bool -> FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO () +wipePath interactive fp = do + exists <- lift $ D.doesDirectoryExist fp + ( if exists + then flip (askForConfirmation interactive) ("wipe the path " <> fp) + else id + ) + (lift $ D.removePathForcibly fp >> D.createDirectoryIfMissing True fp) + +{------------------------------------------------------------------------------- + Helpers +-------------------------------------------------------------------------------} +toDiskSnapshot :: + FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO (SomeHasFS IO, DiskSnapshot) +toDiskSnapshot fp@(F.splitFileName . maybeRemoveTrailingSlash -> (snapPath, snapName)) = + maybe + (throwError $ BadDirectoryName fp) + (pure . (pathToHasFS snapPath,)) + $ snapshotFromPath snapName + +-- | Given a filepath pointing to a snapshot (with or without a trailing slash), produce: +-- +-- * A HasFS at the snapshot directory +pathToHasFS :: FilePath -> SomeHasFS IO +pathToHasFS (maybeRemoveTrailingSlash -> path) = + SomeHasFS $ ioHasFS $ MountPoint path + +maybeRemoveTrailingSlash :: String -> String +maybeRemoveTrailingSlash s = case last s of + '/' -> init s + '\\' -> init s + _ -> s + +defaultLMDBLimits :: V1.LMDBLimits +defaultLMDBLimits = + V1.LMDBLimits + { V1.lmdbMapSize = 16 * 1024 * 1024 * 1024 + , V1.lmdbMaxDatabases = 10 + , V1.lmdbMaxReaders = 16 + } diff --git a/ouroboros-consensus-cardano/app/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs b/ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs similarity index 100% rename from ouroboros-consensus-cardano/app/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs rename to ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 1c45c68155..f399083cc9 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -62,6 +62,7 @@ import Ouroboros.Consensus.Genesis.Governor (gddWatcher) import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.LedgerStateType (TickedL (..)) import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -646,7 +647,7 @@ forkBlockForging IS{..} (MkBlockForging blockForgingM) = snap <- getSnapshot mempool -- only used for its tip-like information pure (castHash $ snapshotStateHash snap, snapshotSlotNo snap) - let readTables = fmap castLedgerTables . roforkerReadTables forker . castLedgerTables + let readTables = roforkerReadTables forker mempoolSnapshot <- lift $ @@ -678,7 +679,7 @@ forkBlockForging IS{..} (MkBlockForging blockForgingM) = cfg bcBlockNo currentSlot - (forgetLedgerTables tickedLedgerState) + (unTickedL $ forgetLedgerTables $ TickedL tickedLedgerState) txs proof @@ -929,7 +930,7 @@ getPeersFromCurrentLedgerAfterSlot :: forall m blk addrNTN addrNTC. ( IOLike m , LedgerSupportsPeerSelection blk - , UpdateLedger blk + , ApplyBlock LedgerState blk ) => NodeKernel m addrNTN addrNTC blk -> SlotNo -> @@ -946,7 +947,7 @@ getPeersFromCurrentLedgerAfterSlot kernel slotNo = -- | Retrieve the slot of the immutable tip getImmTipSlot :: ( IOLike m - , UpdateLedger blk + , ApplyBlock LedgerState blk ) => NodeKernel m addrNTN addrNTC blk -> STM m (WithOrigin SlotNo) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 50da4ba99b..1032f1c040 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -75,6 +75,17 @@ library import: common-lib hs-source-dirs: src/ouroboros-consensus exposed-modules: + -- Ouroboros.Consensus.Ledger.Dual + -- Ouroboros.Consensus.Storage.LedgerDB.V1 + -- Ouroboros.Consensus.Storage.LedgerDB.V1.Args + -- Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore + -- Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API + -- Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory + -- Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog + -- Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq + -- Ouroboros.Consensus.Storage.LedgerDB.V1.Forker + -- Ouroboros.Consensus.Storage.LedgerDB.V1.Lock + -- Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots Ouroboros.Consensus.Block Ouroboros.Consensus.Block.Abstract Ouroboros.Consensus.Block.EBB @@ -158,9 +169,9 @@ library Ouroboros.Consensus.Ledger.Abstract Ouroboros.Consensus.Ledger.Basics Ouroboros.Consensus.Ledger.CommonProtocolParams - Ouroboros.Consensus.Ledger.Dual Ouroboros.Consensus.Ledger.Extended Ouroboros.Consensus.Ledger.Inspect + Ouroboros.Consensus.Ledger.LedgerStateType Ouroboros.Consensus.Ledger.Query Ouroboros.Consensus.Ledger.Query.Version Ouroboros.Consensus.Ledger.SupportsMempool @@ -247,16 +258,6 @@ library Ouroboros.Consensus.Storage.LedgerDB.Forker Ouroboros.Consensus.Storage.LedgerDB.Snapshots Ouroboros.Consensus.Storage.LedgerDB.TraceEvent - Ouroboros.Consensus.Storage.LedgerDB.V1 - Ouroboros.Consensus.Storage.LedgerDB.V1.Args - Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore - Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API - Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory - Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog - Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq - Ouroboros.Consensus.Storage.LedgerDB.V1.Forker - Ouroboros.Consensus.Storage.LedgerDB.V1.Lock - Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots Ouroboros.Consensus.Storage.LedgerDB.V2 Ouroboros.Consensus.Storage.LedgerDB.V2.Backend Ouroboros.Consensus.Storage.LedgerDB.V2.Forker @@ -303,9 +304,14 @@ library Ouroboros.Consensus.Util.RedundantConstraints Ouroboros.Consensus.Util.STM Ouroboros.Consensus.Util.Time + Ouroboros.Consensus.Util.TypeLevel Ouroboros.Consensus.Util.Versioned build-depends: + -- constraints, + -- diff-containers >=1.2, + -- fingertree-rm >=1.0, + -- monoid-subclasses, FailT ^>=0.1.2, aeson, base >=4.14 && <4.22, @@ -324,16 +330,13 @@ library containers >=0.5 && <0.8, contra-tracer, deepseq, - diff-containers >=1.2, filelock, - filepath, - fingertree-rm >=1.0, fs-api ^>=0.4, hashable, io-classes:{io-classes, si-timers, strict-mvar, strict-stm} ^>=1.8.0.1, measures, mempack, - monoid-subclasses, + microlens, mtl, multiset ^>=0.3, nothunks ^>=0.2 || ^>=0.3, @@ -348,6 +351,7 @@ library semialign >=1.1, serialise ^>=0.2, singletons, + singletons-base, small-steps ^>=1.1, sop-core ^>=0.5, sop-extras ^>=0.4.1, @@ -382,12 +386,14 @@ library ouroboros-consensus-lsm build-depends: base >=4.14 && <4.22, blockio, + cardano-ledger-core, containers >=0.5 && <0.8, contra-tracer, filepath, fs-api ^>=0.4, lsm-tree, mempack, + microlens, mtl, nothunks ^>=0.2 || ^>=0.3, ouroboros-consensus, @@ -395,7 +401,11 @@ library ouroboros-consensus-lsm random, resource-registry ^>=0.2, serialise ^>=0.2, + singletons, + singletons-base, + sop-core, streaming, + strict-sop-core, text, transformers, vector ^>=0.13, diff --git a/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs b/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs index 1c4dd4305f..355dcce27e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,12 +8,15 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -- Needed for @NoThunks (Table m k v b)@ @@ -28,6 +31,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.LSM , Trace (LSMTreeTrace) , LSM.LSMTreeTrace (..) , mkLSMArgs + , SerialiseTable , stdMkBlockIOFS -- * Streaming @@ -39,9 +43,12 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.LSM -- * Exported for tests , LSM.Salt , SomeHasFSAndBlockIO (..) + , MemAndDiskTable ) where -import Codec.Serialise (decode) +import Cardano.Ledger.Coin +import Cardano.Ledger.Credential +import Codec.Serialise (DeserialiseFailure, decode) import qualified Control.Monad as Monad import Control.Monad.Trans (lift) import Control.Monad.Trans.Except @@ -49,12 +56,18 @@ import Control.ResourceRegistry import Control.Tracer import qualified Data.Foldable as Foldable import Data.Functor.Contravariant ((>$<)) +import Data.Functor.Product import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Maybe import Data.MemPack import qualified Data.Primitive.ByteArray as PBA +import Data.SOP.BasicFunctors +import Data.SOP.Constraint +import qualified Data.SOP.Dict as Dict +import Data.SOP.Strict import qualified Data.Set as Set +import qualified Data.Singletons as S import Data.String (fromString) import qualified Data.Text as T import qualified Data.Text as Text @@ -63,9 +76,9 @@ import qualified Data.Vector as V import qualified Data.Vector.Mutable as VM import qualified Data.Vector.Primitive as VP import Data.Void -import Database.LSMTree (Salt, Session, Table) +import Database.LSMTree (Salt, Session) import qualified Database.LSMTree as LSM -import GHC.Generics +import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import NoThunks.Class import Ouroboros.Consensus.Block @@ -84,6 +97,7 @@ import Ouroboros.Consensus.Util.CRC import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.IndexedMemPack +import Ouroboros.Consensus.Util.TypeLevel import qualified Streaming as S import qualified Streaming.Prelude as S import System.FS.API @@ -93,15 +107,35 @@ import System.FilePath (splitDirectories, splitFileName) import System.Random import Prelude hiding (read) --- | Type alias for convenience -type UTxOTable m = Table m TxInBytes TxOutBytes Void +type family Value' table blk where + Value' UTxOTable blk = TxOutBytes + Value' table blk = Value table blk -instance NoThunks (Table m txin txout Void) where - showTypeOf _ = "Table" - wNoThunks _ _ = pure Nothing +newtype Table' m blk table = Table' {getTable' :: LSM.Table m (Key table) (Value' table blk) Void} -data LSMClosedExn = LSMClosedExn - deriving (Show, Exception) +data LSMTables m blk = LSMTables (NP (Table' m blk) (TablesForBlock blk)) + +class + ( LSM.SerialiseKey (Key table) + , LSM.SerialiseValue (Value' table blk) + , LSM.ResolveValue (Value' table blk) + , TableLabel table + ) => + SerialiseTable l blk table + where + ser :: Proxy table -> Proxy blk -> l blk EmptyMK -> Value table blk -> Value' table blk + des :: Proxy table -> Proxy blk -> l blk EmptyMK -> Value' table blk -> Value table blk + +instance + (IndexedMemPack l blk UTxOTable, IndexedValue l UTxOTable blk ~ TxOut blk) => + SerialiseTable l blk UTxOTable + where + ser _ _ = toTxOutBytes + des _ _ = fromTxOutBytes + +instance SerialiseTable l blk InstantStakeTable where + ser _ _ _ = id + des _ _ _ = id {------------------------------------------------------------------------------- TxOuts @@ -109,14 +143,18 @@ data LSMClosedExn = LSMClosedExn newtype TxOutBytes = TxOutBytes {unTxOutBytes :: LSM.RawBytes} -toTxOutBytes :: IndexedMemPack (l EmptyMK) (TxOut l) => l EmptyMK -> TxOut l -> TxOutBytes +toTxOutBytes :: + (IndexedMemPack l blk UTxOTable, IndexedValue l UTxOTable blk ~ TxOut blk) => + l blk EmptyMK -> TxOut blk -> TxOutBytes toTxOutBytes st txout = - let barr = indexedPackByteArray True st txout + let barr = indexedPackByteArray @UTxOTable True st txout in TxOutBytes $ LSM.RawBytes (VP.Vector 0 (PBA.sizeofByteArray barr) barr) -fromTxOutBytes :: IndexedMemPack (l EmptyMK) (TxOut l) => l EmptyMK -> TxOutBytes -> TxOut l +fromTxOutBytes :: + (IndexedMemPack l blk UTxOTable, IndexedValue l UTxOTable blk ~ TxOut blk) => + l blk EmptyMK -> TxOutBytes -> TxOut blk fromTxOutBytes st (TxOutBytes (LSM.RawBytes vec)) = - case indexedUnpackEither st vec of + case indexedUnpackEither @UTxOTable st vec of Left err -> error $ unlines @@ -131,20 +169,31 @@ instance LSM.SerialiseValue TxOutBytes where deserialiseValue = TxOutBytes deriving via LSM.ResolveAsFirst TxOutBytes instance LSM.ResolveValue TxOutBytes +deriving via LSM.ResolveAsFirst (CompactForm Coin) instance LSM.ResolveValue (CompactForm Coin) {------------------------------------------------------------------------------- - TxIns + Canonical keys and values -------------------------------------------------------------------------------} -newtype TxInBytes = TxInBytes {unTxInBytes :: LSM.RawBytes} +instance LSM.SerialiseKey TxIn where + serialiseKey = packRawBytes + deserialiseKey = unpackRawBytes + +instance LSM.SerialiseKey (Credential 'Staking) where + serialiseKey = packRawBytes + deserialiseKey = unpackRawBytes + +instance LSM.SerialiseValue (CompactForm Coin) where + serialiseValue = packRawBytes + deserialiseValue = unpackRawBytes -toTxInBytes :: MemPack (TxIn l) => Proxy l -> TxIn l -> TxInBytes -toTxInBytes _ txin = - let barr = packByteArray True txin - in TxInBytes $ LSM.RawBytes (VP.Vector 0 (PBA.sizeofByteArray barr) barr) +packRawBytes :: MemPack x => x -> LSM.RawBytes +packRawBytes x = + let barr = packByteArray True x + in LSM.RawBytes (VP.Vector 0 (PBA.sizeofByteArray barr) barr) -fromTxInBytes :: MemPack (TxIn l) => Proxy l -> TxInBytes -> TxIn l -fromTxInBytes _ (TxInBytes (LSM.RawBytes vec)) = +unpackRawBytes :: MemPack x => LSM.RawBytes -> x +unpackRawBytes (LSM.RawBytes vec) = case unpackEither vec of Left err -> error $ @@ -155,23 +204,21 @@ fromTxInBytes _ (TxInBytes (LSM.RawBytes vec)) = ] Right v -> v -instance LSM.SerialiseKey TxInBytes where - serialiseKey = unTxInBytes - deserialiseKey = TxInBytes - {------------------------------------------------------------------------------- LedgerTablesHandle -------------------------------------------------------------------------------} newLSMLedgerTablesHandle :: - forall m l. + forall m blk. ( IOLike m - , HasLedgerTables l - , IndexedMemPack (l EmptyMK) (TxOut l) + , HasLedgerTables LedgerState blk + , ToAllDict (MemAndDiskTable LedgerState blk) (TablesForBlock blk) + , forall table. SerialiseTable LedgerState blk table + , All TableLabel (TablesForBlock blk) ) => Tracer m LedgerDBV2Trace -> - (ResourceKey m, UTxOTable m) -> - m (LedgerTablesHandle m l) + (ResourceKey m, LSMTables m blk) -> + m (LedgerTablesHandle m LedgerState blk) newLSMLedgerTablesHandle tracer (origResKey, t) = do traceWith tracer TraceLedgerTablesHandleCreate tv <- newTVarIO origResKey @@ -202,126 +249,216 @@ implClose tv = implDuplicate :: ( IOLike m - , HasLedgerTables l - , IndexedMemPack (l EmptyMK) (TxOut l) + , HasLedgerTables LedgerState blk + , ToAllDict (MemAndDiskTable LedgerState blk) (TablesForBlock blk) + , forall table. SerialiseTable LedgerState blk table + , All TableLabel (TablesForBlock blk) ) => ResourceRegistry m -> - UTxOTable m -> + LSMTables m blk -> Tracer m LedgerDBV2Trace -> - m (ResourceKey m, LedgerTablesHandle m l) -implDuplicate rr t tracer = do - (rk, table) <- + m (ResourceKey m, LedgerTablesHandle m LedgerState blk) +implDuplicate rr (LSMTables tbs) tracer = do + (rk, tables) <- allocate rr - (\_ -> LSM.duplicate t) - ( \t' -> do + (\_ -> LSMTables <$> htraverse' (fmap Table' . LSM.duplicate . getTable') tbs) + ( \(LSMTables tbs') -> do traceWith tracer TraceLedgerTablesHandleClose - LSM.closeTable t' + Monad.void $ htraverse' (fmap K . LSM.closeTable . getTable') tbs' ) - (rk,) <$> newLSMLedgerTablesHandle tracer (rk, table) + (rk,) <$> newLSMLedgerTablesHandle tracer (rk, tables) + +class + ( TableConstraints blk table + , SerialiseTable l blk table + , TableLabel table + ) => + MemAndDiskTable l blk table +instance + ( TableConstraints blk table + , SerialiseTable l blk table + , TableLabel table + ) => + MemAndDiskTable l blk table implRead :: - forall m l. + forall m l blk. ( IOLike m - , HasLedgerTables l - , IndexedMemPack (l EmptyMK) (TxOut l) + , ToAllDict (MemAndDiskTable l blk) (TablesForBlock blk) ) => - UTxOTable m -> l EmptyMK -> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK) -implRead t st (LedgerTables (KeysMK keys)) = do - let vec' = V.create $ do - vec <- VM.new (Set.size keys) - Monad.foldM_ - (\i x -> VM.write vec i (toTxInBytes (Proxy @l) x) >> pure (i + 1)) - 0 - keys - pure vec - res <- LSM.lookups t vec' - pure - . LedgerTables - . ValuesMK - . Foldable.foldl' - ( \m (k, item) -> - case item of - LSM.Found v -> Map.insert (fromTxInBytes (Proxy @l) k) (fromTxOutBytes st v) m - LSM.NotFound -> m - LSM.FoundWithBlob{} -> m - ) - Map.empty - $ V.zip vec' res + LSMTables m blk -> + l blk EmptyMK -> + LedgerTables blk KeysMK -> + m (LedgerTables blk ValuesMK) +implRead (LSMTables tbs) st (LedgerTables np) = + LedgerTables + <$> let dictX = toAllDict @(MemAndDiskTable l blk) @(TablesForBlock blk) + in withAllDict dictX + $ hctraverse' + (Proxy @(MemAndDiskTable l blk)) + f + $ hzipWith Pair np tbs + where + f :: + forall table. + ( TableConstraints blk table + , SerialiseTable l blk table + ) => + Product + (Table KeysMK blk) + (Table' m blk) + table -> + m (Table ValuesMK blk table) + f (Pair (Table (KeysMK keys)) (Table' lsmtb)) = do + let vec' = V.create $ do + vec <- VM.new (Set.size keys) + Monad.foldM_ + (\i x -> VM.write vec i x >> pure (i + 1)) + 0 + keys + pure vec + res <- LSM.lookups lsmtb vec' + pure + . Table + . ValuesMK + . Foldable.foldl' + ( \m (k, item) -> + case item of + LSM.Found v -> Map.insert k (des (Proxy @table) (Proxy @blk) st v) m + LSM.NotFound -> m + LSM.FoundWithBlob{} -> m + ) + Map.empty + $ V.zip vec' res implReadRange :: - forall m l. - (IOLike m, IndexedMemPack (l EmptyMK) (TxOut l)) => - HasLedgerTables l => - UTxOTable m -> - l EmptyMK -> - (Maybe (TxIn l), Int) -> - m (LedgerTables l ValuesMK, Maybe (TxIn l)) -implReadRange table st (mPrev, num) = do - entries <- maybe cursorFromStart cursorFromKey mPrev - pure - ( LedgerTables - . ValuesMK - . V.foldl' - ( \m -> \case - LSM.Entry k v -> Map.insert (fromTxInBytes (Proxy @l) k) (fromTxOutBytes st v) m - LSM.EntryWithBlob{} -> m - ) - Map.empty - $ entries - , case snd <$> V.unsnoc entries of - Nothing -> Nothing - Just (LSM.Entry k _) -> Just (fromTxInBytes (Proxy @l) k) - Just (LSM.EntryWithBlob k _ _) -> Just (fromTxInBytes (Proxy @l) k) - ) + forall m l blk table. + ( IOLike m + , ToAllDict (MemAndDiskTable l blk) (TablesForBlock blk) + , HasLedgerTables l blk + , TableConstraints blk table + , SerialiseTable l blk table + ) => + LSMTables m blk -> + Proxy table -> + l blk EmptyMK -> + (Maybe (Key table), Int) -> + m (Table ValuesMK blk table, Maybe (Key table)) +implReadRange (LSMTables tbs) _ st (mPrev, num) = + case getNPByTag (S.sing @table) tbs of + Nothing -> pure (Table (ValuesMK mempty), Nothing) + Just (Table' utxoTable) -> do + entries <- maybe (cursorFromStart utxoTable) (cursorFromKey utxoTable) mPrev + pure + ( Table + . ValuesMK + . V.foldl' + ( \m -> \case + LSM.Entry k v -> Map.insert k (des (Proxy @table) (Proxy @blk) st v) m + LSM.EntryWithBlob{} -> m + ) + Map.empty + $ entries + , case snd <$> V.unsnoc entries of + Nothing -> Nothing + Just (LSM.Entry k _) -> Just k + Just (LSM.EntryWithBlob k _ _) -> Just k + ) where - cursorFromStart = LSM.withCursor table (LSM.take num) + cursorFromStart t = LSM.withCursor t (LSM.take num) -- Here we ask for one value more and we drop one value because the -- cursor returns also the key at which it was opened. - cursorFromKey k = fmap (V.drop 1) $ LSM.withCursorAtOffset table (toTxInBytes (Proxy @l) k) (LSM.take $ num + 1) + cursorFromKey t k = fmap (V.drop 1) $ LSM.withCursorAtOffset t k (LSM.take $ num + 1) implReadAll :: + forall m blk. ( IOLike m - , HasLedgerTables l - , IndexedMemPack (l EmptyMK) (TxOut l) + , HasLedgerTables LedgerState blk + , ToAllDict (MemAndDiskTable LedgerState blk) (TablesForBlock blk) ) => - UTxOTable m -> - l EmptyMK -> - m (LedgerTables l ValuesMK) + LSMTables m blk -> + LedgerState blk EmptyMK -> + m (LedgerTables blk ValuesMK) implReadAll t st = - let readAll' m = do - (v, n) <- implReadRange t st (m, 100000) - maybe (pure v) (fmap (ltliftA2 unionValues v) . readAll' . Just) n - in readAll' Nothing + let + readAll' :: + forall table. + (TableConstraints blk table, SerialiseTable LedgerState blk table) => + Maybe (Key table) -> + (m :.: Table ValuesMK blk) table + readAll' m = Comp $ do + (Table v, n) <- implReadRange t (Proxy @table) st (m, 100000) + maybe (pure $ Table v) (fmap (Table . unionValues v . getTable) . unComp . readAll' @table . Just) n + in + fmap LedgerTables $ + htraverse' unComp $ + hcpure (Proxy @(MemAndDiskTable LedgerState blk)) $ + readAll' Nothing implPushDiffs :: - forall m l mk. + forall m l mk blk. ( IOLike m - , HasLedgerTables l - , IndexedMemPack (l EmptyMK) (TxOut l) + , HasLedgerTables l blk + , ToAllDict (MemAndDiskTable l blk) (TablesForBlock blk) ) => - UTxOTable m -> l mk -> l DiffMK -> m () -implPushDiffs t _ !st1 = do - let LedgerTables (DiffMK (Diff.Diff diffs)) = projectLedgerTables st1 - let vec = V.create $ do - vec' <- VM.new (Map.size diffs) - Monad.foldM_ - (\idx (k, item) -> VM.write vec' idx (toTxInBytes (Proxy @l) k, (f item)) >> pure (idx + 1)) - 0 - $ Map.toList diffs - pure vec' - LSM.updates t vec + LSMTables m blk -> + l blk mk -> + l blk DiffMK -> + m () +implPushDiffs (LSMTables lsmtbs) _ !st1 = do + let LedgerTables np = projectLedgerTables st1 + Monad.void $ + let dictX = toAllDict @(MemAndDiskTable l blk) @(TablesForBlock blk) + in withAllDict dictX + $ hctraverse' + (Proxy @(MemAndDiskTable l blk)) + g + $ hzipWith Pair np lsmtbs where - f (Diff.Insert v) = LSM.Insert (toTxOutBytes (forgetLedgerTables st1) v) Nothing - f Diff.Delete = LSM.Delete - -implTakeHandleSnapshot :: IOLike m => UTxOTable m -> t -> String -> m (Maybe a) -implTakeHandleSnapshot t _ snapshotName = do - LSM.saveSnapshot - (fromString snapshotName) - (LSM.SnapshotLabel $ Text.pack $ "UTxO table") - t - pure Nothing + g :: + forall table. + SerialiseTable l blk table => + Product + (Table DiffMK blk) + (Table' m blk) + table -> + m (K () table) + g (Pair (Table (DiffMK (Diff.Diff diffs))) (Table' lsmt)) = + do + let vec = V.create $ do + vec' <- VM.new (Map.size diffs) + Monad.foldM_ + (\idx (k, item) -> VM.write vec' idx (k, (f item)) >> pure (idx + 1)) + 0 + $ Map.toList diffs + pure vec' + K + <$> LSM.updates + lsmt + vec + where + f (Diff.Insert v) = LSM.Insert (ser (Proxy @table) (Proxy @blk) (forgetLedgerTables st1) v) Nothing + f Diff.Delete = LSM.Delete + +implTakeHandleSnapshot :: + forall m blk t a. + (All TableLabel (TablesForBlock blk), IOLike m) => + LSMTables m blk -> + t -> + String -> + m (NP (K (Maybe a)) (TablesForBlock blk)) +implTakeHandleSnapshot (LSMTables tbs) _ snapshotName = do + Monad.void $ hctraverse' (Proxy @TableLabel) f tbs + pure $ hpure (K Nothing) + where + f :: forall table. TableLabel table => Table' m blk table -> m (K () table) + f (Table' t) = + K + <$> LSM.saveSnapshot + (fromString snapshotName) + (LSM.SnapshotLabel $ Text.pack $ tableLabel (Proxy @table)) + t {------------------------------------------------------------------------------- SnapshotManager @@ -355,7 +492,7 @@ snapshotManager :: CodecConfig blk -> Tracer m (TraceSnapshotEvent blk) -> SomeHasFS m -> - SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) + SnapshotManager m m blk (StateRef m ExtLedgerState blk) snapshotManager session ccfg tracer fs = SnapshotManager { listSnapshots = defaultListSnapshots fs @@ -375,7 +512,7 @@ implTakeSnapshot :: Tracer m (TraceSnapshotEvent blk) -> SomeHasFS m -> Maybe String -> - StateRef m (ExtLedgerState blk) -> + StateRef m ExtLedgerState blk -> m (Maybe (DiskSnapshot, RealPoint blk)) implTakeSnapshot ccfg tracer shfs@(SomeHasFS hasFs) suffix st = case pointToWithOriginRealPoint (castPoint (getTip $ state st)) of @@ -395,7 +532,8 @@ implTakeSnapshot ccfg tracer shfs@(SomeHasFS hasFs) suffix st = writeSnapshot ds = do createDirectoryIfMissing hasFs True $ snapshotToDirPath ds crc1 <- writeExtLedgerState shfs (encodeDiskExtLedgerState ccfg) (snapshotToStatePath ds) $ state st - crc2 <- takeHandleSnapshot (tables st) (state st) $ snapshotToDirName ds + npcrc2 <- takeHandleSnapshot (tables st) (state st) $ snapshotToDirName ds + let crc2 = hcfoldMap (Proxy @Top) unK npcrc2 writeSnapshotMetadata shfs ds $ SnapshotMetadata { snapshotBackend = UTxOHDLSMSnapshot @@ -442,6 +580,9 @@ loadSnapshot :: ( LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk , IOLike m + , ToAllDict (MemAndDiskTable LedgerState blk) (TablesForBlock blk) + , All TableLabel (TablesForBlock blk) + , forall table. SerialiseTable LedgerState blk table ) => Tracer m LedgerDBV2Trace -> ResourceRegistry m -> @@ -473,14 +614,13 @@ loadSnapshot tracer rr ccfg fs@(SomeHasFS hfs) session ds = allocate rr ( \_ -> - LSM.openTableFromSnapshot - session - (fromString $ snapshotToDirName ds) - (LSM.SnapshotLabel $ Text.pack $ "UTxO table") + fmap LSMTables $ + htraverse' unComp $ + foldSing f (toAllDict @(MemAndDiskTable LedgerState blk) @(TablesForBlock blk)) ) - ( \t -> do + ( \(LSMTables tbs) -> do traceWith tracer TraceLedgerTablesHandleClose - LSM.closeTable t + Monad.void $ htraverse' (fmap K . LSM.closeTable . getTable') tbs ) Monad.when (checksumAsRead /= snapshotChecksum snapshotMeta) @@ -488,35 +628,69 @@ loadSnapshot tracer rr ccfg fs@(SomeHasFS hfs) session ds = $ InitFailureRead ReadSnapshotDataCorruption (,pt) - <$> lift (empty extLedgerSt (rk, values) (newLSMLedgerTablesHandle tracer)) + <$> lift + (empty extLedgerSt (rk, values) (fmap castLedgerTablesHandle . newLSMLedgerTablesHandle tracer)) + where + f :: + forall table. + Dict.Dict (MemAndDiskTable LedgerState blk) table -> m (Table' m blk table) + f Dict.Dict = + Table' + <$> LSM.openTableFromSnapshot + session + (fromString $ snapshotToDirName ds) + (LSM.SnapshotLabel $ Text.pack $ tableLabel (Proxy @table)) + +foldSing :: + (forall table. Dict.Dict (MemAndDiskTable LedgerState blk) table -> m (Table' m blk table)) -> + AllDict (MemAndDiskTable LedgerState blk) tables -> + NP (m :.: Table' m blk) tables +foldSing _ Nil = Nil +foldSing f (tb :* tbNext) = Comp (f tb) :* foldSing f tbNext -- | Create the initial LSM table from values, which should happen only at -- Genesis. tableFromValuesMK :: - forall m l. - (IOLike m, IndexedMemPack (l EmptyMK) (TxOut l), MemPack (TxIn l)) => + forall m l blk. + (IOLike m, All (MemAndDiskTable l blk) (TablesForBlock blk)) => Tracer m LedgerDBV2Trace -> ResourceRegistry m -> Session m -> - l EmptyMK -> - LedgerTables l ValuesMK -> - m (ResourceKey m, UTxOTable m) -tableFromValuesMK tracer rr session st (LedgerTables (ValuesMK values)) = do - (rk, table) <- + l blk EmptyMK -> + LedgerTables blk ValuesMK -> + m (ResourceKey m, LSMTables m blk) +tableFromValuesMK tracer rr session st (LedgerTables tbs) = do + (rk, lsmtbs) <- allocate rr - (\_ -> LSM.newTable session) + (\_ -> htraverse' unComp (hpure (Comp $ Table' <$> LSM.newTable session))) ( \tb -> do traceWith tracer TraceLedgerTablesHandleClose - LSM.closeTable tb + Monad.void $ htraverse' (fmap K . LSM.closeTable . getTable') tb ) - mapM_ (go table) $ chunks 1000 $ Map.toList values - pure (rk, table) + Monad.void $ hctraverse' (Proxy @(MemAndDiskTable l blk)) go $ hzipWith Pair tbs lsmtbs + pure (rk, LSMTables lsmtbs) where - go table items = + go :: + SerialiseTable l blk table => + Product + (Table ValuesMK blk) + (Table' m blk) + table -> + m (K () table) + go (Pair (Table (ValuesMK values)) lsmt) = + fmap K $ mapM_ (go' lsmt) $ chunks 1000 $ Map.toList values + + go' :: + forall table. + SerialiseTable l blk table => + Table' m blk table -> + [(Key table, Value table blk)] -> + m () + go' (Table' table) items = LSM.inserts table $ V.fromListN (length items) $ - map (\(k, v) -> (toTxInBytes (Proxy @l) k, toTxOutBytes st v, Nothing)) items + map (\(k, v) -> (k, ser (Proxy @table) (Proxy @blk) st v, Nothing)) items {------------------------------------------------------------------------------- Helpers @@ -542,6 +716,9 @@ type data LSM mkLSMArgs :: ( LedgerSupportsProtocol blk , LedgerDbSerialiseConstraints blk + , ToAllDict (MemAndDiskTable LedgerState blk) (TablesForBlock blk) + , All TableLabel (TablesForBlock blk) + , forall table. SerialiseTable LedgerState blk table ) => Proxy blk -> FilePath -> FilePath -> StdGen -> (LedgerDbBackendArgs IO blk, StdGen) mkLSMArgs _ fp fastStorage gen = @@ -556,7 +733,12 @@ instance ( LedgerSupportsProtocol blk , IOLike m , LedgerDbSerialiseConstraints blk - , HasLedgerTables (LedgerState blk) + , HasLedgerTables LedgerState blk + , ToAllDict + (MemAndDiskTable LedgerState blk) + (TablesForBlock blk) + , forall table. SerialiseTable LedgerState blk table + , All TableLabel (TablesForBlock blk) ) => Backend m LSM blk where @@ -605,25 +787,26 @@ instance newHandleFromValues trcr reg res st = do table <- - tableFromValuesMK trcr reg (sessionResource res) (forgetLedgerTables st) (ltprj st) - newLSMLedgerTablesHandle trcr table + tableFromValuesMK trcr reg (sessionResource res) (ledgerState $ forgetLedgerTables st) (ltprj st) + castLedgerTablesHandle <$> newLSMLedgerTablesHandle trcr table snapshotManager _ res = Ouroboros.Consensus.Storage.LedgerDB.V2.LSM.snapshotManager (sessionResource res) instance - ( MemPack (TxIn l) - , IndexedMemPack (l EmptyMK) (TxOut l) + ( All (IndexedMemPack LedgerState blk) (TablesForBlock blk) , IOLike m + , LedgerTablesConstraints blk + , All (SerialiseTable LedgerState blk) (TablesForBlock blk) ) => - StreamingBackend m LSM l + StreamingBackend m LSM blk where - data YieldArgs m LSM l + data YieldArgs m LSM blk = -- \| Yield an LSM snapshot YieldLSM Int - (LedgerTablesHandle m l) + (LedgerTablesHandle m LedgerState blk) - data SinkArgs m LSM l + data SinkArgs m LSM blk = SinkLSM -- \| Chunk size Int @@ -631,9 +814,11 @@ instance String (Session m) - yield _ (YieldLSM chunkSize hdl) = yieldLsmS chunkSize hdl + yield _ (YieldLSM chunkSize hdl) = + hcpure (Proxy @(TableConstraints blk)) (yieldLsmS chunkSize hdl) - sink _ (SinkLSM chunkSize snapName session) = sinkLsmS chunkSize snapName session + sink _ (SinkLSM chunkSize snapName session) = + hcpure (Proxy @(SerialiseTable LedgerState blk)) (sinkLsmS chunkSize snapName session) data SomeHasFSAndBlockIO m where SomeHasFSAndBlockIO :: @@ -647,69 +832,79 @@ instance IOLike m => NoThunks (Resources m LSM) where -------------------------------------------------------------------------------} yieldLsmS :: - Monad m => + forall m blk table. + (TableConstraints blk table, Monad m) => Int -> - LedgerTablesHandle m l -> - Yield m l -yieldLsmS readChunkSize tb hint k = do - r <- k (go (Nothing, readChunkSize)) + LedgerTablesHandle m LedgerState blk -> + Yield m blk table +yieldLsmS readChunkSize tb = Yield $ \hint k -> do + r <- k (go hint (Nothing, readChunkSize)) lift $ S.effects r where - go p = do - (LedgerTables (ValuesMK values), mx) <- lift $ S.lift $ readRange tb hint p + go hint p = do + (Table (ValuesMK values), mx) <- lift $ S.lift $ readRange tb (Proxy @table) hint p if Map.null values then pure $ pure Nothing else do S.each $ Map.toList values - go (mx, readChunkSize) + go hint (mx, readChunkSize) sinkLsmS :: - forall m l. + forall m blk table. ( MonadAsync m , MonadMVar m , MonadThrow (STM m) , MonadMask m , MonadST m , MonadEvaluate m - , MemPack (TxIn l) - , IndexedMemPack (l EmptyMK) (TxOut l) + , SerialiseTable LedgerState blk table ) => Int -> String -> Session m -> - Sink m l -sinkLsmS writeChunkSize snapName session st s = do - tb :: UTxOTable m <- lift $ LSM.newTable session - r <- go tb writeChunkSize mempty s + Sink m blk table +sinkLsmS writeChunkSize snapName session = Sink $ \st s -> do + tb <- lift $ LSM.newTable session + r <- go st tb writeChunkSize mempty s lift $ LSM.saveSnapshot (LSM.toSnapshotName snapName) - (LSM.SnapshotLabel $ T.pack "UTxO table") + (LSM.SnapshotLabel $ T.pack $ tableLabel (Proxy @table)) tb lift $ LSM.closeTable tb pure (fmap (,Nothing) r) where - go tb 0 m s' = do + go :: + LedgerState blk EmptyMK -> + LSM.Table m (Key table) (Value' table blk) Void -> + Int -> + [(Key table, Value table blk)] -> + S.Stream (S.Of (Key table, Value table blk)) (ExceptT DeserialiseFailure m) b -> + ExceptT DeserialiseFailure m b + go st tb 0 m s' = do lift $ LSM.inserts tb $ - V.fromList [(toTxInBytes (Proxy @l) k, toTxOutBytes st v, Nothing) | (k, v) <- m] - go tb writeChunkSize mempty s' - go tb n m s' = do + V.fromList [(k, ser (Proxy @table) (Proxy @blk) st v, Nothing) | (k, v) <- m] + go st tb writeChunkSize mempty s' + go st tb n m s' = do mbs <- S.uncons s' case mbs of Nothing -> do lift $ LSM.inserts tb $ V.fromList - [(toTxInBytes (Proxy @l) k, toTxOutBytes st v, Nothing) | (k, v) <- m] + [(k, ser (Proxy @table) (Proxy @blk) st v, Nothing) | (k, v) <- m] S.effects s' - Just (item, s'') -> go tb (n - 1) (item : m) s'' + Just (item, s'') -> go st tb (n - 1) (item : m) s'' -- | Create Yield arguments for LSM mkLSMYieldArgs :: + forall m a blk. ( IOLike m - , HasLedgerTables l - , IndexedMemPack (l EmptyMK) (TxOut l) + , HasLedgerTables LedgerState blk + , ToAllDict (MemAndDiskTable LedgerState blk) (TablesForBlock blk) + , forall table. SerialiseTable LedgerState blk table + , All TableLabel (TablesForBlock blk) ) => -- | The filepath in which the LSM database lives. Must not have a trailing slash! FilePath -> @@ -719,9 +914,9 @@ mkLSMYieldArgs :: (FilePath -> ResourceRegistry m -> m (a, SomeHasFSAndBlockIO m)) -> -- | Usually 'newStdGen' (m StdGen) -> - l EmptyMK -> + LedgerState blk EmptyMK -> ResourceRegistry m -> - m (YieldArgs m LSM l) + m (YieldArgs m LSM blk) mkLSMYieldArgs fp snapName mkFS mkGen _ reg = do (_, SomeHasFSAndBlockIO hasFS blockIO) <- mkFS fp reg salt <- fst . genWord64 <$> mkGen @@ -731,13 +926,24 @@ mkLSMYieldArgs fp snapName mkFS mkGen _ reg = do allocate reg ( \_ -> - LSM.openTableFromSnapshot - session - (LSM.toSnapshotName snapName) - (LSM.SnapshotLabel $ T.pack "UTxO table") + fmap LSMTables $ + htraverse' unComp $ + foldSing (f session) (toAllDict @(MemAndDiskTable LedgerState blk) @(TablesForBlock blk)) + ) + ( \(LSMTables tbs') -> + Monad.void $ htraverse' (fmap K . LSM.closeTable . getTable') tbs' ) - LSM.closeTable YieldLSM 1000 <$> newLSMLedgerTablesHandle nullTracer tb + where + f :: + forall table. + LSM.Session m -> Dict.Dict (MemAndDiskTable LedgerState blk) table -> m (Table' m blk table) + f session Dict.Dict = + Table' + <$> LSM.openTableFromSnapshot + session + (LSM.toSnapshotName snapName) + (LSM.SnapshotLabel $ T.pack $ tableLabel (Proxy @table)) -- | Create Sink arguments for LSM mkLSMSinkArgs :: @@ -750,9 +956,9 @@ mkLSMSinkArgs :: (FilePath -> ResourceRegistry m -> m (a, SomeHasFSAndBlockIO m)) -> -- | Usually 'newStdGen' (m StdGen) -> - l EmptyMK -> + l blk EmptyMK -> ResourceRegistry m -> - m (SinkArgs m LSM l) + m (SinkArgs m LSM blk) mkLSMSinkArgs (splitFileName -> (fp, lsmDir)) snapName diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs index c947f4f7f3..399bdd64c7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -module Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork (CanHardFork (..)) where +module Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork (CanHardFork (..), NoThunksLedgerState) where import Data.Measure (Measure) import Data.SOP.Constraint @@ -24,15 +26,22 @@ import Ouroboros.Consensus.HardFork.Combinator.Translation import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Util.TypeLevel {------------------------------------------------------------------------------- CanHardFork -------------------------------------------------------------------------------} +class NoThunks (LedgerState blk mk) => NoThunksLedgerState mk blk +instance NoThunks (LedgerState blk mk) => NoThunksLedgerState mk blk + +class ToAllDict (TableConstraints x) (TablesForBlock x) => ToAllDictTables x +instance ToAllDict (TableConstraints x) (TablesForBlock x) => ToAllDictTables x + class ( All SingleEraBlock xs - , All (Compose HasLedgerTables LedgerState) xs - , All (Compose HasTickedLedgerTables LedgerState) xs + , All (HasLedgerTables LedgerState) xs + , All (HasTickedLedgerTables LedgerState) xs , Typeable xs , IsNonEmpty xs , Measure (HardForkTxMeasure xs) @@ -40,6 +49,7 @@ class , NoThunks (HardForkTxMeasure xs) , Show (HardForkTxMeasure xs) , TxMeasureMetrics (HardForkTxMeasure xs) + , All ToAllDictTables xs ) => CanHardFork xs where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs index 4a64294101..c2895b2572 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableSuperClasses #-} + module Ouroboros.Consensus.HardFork.Combinator.Abstract.NoHardForks ( ImmutableEraParams (..) , NoHardForks (..) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs index 8afbad9ceb..129318946f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock ( -- * Single era block @@ -30,6 +31,7 @@ import Data.SOP.Constraint import Data.SOP.Index import Data.SOP.Match import Data.SOP.Strict +import Data.Singletons (SingI) import qualified Data.Text as Text import Data.Void import Ouroboros.Consensus.Block @@ -40,6 +42,7 @@ import Ouroboros.Consensus.HardFork.History (Bound, EraParams) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect +import Ouroboros.Consensus.Ledger.LedgerStateType (TickedL) import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection @@ -47,8 +50,9 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.Serialisation import Ouroboros.Consensus.Storage.Serialisation -import Ouroboros.Consensus.Ticked import Ouroboros.Consensus.Util.Condense +import Ouroboros.Consensus.Util.TypeLevel (ToAllDict) +import NoThunks.Class {------------------------------------------------------------------------------- SingleEraBlock @@ -74,8 +78,8 @@ class , SerialiseNodeToClient blk (PartialLedgerConfig blk) , -- LedgerTables CanStowLedgerTables (LedgerState blk) - , HasLedgerTables (LedgerState blk) - , HasLedgerTables (Ticked (LedgerState blk)) + , HasLedgerTables LedgerState blk + , HasLedgerTables (TickedL LedgerState) blk , -- Instances required to support testing Eq (GenTx blk) , Eq (Validated (GenTx blk)) @@ -85,6 +89,10 @@ class , Show (CannotForge blk) , Show (ForgeStateInfo blk) , Show (ForgeStateUpdateError blk) + , GetBlockKeySets blk + , All SingI (TablesForBlock blk) + , ToAllDict (TableConstraints blk) (TablesForBlock blk) + , NoThunks (LedgerState blk EmptyMK) ) => SingleEraBlock blk where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index cc261a8f91..736e9349ca 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -31,6 +32,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Basics , completeLedgerConfig'' , distribLedgerConfig , distribTopLevelConfig + , NoThunksLedgerState -- ** Convenience re-exports , EpochInfo @@ -44,7 +46,7 @@ import Data.SOP.Functors import Data.SOP.Strict import Data.Typeable import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) +import NoThunks.Class import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -77,15 +79,18 @@ type instance HeaderHash (HardForkBlock xs) = OneEraHash xs newtype instance LedgerState (HardForkBlock xs) mk = HardForkLedgerState { hardForkLedgerStatePerEra :: HardForkState (Flip LedgerState mk) xs } + deriving Generic -deriving stock instance - (ShowMK mk, CanHardFork xs) => +deriving instance + Show (HardForkState (Flip LedgerState mk) xs) => Show (LedgerState (HardForkBlock xs) mk) -deriving stock instance - (EqMK mk, CanHardFork xs) => + +deriving newtype instance + Eq (HardForkState (Flip LedgerState mk) xs) => Eq (LedgerState (HardForkBlock xs) mk) + deriving newtype instance - (NoThunksMK mk, CanHardFork xs) => + NoThunks (HardForkState (Flip LedgerState mk) xs) => NoThunks (LedgerState (HardForkBlock xs) mk) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs index 788d0a794e..6e51272e14 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs @@ -60,7 +60,7 @@ import Ouroboros.Consensus.TypeFamilyWrappers class Inject f where inject :: forall x xs. - (CanHardFork xs, HasCanonicalTxIn xs, HasHardForkTxOut xs) => + (CanHardFork xs, HasHardForkTxOut xs) => InjectionIndex xs x -> f x -> f (HardForkBlock xs) @@ -69,7 +69,6 @@ inject' :: forall f a b x xs. ( Inject f , CanHardFork xs - , HasCanonicalTxIn xs , HasHardForkTxOut xs , Coercible a (f x) , Coercible b (f (HardForkBlock xs)) @@ -268,7 +267,7 @@ instance Inject (Flip ExtLedgerState mk) where -- not rely on that class. injectInitialExtLedgerState :: forall x xs. - (CanHardFork (x ': xs), HasLedgerTables (LedgerState (HardForkBlock (x : xs)))) => + (CanHardFork (x ': xs), HasLedgerTables LedgerState (HardForkBlock (x : xs))) => TopLevelConfig (HardForkBlock (x ': xs)) -> ExtLedgerState x ValuesMK -> ExtLedgerState (HardForkBlock (x ': xs)) ValuesMK diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs index 2186ee5a43..b01497b811 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs @@ -148,7 +148,7 @@ instance IsSOPLike NP where toSOPLike = (:* Nil) instance IsSOPLike HardForkState where - fromSOPLike = State.fromTZ + fromSOPLike = currentState . Telescope.fromTZ . getHardForkState toSOPLike = HardForkState . Telescope.TZ . State.Current History.initBound {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs index e37e04bfc8..2c70bf24f4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -8,16 +9,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.HardFork.Combinator.Ledger @@ -25,6 +26,8 @@ module Ouroboros.Consensus.HardFork.Combinator.Ledger , HardForkLedgerError (..) , HardForkLedgerUpdate (..) , HardForkLedgerWarning (..) + , CanHardFork' + , InjectValues -- * Type family instances , FlipTickedLedgerState (..) @@ -38,23 +41,21 @@ module Ouroboros.Consensus.HardFork.Combinator.Ledger , ejectLedgerTables , injectLedgerTables - -- ** HardForkTxIn - , HasCanonicalTxIn (..) - - -- ** HardForkTxOut + -- ** HardForkValues , DefaultHardForkTxOut , HasHardForkTxOut (..) , MemPackTxOut - , ejectHardForkTxOutDefault , injectHardForkTxOutDefault ) where import Control.Monad (guard) import Control.Monad.Except (throwError, withExcept) import qualified Control.State.Transition.Extended as STS +import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Functor.Product import Data.Kind (Type) +import qualified Data.List.Singletons as S import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust) import Data.MemPack @@ -62,6 +63,7 @@ import Data.Proxy import Data.SOP.BasicFunctors import Data.SOP.Constraint import Data.SOP.Counting (getExactly) +import qualified Data.SOP.Dict as Dict import Data.SOP.Functors (Flip (..)) import Data.SOP.InPairs (InPairs (..)) import qualified Data.SOP.InPairs as InPairs @@ -72,8 +74,10 @@ import Data.SOP.Tails (Tails) import qualified Data.SOP.Tails as Tails import Data.SOP.Telescope (Telescope (..)) import qualified Data.SOP.Telescope as Telescope +import qualified Data.Singletons as S import Data.Typeable import GHC.Generics (Generic) +import Lens.Micro ((.~)) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -98,13 +102,14 @@ import Ouroboros.Consensus.HardFork.History import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense -import Ouroboros.Consensus.Util.IndexedMemPack (IndexedMemPack) -- $setup -- >>> import Image.LaTeX.Render @@ -209,6 +214,7 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where -- prepends the diffs that might have been created if this tick crossed an era -- boundary. tickOne :: + forall xs blk. (SListI xs, SingleEraBlock blk) => EpochInfo (Except PastHorizonException) -> SlotNo -> @@ -224,7 +230,9 @@ tickOne ei slot evs sopIdx partialCfg st = Comp . fmap ( FlipTickedLedgerState - . prependDiffs (unFlip st) + . unTickedL + . prependDiffs @(LedgerState) @(TickedL LedgerState) (unFlip st) + . TickedL ) . embedLedgerResult (injectLedgerEvent sopIdx) . applyChainTickLedgerResult evs (completeLedgerConfig' ei partialCfg) slot @@ -238,10 +246,11 @@ tickOne ei slot evs sopIdx partialCfg st = instance ( CanHardFork xs - , HasCanonicalTxIn xs , HasHardForkTxOut xs + , LedgerTablesConstraints (HardForkBlock xs) + , All (InjectValues xs) xs ) => - ApplyBlock (LedgerState (HardForkBlock xs)) (HardForkBlock xs) + ApplyBlock LedgerState (HardForkBlock xs) where applyBlockLedgerResultWithValidation doValidate @@ -278,16 +287,21 @@ instance error "reapplyBlockLedgerResult: can't be from other era" ) +instance + CanHardFork' xs => + GetBlockKeySets (HardForkBlock xs) + where getBlockKeySets (HardForkBlock (OneEraBlock ns)) = hcollapse $ - hcimap proxySingle f ns + hcizipWith proxySingle f (toStrict $ Dict.unAll_NP Dict.Dict) ns where f :: SingleEraBlock x => Index xs x -> + Dict.Dict (InjectValues xs) x -> I x -> - K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) x - f idx (I blk) = K $ injectLedgerTables idx $ getBlockKeySets blk + K (LedgerTables (HardForkBlock xs) KeysMK) x + f idx Dict.Dict (I blk) = K $ injectLedgerTables idx $ getBlockKeySets blk apply :: (SListI xs, SingleEraBlock blk) => @@ -307,17 +321,6 @@ apply doValidate opts index (WrapLedgerConfig cfg) (Pair (I block) (FlipTickedLe fmap (Comp . fmap Flip . embedLedgerResult (injectLedgerEvent index)) $ applyBlockLedgerResultWithValidation doValidate opts cfg block st -{------------------------------------------------------------------------------- - UpdateLedger --------------------------------------------------------------------------------} - -instance - ( CanHardFork xs - , HasCanonicalTxIn xs - , HasHardForkTxOut xs - ) => - UpdateLedger (HardForkBlock xs) - {------------------------------------------------------------------------------- HasHardForkHistory -------------------------------------------------------------------------------} @@ -393,8 +396,9 @@ instance CanHardFork xs => ValidateEnvelope (HardForkBlock xs) where instance ( CanHardFork xs - , HasCanonicalTxIn xs , HasHardForkTxOut xs + , LedgerTablesConstraints (HardForkBlock xs) + , All (InjectValues xs) xs ) => LedgerSupportsProtocol (HardForkBlock xs) where @@ -882,27 +886,28 @@ injectLedgerEvent index = -- expensive when using big tables or when used multiple times. See the 'TxOut' -- instance for the 'HardForkBlock' for more information. instance - ( CanHardFork xs - , HasCanonicalTxIn xs + ( CanHardFork' xs , HasHardForkTxOut xs + , LedgerTablesConstraints (HardForkBlock xs) ) => - HasLedgerTables (LedgerState (HardForkBlock xs)) + HasLedgerTables LedgerState (HardForkBlock xs) where projectLedgerTables :: forall mk. - (CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) => + (CanMapMK mk, ZeroableMK mk) => LedgerState (HardForkBlock xs) mk -> - LedgerTables (LedgerState (HardForkBlock xs)) mk + LedgerTables (HardForkBlock xs) mk projectLedgerTables (HardForkLedgerState st) = hcollapse $ - hcimap (Proxy @(Compose HasLedgerTables LedgerState)) projectOne st + hcizipWith proxySingle projectOne (toStrict $ Dict.unAll_NP Dict.Dict) st where projectOne :: - Compose HasLedgerTables LedgerState x => + SingleEraBlock x => Index xs x -> + Dict.Dict (InjectValues xs) x -> Flip LedgerState mk x -> - K (LedgerTables (LedgerState (HardForkBlock xs)) mk) x - projectOne i l = + K (LedgerTables (HardForkBlock xs) mk) x + projectOne i Dict.Dict l = K $ injectLedgerTables i $ projectLedgerTables $ @@ -910,81 +915,86 @@ instance withLedgerTables :: forall mk any. - (CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) => + (CanMapMK mk, ZeroableMK mk) => LedgerState (HardForkBlock xs) any -> - LedgerTables (LedgerState (HardForkBlock xs)) mk -> + LedgerTables (HardForkBlock xs) mk -> LedgerState (HardForkBlock xs) mk withLedgerTables (HardForkLedgerState st) tables = HardForkLedgerState $ - hcimap (Proxy @(Compose HasLedgerTables LedgerState)) withLedgerTablesOne st + hcizipWith proxySingle withLedgerTablesOne (toStrict $ Dict.unAll_NP Dict.Dict) st where withLedgerTablesOne :: - Compose HasLedgerTables LedgerState x => + SingleEraBlock x => Index xs x -> + Dict.Dict (InjectValues xs) x -> Flip LedgerState any x -> Flip LedgerState mk x - withLedgerTablesOne i l = + withLedgerTablesOne i Dict.Dict l = Flip $ withLedgerTables (unFlip l) $ ejectLedgerTables i tables instance - ( CanHardFork xs - , HasCanonicalTxIn xs + ( CanHardFork' xs , HasHardForkTxOut xs + , LedgerTablesConstraints (HardForkBlock xs) ) => - HasLedgerTables (Ticked (LedgerState (HardForkBlock xs))) + HasLedgerTables (TickedL LedgerState) (HardForkBlock xs) where projectLedgerTables :: forall mk. - (CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) => - Ticked (LedgerState (HardForkBlock xs)) mk -> - LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk - projectLedgerTables st = + (CanMapMK mk, ZeroableMK mk) => + TickedL LedgerState (HardForkBlock xs) mk -> + LedgerTables (HardForkBlock xs) mk + projectLedgerTables (TickedL st) = hcollapse $ - hcimap - (Proxy @(Compose HasTickedLedgerTables LedgerState)) + hcizipWith + proxySingle projectOne + (toStrict $ Dict.unAll_NP Dict.Dict) (tickedHardForkLedgerStatePerEra st) where projectOne :: - Compose HasTickedLedgerTables LedgerState x => + SingleEraBlock x => Index xs x -> + Dict.Dict (InjectValues xs) x -> FlipTickedLedgerState mk x -> - K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk) x - projectOne i l = + K (LedgerTables (HardForkBlock xs) mk) x + projectOne i Dict.Dict l = K $ - castLedgerTables $ - injectLedgerTables i $ - castLedgerTables $ - projectLedgerTables $ - getFlipTickedLedgerState l + injectLedgerTables i $ + projectLedgerTables $ + TickedL $ + getFlipTickedLedgerState l withLedgerTables :: forall mk any. - (CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) => - Ticked (LedgerState (HardForkBlock xs)) any -> - LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk -> - Ticked (LedgerState (HardForkBlock xs)) mk - withLedgerTables st tables = - st - { tickedHardForkLedgerStatePerEra = - hcimap - (Proxy @(Compose HasTickedLedgerTables LedgerState)) - withLedgerTablesOne - (tickedHardForkLedgerStatePerEra st) - } + (CanMapMK mk, ZeroableMK mk) => + TickedL LedgerState (HardForkBlock xs) any -> + LedgerTables (HardForkBlock xs) mk -> + TickedL LedgerState (HardForkBlock xs) mk + withLedgerTables (TickedL st) tables = + TickedL $ + st + { tickedHardForkLedgerStatePerEra = + hcizipWith + proxySingle + withLedgerTablesOne + (toStrict $ Dict.unAll_NP Dict.Dict) + (tickedHardForkLedgerStatePerEra st) + } where withLedgerTablesOne :: - Compose HasTickedLedgerTables LedgerState x => + SingleEraBlock x => Index xs x -> + Dict.Dict (InjectValues xs) x -> FlipTickedLedgerState any x -> FlipTickedLedgerState mk x - withLedgerTablesOne i l = + withLedgerTablesOne i Dict.Dict l = FlipTickedLedgerState $ - withLedgerTables (getFlipTickedLedgerState l) $ - castLedgerTables $ - ejectLedgerTables i (castLedgerTables tables) + unTickedL $ + withLedgerTables (TickedL $ getFlipTickedLedgerState l) $ + ejectLedgerTables i tables instance All (Compose CanStowLedgerTables LedgerState) xs => @@ -1016,78 +1026,114 @@ instance Flip LedgerState ValuesMK x unstowOne = Flip . unstowLedgerTables . unFlip +class + ( HasHardForkTxOut xs + , CanHardFork xs + , LedgerTablesConstraints (HardForkBlock xs) + , All (InjectValues xs) xs + ) => + CanHardFork' xs +instance + ( HasHardForkTxOut xs + , CanHardFork xs + , LedgerTablesConstraints (HardForkBlock xs) + , All (InjectValues xs) xs + ) => + CanHardFork' xs + injectLedgerTables :: forall xs x mk. - ( CanMapKeysMK mk - , CanMapMK mk - , HasCanonicalTxIn xs - , HasHardForkTxOut xs + ( CanMapMK mk + , CanHardFork' xs + , ZeroableMK mk + , InjectValues xs x + , All S.SingI (TablesForBlock x) ) => Index xs x -> - LedgerTables (LedgerState x) mk -> - LedgerTables (LedgerState (HardForkBlock xs)) mk -injectLedgerTables idx = - bimapLedgerTables (injectCanonicalTxIn idx) (injectHardForkTxOut idx) + LedgerTables x mk -> + LedgerTables (HardForkBlock xs) mk +injectLedgerTables idx (LedgerTables x) = + foldNP emptyLedgerTables x + where + foldNP :: + (All S.SingI xtags, All (InjectValue xs x) xtags) => + LedgerTables (HardForkBlock xs) mk -> + NP (Table mk x) xtags -> + LedgerTables (HardForkBlock xs) mk + foldNP !acc Nil = acc + foldNP !acc (tb :* tbNext) = foldNP (actOnTable acc tb) tbNext + + actOnTable :: + forall tag. + (InjectValue xs x tag, S.SingI tag) => + LedgerTables (HardForkBlock xs) mk -> + Table mk x tag -> + LedgerTables (HardForkBlock xs) mk + actOnTable acc tb = + acc + & onTable (Proxy @(HardForkBlock xs)) (Proxy @tag) + .~ (Table . mapMK (injectValue (Proxy @tag) idx) . getTable $ tb) ejectLedgerTables :: forall xs x mk. - ( CanMapKeysMK mk - , Ord (TxIn (LedgerState x)) - , HasCanonicalTxIn xs - , CanMapMK mk - , HasHardForkTxOut xs + ( CanMapMK mk + , HasLedgerTables LedgerState (HardForkBlock xs) + , ZeroableMK mk + , LedgerTablesConstraints x + , InjectValues xs x + , All S.SingI (TablesForBlock x) ) => Index xs x -> - LedgerTables (LedgerState (HardForkBlock xs)) mk -> - LedgerTables (LedgerState x) mk -ejectLedgerTables idx = - bimapLedgerTables (ejectCanonicalTxIn idx) (ejectHardForkTxOut idx) + LedgerTables (HardForkBlock xs) mk -> + LedgerTables x mk +ejectLedgerTables idx tbs = + foldSing emptyLedgerTables (S.sing @(TablesForBlock x)) + where + foldSing :: + (All S.SingI xtags, All (InjectValue xs x) xtags) => + LedgerTables x mk -> + S.SList xtags -> + LedgerTables x mk + foldSing !acc S.SNil = acc + foldSing !acc (S.SCons tb tbNext) = foldSing (actOnTable acc tb) tbNext + + actOnTable :: + forall tag. + (InjectValue xs x tag, S.SingI tag) => + LedgerTables x mk -> + S.Sing tag -> + LedgerTables x mk + actOnTable acc stb = + acc + & onTable (Proxy @x) (Proxy @tag) + .~ ( Table . mapMK (ejectValue (Proxy @tag) idx) . getTable $ + fromMaybe (error "Impossible, HF block must have all tables in every block") $ + getTableByTag stb tbs + ) + +-- bimapLedgerTables (ejectCanonicalTxIn idx) (ejectHardForkTxOut idx) {------------------------------------------------------------------------------- - HardForkTxIn + HardForkTxOut -------------------------------------------------------------------------------} --- | Must be the 'CannonicalTxIn' type, but this will probably change in the --- future to @NS 'WrapTxIn' xs@. See 'HasCanonicalTxIn'. -type instance TxIn (LedgerState (HardForkBlock xs)) = CanonicalTxIn xs +class All (InjectValue xs x) (TablesForBlock x) => InjectValues xs x +instance All (InjectValue xs x) (TablesForBlock x) => InjectValues xs x --- | Canonical TxIn --- --- The Ledger and Consensus team discussed the fact that we need to be able to --- reach the TxIn key for an entry from any era, regardless of the era in which --- it was created, therefore we need to have a "canonical" serialization that --- doesn't change between eras. For now we are requiring that a 'HardForkBlock' --- has only one associated 'TxIn' type as a stop-gap, but Ledger will provide a --- serialization function into something more efficient. -type HasCanonicalTxIn :: [Type] -> Constraint -class - ( Show (CanonicalTxIn xs) - , Ord (CanonicalTxIn xs) - , NoThunks (CanonicalTxIn xs) - , MemPack (CanonicalTxIn xs) - ) => - HasCanonicalTxIn xs - where - data CanonicalTxIn (xs :: [Type]) :: Type - - -- | Inject an era-specific 'TxIn' into a 'TxIn' for a 'HardForkBlock'. - injectCanonicalTxIn :: - Index xs x -> - TxIn (LedgerState x) -> - CanonicalTxIn xs +class InjectValue xs x tag where + injectValue :: Proxy tag -> Index xs x -> Value tag x -> Value tag (HardForkBlock xs) + ejectValue :: Proxy tag -> Index xs x -> Value tag (HardForkBlock xs) -> Value tag x - -- | Distribute a 'TxIn' for a 'HardForkBlock' to an era-specific 'TxIn'. - ejectCanonicalTxIn :: - Index xs x -> - CanonicalTxIn xs -> - TxIn (LedgerState x) +instance HasHardForkTxOut xs => InjectValue xs x UTxOTable where + injectValue _ = injectHardForkTxOut + ejectValue _ = ejectHardForkTxOut -{------------------------------------------------------------------------------- - HardForkTxOut --------------------------------------------------------------------------------} +instance InjectValue xs x InstantStakeTable where + injectValue _ _ = id + ejectValue _ _ = id -- | Must be the 'HardForkTxOut' type -type instance TxOut (LedgerState (HardForkBlock xs)) = HardForkTxOut xs +type instance TxOut (HardForkBlock xs) = HardForkTxOut xs -- | This choice for 'HardForkTxOut' imposes some complications on the code. -- @@ -1165,30 +1211,13 @@ type instance TxOut (LedgerState (HardForkBlock xs)) = HardForkTxOut xs type DefaultHardForkTxOut xs = NS WrapTxOut xs class - ( Show (HardForkTxOut xs) - , Eq (HardForkTxOut xs) - , NoThunks (HardForkTxOut xs) - , IndexedMemPack (LedgerState (HardForkBlock xs) EmptyMK) (HardForkTxOut xs) - , SerializeTablesWithHint (LedgerState (HardForkBlock xs)) - ) => HasHardForkTxOut xs where type HardForkTxOut xs :: Type type HardForkTxOut xs = DefaultHardForkTxOut xs - injectHardForkTxOut :: Index xs x -> TxOut (LedgerState x) -> HardForkTxOut xs - ejectHardForkTxOut :: Index xs x -> HardForkTxOut xs -> TxOut (LedgerState x) - - -- | This method is a null-arity method in a typeclass to make it a CAF, such - -- that we only compute it once, then it is cached for the duration of the - -- program, as we will use it very often when converting from the - -- HardForkBlock to the particular @blk@. - -- - -- This particular method is useful when our HardForkBlock uses - -- DefaultHardForkTxOut, so that we can implement inject and project. - txOutEjections :: NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs - default txOutEjections :: CanHardFork xs => NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs - txOutEjections = composeTxOutTranslations $ ipTranslateTxOut hardForkEraTranslation + injectHardForkTxOut :: Index xs x -> TxOut x -> HardForkTxOut xs + ejectHardForkTxOut :: Index xs x -> HardForkTxOut xs -> TxOut x -- | This method is a null-arity method in a typeclass to make it a CAF, such -- that we only compute it once, then it is cached for the duration of the @@ -1203,30 +1232,54 @@ class (translateLedgerTables (hardForkEraTranslation @xs)) instance - (CanHardFork xs, HasHardForkTxOut xs) => - CanUpgradeLedgerTables (LedgerState (HardForkBlock xs)) + ( CanHardFork xs + , HasHardForkTxOut xs + ) => + CanUpgradeLedgerTable (HardForkBlock xs) UTxOTable + where + type UpgradeIndex (HardForkBlock xs) = NS (K ()) xs + upgradeTable + idx + (Table (ValuesMK vs)) = Table $ ValuesMK $ extendUTxOTable idx vs + +instance + CanHardFork xs => + CanUpgradeLedgerTable (HardForkBlock xs) InstantStakeTable + where + type UpgradeIndex (HardForkBlock xs) = NS (K ()) xs + upgradeTable + _idx = + id + +instance + ( SListI xs + , All (CanUpgradeLedgerTable (HardForkBlock xs)) (TablesForBlock (HardForkBlock xs)) + ) => + CanUpgradeLedgerTables LedgerState (HardForkBlock xs) where upgradeTables (HardForkLedgerState (HardForkState hs0)) (HardForkLedgerState (HardForkState hs1)) - orig@(LedgerTables (ValuesMK vs)) = + orig@(LedgerTables np) = if isJust $ Match.telescopesMismatch hs0 hs1 - then LedgerTables $ ValuesMK $ extendTables (hmap (const (K ())) t1) vs + then + LedgerTables $ + hcmap (Proxy @(CanUpgradeLedgerTable (HardForkBlock xs))) (upgradeTable (hmap (const (K ())) t1)) np else orig where t1 = Telescope.tip hs1 -extendTables :: +extendUTxOTable :: forall xs. (CanHardFork xs, HasHardForkTxOut xs) => NS (K ()) xs -> Map.Map - (TxIn (LedgerState (HardForkBlock xs))) - (TxOut (LedgerState (HardForkBlock xs))) -> + TxIn + (TxOut (HardForkBlock xs)) -> Map.Map - (TxIn (LedgerState (HardForkBlock xs))) - (TxOut (LedgerState (HardForkBlock xs))) -extendTables st = + TxIn + (TxOut (HardForkBlock xs)) +extendUTxOTable idx = Map.map ( \txout -> hcollapse $ @@ -1238,60 +1291,29 @@ extendTables st = . ejectHardForkTxOut idxTarget $ txout ) - st + idx ) injectHardForkTxOutDefault :: SListI xs => Index xs x -> - TxOut (LedgerState x) -> + TxOut x -> DefaultHardForkTxOut xs injectHardForkTxOutDefault idx = injectNS idx . WrapTxOut -ejectHardForkTxOutDefault :: - SListI xs => - HasHardForkTxOut xs => - Index xs x -> - DefaultHardForkTxOut xs -> - TxOut (LedgerState x) -ejectHardForkTxOutDefault idx = - unwrapTxOut - . apFn (projectNP idx txOutEjections) - . K - -composeTxOutTranslations :: - SListI xs => - InPairs TranslateTxOut xs -> - NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs -composeTxOutTranslations = \case - PNil -> - fn (unZ . unK) :* Nil - PCons (TranslateTxOut t) ts -> - fn - ( eitherNS - id - (error "composeTranslations: anachrony") - . unK - ) - :* hmap - ( \innerf -> - fn $ - apFn innerf - . K - . eitherNS - (Z . WrapTxOut . t . unwrapTxOut) - id - . unK - ) - (composeTxOutTranslations ts) - where - eitherNS :: (f x -> c) -> (NS f xs -> c) -> NS f (x ': xs) -> c - eitherNS l r = \case - Z x -> l x - S x -> r x - -class MemPack (TxOut (LedgerState x)) => MemPackTxOut x -instance MemPack (TxOut (LedgerState x)) => MemPackTxOut x +-- ejectHardForkTxOutDefault :: +-- SListI xs => +-- HasHardForkTxOut xs => +-- Index xs x -> +-- DefaultHardForkTxOut xs -> +-- TxOut x +-- ejectHardForkTxOutDefault idx = +-- unwrapTxOut +-- . apFn (projectNP idx txOutEjections) +-- . K + +class MemPack (TxOut x) => MemPackTxOut x +instance MemPack (TxOut x) => MemPackTxOut x instance (All MemPackTxOut xs, Typeable xs) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/CommonProtocolParams.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/CommonProtocolParams.hs index 665fcc2838..9e7553f3a9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/CommonProtocolParams.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/CommonProtocolParams.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -11,16 +12,17 @@ import Data.SOP.Strict import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.Basics import Ouroboros.Consensus.HardFork.Combinator.Ledger - ( HasCanonicalTxIn + ( CanHardFork' , HasHardForkTxOut (..) ) import qualified Ouroboros.Consensus.HardFork.Combinator.State as State import Ouroboros.Consensus.Ledger.CommonProtocolParams +import Ouroboros.Consensus.Ledger.Tables instance - ( CanHardFork xs - , HasCanonicalTxIn xs + ( CanHardFork' xs , HasHardForkTxOut xs + , LedgerTablesConstraints (HardForkBlock xs) ) => CommonProtocolParams (HardForkBlock xs) where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs index a240228bbd..e7beda0e32 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs @@ -124,8 +124,8 @@ class ( All (Compose NoThunks WrapTxOut) xs , All (Compose Show WrapTxOut) xs , All (Compose Eq WrapTxOut) xs - , All (Compose HasTickedLedgerTables LedgerState) xs - , All (Compose HasLedgerTables LedgerState) xs + , All (HasTickedLedgerTables LedgerState) xs + , All (HasLedgerTables LedgerState) xs ) => BlockSupportsHFLedgerQuery xs where @@ -153,7 +153,7 @@ class queryLedgerGetTraversingFilter :: Index xs x -> BlockQuery x QFTraverseTables result -> - TxOut (LedgerState (HardForkBlock xs)) -> + TxOut (HardForkBlock xs) -> Bool {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs index 0c6de3deb5..0869f9680a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs @@ -34,6 +34,7 @@ import Data.Kind (Type) import qualified Data.Measure as Measure import Data.SOP.BasicFunctors import Data.SOP.Constraint +import qualified Data.SOP.Dict as Dict import Data.SOP.Functors import Data.SOP.InPairs (InPairs) import qualified Data.SOP.InPairs as InPairs @@ -119,9 +120,9 @@ type DecomposedReapplyTxsResult extra xs = :.: FlipTickedLedgerState TrackingMK instance - ( CanHardFork xs - , HasCanonicalTxIn xs + ( CanHardFork' xs , HasHardForkTxOut xs + , LedgerTablesConstraints (HardForkBlock xs) ) => LedgerSupportsMempool (HardForkBlock xs) where @@ -243,14 +244,15 @@ instance getTransactionKeySets (HardForkGenTx (OneEraGenTx ns)) = hcollapse $ - hcimap proxySingle f ns + hcizipWith proxySingle f (toStrict $ Dict.unAll_NP Dict.Dict) ns where f :: SingleEraBlock x => Index xs x -> + Dict.Dict (InjectValues xs) x -> GenTx x -> - K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) x - f idx tx = K $ injectLedgerTables idx $ getTransactionKeySets tx + K (LedgerTables (HardForkBlock xs) KeysMK) x + f idx Dict.Dict tx = K $ injectLedgerTables idx $ getTransactionKeySets tx -- This optimization is worthwile because we can save the projection and -- injection of ledger tables. @@ -294,17 +296,25 @@ instance (TickedHardForkLedgerState tr (State.HardForkState st)) = TickedHardForkLedgerState tr $ State.HardForkState $ - hcimap + hcizipWith proxySingle - ( \idx (State.Current start (FlipTickedLedgerState a)) -> - State.Current start $ - FlipTickedLedgerState $ - applyMempoolDiffs - (ejectLedgerTables idx vals) - (ejectLedgerTables idx keys) - a - ) + f + (toStrict $ Dict.unAll_NP Dict.Dict) st + where + f :: + SingleEraBlock x => + Index xs x -> + Dict.Dict (InjectValues xs) x -> + State.Current (FlipTickedLedgerState DiffMK) x -> + State.Current (FlipTickedLedgerState ValuesMK) x + f idx Dict.Dict (State.Current start (FlipTickedLedgerState a)) = + State.Current start $ + FlipTickedLedgerState $ + applyMempoolDiffs + (ejectLedgerTables idx vals) + (ejectLedgerTables idx keys) + a instance CanHardFork xs => TxLimits (HardForkBlock xs) where type TxMeasure (HardForkBlock xs) = HardForkTxMeasure xs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs index fda1547659..28a9e5ebe6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -27,6 +28,7 @@ import Ouroboros.Consensus.HardFork.Combinator.Node.SanityCheck () import Ouroboros.Consensus.HardFork.Combinator.Serialisation import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run +import Ouroboros.Consensus.Storage.LedgerDB.API {------------------------------------------------------------------------------- ConfigSupportsNode @@ -60,11 +62,11 @@ getSameConfigValue getValue blockConfig = getSameValue values -------------------------------------------------------------------------------} instance - ( CanHardFork xs - , HasCanonicalTxIn xs + ( CanHardFork' xs , HasHardForkTxOut xs , BlockSupportsHFLedgerQuery xs , SupportedNetworkProtocolVersion (HardForkBlock xs) , SerialiseHFC xs + , LedgerSupportsLedgerDB (HardForkBlock xs) ) => RunNode (HardForkBlock xs) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/PartialConfig.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/PartialConfig.hs index 8ebc1380cc..c3a168a33e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/PartialConfig.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/PartialConfig.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.HardFork.Combinator.PartialConfig ( HasPartialConsensusConfig (..) @@ -77,7 +78,7 @@ class -- | Partial ledger config class - ( UpdateLedger blk + ( ApplyBlock LedgerState blk , Show (PartialLedgerConfig blk) , NoThunks (PartialLedgerConfig blk) ) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs index ecb65f33c0..ad4420f032 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs @@ -102,10 +102,8 @@ import Ouroboros.Consensus.HardFork.Combinator.NetworkVersion import Ouroboros.Consensus.HardFork.Combinator.State import Ouroboros.Consensus.HardFork.Combinator.State.Instances import Ouroboros.Consensus.Ledger.Query -import Ouroboros.Consensus.Ledger.Tables import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run -import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Network.Block (Serialised) @@ -198,10 +196,6 @@ class All HasBinaryBlockInfo xs , All HasNetworkProtocolVersion xs , All BlockSupportsLedgerQuery xs - , -- LedgerTables on the HardForkBlock might not be compositionally - -- defined, but we need to require this instances for any instantiation. - HasLedgerTables (LedgerState (HardForkBlock xs)) - , LedgerSupportsLedgerDB (HardForkBlock xs) ) => SerialiseHFC xs where @@ -258,7 +252,7 @@ class reconstructHfcNestedCtxt _ prefix blockSize = case nsFromIndex tag of Nothing -> error $ "invalid HardForkBlock with tag: " <> show tag - Just ns -> injSomeSecond $ hcmap proxySingle reconstructOne ns + Just ns -> injSomeSecond @xs $ hcmap proxySingle reconstructOne ns where tag :: Word8 tag = Short.index prefix 1 @@ -274,6 +268,7 @@ class reconstructNestedCtxt (Proxy @(Header blk)) prefixOne blockSize injSomeSecond :: + forall xs'. NS (SomeSecond (NestedCtxt Header)) xs' -> SomeSecond (NestedCtxt Header) (HardForkBlock xs') injSomeSecond (Z x) = case x of diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseDisk.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseDisk.hs index 2febd03bad..fbe57c7591 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseDisk.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseDisk.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -19,11 +22,13 @@ import Ouroboros.Consensus.HardFork.Combinator.Protocol import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Basics +--import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Storage.ChainDB +import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers -instance SerialiseHFC xs => SerialiseDiskConstraints (HardForkBlock xs) +instance (SerialiseHFC xs, LedgerSupportsLedgerDB (HardForkBlock xs)) => SerialiseDiskConstraints (HardForkBlock xs) {------------------------------------------------------------------------------- 'ReconstructNestedCtxt' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs index 8cc8cea834..a48a578715 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs @@ -44,6 +44,7 @@ import qualified Data.SOP.InPairs as InPairs import Data.SOP.Strict import Data.SOP.Telescope (Extend (..), ScanNext (..), Telescope) import qualified Data.SOP.Telescope as Telescope +import Data.Singletons (SingI) import Ouroboros.Consensus.Block import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.AcrossEras @@ -56,6 +57,7 @@ import Ouroboros.Consensus.HardFork.Combinator.Translation import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Ledger.Abstract hiding (getTip) import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Util.TypeLevel import Prelude hiding (sequence) {------------------------------------------------------------------------------- @@ -290,7 +292,11 @@ extendToSlot ledgerCfg@HardForkLedgerConfig{..} slot ledgerSt@(HardForkState st) return endBound howExtend :: - (HasLedgerTables (LedgerState blk), HasLedgerTables (LedgerState blk')) => + ( All SingI (TablesForBlock blk) + , HasLedgerTables LedgerState blk + , HasLedgerTables LedgerState blk' + , ToAllDict (TableConstraints blk') (TablesForBlock blk') + ) => TranslateLedgerState blk blk' -> TranslateLedgerTables blk blk' -> History.Bound -> @@ -312,7 +318,7 @@ extendToSlot ledgerCfg@HardForkLedgerConfig{..} slot ledgerSt@(HardForkState st) -- will just be a no-op. See the haddock for -- 'translateLedgerTablesWith' and 'extendToSlot' for more -- information. - . prependDiffs + . prependDiffsT ( translateLedgerTablesWith f' . projectLedgerTables . unFlip diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs index 2ac107bd05..c9fea70e2d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs @@ -1,8 +1,17 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.HardFork.Combinator.State.Types ( -- * Main types @@ -17,24 +26,27 @@ module Ouroboros.Consensus.HardFork.Combinator.State.Types , Translate (..) , TranslateLedgerState (..) , TranslateLedgerTables (..) - , TranslateTxOut (..) , translateLedgerTablesWith ) where import Control.Monad.Except -import qualified Data.Map.Strict as Map +import Data.Function ((&)) import Data.SOP.BasicFunctors import Data.SOP.Constraint +import qualified Data.SOP.Dict as Dict import Data.SOP.Strict import Data.SOP.Telescope (Telescope) import qualified Data.SOP.Telescope as Telescope +import Data.Singletons (SingI, sing) import GHC.Generics (Generic) +import Lens.Micro ((.~)) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HardFork.History (Bound) import Ouroboros.Consensus.Ledger.Basics -import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff +import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Util.TypeLevel {------------------------------------------------------------------------------- Types @@ -164,20 +176,13 @@ newtype TranslateLedgerState x y = TranslateLedgerState -- more information. } --- | Transate a 'LedgerTables' across an era transition. -data TranslateLedgerTables x y = TranslateLedgerTables - { translateTxInWith :: !(TxIn (LedgerState x) -> TxIn (LedgerState y)) - -- ^ Translate a 'TxIn' across an era transition. - -- - -- See 'translateLedgerTablesWith'. - , translateTxOutWith :: !(TxOut (LedgerState x) -> TxOut (LedgerState y)) - -- ^ Translate a 'TxOut' across an era transition. - -- - -- See 'translateLedgerTablesWith'. +-- | Transate a 'LedgerTables' across an era transition. Note that only UTxOs +-- require translation. +newtype TranslateLedgerTables x y + = TranslateLedgerTables + { translateTxOutWith :: Value UTxOTable x -> Value UTxOTable y } -newtype TranslateTxOut x y = TranslateTxOut (TxOut (LedgerState x) -> TxOut (LedgerState y)) - -- | Translate a 'LedgerTables' across an era transition. -- -- To translate 'LedgerTable's, it's sufficient to know how to translate @@ -203,21 +208,22 @@ newtype TranslateTxOut x y = TranslateTxOut (TxOut (LedgerState x) -> TxOut (Led -- previous eras, so it will be called only when crossing era boundaries, -- therefore the translation won't be equivalent to 'id'. translateLedgerTablesWith :: - Ord (TxIn (LedgerState y)) => + forall x y. + ( SListI (TablesForBlock x) + , SingI (TablesForBlock x) + , LedgerTablesConstraints y + , ToAllDict (TableConstraints y) (TablesForBlock y) + ) => TranslateLedgerTables x y -> - LedgerTables (LedgerState x) DiffMK -> - LedgerTables (LedgerState y) DiffMK -translateLedgerTablesWith f = - LedgerTables - . DiffMK - . Diff.Diff - . Map.mapKeys (translateTxInWith f) - . getDiff - . getDiffMK - . mapMK (translateTxOutWith f) - . getLedgerTables - where - getDiff (Diff.Diff m) = m + LedgerTables x DiffMK -> + LedgerTables y DiffMK +translateLedgerTablesWith (TranslateLedgerTables tv) x = + case getNPByTag (sing @UTxOTable) (toAllDict @(TableConstraints y) @(TablesForBlock y)) of + Nothing -> emptyLedgerTables + Just Dict.Dict -> + emptyLedgerTables + & onTable (Proxy @y) (Proxy @UTxOTable) + .~ maybe (Table emptyMK) (Table . mapMK tv . getTable) (getTableByTag (sing @UTxOTable) x) -- | Knowledge in a particular era of the transition to the next era data TransitionInfo diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Translation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Translation.hs index bb71423a88..0a6bc3a69f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Translation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Translation.hs @@ -5,13 +5,11 @@ module Ouroboros.Consensus.HardFork.Combinator.Translation ( -- * Translate from one era to the next EraTranslation (..) - , ipTranslateTxOut + -- , ipTranslateTxOut , trivialEraTranslation ) where -import Data.SOP.Constraint import Data.SOP.InPairs (InPairs (..), RequiringBoth (..)) -import qualified Data.SOP.InPairs as InPairs import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.Ledger.Abstract @@ -35,12 +33,6 @@ data EraTranslation xs = EraTranslation NoThunks via OnlyCheckWhnfNamed "EraTranslation" (EraTranslation xs) -ipTranslateTxOut :: - All Top xs => - EraTranslation xs -> - InPairs TranslateTxOut xs -ipTranslateTxOut = InPairs.hmap (TranslateTxOut . translateTxOutWith) . translateLedgerTables - trivialEraTranslation :: EraTranslation '[blk] trivialEraTranslation = EraTranslation diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs index 112397e464..4a450c78a4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs @@ -256,7 +256,7 @@ validateHeader cfg lv hdr slotTime history = do -- PRECONDITION: the blocks in the chain are valid. fromChain :: forall blk. - ( ApplyBlock (ExtLedgerState blk) blk + ( ApplyBlock ExtLedgerState blk , HasHardForkHistory blk , HasAnnTip blk ) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs index 29c0e64e48..3516b775e5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs @@ -1,11 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} -- | Interface to the ledger layer -- @@ -18,8 +17,8 @@ module Ouroboros.Consensus.Ledger.Abstract -- * Apply block , ApplyBlock (..) + , GetBlockKeySets (..) , ComputeLedgerEvents (..) - , UpdateLedger , defaultApplyBlockLedgerResult , defaultReapplyBlockLedgerResult @@ -48,6 +47,7 @@ import Data.Kind (Type) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ledger.Basics +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Ticked import Ouroboros.Consensus.Util @@ -83,12 +83,13 @@ data family Validated x :: Type -------------------------------------------------------------------------------} class - ( IsLedger l - , HeaderHash l ~ HeaderHash blk + ( IsLedger (l blk) + , HeaderHash (l blk) ~ HeaderHash blk , HasHeader blk , HasHeader (Header blk) - , HasLedgerTables l - , HasLedgerTables (Ticked l) + , HasLedgerTables l blk + , HasLedgerTables (TickedL l) blk + , GetBlockKeySets blk ) => ApplyBlock l blk where @@ -103,10 +104,10 @@ class HasCallStack => STS.ValidationPolicy -> ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - Ticked l ValuesMK -> - Except (LedgerErr l) (LedgerResult l (l DiffMK)) + Ticked (l blk) ValuesMK -> + Except (LedgerErr (l blk)) (LedgerResult (l blk) (l blk DiffMK)) -- | Apply a block to the ledger state. -- @@ -117,10 +118,10 @@ class applyBlockLedgerResult :: HasCallStack => ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - Ticked l ValuesMK -> - Except (LedgerErr l) (LedgerResult l (l DiffMK)) + Ticked (l blk) ValuesMK -> + Except (LedgerErr (l blk)) (LedgerResult (l blk) (l blk DiffMK)) -- | Re-apply a block to the very same ledger state it was applied in before. -- @@ -135,40 +136,38 @@ class reapplyBlockLedgerResult :: HasCallStack => ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - Ticked l ValuesMK -> - LedgerResult l (l DiffMK) + Ticked (l blk) ValuesMK -> + LedgerResult (l blk) (l blk DiffMK) +class GetBlockKeySets blk where -- | Given a block, get the key-sets that we need to apply it to a ledger -- state. - getBlockKeySets :: blk -> LedgerTables l KeysMK + getBlockKeySets :: blk -> LedgerTables blk KeysMK defaultApplyBlockLedgerResult :: (HasCallStack, ApplyBlock l blk) => ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - Ticked l ValuesMK -> - Except (LedgerErr l) (LedgerResult l (l DiffMK)) + Ticked (l blk) ValuesMK -> + Except (LedgerErr (l blk)) (LedgerResult (l blk) (l blk DiffMK)) defaultApplyBlockLedgerResult = applyBlockLedgerResultWithValidation STS.ValidateAll defaultReapplyBlockLedgerResult :: (HasCallStack, ApplyBlock l blk) => - (LedgerErr l -> LedgerResult l (l DiffMK)) -> + (LedgerErr (l blk) -> LedgerResult (l blk) (l blk DiffMK)) -> ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - Ticked l ValuesMK -> - LedgerResult l (l DiffMK) + Ticked (l blk) ValuesMK -> + LedgerResult (l blk) (l blk DiffMK) defaultReapplyBlockLedgerResult throwReapplyError = (either throwReapplyError id . runExcept) ...: applyBlockLedgerResultWithValidation STS.ValidateNone --- | Interaction with the ledger layer -class ApplyBlock (LedgerState blk) blk => UpdateLedger blk - {------------------------------------------------------------------------------- Derived functionality -------------------------------------------------------------------------------} @@ -178,10 +177,10 @@ applyLedgerBlock :: forall l blk. (ApplyBlock l blk, HasCallStack) => ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - Ticked l ValuesMK -> - Except (LedgerErr l) (l DiffMK) + Ticked (l blk) ValuesMK -> + Except (LedgerErr (l blk)) (l blk DiffMK) applyLedgerBlock = fmap lrResult ...: applyBlockLedgerResult -- | 'lrResult' after 'reapplyBlockLedgerResult' @@ -189,19 +188,20 @@ reapplyLedgerBlock :: forall l blk. (ApplyBlock l blk, HasCallStack) => ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - Ticked l ValuesMK -> - l DiffMK + Ticked (l blk) ValuesMK -> + l blk DiffMK reapplyLedgerBlock = lrResult ...: reapplyBlockLedgerResult tickThenApplyLedgerResult :: + forall (l :: Type -> LedgerStateKind) blk. ApplyBlock l blk => ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - l ValuesMK -> - Except (LedgerErr l) (LedgerResult l (l DiffMK)) + l blk ValuesMK -> + Except (LedgerErr (l blk)) (LedgerResult (l blk) (l blk DiffMK)) tickThenApplyLedgerResult evs cfg blk l = do let lrTick = applyChainTickLedgerResult evs cfg (blockSlot blk) (forgetLedgerTables l) lrBlock <- @@ -209,21 +209,21 @@ tickThenApplyLedgerResult evs cfg blk l = do evs cfg blk - (applyDiffForKeys l (getBlockKeySets blk) (lrResult lrTick)) + (unTickedL $ applyDiffForKeys l (getBlockKeySets blk) (TickedL $ lrResult lrTick)) pure LedgerResult { lrEvents = lrEvents lrTick <> lrEvents lrBlock - , lrResult = prependDiffs (lrResult lrTick) (lrResult lrBlock) + , lrResult = prependDiffs @(TickedL l) @l @blk (TickedL $ lrResult lrTick) (lrResult lrBlock) } tickThenReapplyLedgerResult :: forall l blk. ApplyBlock l blk => ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - l ValuesMK -> - LedgerResult l (l DiffMK) + l blk ValuesMK -> + LedgerResult (l blk) (l blk DiffMK) tickThenReapplyLedgerResult evs cfg blk l = let lrTick = applyChainTickLedgerResult evs cfg (blockSlot blk) (forgetLedgerTables l) lrBlock = @@ -231,42 +231,46 @@ tickThenReapplyLedgerResult evs cfg blk l = evs cfg blk - (applyDiffForKeys l (getBlockKeySets blk) (lrResult lrTick)) + (unTickedL $ applyDiffForKeys l (getBlockKeySets blk) (TickedL $ lrResult lrTick)) in LedgerResult { lrEvents = lrEvents lrTick <> lrEvents lrBlock - , lrResult = prependDiffs (lrResult lrTick) (lrResult lrBlock) + , lrResult = prependDiffs @(TickedL l) @l @blk (TickedL $ lrResult lrTick) (lrResult lrBlock) } tickThenApply :: forall l blk. ApplyBlock l blk => ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - l ValuesMK -> - Except (LedgerErr l) (l DiffMK) + l blk ValuesMK -> + Except (LedgerErr (l blk)) (l blk DiffMK) tickThenApply = fmap lrResult ...: tickThenApplyLedgerResult tickThenReapply :: forall l blk. ApplyBlock l blk => ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> - l ValuesMK -> - l DiffMK + l blk ValuesMK -> + l blk DiffMK tickThenReapply = lrResult ...: tickThenReapplyLedgerResult foldLedger :: ApplyBlock l blk => - ComputeLedgerEvents -> LedgerCfg l -> [blk] -> l ValuesMK -> Except (LedgerErr l) (l ValuesMK) + ComputeLedgerEvents -> + LedgerCfg (l blk) -> + [blk] -> + l blk ValuesMK -> + Except (LedgerErr (l blk)) (l blk ValuesMK) foldLedger evs cfg = repeatedlyM (\blk state -> applyDiffForKeys state (getBlockKeySets blk) <$> tickThenApply evs cfg blk state) refoldLedger :: ApplyBlock l blk => - ComputeLedgerEvents -> LedgerCfg l -> [blk] -> l ValuesMK -> l ValuesMK + ComputeLedgerEvents -> LedgerCfg (l blk) -> [blk] -> l blk ValuesMK -> l blk ValuesMK refoldLedger evs cfg = repeatedly (\blk state -> applyDiffForKeys state (getBlockKeySets blk) $ tickThenReapply evs cfg blk state) @@ -276,16 +280,16 @@ refoldLedger evs cfg = -------------------------------------------------------------------------------} ledgerTipPoint :: - UpdateLedger blk => + ApplyBlock LedgerState blk => LedgerState blk mk -> Point blk ledgerTipPoint = castPoint . getTip ledgerTipHash :: - UpdateLedger blk => + ApplyBlock LedgerState blk => LedgerState blk mk -> ChainHash blk ledgerTipHash = pointHash . ledgerTipPoint ledgerTipSlot :: - UpdateLedger blk => + ApplyBlock LedgerState blk => LedgerState blk mk -> WithOrigin SlotNo ledgerTipSlot = pointSlot . ledgerTipPoint diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs index 2313a0d086..517cdb005f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilies #-} @@ -50,6 +48,7 @@ module Ouroboros.Consensus.Ledger.Basics import Data.Kind (Constraint, Type) import GHC.Generics import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.Tables import Ouroboros.Consensus.Ticked import Ouroboros.Consensus.Util.IOLike @@ -141,11 +140,7 @@ data ComputeLedgerEvents = ComputeLedgerEvents | OmitLedgerEvents type IsLedger :: LedgerStateKind -> Constraint class - ( -- Requirements on the ledger state itself - forall mk. EqMK mk => Eq (l mk) - , forall mk. NoThunksMK mk => NoThunks (l mk) - , forall mk. ShowMK mk => Show (l mk) - , -- Requirements on 'LedgerCfg' + ( -- Requirements on 'LedgerCfg' NoThunks (LedgerCfg l) , -- Requirements on 'LedgerErr' Show (LedgerErr l) @@ -220,34 +215,5 @@ applyChainTick :: Ticked l DiffMK applyChainTick = lrResult ...: applyChainTickLedgerResult -{------------------------------------------------------------------------------- - Link block to its ledger --------------------------------------------------------------------------------} - --- | Ledger state associated with a block --- --- This is the Consensus notion of a Ledger /ledger state/. Each block type is --- associated with one of the Ledger types for the /ledger state/. Virtually --- every concept in this codebase revolves around this type, or the referenced --- @blk@. Whenever we use the type variable @l@ we intend to signal that the --- expected instantiation is either a 'LedgerState' or some wrapper over it --- (like the 'Ouroboros.Consensus.Ledger.Extended.ExtLedgerState'). --- --- This type is parametrized over @mk :: 'MapKind'@ to express the --- 'LedgerTables' contained in such a 'LedgerState'. See 'LedgerTables' for a --- more thorough description. --- --- The main operations we can do with a 'LedgerState' are /ticking/ (defined in --- 'IsLedger'), and /applying a block/ (defined in --- 'Ouroboros.Consensus.Ledger.Abstract.ApplyBlock'). -type LedgerState :: Type -> LedgerStateKind -data family LedgerState blk mk - -type TickedLedgerState blk = Ticked (LedgerState blk) - -type instance HeaderHash (LedgerState blk) = HeaderHash blk - -instance StandardHash blk => StandardHash (LedgerState blk) - type LedgerConfig blk = LedgerCfg (LedgerState blk) type LedgerError blk = LedgerErr (LedgerState blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/CommonProtocolParams.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/CommonProtocolParams.hs index d51ab4b601..921616bf0e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/CommonProtocolParams.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/CommonProtocolParams.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableSuperClasses #-} + module Ouroboros.Consensus.Ledger.CommonProtocolParams (CommonProtocolParams (..)) where import Data.Word (Word32) import Ouroboros.Consensus.Ledger.Abstract -- | Ask the ledger for common protocol parameters. -class UpdateLedger blk => CommonProtocolParams blk where +class ApplyBlock LedgerState blk => CommonProtocolParams blk where -- | The maximum header size in bytes according to the currently adopted -- protocol parameters of the ledger state. maxHeaderSize :: LedgerState blk mk -> Word32 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index 9ae75c141a..fdae9b6bdd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -269,6 +269,7 @@ class , Serialise (BridgeBlock m a) , Serialise (BridgeTx m a) , Show (BridgeTx m a) + , GetBlockKeySets m ) => Bridge m a where @@ -464,7 +465,7 @@ applyHelper f opts cfg block@DualBlock{..} TickedDualLedgerState{..} = do tickedDualLedgerStateBridge } -instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) where +instance Bridge m a => ApplyBlock LedgerState (DualBlock m a) where applyBlockLedgerResultWithValidation doValidate = applyHelper (applyBlockLedgerResultWithValidation doValidate) @@ -500,9 +501,9 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) dualBlockMain tickedDualLedgerStateMain +instance Bridge m a => GetBlockKeySets (DualBlock m a) where getBlockKeySets = - castLedgerTables - . getBlockKeySets @(LedgerState m) + getBlockKeySets @m . dualBlockMain data instance LedgerState (DualBlock m a) mk = DualLedgerState @@ -733,8 +734,7 @@ instance Bridge m a => LedgerSupportsMempool (DualBlock m a) where } = vtx getTransactionKeySets = - castLedgerTables - . getTransactionKeySets @m + getTransactionKeySets @m . dualGenTxMain instance Bridge m a => TxLimits (DualBlock m a) where @@ -1101,14 +1101,18 @@ decodeDualLedgerState decodeMain = do Ledger Tables -------------------------------------------------------------------------------} -type instance TxIn (LedgerState (DualBlock m a)) = TxIn (LedgerState m) -type instance TxOut (LedgerState (DualBlock m a)) = TxOut (LedgerState m) +type instance TxIn (DualBlock m a) = TxIn m +type instance TxOut (DualBlock m a) = TxOut m +type instance Credential (DualBlock m a) = Credential m +type instance Coin (DualBlock m a) = Coin m + +type instance TablesForBlock (DualBlock m a) = TablesForBlock m instance CanUpgradeLedgerTables (LedgerState (DualBlock m a)) where upgradeTables _ _ = id instance - (txout ~ TxOut (LedgerState m), IndexedMemPack (LedgerState m EmptyMK) txout) => + (txout ~ TxOut m, IndexedMemPack (LedgerState m EmptyMK) txout) => IndexedMemPack (LedgerState (DualBlock m a) EmptyMK) txout where indexedTypeName (DualLedgerState st _ _) = indexedTypeName @(LedgerState m EmptyMK) @txout st @@ -1117,27 +1121,18 @@ instance indexedUnpackM (DualLedgerState st _ _) = indexedUnpackM st instance - (Ord (TxIn (LedgerState m)), MemPack (TxIn (LedgerState m)), MemPack (TxOut (LedgerState m))) => - SerializeTablesWithHint (LedgerState (DualBlock m a)) + SerializeTablesWithHint (LedgerState m) m tag => + SerializeTablesWithHint (LedgerState (DualBlock m a)) (DualBlock m a) tag where - encodeTablesWithHint = defaultEncodeTablesWithHint - decodeTablesWithHint = defaultDecodeTablesWithHint + encodeTablesWithHint hint = encodeTablesWithHint (dualLedgerStateMain hint) + decodeTablesWithHint hint = decodeTablesWithHint (dualLedgerStateMain hint) instance - ( Bridge m a - , NoThunks (TxOut (LedgerState m)) - , NoThunks (TxIn (LedgerState m)) - , Show (TxOut (LedgerState m)) - , Show (TxIn (LedgerState m)) - , Eq (TxOut (LedgerState m)) - , Ord (TxIn (LedgerState m)) - , MemPack (TxIn (LedgerState m)) - ) => + Bridge m a => HasLedgerTables (LedgerState (DualBlock m a)) where projectLedgerTables DualLedgerState{..} = - castLedgerTables - (projectLedgerTables dualLedgerStateMain) + projectLedgerTables dualLedgerStateMain withLedgerTables DualLedgerState{..} main = DualLedgerState @@ -1149,15 +1144,7 @@ instance } instance - ( Bridge m a - , NoThunks (TxOut (LedgerState m)) - , NoThunks (TxIn (LedgerState m)) - , Show (TxOut (LedgerState m)) - , Show (TxIn (LedgerState m)) - , Eq (TxOut (LedgerState m)) - , Ord (TxIn (LedgerState m)) - , MemPack (TxIn (LedgerState m)) - ) => + Bridge m a => HasLedgerTables (Ticked (LedgerState (DualBlock m a))) where projectLedgerTables TickedDualLedgerState{..} = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index 4a47abcceb..c91794f6e3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -1,6 +1,4 @@ -{- HLINT ignore "Unused LANGUAGE pragma" -} --- False hint on TypeOperators -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -31,14 +29,25 @@ module Ouroboros.Consensus.Ledger.Extended -- * Type family instances , LedgerTables (..) , Ticked (..) + , valuesMKEncoder + , valuesMKDecoder + , SerializeTablesWithHint (..) + , defaultEncodeTablesWithHint + , defaultDecodeTablesWithHint ) where import Codec.CBOR.Decoding (Decoder, decodeListLenOf) +import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding, encodeListLen) +import qualified Codec.CBOR.Encoding as CBOR import Control.Monad.Except import Data.Functor ((<&>)) -import Data.MemPack +import qualified Data.Map.Strict as Map +import Data.MemPack (packByteString, unpackMonadFail) import Data.Proxy +import Data.SOP.BasicFunctors (K (..), (:.:) (..)) +import Data.SOP.Constraint +import Data.SOP.Strict (NP, hcmap, hcpure) import Data.Typeable import GHC.Generics (Generic) import GHC.Stack (HasCallStack) @@ -47,6 +56,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.Serialisation @@ -75,10 +85,10 @@ data ExtLedgerState blk mk = ExtLedgerState deriving Generic deriving instance - (EqMK mk, LedgerSupportsProtocol blk) => + (Eq (LedgerState blk mk), LedgerSupportsProtocol blk) => Eq (ExtLedgerState blk mk) deriving instance - (ShowMK mk, LedgerSupportsProtocol blk) => + (Show (LedgerState blk mk), LedgerSupportsProtocol blk) => Show (ExtLedgerState blk mk) -- | We override 'showTypeOf' to show the type of the block @@ -86,7 +96,7 @@ deriving instance -- This makes debugging a bit easier, as the block gets used to resolve all -- kinds of type families. instance - (NoThunksMK mk, LedgerSupportsProtocol blk) => + (NoThunks (LedgerState blk mk), LedgerSupportsProtocol blk) => NoThunks (ExtLedgerState blk mk) where showTypeOf _ = show $ typeRep (Proxy @(ExtLedgerState blk)) @@ -205,7 +215,14 @@ applyHelper f opts cfg blk TickedExtLedgerState{..} = do tickedHeaderState pure $ (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult -instance LedgerSupportsProtocol blk => ApplyBlock (ExtLedgerState blk) blk where +instance + ( HasLedgerTables ExtLedgerState blk + , HasLedgerTables (TickedL ExtLedgerState) blk + , LedgerSupportsProtocol blk + , GetBlockKeySets blk + ) => + ApplyBlock ExtLedgerState blk + where applyBlockLedgerResultWithValidation doValidate = applyHelper (applyBlockLedgerResultWithValidation doValidate) @@ -228,8 +245,6 @@ instance LedgerSupportsProtocol blk => ApplyBlock (ExtLedgerState blk) blk where (getHeader blk) tickedHeaderState - getBlockKeySets = castLedgerTables . getBlockKeySets @(LedgerState blk) - {------------------------------------------------------------------------------- Serialisation -------------------------------------------------------------------------------} @@ -305,62 +320,31 @@ decodeDiskExtLedgerState cfg = Ledger Tables -------------------------------------------------------------------------------} -type instance TxIn (ExtLedgerState blk) = TxIn (LedgerState blk) -type instance TxOut (ExtLedgerState blk) = TxOut (LedgerState blk) - instance - ( HasLedgerTables (LedgerState blk) - , NoThunks (TxOut (LedgerState blk)) - , NoThunks (TxIn (LedgerState blk)) - , Show (TxOut (LedgerState blk)) - , Show (TxIn (LedgerState blk)) - , Eq (TxOut (LedgerState blk)) - , Ord (TxIn (LedgerState blk)) - , MemPack (TxIn (LedgerState blk)) - ) => - HasLedgerTables (ExtLedgerState blk) + HasLedgerTables LedgerState blk => + HasLedgerTables ExtLedgerState blk where projectLedgerTables (ExtLedgerState lstate _) = - castLedgerTables (projectLedgerTables lstate) + projectLedgerTables lstate withLedgerTables (ExtLedgerState lstate hstate) tables = ExtLedgerState - (lstate `withLedgerTables` castLedgerTables tables) + (lstate `withLedgerTables` tables) hstate instance - LedgerTablesAreTrivial (LedgerState blk) => - LedgerTablesAreTrivial (ExtLedgerState blk) - where - convertMapKind (ExtLedgerState x y) = ExtLedgerState (convertMapKind x) y - -instance - LedgerTablesAreTrivial (Ticked (LedgerState blk)) => - LedgerTablesAreTrivial (Ticked (ExtLedgerState blk)) - where - convertMapKind (TickedExtLedgerState x y z) = - TickedExtLedgerState (convertMapKind x) y z - -instance - ( HasLedgerTables (Ticked (LedgerState blk)) - , NoThunks (TxOut (LedgerState blk)) - , NoThunks (TxIn (LedgerState blk)) - , Show (TxOut (LedgerState blk)) - , Show (TxIn (LedgerState blk)) - , Eq (TxOut (LedgerState blk)) - , Ord (TxIn (LedgerState blk)) - , MemPack (TxIn (LedgerState blk)) - ) => - HasLedgerTables (Ticked (ExtLedgerState blk)) + HasLedgerTables (TickedL LedgerState) blk => + HasLedgerTables (TickedL ExtLedgerState) blk where - projectLedgerTables (TickedExtLedgerState lstate _view _hstate) = - castLedgerTables (projectLedgerTables lstate) + projectLedgerTables (TickedL (TickedExtLedgerState lstate _view _hstate)) = + projectLedgerTables (TickedL lstate) withLedgerTables - (TickedExtLedgerState lstate view hstate) + (TickedL (TickedExtLedgerState lstate view hstate)) tables = - TickedExtLedgerState - (lstate `withLedgerTables` castLedgerTables tables) - view - hstate + TickedL $ + TickedExtLedgerState + (unTickedL $ TickedL lstate `withLedgerTables` tables) + view + hstate instance CanStowLedgerTables (LedgerState blk) => @@ -373,14 +357,96 @@ instance ExtLedgerState (unstowLedgerTables lstate) hstate instance - (txout ~ (TxOut (LedgerState blk)), IndexedMemPack (LedgerState blk EmptyMK) txout) => - IndexedMemPack (ExtLedgerState blk EmptyMK) txout + IndexedMemPack LedgerState blk table => + IndexedMemPack ExtLedgerState blk table + where + type IndexedValue ExtLedgerState table blk = IndexedValue LedgerState table blk + indexedTypeName _ p q = indexedTypeName (Proxy @LedgerState) p q + indexedPackedByteCount _ p q (ExtLedgerState st _) = indexedPackedByteCount (Proxy @LedgerState) p q st + indexedPackM _ p q (ExtLedgerState st _) = indexedPackM (Proxy @LedgerState) p q st + indexedUnpackM _ p q (ExtLedgerState st _) = indexedUnpackM (Proxy @LedgerState) p q st + +{------------------------------------------------------------------------------- + Serialization Codecs +-------------------------------------------------------------------------------} + +-- | Default encoder of @'LedgerTables' l ''ValuesMK'@ to be used by the +-- in-memory backing store. +valuesMKEncoder :: + forall l blk. + All (SerializeTablesWithHint l blk) (TablesForBlock blk) => + l blk EmptyMK -> + LedgerTables blk ValuesMK -> + NP (K Encoding) (TablesForBlock blk) +valuesMKEncoder st (LedgerTables tbs) = + hcmap (Proxy @(SerializeTablesWithHint l blk)) (K . encodeTablesWithHint st) tbs + +-- | Default decoder of @'LedgerTables' l ''ValuesMK'@ to be used by the +-- in-memory backing store. +valuesMKDecoder :: + forall l blk s. + All (SerializeTablesWithHint l blk) (TablesForBlock blk) => + l blk EmptyMK -> + NP (Decoder s :.: Table ValuesMK blk) (TablesForBlock blk) +valuesMKDecoder st = do + hcpure (Proxy @(SerializeTablesWithHint l blk)) (Comp $ decodeTablesWithHint st) + +-- | When decoding the tables and in particular the UTxO set we want +-- to share data in the Values in the same way the Ledger did (see the +-- @Share (TxOut era)@ instances). We need to provide the state in the +-- HFC case so that we can call 'eraDecoder' and also to extract the +-- interns from the state. +-- +-- As we will decode with 'eraDecoder' we also need to use such era +-- for the encoding thus we need the hint also in the encoding. +-- +-- See @SerializeTablesWithHint (LedgerState (HardForkBlock (CardanoBlock c))) +-- UTxOTable@ and @SerializeTablesWithHint (LedgerState (HardForkBlock +-- (CardanoBlock c))) InstantStakeTable@ for good examples, the rest of the +-- instances are somewhat degenerate. +class SerializeTablesWithHint l blk tag where + encodeTablesWithHint :: + l blk EmptyMK -> + Table ValuesMK blk tag -> + Encoding + decodeTablesWithHint :: + l blk EmptyMK -> + Decoder s (Table ValuesMK blk tag) + +instance + SerializeTablesWithHint LedgerState blk tag => + SerializeTablesWithHint ExtLedgerState blk tag where - indexedTypeName (ExtLedgerState st _) = indexedTypeName @(LedgerState blk EmptyMK) @txout st - indexedPackedByteCount (ExtLedgerState st _) = indexedPackedByteCount st - indexedPackM (ExtLedgerState st _) = indexedPackM st - indexedUnpackM (ExtLedgerState st _) = indexedUnpackM st - -instance SerializeTablesWithHint (LedgerState blk) => SerializeTablesWithHint (ExtLedgerState blk) where - decodeTablesWithHint st = castLedgerTables <$> decodeTablesWithHint (ledgerState st) - encodeTablesWithHint st tbs = encodeTablesWithHint (ledgerState st) (castLedgerTables tbs) + encodeTablesWithHint = encodeTablesWithHint . ledgerState + decodeTablesWithHint = decodeTablesWithHint . ledgerState + +defaultEncodeTablesWithHint :: + (TableConstraints blk tag, MemPack (Value tag blk)) => + l blk EmptyMK -> + Table ValuesMK blk tag -> + Encoding +defaultEncodeTablesWithHint _ (Table (ValuesMK tbs)) = + mconcat + [ CBOR.encodeMapLen (fromIntegral $ Map.size tbs) + , Map.foldMapWithKey + ( \k v -> + mconcat + [ CBOR.encodeBytes (packByteString k) + , CBOR.encodeBytes (packByteString v) + ] + ) + tbs + ] + +defaultDecodeTablesWithHint :: + (TableConstraints blk tag, MemPack (Value tag blk)) => + l blk EmptyMK -> + Decoder s (Table ValuesMK blk tag) +defaultDecodeTablesWithHint _ = do + n <- CBOR.decodeMapLen + Table . ValuesMK <$> go n Map.empty + where + go 0 m = pure m + go n !m = do + (k, v) <- (,) <$> (unpackMonadFail =<< CBOR.decodeBytes) <*> (unpackMonadFail =<< CBOR.decodeBytes) + go (n - 1) (Map.insert k v m) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/LedgerStateType.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/LedgerStateType.hs new file mode 100644 index 0000000000..c7f66a8821 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/LedgerStateType.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The types basic definitions for a LedgerState +module Ouroboros.Consensus.Ledger.LedgerStateType + ( -- * Kinds + F2 + , LedgerStateKind + , StateKind + + -- * LedgerState type + , LedgerState + , TickedLedgerState + , TickedL (..) + ) +where + +import Data.Kind (Type) +import Ouroboros.Consensus.Ticked +import Ouroboros.Network.Block (HeaderHash, StandardHash) + +-- | The kind of 'Data.Map' +type F2 = Type -> Type -> Type + +-- | The kind of 'LedgerState blk' +type LedgerStateKind = F2 -> Type + +-- | The kind of 'LedgerState' +type StateKind = Type -> LedgerStateKind + +-- | Ledger state associated with a block +-- +-- This is the Consensus notion of a Ledger /ledger state/. Each block type is +-- associated with one of the Ledger types for the /ledger state/. Virtually +-- every concept in this codebase revolves around this type, or the referenced +-- @blk@. Whenever we use the type variable @l@ we intend to signal that the +-- expected instantiation is either a 'LedgerState' or some wrapper over it +-- (like the 'Ouroboros.Consensus.Ledger.Extended.ExtLedgerState'). +-- +-- This type is parametrized over @mk :: 'MapKind'@ to express the +-- 'LedgerTables' contained in such a 'LedgerState'. See 'LedgerTables' for a +-- more thorough description. +-- +-- The main operations we can do with a 'LedgerState' are /ticking/ (defined in +-- 'IsLedger'), and /applying a block/ (defined in +-- 'Ouroboros.Consensus.Ledger.Abstract.ApplyBlock'). +type LedgerState :: Type -> LedgerStateKind +data family LedgerState blk mk + +type TickedLedgerState blk = Ticked (LedgerState blk) + +-- | Useful for referring to @TickedL l@ when dealing with 'StateKind' constraints. +type TickedL :: StateKind -> Type -> F2 -> Type +newtype TickedL l blk mk = TickedL {unTickedL :: Ticked (l blk) mk} + +type instance HeaderHash (LedgerState blk) = HeaderHash blk + +instance StandardHash blk => StandardHash (LedgerState blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query.hs index 25b4aafa74..55bf59a97f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs index 459b6067bd..0d956ce400 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs @@ -3,9 +3,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.Ledger.SupportsMempool ( ApplyTxErr @@ -44,6 +46,7 @@ import NoThunks.Class import Numeric.Natural import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.Tables.Utils -- | Generalized transaction @@ -105,7 +108,7 @@ data ComputeDiffs deriving Show class - ( UpdateLedger blk + ( ApplyBlock LedgerState blk , TxLimits blk , NoThunks (GenTx blk) , NoThunks (Validated (GenTx blk)) @@ -189,17 +192,17 @@ class ) $ Foldable.foldl' ( \(accE, accV, st') (tx, extra) -> - case runExcept (reapplyTx doDiffs cfg slot tx $ trackingToValues st') of + case runExcept (reapplyTx doDiffs cfg slot tx $ unTickedL $ trackingToValues $ TickedL st') of Left err -> (Invalidated tx err : accE, accV, st') Right st'' -> ( accE , (tx, extra) : accV , case doDiffs of - ComputeDiffs -> prependTrackingDiffs st' st'' + ComputeDiffs -> unTickedL $ prependTrackingDiffs (TickedL st') (TickedL st'') IgnoreDiffs -> st'' ) ) - ([], [], attachEmptyDiffs st) + ([], [], unTickedL $ attachEmptyDiffs (TickedL st)) txs -- | Discard the evidence that transaction has been previously validated @@ -209,7 +212,7 @@ class -- ledger state. This is implemented in the Ledger. An example of non-obvious -- needed keys in Cardano are those of reference scripts for computing the -- transaction size. - getTransactionKeySets :: GenTx blk -> LedgerTables (LedgerState blk) KeysMK + getTransactionKeySets :: GenTx blk -> LedgerTables blk KeysMK -- Mempools live in a single slot so in the hard fork block case -- it is cheaper to perform these operations on LedgerStates, saving @@ -227,15 +230,16 @@ class TickedLedgerState blk DiffMK -> TickedLedgerState blk DiffMK -> TickedLedgerState blk DiffMK - prependMempoolDiffs = prependDiffs + prependMempoolDiffs x y = + unTickedL $ prependDiffs @(TickedL LedgerState) @(TickedL LedgerState) @blk (TickedL x) (TickedL y) -- | Apply diffs on ledger states applyMempoolDiffs :: - LedgerTables (LedgerState blk) ValuesMK -> - LedgerTables (LedgerState blk) KeysMK -> + LedgerTables blk ValuesMK -> + LedgerTables blk KeysMK -> TickedLedgerState blk DiffMK -> TickedLedgerState blk ValuesMK - applyMempoolDiffs = applyDiffForKeysOnTables + applyMempoolDiffs t1 t2 = unTickedL . applyDiffForKeysOnTables @(TickedL LedgerState) @blk t1 t2 . TickedL data ReapplyTxsResult extra blk = ReapplyTxsResult diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs index 1babfe531d..acb4ebc4ce 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.Ledger.SupportsProtocol ( GenesisWindow (..) @@ -19,7 +21,7 @@ import Ouroboros.Consensus.Protocol.Abstract -- | Link protocol to ledger class ( BlockSupportsProtocol blk - , UpdateLedger blk + , ApplyBlock LedgerState blk , ValidateEnvelope blk ) => LedgerSupportsProtocol blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables.hs index e3274c8365..6307f55940 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables.hs @@ -1,15 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} -- | This module defines the 'LedgerTables', a portion of the Ledger notion of a -- /ledger state/ (not to confuse with our @@ -170,34 +165,14 @@ module Ouroboros.Consensus.Ledger.Tables -- ** Extracting and injecting ledger tables , HasLedgerTables (..) , HasTickedLedgerTables - - -- * Serialization - , SerializeTablesHint - , SerializeTablesWithHint (..) - , defaultDecodeTablesWithHint - , defaultEncodeTablesWithHint - , valuesMKDecoder - , valuesMKEncoder - - -- * Special classes - , LedgerTablesAreTrivial - , TrivialLedgerTables (..) - , convertMapKind - , trivialLedgerTables ) where -import qualified Codec.CBOR.Decoding as CBOR -import qualified Codec.CBOR.Encoding as CBOR -import Data.Kind (Constraint, Type) -import qualified Data.Map.Strict as Map -import Data.MemPack -import Data.Void (Void) -import NoThunks.Class (NoThunks (..)) +import Data.Kind (Type) +import Data.SOP.Constraint +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.Tables.Basics import Ouroboros.Consensus.Ledger.Tables.Combinators import Ouroboros.Consensus.Ledger.Tables.MapKind -import Ouroboros.Consensus.Ticked -import Ouroboros.Consensus.Util.IndexedMemPack {------------------------------------------------------------------------------- Basic LedgerState classes @@ -205,27 +180,16 @@ import Ouroboros.Consensus.Util.IndexedMemPack -- | Extracting @'LedgerTables'@ from @l mk@ (which will share the same @mk@), -- or replacing the @'LedgerTables'@ associated to a particular @l@. -type HasLedgerTables :: LedgerStateKind -> Constraint -class - ( Ord (TxIn l) - , Eq (TxOut l) - , Show (TxIn l) - , Show (TxOut l) - , NoThunks (TxIn l) - , NoThunks (TxOut l) - , MemPack (TxIn l) - , IndexedMemPack (MemPackIdx l EmptyMK) (TxOut l) - ) => - HasLedgerTables l - where +type HasLedgerTables :: (Type -> LedgerStateKind) -> Type -> Constraint +class LedgerTablesConstraints blk => HasLedgerTables l blk where -- | Extract the ledger tables from a ledger state -- -- The constraints on @mk@ are necessary because the 'CardanoBlock' instance -- uses them. projectLedgerTables :: - (CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) => - l mk -> - LedgerTables l mk + (CanMapMK mk, ZeroableMK mk) => + l blk mk -> + LedgerTables blk mk -- | Overwrite the tables in the given ledger state. -- @@ -238,32 +202,17 @@ class -- The constraints on @mk@ are necessary because the 'CardanoBlock' instance -- uses them. withLedgerTables :: - (CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) => - l any -> - LedgerTables l mk -> - l mk - -instance - ( Ord (TxIn l) - , Eq (TxOut l) - , Show (TxIn l) - , Show (TxOut l) - , NoThunks (TxIn l) - , NoThunks (TxOut l) - , MemPack (TxIn l) - , IndexedMemPack (MemPackIdx l EmptyMK) (TxOut l) - ) => - HasLedgerTables (LedgerTables l) - where - projectLedgerTables = castLedgerTables - withLedgerTables _ = castLedgerTables + (CanMapMK mk, ZeroableMK mk) => + l blk any -> + LedgerTables blk mk -> + l blk mk -- | Convenience class, useful for partially applying the composition of -- 'HasLedgerTables' and 'Ticked'. -type HasTickedLedgerTables :: LedgerStateKind -> Constraint -class HasLedgerTables (Ticked l) => HasTickedLedgerTables l +type HasTickedLedgerTables :: StateKind -> Type -> Constraint +class HasLedgerTables (TickedL l) blk => HasTickedLedgerTables l blk -instance HasLedgerTables (Ticked l) => HasTickedLedgerTables l +instance HasLedgerTables (TickedL l) blk => HasTickedLedgerTables l blk -- | LedgerTables are projections of data from a LedgerState and as such they -- can be injected back into a LedgerState. This is necessary because the Ledger @@ -279,143 +228,3 @@ type CanStowLedgerTables :: LedgerStateKind -> Constraint class CanStowLedgerTables l where stowLedgerTables :: l ValuesMK -> l EmptyMK unstowLedgerTables :: l EmptyMK -> l ValuesMK - -{------------------------------------------------------------------------------- - Serialization Codecs --------------------------------------------------------------------------------} - --- | Default encoder of @'LedgerTables' l ''ValuesMK'@ to be used by the --- in-memory backing store. -valuesMKEncoder :: - forall l. - SerializeTablesWithHint l => - l EmptyMK -> - LedgerTables l ValuesMK -> - CBOR.Encoding -valuesMKEncoder st tbs = - CBOR.encodeListLen 1 <> encodeTablesWithHint st tbs - --- | Default decoder of @'LedgerTables' l ''ValuesMK'@ to be used by the --- in-memory backing store. -valuesMKDecoder :: - forall l s. - SerializeTablesWithHint l => - l EmptyMK -> - CBOR.Decoder s (LedgerTables l ValuesMK) -valuesMKDecoder st = - CBOR.decodeListLenOf 1 >> decodeTablesWithHint st - --- | When decoding the tables and in particular the UTxO set we want --- to share data in the TxOuts in the same way the Ledger did (see the --- @Share (TxOut era)@ instances). We need to provide the state in the --- HFC case so that we can call 'eraDecoder' and also to extract the --- interns from the state. --- --- As we will decode with 'eraDecoder' we also need to use such era --- for the encoding thus we need the hint also in the encoding. --- --- See @SerializeTablesWithHint (LedgerState (HardForkBlock --- (CardanoBlock c)))@ for a good example, the rest of the instances --- are somewhat degenerate. -class SerializeTablesWithHint l where - encodeTablesWithHint :: - SerializeTablesHint (LedgerTables l ValuesMK) -> - LedgerTables l ValuesMK -> - CBOR.Encoding - decodeTablesWithHint :: - SerializeTablesHint (LedgerTables l ValuesMK) -> - CBOR.Decoder s (LedgerTables l ValuesMK) - --- This is just for the BackingStore Lockstep tests. Once V1 is gone --- we can inline it above. - --- | The hint for 'SerializeTablesWithHint' -type family SerializeTablesHint values :: Type - -type instance SerializeTablesHint (LedgerTables l ValuesMK) = l EmptyMK - -defaultEncodeTablesWithHint :: - (MemPack (TxIn l), MemPack (TxOut l)) => - SerializeTablesHint (LedgerTables l ValuesMK) -> - LedgerTables l ValuesMK -> - CBOR.Encoding -defaultEncodeTablesWithHint _ (LedgerTables (ValuesMK tbs)) = - mconcat - [ CBOR.encodeMapLen (fromIntegral $ Map.size tbs) - , Map.foldMapWithKey - ( \k v -> - mconcat - [ CBOR.encodeBytes (packByteString k) - , CBOR.encodeBytes (packByteString v) - ] - ) - tbs - ] - -defaultDecodeTablesWithHint :: - (Ord (TxIn l), MemPack (TxIn l), MemPack (TxOut l)) => - SerializeTablesHint (LedgerTables l ValuesMK) -> - CBOR.Decoder s (LedgerTables l ValuesMK) -defaultDecodeTablesWithHint _ = do - n <- CBOR.decodeMapLen - LedgerTables . ValuesMK <$> go n Map.empty - where - go 0 m = pure m - go n !m = do - (k, v) <- (,) <$> (unpackMonadFail =<< CBOR.decodeBytes) <*> (unpackMonadFail =<< CBOR.decodeBytes) - go (n - 1) (Map.insert k v m) - -{------------------------------------------------------------------------------- - Special classes of ledger states --------------------------------------------------------------------------------} - --- | For some ledger states we won't be defining 'LedgerTables' and instead the --- ledger state will be fully stored in memory, as before UTxO-HD. The ledger --- states that are defined this way can be made instances of this class which --- allows for easy manipulation of the types of @mk@ required at any step of the --- program. -type LedgerTablesAreTrivial :: LedgerStateKind -> Constraint -class (TxIn l ~ Void, TxOut l ~ Void) => LedgerTablesAreTrivial l where - -- | If the ledger state is always in memory, then @l mk@ will be isomorphic - -- to @l mk'@ for all @mk@, @mk'@. As a result, we can convert between ledgers - -- states indexed by different map kinds. - -- - -- This function is useful to combine functions that operate on functions that - -- transform the map kind on a ledger state (eg @applyChainTickLedgerResult@). - convertMapKind :: l mk -> l mk' - -trivialLedgerTables :: - (ZeroableMK mk, LedgerTablesAreTrivial l) => - LedgerTables l mk -trivialLedgerTables = LedgerTables emptyMK - --- | A newtype to @derive via@ the instances for blocks with trivial ledger --- tables. -type TrivialLedgerTables :: LedgerStateKind -> MapKind -> Type -newtype TrivialLedgerTables l mk = TrivialLedgerTables {untrivialLedgerTables :: l mk} - -type instance TxIn (TrivialLedgerTables l) = TxIn l -type instance TxOut (TrivialLedgerTables l) = TxOut l - -instance LedgerTablesAreTrivial l => LedgerTablesAreTrivial (TrivialLedgerTables l) where - convertMapKind = TrivialLedgerTables . convertMapKind . untrivialLedgerTables - -instance LedgerTablesAreTrivial l => HasLedgerTables (TrivialLedgerTables l) where - projectLedgerTables _ = trivialLedgerTables - withLedgerTables st _ = convertMapKind st - -instance LedgerTablesAreTrivial l => CanStowLedgerTables (TrivialLedgerTables l) where - stowLedgerTables = convertMapKind - unstowLedgerTables = convertMapKind - -instance IndexedMemPack (TrivialLedgerTables l EmptyMK) Void where - indexedTypeName _ = typeName @Void - indexedPackedByteCount _ = packedByteCount - indexedPackM _ = packM - indexedUnpackM _ = unpackM - -instance SerializeTablesWithHint (TrivialLedgerTables l) where - decodeTablesWithHint _ = do - _ <- CBOR.decodeMapLen - pure (LedgerTables $ ValuesMK Map.empty) - encodeTablesWithHint _ _ = CBOR.encodeMapLen 0 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Basics.hs index 286a6e8c29..ad2629f31f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Basics.hs @@ -1,54 +1,192 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.Ledger.Tables.Basics ( -- * Kinds - - -- - - -- | For convenience' sake, we define these kinds which convey the intended - -- instantiation for the type variables. LedgerStateKind - , MapKind + , StateKind + , F2 -- * Ledger tables + , Table (..) , LedgerTables (..) - , MemPackIdx - , SameUtxoTypes - , TxIn + + -- * Known tables + , TABLE (..) + , TableLabel (..) + , Key + , Value + , TablesForBlock + + -- ** UTxO table + , TxIn (..) , TxOut - , castLedgerTables + + -- ** Instant stake table + , Credential + , KeyRole (Staking) + , CompactForm + , Coin + + -- * Helpers + , setterForSing + , getTableByTag + , AllTables ) where -import Data.Coerce (coerce) +import qualified Cardano.Ledger.BaseTypes as SL +import Cardano.Ledger.Coin +import Cardano.Ledger.Credential +import Cardano.Ledger.Keys (KeyRole (Staking)) +import qualified Cardano.Ledger.TxIn as SL import Data.Kind (Type) +import Data.List.Singletons hiding (All) +import Data.MemPack +import Data.SOP.Constraint +import Data.SOP.Index (Index (..), projectNP) +import Data.SOP.Strict +import Data.Singletons +import Data.Type.Equality (TestEquality (testEquality), (:~:) (Refl)) +import Data.Word import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) -import Ouroboros.Consensus.Ticked (Ticked) +import Lens.Micro +import NoThunks.Class +import Ouroboros.Consensus.Ledger.LedgerStateType +import Ouroboros.Consensus.Util.TypeLevel +import Ouroboros.Consensus.Util.IndexedMemPack -{------------------------------------------------------------------------------- - Kinds --------------------------------------------------------------------------------} +-------------------------------------------------------------------------------- +-- Keys and values +-------------------------------------------------------------------------------- + +-- | The possible tables that Consensus is aware of +type data TABLE = UTxOTable | InstantStakeTable + +class TableLabel table where + tableLabel :: Proxy table -> String + +instance TableLabel UTxOTable where + tableLabel _ = "utxo" + +instance TableLabel InstantStakeTable where + tableLabel _ = "instantStake" + +------------------------------------------------------------ +-- START Singletons +------------------------------------------------------------ + +data STABLE a where + SUTxOTable :: STABLE UTxOTable + SInstantStakeTable :: STABLE InstantStakeTable + +type instance Sing = STABLE + +instance SingI UTxOTable where + sing = SUTxOTable +instance SingI InstantStakeTable where + sing = SInstantStakeTable + +instance TestEquality STABLE where + testEquality SUTxOTable SUTxOTable = Just Refl + testEquality SUTxOTable _ = Nothing + testEquality SInstantStakeTable SInstantStakeTable = Just Refl + testEquality SInstantStakeTable _ = Nothing + +------------------------------------------------------------ +-- END Singletons +------------------------------------------------------------ + +-- | The only purpose of this type is to modify the MemPack instance to use big +-- endian serialization. This is necessary to ensure streaming functions of the +-- UTxO set preserve the order of the entries, as otherwise we would get +-- different sortings if sorting via the Serialized form and the Haskell Ord +-- instance. +-- +-- TODO: fix this in the Ledger. See cardano-ledger#5336. +newtype TxIn = TxIn {getOriginalTxIn :: SL.TxIn} + deriving newtype (Eq, Show, Ord, NoThunks) + +newtype BigEndianTxIx = BigEndianTxIx {getOriginalTxIx :: SL.TxIx} + +instance MemPack BigEndianTxIx where + typeName = "BigEndianTxIx" + packedByteCount = packedByteCount . getOriginalTxIx + packM (BigEndianTxIx (SL.TxIx w)) = packM (byteSwap16 w) + unpackM = BigEndianTxIx . SL.TxIx . byteSwap16 <$> unpackM + +instance MemPack TxIn where + typeName = "BigEndianTxIn" + packedByteCount = packedByteCount . getOriginalTxIn + packM (TxIn (SL.TxIn txid txix)) = do + packM txid + packM (BigEndianTxIx txix) + unpackM = do + TxIn <$> (SL.TxIn <$> unpackM <*> (getOriginalTxIx <$> unpackM)) + +-- | Table-indexed type family for key type +type Key :: TABLE -> Type +type family Key table where + Key UTxOTable = TxIn + Key InstantStakeTable = Credential 'Staking --- | Something that holds two types, which intend to represent /keys/ and --- /values/. -type MapKind {- key -} = Type {- value -} -> Type -> Type +-- | Table-indexed type family for value type +type Value :: TABLE -> Type -> Type +type family Value table blk where + Value UTxOTable blk = TxOut blk + Value InstantStakeTable blk = CompactForm Coin -type LedgerStateKind = MapKind -> Type +-- | Block-indexed type for TxOut, as TxOut is the only value that varies per era. +type TxOut :: Type -> Type +type family TxOut blk + +instance IndexedMemPack l blk InstantStakeTable where + type IndexedValue l InstantStakeTable blk = Value InstantStakeTable blk + indexedTypeName _ _ _ = typeName @(CompactForm Coin) + indexedPackM _ _ _ _ = packM + indexedPackedByteCount _ _ _ _ = packedByteCount + indexedUnpackM _ _ _ _ = unpackM {------------------------------------------------------------------------------- Ledger tables -------------------------------------------------------------------------------} +-- | Useful for partially applying @Table mk blk@ +type Table :: F2 -> Type -> TABLE -> Type +newtype Table mk blk table = Table {getTable :: mk (Key table) (Value table blk)} + deriving Generic + +deriving instance NoThunks (mk (Key table) (Value table blk)) => NoThunks (Table mk blk table) +deriving instance Show (mk (Key table) (Value table blk)) => Show (Table mk blk table) +deriving instance Eq (mk (Key table) (Value table blk)) => Eq (Table mk blk table) + +-- | Each block will declare its tables. +-- +-- > TablesForBlock ByronBlock = '[] +-- > TablesForBlock (ShelleyBlock (TPraos c) ShelleyEra) = '[UTxOTable] +-- > TablesForBlock (ShelleyBlock (Praos c) DijkstraEra) = '[UTxOTable, InstantStakeTable] +-- > TablesForBlock (HardForkBlock (CardanoEras c)) = '[UTxOTable, InstantStakeTable] +type TablesForBlock :: Type -> [TABLE] +type family TablesForBlock blk + +class All (Compose c (Table mk l)) (TablesForBlock l) => AllTables c mk l +instance All (Compose c (Table mk l)) (TablesForBlock l) => AllTables c mk l + -- | The Ledger Tables represent the portion of the data on disk that has been -- pulled from disk and attached to the in-memory Ledger State or that will -- eventually be written to disk. @@ -68,51 +206,52 @@ type LedgerStateKind = MapKind -> Type -- -- The @mk@ can be instantiated to anything that is map-like, i.e. that expects -- two type parameters, the key and the value. -type LedgerTables :: LedgerStateKind -> MapKind -> Type -newtype LedgerTables l mk = LedgerTables - { getLedgerTables :: mk (TxIn l) (TxOut l) +type LedgerTables :: StateKind +newtype LedgerTables blk mk = LedgerTables + { getLedgerTables :: NP (Table mk blk) (TablesForBlock blk) } - deriving stock Generic - -deriving stock instance - Show (mk (TxIn l) (TxOut l)) => - Show (LedgerTables l mk) -deriving stock instance - Eq (mk (TxIn l) (TxOut l)) => - Eq (LedgerTables l mk) + deriving Generic + +deriving newtype instance + AllTables NoThunks mk blk => + NoThunks (LedgerTables blk mk) deriving newtype instance - NoThunks (mk (TxIn l) (TxOut l)) => - NoThunks (LedgerTables l mk) + AllTables Show mk blk => + Show (LedgerTables blk mk) +deriving newtype instance + AllTables Eq mk blk => + Eq (LedgerTables blk mk) --- | Each @LedgerState@ instance will have the notion of a @TxIn@ for the tables. --- --- This will change once there is more than one table. -type TxIn :: LedgerStateKind -> Type -type family TxIn l +------------------------------------------------------------ +-- Type proof of inclusion +------------------------------------------------------------ --- | Each @LedgerState@ instance will have the notion of a @TxOut@ for the --- tables. --- --- This will change once there is more than one table. -type TxOut :: LedgerStateKind -> Type -type family TxOut l - -type instance TxIn (LedgerTables l) = TxIn l -type instance TxOut (LedgerTables l) = TxOut l -type instance TxIn (Ticked l) = TxIn l -type instance TxOut (Ticked l) = TxOut l - --- | Auxiliary information for @IndexedMemPack@. -type MemPackIdx :: LedgerStateKind -> MapKind -> Type -type family MemPackIdx l mk where - MemPackIdx (LedgerTables l) mk = MemPackIdx l mk - MemPackIdx (Ticked l) mk = MemPackIdx l mk - MemPackIdx l mk = l mk - -type SameUtxoTypes l l' = (TxIn l ~ TxIn l', TxOut l ~ TxOut l') - -castLedgerTables :: - SameUtxoTypes l l' => +------------------------------------------------------------ +-- Lenses +------------------------------------------------------------ + +-- | Given a proof of inclusion, create a lens for the particular item in the NP +ixNP :: Index xs x -> Lens' (NP f xs) (f x) +ixNP IZ f (x :* xs) = (:* xs) <$> f x +ixNP (IS m) f (x :* xs) = (x :*) <$> ixNP m f xs + +setterForSing :: + forall l mk table. + SList (TablesForBlock l) -> + Sing table -> + Maybe (ASetter' (LedgerTables l mk) (Table mk l table)) +setterForSing sxs sx = + (\mbm -> \f -> fmap LedgerTables . ixNP mbm f . getLedgerTables) <$> findIndex sxs sx + +-- | Extract a table based on the singleton +getTableByTag :: + forall table mk l. + ( SListI (TablesForBlock l) + , SingI (TablesForBlock l) + ) => + Sing table -> LedgerTables l mk -> - LedgerTables l' mk -castLedgerTables = coerce + Maybe (Table mk l table) +getTableByTag stag (LedgerTables np) = + let mem = findIndex (sing @(TablesForBlock l)) stag + in fmap (flip projectNP np) mem diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Combinators.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Combinators.hs index 431d625b07..aedca11fe0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Combinators.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Combinators.hs @@ -2,15 +2,21 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Ledger tables are barbie-types (see @barbies@ package), though unfortunately @@ -31,7 +37,8 @@ -- Type@, then we could reuse most of the @barbies@ machinery. module Ouroboros.Consensus.Ledger.Tables.Combinators ( -- * Common constraints - LedgerTableConstraints + LedgerTablesConstraints + , TableConstraints -- * Functor , ltmap @@ -74,13 +81,25 @@ module Ouroboros.Consensus.Ledger.Tables.Combinators -- * Basic bifunctors , K2 (..) , type (:..:) (..) + + -- * Operate on particular tables + , onUTxOTable + , onInstantStakeTable + , onTable ) where import Data.Bifunctor import Data.Kind +import Data.List.Singletons (SList (..)) +import Data.Proxy +import Data.SOP.BasicFunctors (K (..), (:.:) (..)) +import Data.SOP.Constraint import Data.SOP.Functors +import Data.SOP.Strict +import Data.Singletons +import Lens.Micro +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.Tables.Basics -import Ouroboros.Consensus.Ledger.Tables.MapKind import Ouroboros.Consensus.Util ((...:), (..:), (.:)) import Ouroboros.Consensus.Util.IndexedMemPack @@ -88,35 +107,110 @@ import Ouroboros.Consensus.Util.IndexedMemPack Common constraints -------------------------------------------------------------------------------} --- | The @Eq (TxOut l)@ constraint is here only because of --- 'Ouroboros.Consensus.Ledger.Tables.Diff.diff'. Once the ledger provides --- deltas instead of us being the ones that compute them, we can probably drop --- this constraint. -type LedgerTableConstraints l = - ( Ord (TxIn l) - , Eq (TxOut l) - , MemPack (TxIn l) - , IndexedMemPack (MemPackIdx l EmptyMK) (TxOut l) - ) +-- | What must a table satisfy to be considered a table? +class + ( Ord (Key table) + , MemPack (Key table) + , Eq (Value table blk) + , IndexedMemPack LedgerState blk table + , SingI table + ) => + TableConstraints blk table + +instance + ( Ord (Key table) + , MemPack (Key table) + , Eq (Value table blk) + , IndexedMemPack LedgerState blk table + , SingI table + ) => + TableConstraints blk table -type LedgerTableConstraints' l k v = +-- | 'TableConstraints' for all tables for a block +class + (SingI (TablesForBlock blk), All (TableConstraints blk) (TablesForBlock blk)) => + LedgerTablesConstraints blk + +instance + (SingI (TablesForBlock blk), All (TableConstraints blk) (TablesForBlock blk)) => + LedgerTablesConstraints blk + +type RawLedgerTableConstraints blk k v = ( Ord k , Eq v , MemPack k - , IndexedMemPack (MemPackIdx l EmptyMK) v ) +onUTxOTable :: + SingI (TablesForBlock blk) => + Proxy blk -> ASetter' (LedgerTables blk mk) (Table mk blk UTxOTable) +onUTxOTable p = onTable p (Proxy @UTxOTable) + +onInstantStakeTable :: + SingI (TablesForBlock blk) => + Proxy blk -> ASetter' (LedgerTables blk mk) (Table mk blk InstantStakeTable) +onInstantStakeTable p = onTable p (Proxy @InstantStakeTable) + +onTable :: + forall blk (table :: TABLE) mk. + (SingI table, SingI (TablesForBlock blk)) => + Proxy blk -> + Proxy table -> + ASetter' (LedgerTables blk mk) (Table mk blk table) +onTable _ _ = + case setterForSing (sing @(TablesForBlock blk)) (sing @table) of + Nothing -> \_ s -> pure s + Just setter -> setter + +onAllTables :: + forall blk mk mk'. + LedgerTablesConstraints blk => + Proxy blk -> + (forall k v. RawLedgerTableConstraints blk k v => mk k v -> mk' k v) -> + LedgerTables blk mk -> + LedgerTables blk mk' +onAllTables p f (LedgerTables tbs) = + LedgerTables (onAllRawTables p f tbs) + +onAllRawTables :: + forall blk mk mk'. + LedgerTablesConstraints blk => + Proxy blk -> + (forall k v. RawLedgerTableConstraints blk k v => mk k v -> mk' k v) -> + NP (Table mk blk) (TablesForBlock blk) -> + NP (Table mk' blk) (TablesForBlock blk) +onAllRawTables _ f tbs = go (sing @(TablesForBlock blk)) tbs + where + go :: All (TableConstraints blk) xs => SList xs -> NP (Table mk blk) xs -> NP (Table mk' blk) xs + go SNil Nil = Nil + go (SCons _ sn) (Table mk :* next) = Table (f mk) :* go sn next + +onAllRawTablesF :: + forall blk f mk mk'. + (Applicative f, LedgerTablesConstraints blk) => + Proxy blk -> + (forall k v. RawLedgerTableConstraints blk k v => mk k v -> f (mk' k v)) -> + NP (Table mk blk) (TablesForBlock blk) -> + f (NP (Table mk' blk) (TablesForBlock blk)) +onAllRawTablesF _ f tbs = hsequence' $ go (sing @(TablesForBlock blk)) tbs + where + go :: + All (TableConstraints blk) xs => SList xs -> NP (Table mk blk) xs -> NP (f :.: Table mk' blk) xs + go SNil Nil = Nil + go (SCons _ sn) (Table mk :* next) = Comp (Table <$> f mk) :* go sn next + {------------------------------------------------------------------------------- Functor -------------------------------------------------------------------------------} -- | Like 'bmap', but for ledger tables. ltmap :: - LedgerTableConstraints l => - (forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v) -> - LedgerTables l mk1 -> - LedgerTables l mk2 -ltmap f (LedgerTables x) = LedgerTables $ f x + forall blk mk1 mk2. + LedgerTablesConstraints blk => + (forall k v. RawLedgerTableConstraints blk k v => mk1 k v -> mk2 k v) -> + LedgerTables blk mk1 -> + LedgerTables blk mk2 +ltmap = onAllTables (Proxy @blk) {------------------------------------------------------------------------------- Traversable @@ -124,20 +218,21 @@ ltmap f (LedgerTables x) = LedgerTables $ f x -- | Like 'btraverse', but for ledger tables. lttraverse :: - (Applicative f, LedgerTableConstraints l) => - (forall k v. LedgerTableConstraints' l k v => mk1 k v -> f (mk2 k v)) -> - LedgerTables l mk1 -> - f (LedgerTables l mk2) -lttraverse f (LedgerTables x) = LedgerTables <$> f x + forall blk f mk1 mk2. + (Applicative f, LedgerTablesConstraints blk) => + (forall k v. RawLedgerTableConstraints blk k v => mk1 k v -> f (mk2 k v)) -> + LedgerTables blk mk1 -> + f (LedgerTables blk mk2) +lttraverse f (LedgerTables x) = LedgerTables <$> onAllRawTablesF (Proxy @blk) f x -- -- Utility functions -- ltsequence :: - (Applicative f, LedgerTableConstraints l) => - LedgerTables l (f :..: mk) -> - f (LedgerTables l mk) + (Applicative f, LedgerTablesConstraints blk) => + LedgerTables blk (f :..: mk) -> + f (LedgerTables blk mk) ltsequence = lttraverse unComp2 {------------------------------------------------------------------------------- @@ -146,63 +241,69 @@ ltsequence = lttraverse unComp2 -- | Like 'bpure', but for ledger tables. ltpure :: - LedgerTableConstraints l => - (forall k v. LedgerTableConstraints' l k v => mk k v) -> - LedgerTables l mk -ltpure = LedgerTables + forall blk mk. + LedgerTablesConstraints blk => + (forall k v. RawLedgerTableConstraints blk k v => mk k v) -> + LedgerTables blk mk +ltpure f = LedgerTables $ hcpure (Proxy @(TableConstraints blk)) (Table f) -- | Like 'bprod', but for ledger tables. -ltprod :: LedgerTables l f -> LedgerTables l g -> LedgerTables l (f `Product2` g) -ltprod (LedgerTables x) (LedgerTables y) = LedgerTables (Pair2 x y) +ltprod :: + forall blk f g. + LedgerTablesConstraints blk => + LedgerTables blk f -> LedgerTables blk g -> LedgerTables blk (f `Product2` g) +ltprod (LedgerTables x) (LedgerTables y) = + LedgerTables $ + hczipWith (Proxy @(TableConstraints blk)) (\(Table tx) (Table ty) -> Table $ Pair2 tx ty) x y -- -- Utility functions -- ltap :: - LedgerTableConstraints l => - LedgerTables l (mk1 -..-> mk2) -> - LedgerTables l mk1 -> - LedgerTables l mk2 + LedgerTablesConstraints blk => + LedgerTables blk (mk1 -..-> mk2) -> + LedgerTables blk mk1 -> + LedgerTables blk mk2 ltap f x = ltmap g $ ltprod f x where g (Pair2 f' x') = apFn2 f' x' ltliftA :: - LedgerTableConstraints l => - (forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v) -> - LedgerTables l mk1 -> - LedgerTables l mk2 + LedgerTablesConstraints blk => + (forall k v. RawLedgerTableConstraints blk k v => mk1 k v -> mk2 k v) -> + LedgerTables blk mk1 -> + LedgerTables blk mk2 ltliftA f x = ltpure (fn2_1 f) `ltap` x ltliftA2 :: - LedgerTableConstraints l => - (forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v -> mk3 k v) -> - LedgerTables l mk1 -> - LedgerTables l mk2 -> - LedgerTables l mk3 + LedgerTablesConstraints blk => + (forall k v. RawLedgerTableConstraints blk k v => mk1 k v -> mk2 k v -> mk3 k v) -> + LedgerTables blk mk1 -> + LedgerTables blk mk2 -> + LedgerTables blk mk3 ltliftA2 f x x' = ltpure (fn2_2 f) `ltap` x `ltap` x' ltliftA3 :: - LedgerTableConstraints l => - (forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v -> mk3 k v -> mk4 k v) -> - LedgerTables l mk1 -> - LedgerTables l mk2 -> - LedgerTables l mk3 -> - LedgerTables l mk4 + LedgerTablesConstraints blk => + (forall k v. RawLedgerTableConstraints blk k v => mk1 k v -> mk2 k v -> mk3 k v -> mk4 k v) -> + LedgerTables blk mk1 -> + LedgerTables blk mk2 -> + LedgerTables blk mk3 -> + LedgerTables blk mk4 ltliftA3 f x x' x'' = ltpure (fn2_3 f) `ltap` x `ltap` x' `ltap` x'' ltliftA4 :: - LedgerTableConstraints l => + LedgerTablesConstraints blk => ( forall k v. - LedgerTableConstraints' l k v => + RawLedgerTableConstraints blk k v => mk1 k v -> mk2 k v -> mk3 k v -> mk4 k v -> mk5 k v ) -> - LedgerTables l mk1 -> - LedgerTables l mk2 -> - LedgerTables l mk3 -> - LedgerTables l mk4 -> - LedgerTables l mk5 + LedgerTables blk mk1 -> + LedgerTables blk mk2 -> + LedgerTables blk mk3 -> + LedgerTables blk mk4 -> + LedgerTables blk mk5 ltliftA4 f x x' x'' x''' = ltpure (fn2_4 f) `ltap` x `ltap` x' `ltap` x'' `ltap` x''' @@ -211,40 +312,41 @@ ltliftA4 f x x' x'' x''' = -------------------------------------------------------------------------------} ltzipWith2A :: - (Applicative f, LedgerTableConstraints l) => - (forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v -> f (mk3 k v)) -> - LedgerTables l mk1 -> - LedgerTables l mk2 -> - f (LedgerTables l mk3) + (Applicative f, LedgerTablesConstraints blk) => + (forall k v. RawLedgerTableConstraints blk k v => mk1 k v -> mk2 k v -> f (mk3 k v)) -> + LedgerTables blk mk1 -> + LedgerTables blk mk2 -> + f (LedgerTables blk mk3) ltzipWith2A f = ltsequence .: ltliftA2 (Comp2 .: f) {------------------------------------------------------------------------------- Collapsing -------------------------------------------------------------------------------} -ltcollapse :: LedgerTables l (K2 a) -> a -ltcollapse = unK2 . getLedgerTables +ltcollapse :: + SListI (TablesForBlock blk) => LedgerTables blk (K2 a) -> NP (K a) (TablesForBlock blk) +ltcollapse (LedgerTables tbs) = hmap (\(Table (K2 t)) -> K t) tbs {------------------------------------------------------------------------------- Semigroup and Monoid -------------------------------------------------------------------------------} instance - ( forall k v. LedgerTableConstraints' l k v => Semigroup (mk k v) - , LedgerTableConstraints l + ( forall k v. RawLedgerTableConstraints blk k v => Semigroup (mk k v) + , LedgerTablesConstraints blk ) => - Semigroup (LedgerTables l mk) + Semigroup (LedgerTables blk mk) where - (<>) :: LedgerTables l mk -> LedgerTables l mk -> LedgerTables l mk + (<>) :: LedgerTables blk mk -> LedgerTables blk mk -> LedgerTables blk mk (<>) = ltliftA2 (<>) instance - ( forall k v. LedgerTableConstraints' l k v => Monoid (mk k v) - , LedgerTableConstraints l + ( forall k v. RawLedgerTableConstraints blk k v => Monoid (mk k v) + , LedgerTablesConstraints blk ) => - Monoid (LedgerTables l mk) + Monoid (LedgerTables blk mk) where - mempty :: LedgerTables l mk + mempty :: LedgerTables blk mk mempty = ltpure mempty {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/MapKind.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/MapKind.hs index 00271ffd9b..23a20434d8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/MapKind.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/MapKind.hs @@ -1,104 +1,45 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -- | Classes for 'MapKind's and concrete 'MapKind's module Ouroboros.Consensus.Ledger.Tables.MapKind ( -- * Classes - CanMapKeysMK (..) - , CanMapMK (..) - , EqMK - , NoThunksMK - , ShowMK + CanMapMK (..) , ZeroableMK (..) - , bimapLedgerTables -- * Concrete MapKinds - , CodecMK (..) , DiffMK (..) , EmptyMK (..) , KeysMK (..) - , SeqDiffMK (..) , TrackingMK (..) , ValuesMK (..) ) where -import qualified Codec.CBOR.Decoding as CBOR -import qualified Codec.CBOR.Encoding as CBOR import Data.Kind (Constraint) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) -import qualified Data.Set as Set import GHC.Generics (Generic) import NoThunks.Class -import Ouroboros.Consensus.Ledger.Tables.Basics +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.Tables.Diff (Diff (..)) -import Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq {------------------------------------------------------------------------------- Classes -------------------------------------------------------------------------------} -type ZeroableMK :: MapKind -> Constraint +type ZeroableMK :: F2 -> Constraint class ZeroableMK mk where emptyMK :: forall k v. (Ord k, Eq v) => mk k v -type CanMapMK :: MapKind -> Constraint +type CanMapMK :: F2 -> Constraint class CanMapMK mk where mapMK :: (v -> v') -> mk k v -> mk k v' -type CanMapKeysMK :: MapKind -> Constraint -class CanMapKeysMK mk where - -- | Instances defined for the standard mapkinds suffer from the same caveats - -- as 'Data.Map.Strict.mapKeys' or 'Data.Set.map' - mapKeysMK :: Ord k' => (k -> k') -> mk k v -> mk k' v - --- | For convenience, such that we don't have to include @QuantifiedConstraints@ --- everywhere. -type ShowMK :: MapKind -> Constraint -class (forall k v. (Show k, Show v) => Show (mk k v)) => ShowMK mk - --- | For convenience, such that we don't have to include @QuantifiedConstraints@ --- everywhere. -type EqMK :: MapKind -> Constraint -class (forall k v. (Eq k, Eq v) => Eq (mk k v)) => EqMK mk - --- | For convenience, such that we don't have to include @QuantifiedConstraints@ --- everywhere. -type NoThunksMK :: MapKind -> Constraint -class - (forall k v. (NoThunks k, NoThunks v) => NoThunks (mk k v)) => - NoThunksMK mk - --- | Map both keys and values in ledger tables. --- --- For keys, it has the same caveats as 'Data.Map.Strict.mapKeys' or --- `Data.Set.map', namely that only injective functions are suitable to be used --- here. -bimapLedgerTables :: - forall x y mk. - ( CanMapKeysMK mk - , CanMapMK mk - , Ord (TxIn y) - ) => - (TxIn x -> TxIn y) -> - (TxOut x -> TxOut y) -> - LedgerTables x mk -> - LedgerTables y mk -bimapLedgerTables f g = - LedgerTables - . mapKeysMK f - . mapMK g - . getLedgerTables - {------------------------------------------------------------------------------- EmptyMK -------------------------------------------------------------------------------} @@ -106,7 +47,6 @@ bimapLedgerTables f g = data EmptyMK k v = EmptyMK deriving stock (Generic, Eq, Show) deriving anyclass NoThunks - deriving anyclass (ShowMK, EqMK, NoThunksMK) instance ZeroableMK EmptyMK where emptyMK = EmptyMK @@ -114,9 +54,6 @@ instance ZeroableMK EmptyMK where instance CanMapMK EmptyMK where mapMK _ EmptyMK = EmptyMK -instance CanMapKeysMK EmptyMK where - mapKeysMK _ EmptyMK = EmptyMK - {------------------------------------------------------------------------------- KeysMK -------------------------------------------------------------------------------} @@ -125,7 +62,6 @@ newtype KeysMK k v = KeysMK (Set k) deriving stock (Generic, Eq, Show) deriving newtype (Semigroup, Monoid) deriving anyclass NoThunks - deriving anyclass (ShowMK, EqMK, NoThunksMK) instance ZeroableMK KeysMK where emptyMK = KeysMK mempty @@ -133,9 +69,6 @@ instance ZeroableMK KeysMK where instance CanMapMK KeysMK where mapMK _ (KeysMK ks) = KeysMK ks -instance CanMapKeysMK KeysMK where - mapKeysMK f (KeysMK ks) = KeysMK $ Set.map f ks - {------------------------------------------------------------------------------- ValuesMK -------------------------------------------------------------------------------} @@ -143,7 +76,6 @@ instance CanMapKeysMK KeysMK where newtype ValuesMK k v = ValuesMK {getValuesMK :: Map k v} deriving stock (Generic, Eq, Show) deriving anyclass NoThunks - deriving anyclass (ShowMK, EqMK, NoThunksMK) instance ZeroableMK ValuesMK where emptyMK = ValuesMK mempty @@ -151,9 +83,6 @@ instance ZeroableMK ValuesMK where instance CanMapMK ValuesMK where mapMK f (ValuesMK vs) = ValuesMK $ Map.map f vs -instance CanMapKeysMK ValuesMK where - mapKeysMK f (ValuesMK vs) = ValuesMK $ Map.mapKeys f vs - {------------------------------------------------------------------------------- DiffMK -------------------------------------------------------------------------------} @@ -162,16 +91,10 @@ newtype DiffMK k v = DiffMK {getDiffMK :: Diff k v} deriving stock (Generic, Eq, Show) deriving newtype Functor deriving anyclass NoThunks - deriving anyclass (ShowMK, EqMK, NoThunksMK) instance ZeroableMK DiffMK where emptyMK = DiffMK mempty -instance CanMapKeysMK DiffMK where - mapKeysMK f (DiffMK (Diff m)) = - DiffMK . Diff $ - Map.mapKeys f m - instance CanMapMK DiffMK where mapMK f (DiffMK d) = DiffMK $ fmap f d @@ -181,56 +104,9 @@ instance CanMapMK DiffMK where data TrackingMK k v = TrackingMK !(Map k v) !(Diff k v) deriving (Generic, Eq, Show, NoThunks) - deriving anyclass (ShowMK, EqMK, NoThunksMK) instance ZeroableMK TrackingMK where emptyMK = TrackingMK mempty mempty instance CanMapMK TrackingMK where mapMK f (TrackingMK vs d) = TrackingMK (Map.map f vs) (fmap f d) - -instance CanMapKeysMK TrackingMK where - mapKeysMK f (TrackingMK vs d) = - TrackingMK - (getValuesMK . mapKeysMK f . ValuesMK $ vs) - (getDiffMK . mapKeysMK f . DiffMK $ d) - -{------------------------------------------------------------------------------- - SeqDiffMK --------------------------------------------------------------------------------} - -newtype SeqDiffMK k v = SeqDiffMK {getSeqDiffMK :: DiffSeq k v} - deriving stock (Generic, Eq, Show) - deriving anyclass NoThunks - deriving anyclass (ShowMK, EqMK, NoThunksMK) - -instance ZeroableMK SeqDiffMK where - emptyMK = SeqDiffMK empty - -{------------------------------------------------------------------------------- - CodecMK --------------------------------------------------------------------------------} - --- | A codec 'MapKind' that will be used to refer to @'LedgerTables' l CodecMK@ --- as the codecs that can encode every key and value in the @'LedgerTables' l --- mk@. --- --- It is important to note that in the context of the HardForkCombinator, the --- key @k@ has to be accessible from any era we are currently in, regardless of --- which era it was created in. Because of that, we need that the serialization --- of the key remains stable accross eras. --- --- Ledger will provide more efficient encoders than CBOR, which will produce a --- @'ShortByteString'@ directly. --- --- See also 'HasCanonicalTxIn' in --- "Ouroboros.Consensus.HardFork.Combinator.Ledger". --- --- We will serialize UTxO maps as unstowed ledger tables when storing snapshots --- while using an in-memory backend for the LedgerDB. -data CodecMK k v = CodecMK - { encodeKey :: !(k -> CBOR.Encoding) - , encodeValue :: !(v -> CBOR.Encoding) - , decodeKey :: !(forall s. CBOR.Decoder s k) - , decodeValue :: !(forall s. CBOR.Decoder s v) - } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Utils.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Utils.hs index e1d6365311..7bb494a5fd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Utils.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Utils.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | A collection of useful combinators to shorten the code in other places. @@ -35,6 +37,7 @@ module Ouroboros.Consensus.Ledger.Tables.Utils -- ** Combining diffs , prependDiffs + , prependDiffsT -- * Operations on 'TrackingMK' @@ -70,21 +73,20 @@ import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff -------------------------------------------------------------------------------} ltwith :: - ( HasLedgerTables l + ( HasLedgerTables l blk , CanMapMK mk' - , CanMapKeysMK mk' , ZeroableMK mk' ) => - l mk -> - LedgerTables l mk' -> - l mk' + l blk mk -> + LedgerTables blk mk' -> + l blk mk' ltwith = withLedgerTables ltprj :: - (HasLedgerTables l, SameUtxoTypes l l', CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) => - l mk -> - LedgerTables l' mk -ltprj = castLedgerTables . projectLedgerTables + (HasLedgerTables l blk, CanMapMK mk, ZeroableMK mk) => + l blk mk -> + LedgerTables blk mk +ltprj = projectLedgerTables {------------------------------------------------------------------------------- Utils aliases: tables @@ -93,17 +95,17 @@ ltprj = castLedgerTables . projectLedgerTables -- | Replace tables with an empty diff. Can be used to specify that a ledger -- state tick produces no new UTXO entries. noNewTickingDiffs :: - HasLedgerTables l => - l any -> - l DiffMK + HasLedgerTables l blk => + l blk any -> + l blk DiffMK noNewTickingDiffs l = withLedgerTables l emptyLedgerTables -- | Remove the ledger tables -forgetLedgerTables :: HasLedgerTables l => l mk -> l EmptyMK +forgetLedgerTables :: HasLedgerTables l blk => l blk mk -> l blk EmptyMK forgetLedgerTables l = withLedgerTables l emptyLedgerTables -- | Empty values for every table -emptyLedgerTables :: (ZeroableMK mk, LedgerTableConstraints l) => LedgerTables l mk +emptyLedgerTables :: (ZeroableMK mk, LedgerTablesConstraints l) => LedgerTables l mk emptyLedgerTables = ltpure emptyMK -- @@ -113,7 +115,8 @@ emptyLedgerTables = ltpure emptyMK rawTrackingDiffs :: TrackingMK k v -> DiffMK k v rawTrackingDiffs (TrackingMK _vs d) = DiffMK d -trackingToDiffs :: (HasLedgerTables l, LedgerTableConstraints l) => l TrackingMK -> l DiffMK +trackingToDiffs :: + HasLedgerTables l blk => l blk TrackingMK -> l blk DiffMK trackingToDiffs l = ltwith l $ ltmap rawTrackingDiffs (ltprj l) -- @@ -123,7 +126,8 @@ trackingToDiffs l = ltwith l $ ltmap rawTrackingDiffs (ltprj l) rawTrackingValues :: TrackingMK k v -> ValuesMK k v rawTrackingValues (TrackingMK vs _ds) = ValuesMK vs -trackingToValues :: (LedgerTableConstraints l, HasLedgerTables l) => l TrackingMK -> l ValuesMK +trackingToValues :: + HasLedgerTables l blk => l blk TrackingMK -> l blk ValuesMK trackingToValues l = ltwith l $ ltmap rawTrackingValues (ltprj l) -- @@ -142,20 +146,34 @@ rawPrependDiffs (DiffMK d1) (DiffMK d2) = DiffMK (d1 <> d2) -- | Prepend diffs from the first ledger state to the diffs from the second -- ledger state. Returns ledger tables. prependDiffs' :: - ( SameUtxoTypes l l'' - , SameUtxoTypes l' l'' - , HasLedgerTables l - , HasLedgerTables l' - , HasLedgerTables l'' + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk ) => - l DiffMK -> l' DiffMK -> LedgerTables l'' DiffMK + l blk DiffMK -> l' blk DiffMK -> LedgerTables blk DiffMK prependDiffs' l1 l2 = ltliftA2 rawPrependDiffs (ltprj l1) (ltprj l2) -- | Prepend the diffs from @l1@ to @l2@. Returns @l2@. prependDiffs :: - (SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') => - l DiffMK -> l' DiffMK -> l' DiffMK -prependDiffs l1 l2 = ltwith l2 $ prependDiffs' l1 l2 + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk + ) => + l blk DiffMK -> l' blk DiffMK -> l' blk DiffMK +prependDiffs l1 l2 = ltwith l2 $ prependDiffs' @l @l' @blk l1 l2 + +prependDiffsT' :: + forall l blk. + HasLedgerTables l blk => + LedgerTables blk DiffMK -> l blk DiffMK -> LedgerTables blk DiffMK +prependDiffsT' l1 l2 = ltliftA2 rawPrependDiffs l1 (ltprj l2) + +-- | Prepend the diffs from @l1@ to @l2@. Returns @l2@. +prependDiffsT :: + forall l blk. + HasLedgerTables l blk => + LedgerTables blk DiffMK -> l blk DiffMK -> l blk DiffMK +prependDiffsT l1 l2 = ltwith l2 $ prependDiffsT' @l @blk l1 l2 -- -- Apply diffs @@ -173,20 +191,21 @@ applyDiffsMK (ValuesMK vals) (DiffMK diffs) = ValuesMK (Diff.applyDiff vals diff -- | Apply diffs from the second ledger state to the values of the first ledger -- state. Returns ledger tables. applyDiffs' :: - ( SameUtxoTypes l l'' - , SameUtxoTypes l' l'' - , HasLedgerTables l - , HasLedgerTables l' - , HasLedgerTables l'' + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk ) => - l ValuesMK -> l' DiffMK -> LedgerTables l'' ValuesMK + l blk ValuesMK -> l' blk DiffMK -> LedgerTables blk ValuesMK applyDiffs' l1 l2 = ltliftA2 applyDiffsMK (ltprj l1) (ltprj l2) -- | Apply diffs from @l2@ on values from @l1@. Returns @l2@. applyDiffs :: - (SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') => - l ValuesMK -> l' DiffMK -> l' ValuesMK -applyDiffs l1 l2 = ltwith l2 $ applyDiffs' l1 l2 + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk + ) => + l blk ValuesMK -> l' blk DiffMK -> l' blk ValuesMK +applyDiffs l1 l2 = ltwith l2 $ applyDiffs' @l @l' @blk l1 l2 rawApplyDiffForKeys :: Ord k => @@ -199,25 +218,28 @@ rawApplyDiffForKeys (ValuesMK vals) (KeysMK keys) (DiffMK diffs) = -- | Apply diffs in @l3@ for keys in @l2@ and @l1@ on values from @l1@. Returns @l3@. applyDiffForKeys :: - (SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') => - l ValuesMK -> LedgerTables l KeysMK -> l' DiffMK -> l' ValuesMK -applyDiffForKeys l1 l2 l3 = ltwith l3 $ applyDiffForKeys' (ltprj l1) l2 l3 + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk + ) => + l blk ValuesMK -> LedgerTables blk KeysMK -> l' blk DiffMK -> l' blk ValuesMK +applyDiffForKeys l1 l2 l3 = ltwith l3 $ applyDiffForKeys' @l' @blk (ltprj l1) l2 l3 applyDiffForKeys' :: - ( SameUtxoTypes l l'' - , SameUtxoTypes l l' - , HasLedgerTables l - , HasLedgerTables l' - , HasLedgerTables l'' - ) => - LedgerTables l ValuesMK -> LedgerTables l KeysMK -> l' DiffMK -> LedgerTables l'' ValuesMK -applyDiffForKeys' l1 l2 l3 = ltliftA3 rawApplyDiffForKeys (castLedgerTables l1) (castLedgerTables l2) (ltprj l3) + forall l blk. + HasLedgerTables l blk => + LedgerTables blk ValuesMK -> + LedgerTables blk KeysMK -> + l blk DiffMK -> + LedgerTables blk ValuesMK +applyDiffForKeys' l1 l2 l3 = ltliftA3 rawApplyDiffForKeys l1 l2 (ltprj l3) -- | Apply diffs in @l3@ for keys in @l2@ and @l1@ on values from @l1@. Returns @l3@. applyDiffForKeysOnTables :: - (SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') => - LedgerTables l ValuesMK -> LedgerTables l KeysMK -> l' DiffMK -> l' ValuesMK -applyDiffForKeysOnTables l1 l2 l3 = ltwith l3 $ applyDiffForKeys' l1 l2 l3 + forall l blk. + HasLedgerTables l blk => + LedgerTables blk ValuesMK -> LedgerTables blk KeysMK -> l blk DiffMK -> l blk ValuesMK +applyDiffForKeysOnTables l1 l2 l3 = ltwith l3 $ applyDiffForKeys' @l @blk l1 l2 l3 -- -- Calculate differences @@ -234,30 +256,30 @@ rawCalculateDifference (ValuesMK before) (ValuesMK after) = TrackingMK after (Di -- considered diffs. In particular this is used when populating the ledger -- tables for the first time. valuesAsDiffs :: - (LedgerTableConstraints l, HasLedgerTables l) => - l ValuesMK -> l DiffMK + HasLedgerTables l blk => l blk ValuesMK -> l blk DiffMK valuesAsDiffs l = trackingToDiffs $ ltwith l $ ltliftA (rawCalculateDifference emptyMK) (ltprj l) -- | Calculate the differences between two ledger states. The first ledger state -- is considered /before/, the second ledger state is considered /after/. -- Returns ledger tables. calculateDifference' :: - ( SameUtxoTypes l l'' - , SameUtxoTypes l' l'' - , HasLedgerTables l - , HasLedgerTables l' - , HasLedgerTables l'' + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk ) => - l ValuesMK -> l' ValuesMK -> LedgerTables l'' TrackingMK + l blk ValuesMK -> l' blk ValuesMK -> LedgerTables blk TrackingMK calculateDifference' l1 l2 = ltliftA2 rawCalculateDifference (ltprj l1) (ltprj l2) -- | Calculate the differences between two ledger states. The first ledger state -- is considered /before/, the second ledger state is considered /after/. -- Returns the second ledger state. calculateDifference :: - (SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') => - l ValuesMK -> l' ValuesMK -> l' TrackingMK -calculateDifference l1 l2 = ltwith l2 $ calculateDifference' l1 l2 + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk + ) => + l blk ValuesMK -> l' blk ValuesMK -> l' blk TrackingMK +calculateDifference l1 l2 = ltwith l2 $ calculateDifference' @l @l' @blk l1 l2 -- -- Attaching and/or applying diffs @@ -274,28 +296,29 @@ rawAttachAndApplyDiffs (ValuesMK v) (DiffMK d) = TrackingMK (Diff.applyDiff v d) -- second ledger state, and returns the resulting values together with the -- applied diff. attachAndApplyDiffs' :: - ( SameUtxoTypes l l'' - , SameUtxoTypes l' l'' - , HasLedgerTables l - , HasLedgerTables l' - , HasLedgerTables l'' + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk ) => - l' ValuesMK -> l DiffMK -> LedgerTables l'' TrackingMK + l blk ValuesMK -> l' blk DiffMK -> LedgerTables blk TrackingMK attachAndApplyDiffs' l1 l2 = ltliftA2 rawAttachAndApplyDiffs (ltprj l1) (ltprj l2) -- | Apply the differences from the first ledger state to the values of the -- second ledger state. Returns the second ledger state with a 'TrackingMK' of -- the final values and all the diffs. attachAndApplyDiffs :: - (SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') => - l ValuesMK -> l' DiffMK -> l' TrackingMK -attachAndApplyDiffs l1 l2 = ltwith l2 $ attachAndApplyDiffs' l1 l2 + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk + ) => + l blk ValuesMK -> l' blk DiffMK -> l' blk TrackingMK +attachAndApplyDiffs l1 l2 = ltwith l2 $ attachAndApplyDiffs' @l @l' @blk l1 l2 rawAttachEmptyDiffs :: Ord k => ValuesMK k v -> TrackingMK k v rawAttachEmptyDiffs (ValuesMK v) = TrackingMK v mempty -- | Make a 'TrackingMK' with empty diffs. -attachEmptyDiffs :: HasLedgerTables l => l ValuesMK -> l TrackingMK +attachEmptyDiffs :: HasLedgerTables l blk => l blk ValuesMK -> l blk TrackingMK attachEmptyDiffs l1 = ltwith l1 $ ltmap rawAttachEmptyDiffs (ltprj l1) -- @@ -322,13 +345,11 @@ rawPrependTrackingDiffs (TrackingMK _ d1) (TrackingMK v d2) = -- -- PRECONDITION: See 'rawPrependTrackingDiffs'. prependTrackingDiffs' :: - ( SameUtxoTypes l l'' - , SameUtxoTypes l' l'' - , HasLedgerTables l - , HasLedgerTables l' - , HasLedgerTables l'' + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk ) => - l TrackingMK -> l' TrackingMK -> LedgerTables l'' TrackingMK + l blk TrackingMK -> l' blk TrackingMK -> LedgerTables blk TrackingMK prependTrackingDiffs' l1 l2 = ltliftA2 rawPrependTrackingDiffs (ltprj l1) (ltprj l2) -- | Prepend tracking diffs from the first ledger state to the tracking diffs @@ -337,9 +358,12 @@ prependTrackingDiffs' l1 l2 = ltliftA2 rawPrependTrackingDiffs (ltprj l1) (ltprj -- -- PRECONDITION: See 'rawPrependTrackingDiffs'. prependTrackingDiffs :: - (SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') => - l TrackingMK -> l' TrackingMK -> l' TrackingMK -prependTrackingDiffs l1 l2 = ltwith l2 $ prependTrackingDiffs' l1 l2 + forall l l' blk. + ( HasLedgerTables l blk + , HasLedgerTables l' blk + ) => + l blk TrackingMK -> l' blk TrackingMK -> l' blk TrackingMK +prependTrackingDiffs l1 l2 = ltwith l2 $ prependTrackingDiffs' @l @l' @blk l1 l2 -- Restrict values @@ -351,13 +375,10 @@ restrictValuesMK :: restrictValuesMK (ValuesMK v) (KeysMK k) = ValuesMK $ v `Map.restrictKeys` k restrictValues' :: - ( SameUtxoTypes l l'' - , SameUtxoTypes l' l'' - , HasLedgerTables l - , HasLedgerTables l' - , HasLedgerTables l'' + ( HasLedgerTables l blk + , HasLedgerTables l' blk ) => - l ValuesMK -> l' KeysMK -> LedgerTables l'' ValuesMK + l blk ValuesMK -> l' blk KeysMK -> LedgerTables blk ValuesMK restrictValues' l1 l2 = ltliftA2 restrictValuesMK (ltprj l1) (ltprj l2) --- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs index d9db885e21..9cf5ab14ec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs @@ -171,7 +171,7 @@ data Mempool m blk = Mempool , getSnapshotFor :: SlotNo -> TickedLedgerState blk DiffMK -> - (LedgerTables (LedgerState blk) KeysMK -> m (LedgerTables (LedgerState blk) ValuesMK)) -> + (LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)) -> m (MempoolSnapshot blk) -- ^ Get a snapshot of the mempool state that is valid with respect to -- the given ledger state diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs index 79432d1a86..abeb9d3832 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs @@ -47,6 +47,7 @@ import Control.ResourceRegistry import Control.Tracer import qualified Data.Foldable as Foldable import qualified Data.List.NonEmpty as NE +import Data.SOP.Constraint import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable @@ -55,6 +56,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended (ledgerState) +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Mempool.API @@ -92,12 +94,12 @@ data InternalState blk = IS -- 'MempoolSnapshot' (see 'snapshotHasTx'). -- -- This should always be in-sync with the transactions in 'isTxs'. - , isTxKeys :: !(LedgerTables (LedgerState blk) KeysMK) + , isTxKeys :: !(LedgerTables blk KeysMK) -- ^ The cached set of keys needed for the transactions -- currently in the mempool. -- -- INVARIANT: @'isTxKeys' == foldMap (getTransactionKeySets . txForgetValidated) $ toList 'isTxs'@ - , isTxValues :: !(LedgerTables (LedgerState blk) ValuesMK) + , isTxValues :: !(LedgerTables blk ValuesMK) -- ^ The cached values corresponding to reading 'isTxKeys' at -- 'isLedgerState'. These values can be used unless we switch to -- a different ledger state. It usually happens in the forging @@ -148,8 +150,11 @@ deriving instance ( NoThunks (Validated (GenTx blk)) , NoThunks (GenTxId blk) , NoThunks (TickedLedgerState blk DiffMK) - , NoThunks (TxIn (LedgerState blk)) - , NoThunks (TxOut (LedgerState blk)) + , -- , NoThunks (TxIn (LedgerState blk)) + -- , NoThunks (TxOut (LedgerState blk)) + All (Compose NoThunks (Table ValuesMK blk)) (TablesForBlock blk) + , All (Compose NoThunks (Table KeysMK blk)) (TablesForBlock blk) + , HasLedgerTables LedgerState blk , NoThunks (TxMeasure blk) , StandardHash blk , Typeable blk @@ -207,7 +212,7 @@ data MempoolLedgerDBView m blk = MempoolLedgerDBView } instance - (StandardHash blk, UpdateLedger blk) => + (StandardHash blk, ApplyBlock LedgerState blk) => Eq (MempoolLedgerDBView m blk) where MempoolLedgerDBView a _ == MempoolLedgerDBView b _ = @@ -298,7 +303,7 @@ initMempoolEnv ledgerInterface cfg capacityOverride tracer topLevelRegistry = do -- | Tick the 'LedgerState' using the given 'BlockSlot'. tickLedgerState :: forall blk. - (UpdateLedger blk, ValidateEnvelope blk) => + (ApplyBlock LedgerState blk, ValidateEnvelope blk) => LedgerConfig blk -> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk DiffMK) @@ -330,7 +335,7 @@ validateNewTransaction :: GenTx blk -> TxMeasure blk -> -- | Values to cache if success - LedgerTables (LedgerState blk) ValuesMK -> + LedgerTables blk ValuesMK -> -- | This state is the internal state with the tables for this transaction -- advanced through the diffs in the internal state. One could think we can -- create this value here, but it is needed for some other uses like calling @@ -382,7 +387,7 @@ revalidateTxsFor :: -- | The ticked ledger state againt which txs will be revalidated TickedLedgerState blk DiffMK -> -- | The tables with all the inputs for the transactions - LedgerTables (LedgerState blk) ValuesMK -> + LedgerTables blk ValuesMK -> -- | 'isLastTicketNo' and 'vrLastTicketNo' TicketNo -> [TxTicket (TxMeasure blk) (Validated (GenTx blk))] -> @@ -404,7 +409,7 @@ revalidateTxsFor capacityOverride cfg slot st values lastTicketNo txTickets = , isTxIds = Set.fromList $ map (txId . txForgetValidated . fst) val , isTxKeys = keys , isTxValues = ltliftA2 restrictValuesMK values keys - , isLedgerState = trackingToDiffs st' + , isLedgerState = unTickedL $ trackingToDiffs (TickedL st') , isTip = castPoint $ getTip st , isSlotNo = slot , isLastTicketNo = lastTicketNo @@ -431,7 +436,7 @@ computeSnapshot :: -- | The ticked ledger state againt which txs will be revalidated TickedLedgerState blk DiffMK -> -- | The tables with all the inputs for the transactions - LedgerTables (LedgerState blk) ValuesMK -> + LedgerTables blk ValuesMK -> -- | 'isLastTicketNo' and 'vrLastTicketNo' TicketNo -> [TxTicket (TxMeasure blk) (Validated (GenTx blk))] -> @@ -455,7 +460,7 @@ computeSnapshot capacityOverride cfg slot st values lastTicketNo txTickets = -- the internal state. isTxKeys = emptyLedgerTables , isTxValues = emptyLedgerTables - , isLedgerState = trackingToDiffs st' + , isLedgerState = unTickedL $ trackingToDiffs $ TickedL st' , isTip = castPoint $ getTip st , isSlotNo = slot , isLastTicketNo = lastTicketNo diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs index 22b4e96eeb..820c77f1b4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs @@ -24,7 +24,7 @@ implGetSnapshotFor :: TickedLedgerState blk DiffMK -> -- | A function that returns values corresponding to the given keys for -- the unticked ledger state. - (LedgerTables (LedgerState blk) KeysMK -> m (LedgerTables (LedgerState blk) ValuesMK)) -> + (LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)) -> m (MempoolSnapshot blk) implGetSnapshotFor mpEnv slot ticked readUntickedTables = do is <- atomically $ readTMVar istate diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs index 37f599f251..e5603baa2d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs @@ -20,6 +20,7 @@ import qualified Data.Measure as Measure import qualified Data.Set as Set import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.LedgerStateType (TickedL (..)) import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables) import Ouroboros.Consensus.Mempool.API @@ -43,7 +44,6 @@ import Ouroboros.Network.Block implAddTx :: ( IOLike m , LedgerSupportsMempool blk - , ValidateEnvelope blk , HasTxId (GenTx blk) ) => MempoolEnv m blk -> @@ -142,7 +142,6 @@ data TransactionProcessed blk doAddTx :: ( LedgerSupportsMempool blk , HasTxId (GenTx blk) - , ValidateEnvelope blk , IOLike m ) => MempoolEnv m blk -> @@ -174,8 +173,7 @@ doAddTx mpEnv wti tx = \is () -> do frkr <- readMVar forker tbs <- - castLedgerTables - <$> roforkerReadTables frkr (castLedgerTables $ getTransactionKeySets tx) + roforkerReadTables frkr (getTransactionKeySets tx) case pureTryAddTx cfg wti tx is tbs of NotEnoughSpaceLeft -> do pure (Left (isMempoolSize is), is) @@ -194,7 +192,7 @@ pureTryAddTx :: GenTx blk -> -- | The current internal state of the mempool. InternalState blk -> - LedgerTables (LedgerState blk) ValuesMK -> + LedgerTables blk ValuesMK -> TriedToAddTx blk pureTryAddTx cfg wti tx is values = let st = @@ -308,7 +306,6 @@ implRemoveTxsEvenIfValid :: ( IOLike m , LedgerSupportsMempool blk , HasTxId (GenTx blk) - , ValidateEnvelope blk ) => MempoolEnv m blk -> NE.NonEmpty (GenTxId blk) -> @@ -326,13 +323,13 @@ implRemoveTxsEvenIfValid mpEnv toRemove = (TxSeq.toList $ isTxs is) toKeep' = Foldable.foldMap' (getTransactionKeySets . txForgetValidated . TxSeq.txTicketTx) toKeep frkr <- readMVar forker - tbs <- castLedgerTables <$> roforkerReadTables frkr (castLedgerTables toKeep') + tbs <- roforkerReadTables frkr toKeep' let (is', t) = pureRemoveTxs capacityOverride cfg (isSlotNo is) - (isLedgerState is `withLedgerTables` emptyLedgerTables) + (unTickedL $ TickedL (isLedgerState is) `withLedgerTables` emptyLedgerTables) tbs (isLastTicketNo is) toKeep @@ -358,7 +355,7 @@ pureRemoveTxs :: LedgerConfig blk -> SlotNo -> TickedLedgerState blk DiffMK -> - LedgerTables (LedgerState blk) ValuesMK -> + LedgerTables blk ValuesMK -> TicketNo -> -- | Txs to keep [TxTicket (TxMeasure blk) (Validated (GenTx blk))] -> @@ -449,7 +446,7 @@ implSyncWithLedger mpEnv = roforkerClose oldFrk pure frk ) - tbs <- castLedgerTables <$> roforkerReadTables frk (castLedgerTables $ isTxKeys is) + tbs <- roforkerReadTables frk (isTxKeys is) let (is', mTrace) = pureSyncWithLedger capacityOverride @@ -485,7 +482,7 @@ pureSyncWithLedger :: LedgerConfig blk -> SlotNo -> TickedLedgerState blk DiffMK -> - LedgerTables (LedgerState blk) ValuesMK -> + LedgerTables blk ValuesMK -> InternalState blk -> ( InternalState blk , Maybe (TraceEventMempool blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs index deb339db27..1e5c493783 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableSuperClasses #-} -- | Infrastructure required to run a node -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs index e8297223b3..44a90bb16e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs @@ -1,16 +1,14 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 908 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 8b89764c2c..45cbb5babf 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -393,7 +393,7 @@ data ChainDB m blk = ChainDB , getChainSelStarvation :: STM m ChainSelStarvation -- ^ Whether ChainSel is currently starved, or when was last time it -- stopped being starved. - , getStatistics :: m (Maybe Statistics) + , getStatistics :: m (Maybe (Statistics blk)) -- ^ Get statistics from the LedgerDB, in particular the number of entries -- in the tables. , addPerasCertAsync :: ValidatedPerasCert blk -> m (AddPerasCertPromise m) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index a49173a15a..5f48324ce0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -78,7 +79,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Query as Query import Ouroboros.Consensus.Storage.ChainDB.Impl.Types import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.ImmutableDB.Stream as ImmutableDB -import Ouroboros.Consensus.Storage.LedgerDB (LedgerSupportsLedgerDB) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB @@ -108,7 +108,7 @@ withDB :: , HasHardForkHistory blk , ConvertRawHash blk , SerialiseDiskConstraints blk - , LedgerSupportsLedgerDB blk + , LedgerDB.LedgerSupportsLedgerDB blk ) => Complete Args.ChainDbArgs m blk -> (ChainDB m blk -> m a) -> @@ -124,7 +124,7 @@ openDB :: , HasHardForkHistory blk , ConvertRawHash blk , SerialiseDiskConstraints blk - , LedgerSupportsLedgerDB blk + , LedgerDB.LedgerSupportsLedgerDB blk ) => Complete Args.ChainDbArgs m blk -> m (ChainDB m blk) @@ -140,7 +140,7 @@ openDBInternal :: , ConvertRawHash blk , SerialiseDiskConstraints blk , HasCallStack - , LedgerSupportsLedgerDB blk + , LedgerDB.LedgerSupportsLedgerDB blk ) => Complete Args.ChainDbArgs m blk -> -- | 'True' = Launch background tasks diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index 0308b66dc3..e4b0e813c6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -137,9 +137,8 @@ defaultSpecificArgs = defaultArgs :: forall m blk. ( IOLike m - , LedgerDB.LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk - , LedgerDB.LedgerSupportsInMemoryLedgerDB (LedgerState blk) + , LedgerDB.LedgerSupportsLedgerDB blk ) => Incomplete ChainDbArgs m blk defaultArgs = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 1dbd00c530..d79ac368bc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -285,7 +285,7 @@ getReadOnlyForkerAtPoint :: m (Either LedgerDB.GetForkerError (LedgerDB.ReadOnlyForker' m blk)) getReadOnlyForkerAtPoint CDB{..} = LedgerDB.getReadOnlyForker cdbLedgerDB -getStatistics :: IOLike m => ChainDbEnv m blk -> m (Maybe LedgerDB.Statistics) +getStatistics :: IOLike m => ChainDbEnv m blk -> m (Maybe (LedgerDB.Statistics blk)) getStatistics CDB{..} = LedgerDB.getTipStatistics cdbLedgerDB getPerasWeightSnapshot :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 3336ba527f..0cd723125d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -16,6 +16,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} -- | Types used throughout the implementation: handle, state, environment, -- types, trace types, etc. @@ -99,7 +100,9 @@ import Ouroboros.Consensus.Fragment.Diff (ChainDiff) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Consensus.Ledger.Extended (ExtValidationError) import Ouroboros.Consensus.Ledger.Inspect +import Ouroboros.Consensus.Ledger.LedgerStateType import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Ledger.Tables (HasLedgerTables) import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API @@ -221,7 +224,9 @@ getEnvSTM1 (CDBHandle varState) f a = data ChainDbState m blk = ChainDbOpen !(ChainDbEnv m blk) | ChainDbClosed - deriving (Generic, NoThunks) + deriving Generic + +deriving instance NoThunks (ChainDbEnv m blk) => NoThunks (ChainDbState m blk) -- | The current chain, both without and with slot times -- @@ -362,7 +367,11 @@ data ChainDbEnv m blk = CDB -- (but avoid including @m@ because we cannot impose @Typeable m@ as a -- constraint and still have it work with the simulator) instance - (IOLike m, LedgerSupportsProtocol blk, BlockSupportsDiffusionPipelining blk) => + ( IOLike m + , LedgerSupportsProtocol blk + , HasLedgerTables LedgerState blk + , BlockSupportsDiffusionPipelining blk + ) => NoThunks (ChainDbEnv m blk) where showTypeOf _ = "ChainDbEnv m " ++ show (typeRep (Proxy @blk)) @@ -510,7 +519,11 @@ data InvalidBlockInfo blk = InvalidBlockInfo { invalidBlockReason :: !(ExtValidationError blk) , invalidBlockSlotNo :: !SlotNo } - deriving (Eq, Show, Generic, NoThunks) + deriving Generic + +deriving instance Eq (ExtValidationError blk) => Eq (InvalidBlockInfo blk) +deriving instance Show (ExtValidationError blk) => Show (InvalidBlockInfo blk) +deriving instance NoThunks (ExtValidationError blk) => NoThunks (InvalidBlockInfo blk) {------------------------------------------------------------------------------- Blocks to add diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs index cb01fe8a8d..a19f1d190d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -29,8 +30,6 @@ import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Forker import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as V1 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as V2 import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend import Ouroboros.Consensus.Util.Args @@ -69,16 +68,6 @@ openDB getBlock getVolatileSuffix = case lgrBackendArgs args of - LedgerDbBackendArgsV1 bss -> - let snapManager = V1.snapshotManager args - initDb = - V1.mkInitDb - args - bss - getBlock - snapManager - getVolatileSuffix - in doOpenDB args initDb snapManager stream replayGoal LedgerDbBackendArgsV2 (SomeBackendArgs bArgs) -> do res <- mkResources diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs index ec75069317..f86d5745f0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs @@ -15,6 +15,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} -- | The Ledger DB is responsible for the following tasks: -- @@ -107,17 +108,17 @@ module Ouroboros.Consensus.Storage.LedgerDB.API ( -- * Main API CanUpgradeLedgerTables (..) + , CanUpgradeLedgerTable (..) , LedgerDB (..) , LedgerDB' , LedgerDbPrune (..) + , ResolveBlock + , currentPoint + + -- * Constraints , LedgerDbSerialiseConstraints , LedgerSupportsInMemoryLedgerDB , LedgerSupportsLedgerDB - , LedgerSupportsLMDBLedgerDB - , LedgerSupportsV1LedgerDB - , LedgerSupportsV2LedgerDB - , ResolveBlock - , currentPoint -- * Initialization , InitDB (..) @@ -152,14 +153,17 @@ module Ouroboros.Consensus.Storage.LedgerDB.API -- * Streaming , StreamingBackend (..) - , Yield - , Sink - , Decoders (..) + , StreamOfTable (..) + , Yield (..) + , Sink (..) + , TableCodec (..) + , TablesCodecs (..) -- * Testing , TestInternals (..) , TestInternals' , WhereToTakeSnapshot (..) + , LedgerSupportsLedgerDB' ) where import Codec.CBOR.Decoding @@ -173,11 +177,10 @@ import Control.Tracer import Data.ByteString (ByteString) import Data.Functor.Contravariant ((>$<)) import Data.Kind -import qualified Data.Map.Strict as Map -import Data.MemPack import Data.Proxy +import Data.SOP.Constraint +import Data.SOP.Strict import Data.Set (Set) -import Data.Void (absurd) import Data.Word import GHC.Generics (Generic) import NoThunks.Class @@ -198,11 +201,11 @@ import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.IndexedMemPack import Ouroboros.Network.Block import Ouroboros.Network.Protocol.LocalStateQuery.Type import Streaming import System.FS.CRC +import Codec.CBOR.Encoding (Encoding) {------------------------------------------------------------------------------- Main API @@ -210,7 +213,7 @@ import System.FS.CRC -- | Serialization constraints required by the 'LedgerDB' to be properly -- instantiated with a @blk@. -type LedgerDbSerialiseConstraints blk = +class ( Serialise (HeaderHash blk) , EncodeDisk blk (LedgerState blk EmptyMK) , DecodeDisk blk (LedgerState blk EmptyMK) @@ -218,12 +221,19 @@ type LedgerDbSerialiseConstraints blk = , DecodeDisk blk (AnnTip blk) , EncodeDisk blk (ChainDepState (BlockProtocol blk)) , DecodeDisk blk (ChainDepState (BlockProtocol blk)) - , -- For InMemory LedgerDBs - MemPack (TxIn (LedgerState blk)) - , SerializeTablesWithHint (LedgerState blk) - , -- For OnDisk LedgerDBs - IndexedMemPack (LedgerState blk EmptyMK) (TxOut (LedgerState blk)) - ) + ) => + LedgerDbSerialiseConstraints blk + +instance + ( Serialise (HeaderHash blk) + , EncodeDisk blk (LedgerState blk EmptyMK) + , DecodeDisk blk (LedgerState blk EmptyMK) + , EncodeDisk blk (AnnTip blk) + , DecodeDisk blk (AnnTip blk) + , EncodeDisk blk (ChainDepState (BlockProtocol blk)) + , DecodeDisk blk (ChainDepState (BlockProtocol blk)) + ) => + LedgerDbSerialiseConstraints blk -- | The core API of the LedgerDB component type LedgerDB :: (Type -> Type) -> LedgerStateKind -> Type -> Type @@ -418,7 +428,7 @@ withPrivateTipForker ldb = getTipStatistics :: IOLike m => LedgerDB m l blk -> - m (Maybe Statistics) + m (Maybe (Statistics blk)) getTipStatistics ldb = withPrivateTipForker ldb forkerReadStatistics getReadOnlyForker :: @@ -740,54 +750,60 @@ data TraceReplayProgressEvent blk -- No correctness property relies on this, as Consensus can work with TxOuts -- from multiple eras, but the performance depends on it as otherwise we will be -- upgrading the TxOuts every time we consult them. -class CanUpgradeLedgerTables l where +type CanUpgradeLedgerTable :: Type -> TABLE -> Constraint +class CanUpgradeLedgerTable blk tag where + type UpgradeIndex blk :: Type + upgradeTable :: + -- | The original ledger state before the upgrade. This will be the + -- tip before applying the block. + UpgradeIndex blk -> + -- | The tables we want to maybe upgrade. + Table ValuesMK blk tag -> + Table ValuesMK blk tag + +type CanUpgradeLedgerTables :: StateKind -> Type -> Constraint +class All (CanUpgradeLedgerTable blk) (TablesForBlock blk) => CanUpgradeLedgerTables l blk where upgradeTables :: -- | The original ledger state before the upgrade. This will be the -- tip before applying the block. - l mk1 -> + l blk mk1 -> -- | The ledger state after the upgrade, which might be in a -- different era than the one above. - l mk2 -> + l blk mk2 -> -- | The tables we want to maybe upgrade. - LedgerTables l ValuesMK -> - LedgerTables l ValuesMK - -instance - CanUpgradeLedgerTables (LedgerState blk) => - CanUpgradeLedgerTables (ExtLedgerState blk) - where - upgradeTables (ExtLedgerState st0 _) (ExtLedgerState st1 _) = - castLedgerTables . upgradeTables st0 st1 . castLedgerTables - -instance - LedgerTablesAreTrivial l => - CanUpgradeLedgerTables (TrivialLedgerTables l) - where - upgradeTables _ _ (LedgerTables (ValuesMK mk)) = - LedgerTables (ValuesMK (Map.map absurd mk)) + LedgerTables blk ValuesMK -> + LedgerTables blk ValuesMK {------------------------------------------------------------------------------- LedgerDB constraints -------------------------------------------------------------------------------} -type LedgerSupportsInMemoryLedgerDB l = - (CanUpgradeLedgerTables l, SerializeTablesWithHint l) - -type LedgerSupportsLMDBLedgerDB l = - (IndexedMemPack (l EmptyMK) (TxOut l), MemPackIdx l EmptyMK ~ l EmptyMK) - -type LedgerSupportsV1LedgerDB l = - (LedgerSupportsInMemoryLedgerDB l, LedgerSupportsLMDBLedgerDB l) - -type LedgerSupportsV2LedgerDB l = - (LedgerSupportsInMemoryLedgerDB l, MemPack (TxIn l)) +class + ( CanUpgradeLedgerTables l blk + , All (SerializeTablesWithHint l blk) (TablesForBlock blk) + , NoThunks (LedgerTables blk ValuesMK) + , NoThunks (l blk EmptyMK) + , All TableLabel (TablesForBlock blk) + , LedgerTablesConstraints blk + ) => + LedgerSupportsInMemoryLedgerDB l blk +instance + ( CanUpgradeLedgerTables l blk + , All (SerializeTablesWithHint l blk) (TablesForBlock blk) + , NoThunks (LedgerTables blk ValuesMK) + , NoThunks (l blk EmptyMK) + , All TableLabel (TablesForBlock blk) + , LedgerTablesConstraints blk + ) => + LedgerSupportsInMemoryLedgerDB l blk -type LedgerSupportsLedgerDB blk = LedgerSupportsLedgerDB' (LedgerState blk) blk +type LedgerSupportsLedgerDB blk = + (LedgerSupportsLedgerDB' LedgerState blk) type LedgerSupportsLedgerDB' l blk = - ( LedgerSupportsV1LedgerDB l - , LedgerSupportsV2LedgerDB l + ( LedgerSupportsInMemoryLedgerDB l blk , LedgerDbSerialiseConstraints blk + , TableConstraints blk UTxOTable ) {------------------------------------------------------------------------------- @@ -808,35 +824,53 @@ data LedgerDbPrune -------------------------------------------------------------------------------} -- | A backend that supports streaming the ledger tables -class StreamingBackend m backend l where - data YieldArgs m backend l - - data SinkArgs m backend l - - yield :: Proxy backend -> YieldArgs m backend l -> Yield m l +class StreamingBackend m backend blk where + data YieldArgs m backend blk + + data SinkArgs m backend blk + + yield :: Proxy backend -> YieldArgs m backend blk -> NP (Yield m blk) (TablesForBlock blk) + + sink :: Proxy backend -> SinkArgs m backend blk -> NP (Sink m blk) (TablesForBlock blk) + +newtype StreamOfTable m blk table + = StreamOfTable + ( Stream + (Of (Key table, Value table blk)) + (ExceptT DeserialiseFailure m) + (Stream (Of ByteString) m (Maybe CRC)) + ) + +newtype Yield m blk table + = Yield + ( LedgerState blk EmptyMK -> + ( ( Stream + (Of (Key table, Value table blk)) + (ExceptT DeserialiseFailure m) + (Stream (Of ByteString) m (Maybe CRC)) -> + ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)) + ) + ) -> + ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC) + ) + +newtype Sink m blk table + = Sink + ( LedgerState blk EmptyMK -> + ( Stream + (Of (Key table, Value table blk)) + (ExceptT DeserialiseFailure m) + (Stream (Of ByteString) m (Maybe CRC)) -> + ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)) + ) + ) - sink :: Proxy backend -> SinkArgs m backend l -> Sink m l +data TableCodec blk table = TableCodec + { decK :: forall s. Decoder s (Key table) + , decV :: forall s. Decoder s (Value table blk) + , encK :: Key table -> Encoding + , encV :: Value table blk -> Encoding + } -type Yield m l = - l EmptyMK -> - ( ( Stream - (Of (TxIn l, TxOut l)) - (ExceptT DeserialiseFailure m) - (Stream (Of ByteString) m (Maybe CRC)) -> - ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)) - ) - ) -> - ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC) - -type Sink m l = - l EmptyMK -> - Stream - (Of (TxIn l, TxOut l)) - (ExceptT DeserialiseFailure m) - (Stream (Of ByteString) m (Maybe CRC)) -> - ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)) - -data Decoders l - = Decoders - (forall s. Decoder s (TxIn l)) - (forall s. Decoder s (TxOut l)) +data TablesCodecs blk + = TablesCodecs (NP (TableCodec blk) (TablesForBlock blk)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs index 582d3d8de0..1aac2043ec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs @@ -34,7 +34,6 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike @@ -88,8 +87,7 @@ defaultArgs backendArgs = } data LedgerDbBackendArgs m blk - = LedgerDbBackendArgsV1 (V1.LedgerDbBackendArgs m (ExtLedgerState blk)) - | LedgerDbBackendArgsV2 (V2.SomeBackendArgs m blk) + = LedgerDbBackendArgsV2 (V2.SomeBackendArgs m blk) {------------------------------------------------------------------------------- QueryBatchSize diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs index d23b748edd..f579ae9290 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} @@ -10,7 +8,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilies #-} @@ -28,7 +25,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.Forker , RangeQueryPrevious (..) , Statistics (..) , forkerCurrentPoint - , castRangeQueryPrevious + -- , castRangeQueryPrevious , ledgerStateReadOnlyForker -- ** Read only @@ -67,8 +64,9 @@ import Control.Monad.Except import Control.Monad.Reader (ReaderT (..)) import Control.Monad.Trans (MonadTrans (..)) import Control.ResourceRegistry -import Data.Bifunctor (first) import Data.Kind +import Data.SOP.BasicFunctors +import Data.SOP.Strict import Data.Set (Set) import qualified Data.Set as Set import Data.Word @@ -106,9 +104,9 @@ data Forker m l blk = Forker -- and not by the LedgerDB. , -- Queries - forkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)) + forkerReadTables :: !(LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)) -- ^ Read ledger tables from disk. - , forkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l))) + , forkerRangeReadTables :: !(RangeQueryPrevious blk -> m (LedgerTables blk ValuesMK, Maybe TxIn)) -- ^ Range-read ledger tables from disk. -- -- This range read will return as many values as the 'QueryBatchSize' that was @@ -127,7 +125,7 @@ data Forker m l blk = Forker -- -- If an empty ledger state is all you need, use 'getVolatileTip', -- 'getImmutableTip', or 'getPastLedgerState' instead of using a 'Forker'. - , forkerReadStatistics :: !(m (Maybe Statistics)) + , forkerReadStatistics :: !(m (Maybe (Statistics blk))) -- ^ Get statistics about the current state of the handle if possible. -- -- Returns 'Nothing' if the implementation is backed by @lsm-tree@. @@ -158,12 +156,12 @@ instance where getTipSTM forker = castPoint . getTip <$> forkerGetLedgerState forker -data RangeQueryPrevious l = NoPreviousQuery | PreviousQueryWasFinal | PreviousQueryWasUpTo (TxIn l) +data RangeQueryPrevious blk = NoPreviousQuery | PreviousQueryWasFinal | PreviousQueryWasUpTo TxIn -castRangeQueryPrevious :: TxIn l ~ TxIn l' => RangeQueryPrevious l -> RangeQueryPrevious l' -castRangeQueryPrevious NoPreviousQuery = NoPreviousQuery -castRangeQueryPrevious PreviousQueryWasFinal = PreviousQueryWasFinal -castRangeQueryPrevious (PreviousQueryWasUpTo txin) = PreviousQueryWasUpTo txin +-- castRangeQueryPrevious :: RangeQueryPrevious l -> RangeQueryPrevious l' +-- castRangeQueryPrevious NoPreviousQuery = NoPreviousQuery +-- castRangeQueryPrevious PreviousQueryWasFinal = PreviousQueryWasFinal +-- castRangeQueryPrevious (PreviousQueryWasUpTo txin) = PreviousQueryWasUpTo txin data RangeQuery l = RangeQuery { rqPrev :: !(RangeQueryPrevious l) @@ -175,8 +173,8 @@ data RangeQuery l = RangeQuery -- -- This is for now the only metric that was requested from other components, but -- this type might be augmented in the future with more statistics. -newtype Statistics = Statistics - { ledgerTableSize :: Int +newtype Statistics blk = Statistics + { ledgerTableSize :: NP (K Int) (TablesForBlock blk) } -- | Errors that can be thrown while acquiring forkers. @@ -213,13 +211,13 @@ forkerCurrentPoint forker = <$> forkerGetLedgerState forker ledgerStateReadOnlyForker :: - IOLike m => ReadOnlyForker m (ExtLedgerState blk) blk -> ReadOnlyForker m (LedgerState blk) blk + IOLike m => + ReadOnlyForker m (ExtLedgerState blk) blk -> ReadOnlyForker m (LedgerState blk) blk ledgerStateReadOnlyForker frk = ReadOnlyForker { roforkerClose = roforkerClose - , roforkerReadTables = fmap castLedgerTables . roforkerReadTables . castLedgerTables - , roforkerRangeReadTables = - fmap (first castLedgerTables) . roforkerRangeReadTables . castRangeQueryPrevious + , roforkerReadTables = roforkerReadTables + , roforkerRangeReadTables = roforkerRangeReadTables , roforkerGetLedgerState = ledgerState <$> roforkerGetLedgerState , roforkerReadStatistics = roforkerReadStatistics } @@ -250,13 +248,13 @@ type ReadOnlyForker :: (Type -> Type) -> LedgerStateKind -> Type -> Type data ReadOnlyForker m l blk = ReadOnlyForker { roforkerClose :: !(m ()) -- ^ See 'forkerClose' - , roforkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)) + , roforkerReadTables :: !(LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)) -- ^ See 'forkerReadTables' - , roforkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l))) + , roforkerRangeReadTables :: !(RangeQueryPrevious blk -> m (LedgerTables blk ValuesMK, Maybe TxIn)) -- ^ See 'forkerRangeReadTables'. , roforkerGetLedgerState :: !(STM m (l EmptyMK)) -- ^ See 'forkerGetLedgerState' - , roforkerReadStatistics :: !(m (Maybe Statistics)) + , roforkerReadStatistics :: !(m (Maybe (Statistics blk))) -- ^ See 'forkerReadStatistics' } deriving Generic @@ -388,16 +386,16 @@ validate evs args = do -- new blocks. switch :: (ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) => - (ResourceRegistry bm -> Word64 -> bm (Either GetForkerError (Forker bm l blk))) -> + (ResourceRegistry bm -> Word64 -> bm (Either GetForkerError (Forker bm (l blk) blk))) -> ResourceRegistry bm -> ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> -- | How many blocks to roll back Word64 -> (TraceValidateEvent blk -> m ()) -> -- | New blocks to apply - [Ap bm m l blk c] -> - m (Either GetForkerError (Forker bm l blk)) + [Ap bm m (l blk) blk c] -> + m (Either GetForkerError (Forker bm (l blk) blk)) switch forkerAtFromTip rr evs cfg numRollbacks trace newBlocks = do foEith <- liftBase $ forkerAtFromTip rr numRollbacks case foEith of @@ -472,10 +470,10 @@ applyBlock :: forall m bm c l blk. (ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) => ComputeLedgerEvents -> - LedgerCfg l -> - Ap bm m l blk c -> - Forker bm l blk -> - m (ValidLedgerState (l DiffMK)) + LedgerCfg (l blk) -> + Ap bm m (l blk) blk c -> + Forker bm (l blk) blk -> + m (ValidLedgerState (l blk DiffMK)) applyBlock evs cfg ap fo = case ap of ReapplyVal b -> ValidLedgerState @@ -497,7 +495,7 @@ applyBlock evs cfg ap fo = case ap of Weaken ap' -> applyBlock evs cfg ap' fo where - withValues :: blk -> (l ValuesMK -> m (l DiffMK)) -> m (l DiffMK) + withValues :: blk -> (l blk ValuesMK -> m (l blk DiffMK)) -> m (l blk DiffMK) withValues blk f = do l <- liftBase $ atomically $ forkerGetLedgerState fo vs <- @@ -513,9 +511,9 @@ applyBlock evs cfg ap fo = case ap of applyThenPush :: (ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) => ComputeLedgerEvents -> - LedgerCfg l -> - Ap bm m l blk c -> - Forker bm l blk -> + LedgerCfg (l blk) -> + Ap bm m (l blk) blk c -> + Forker bm (l blk) blk -> m () applyThenPush evs cfg ap fo = liftBase . forkerPush fo . getValidLedgerState @@ -526,9 +524,9 @@ applyThenPushMany :: (ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) => (Pushing blk -> m ()) -> ComputeLedgerEvents -> - LedgerCfg l -> - [Ap bm m l blk c] -> - Forker bm l blk -> + LedgerCfg (l blk) -> + [Ap bm m (l blk) blk c] -> + Forker bm (l blk) blk -> m () applyThenPushMany trace evs cfg aps fo = mapM_ pushAndTrace aps where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/TraceEvent.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/TraceEvent.hs index 77b3d040ad..90f6e78034 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/TraceEvent.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/TraceEvent.hs @@ -14,7 +14,6 @@ import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Forker import Ouroboros.Consensus.Storage.LedgerDB.Snapshots -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 {------------------------------------------------------------------------------- @@ -22,8 +21,7 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 -------------------------------------------------------------------------------} data FlavorImplSpecificTrace - = FlavorImplSpecificTraceV1 V1.SomeBackendTrace - | FlavorImplSpecificTraceV2 V2.LedgerDBV2Trace + = FlavorImplSpecificTraceV2 V2.LedgerDBV2Trace deriving Show data TraceEvent blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs index e1264ab257..6417ccdfd6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -78,6 +79,7 @@ mkInitDb :: , IOLike m , HasHardForkHistory blk , LedgerSupportsLedgerDB blk + , ApplyBlock (ExtLedgerState blk) blk ) => Complete LedgerDbArgs m blk -> V1.LedgerDbBackendArgs m (ExtLedgerState blk) -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs index 02908a7ab7..569284aea1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -80,10 +81,10 @@ newtype LiveLMDBFS m = LiveLMDBFS {liveLMDBFs :: SomeHasFS m} -- | A container for differences that are inteded to be flushed to a -- 'BackingStore' -data DiffsToFlush l = DiffsToFlush - { toFlushDiffs :: !(LedgerTables l DiffMK) +data DiffsToFlush l blk = DiffsToFlush + { toFlushDiffs :: !(LedgerTables blk DiffMK) -- ^ The set of differences that should be flushed into the 'BackingStore' - , toFlushState :: !(l EmptyMK, l EmptyMK) + , toFlushState :: !(l blk EmptyMK, l blk EmptyMK) -- ^ The last flushed state and the newly flushed state. This will be the -- immutable tip. , toFlushSlot :: !SlotNo @@ -130,22 +131,25 @@ type LedgerBackingStore m l = type BackingStore' m blk = LedgerBackingStore m (ExtLedgerState blk) -type family InitHint values :: Type -type instance InitHint (LedgerTables l ValuesMK) = l EmptyMK +type InitHint :: LedgerStateKind -> Type -> Type +type family InitHint l values :: Type +type instance InitHint l (LedgerTables blk ValuesMK) = l EmptyMK -type family WriteHint diffs :: Type -type instance WriteHint (LedgerTables l DiffMK) = (l EmptyMK, l EmptyMK) +type WriteHint :: LedgerStateKind -> Type -> Type +type family WriteHint l diffs :: Type +type instance WriteHint l (LedgerTables blk DiffMK) = (l EmptyMK, l EmptyMK) -type family ReadHint values :: Type -type instance ReadHint (LedgerTables l ValuesMK) = l EmptyMK +type ReadHint :: LedgerStateKind -> Type -> Type +type family ReadHint l values :: Type +type instance ReadHint l (LedgerTables blk ValuesMK) = l EmptyMK -- | Choose how to initialize the backing store -data InitFrom values +data InitFrom l values = -- | Initialize from a set of values, at the given slot. - InitFromValues !(WithOrigin SlotNo) !(InitHint values) !values + InitFromValues !(WithOrigin SlotNo) !(InitHint l values) !values | -- | Use a snapshot at the given path to overwrite the set of values in the -- opened database. - InitFromCopy !(InitHint values) !FS.FsPath + InitFromCopy !(InitHint l values) !FS.FsPath {------------------------------------------------------------------------------- Value handles diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs index eb7e3964dc..ddf7758428 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs @@ -83,18 +83,14 @@ data BackingStoreContents m l deriving Generic deriving instance - ( NoThunks (TxIn l) - , NoThunks (TxOut l) - ) => + AllTables NoThunks ValuesMK l => NoThunks (BackingStoreContents m l) -- | Use a 'TVar' as a trivial backing store newInMemoryBackingStore :: forall l m. ( IOLike m - , HasLedgerTables l - , CanUpgradeLedgerTables l - , SerializeTablesWithHint l + , LedgerSupportsInMemoryLedgerDB l ) => Tracer m BackingStoreTrace -> SnapshotsFS m -> @@ -253,14 +249,13 @@ newInMemoryBackingStore tracer (SnapshotsFS (SomeHasFS fs)) initialization = do RangeQuery (LedgerTables l KeysMK) -> LedgerTables l ValuesMK -> (LedgerTables l ValuesMK, Maybe (TxIn l)) - rangeRead rq values = - let vs@(LedgerTables (ValuesMK m)) = case rqPrev rq of - Nothing -> - ltmap (rangeRead0' (rqCount rq)) values - Just keys -> - ltliftA2 (rangeRead' (rqCount rq)) keys values - in (vs, fst <$> Map.lookupMax m) - + rangeRead rq values = undefined -- TODO @js + -- let vs@(LedgerTables (ValuesMK m)) = case rqPrev rq of + -- Nothing -> + -- ltmap (rangeRead0' (rqCount rq)) values + -- Just keys -> + -- ltliftA2 (rangeRead' (rqCount rq)) keys values + -- in (vs, fst <$> Map.lookupMax m) rangeRead0' :: Int -> ValuesMK k v -> @@ -294,8 +289,7 @@ newInMemoryBackingStore tracer (SnapshotsFS (SomeHasFS fs)) initialization = do ValuesMK (Diff.applyDiff values diff) count :: LedgerTables l ValuesMK -> Int - count = ltcollapse . ltmap (K2 . count') - + count = undefined -- TODO @js ltcollapse . ltmap (K2 . count') count' :: ValuesMK k v -> Int count' (ValuesMK values) = Map.size values @@ -353,9 +347,7 @@ type data Mem instance ( IOLike m - , HasLedgerTables l - , CanUpgradeLedgerTables l - , SerializeTablesWithHint l + , LedgerSupportsInMemoryLedgerDB l ) => Backend m Mem l where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/DbChangelog.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/DbChangelog.hs index bf913d6062..01d4b0b254 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/DbChangelog.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/DbChangelog.hs @@ -192,7 +192,7 @@ import Control.Exception as Exn import Data.Bifunctor (bimap) import Data.Functor.Identity import Data.Map.Diff.Strict as AntiDiff (applyDiffForKeys) -import Data.SOP (K, unK) +import Data.SOP (K, hcollapse, unK) import Data.SOP.Functors import Data.Word import GHC.Generics (Generic) @@ -290,13 +290,13 @@ data DbChangelog l = DbChangelog deriving Generic deriving instance - (Eq (TxIn l), Eq (TxOut l), Eq (l EmptyMK)) => + (AllTables Eq SeqDiffMK l, Eq (l EmptyMK)) => Eq (DbChangelog l) deriving instance - (NoThunks (TxIn l), NoThunks (TxOut l), NoThunks (l EmptyMK)) => + (AllTables NoThunks SeqDiffMK l, NoThunks (l EmptyMK)) => NoThunks (DbChangelog l) deriving instance - (Show (TxIn l), Show (TxOut l), Show (l EmptyMK)) => + (AllTables Show SeqDiffMK l, Show (l EmptyMK)) => Show (DbChangelog l) type DbChangelog' blk = DbChangelog (ExtLedgerState blk) @@ -663,7 +663,8 @@ splitForFlushing :: DbChangelog l -> (Maybe (DiffsToFlush l), DbChangelog l) splitForFlushing dblog = - if getTipSlot immTip == Origin || ltcollapse (ltmap (K2 . DS.length . getSeqDiffMK) l) == 0 + if getTipSlot immTip == Origin + || maximum (hcollapse (ltcollapse (ltmap (K2 . DS.length . getSeqDiffMK) l))) == 0 then (Nothing, dblog) else (Just ldblog, rdblog) where @@ -862,14 +863,14 @@ immutableTipSlot = . changelogStates -- | How many diffs we can flush to the backing store? --- --- NOTE: This will be wrong once we have more than one table. flushableLength :: (HasLedgerTables l, GetTip l) => DbChangelog l -> Word64 flushableLength chlog = (\x -> x - fromIntegral (AS.length (changelogStates chlog))) + . maximum + . hcollapse . ltcollapse . ltmap (K2 . f) $ changelogDiffs chlog diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs index 49ba973a6b..6c1f525d83 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs @@ -61,15 +61,16 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type import System.FS.API import Prelude hiding (read) -type SnapshotManagerV2 m blk = SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) +type SnapshotManagerV2 m blk = SnapshotManager m m blk (StateRef m ExtLedgerState blk) mkInitDb :: forall m blk backend. ( LedgerSupportsProtocol blk - , LedgerDbSerialiseConstraints blk , HasHardForkHistory blk , Backend m backend blk , IOLike m + , LedgerSupportsInMemoryLedgerDB LedgerState blk + , TableConstraints blk UTxOTable ) => Complete LedgerDbArgs m blk -> ResolveBlock m blk -> @@ -143,19 +144,20 @@ mkInitDb args getBlock snapManager getVolatileSuffix res = do emptyF st = empty' st $ newHandleFromValues v2Tracer lgrRegistry res implMkLedgerDb :: - forall m l blk. + forall m blk. ( IOLike m , HasCallStack - , IsLedger l - , l ~ ExtLedgerState blk - , StandardHash l - , HasLedgerTables l + , IsLedger (ExtLedgerState blk) + , StandardHash (ExtLedgerState blk) + , HasLedgerTables ExtLedgerState blk , LedgerSupportsProtocol blk , HasHardForkHistory blk + , LedgerSupportsInMemoryLedgerDB LedgerState blk + , TableConstraints blk UTxOTable ) => - LedgerDBHandle m l blk -> - SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) -> - (LedgerDB m l blk, TestInternals m l blk) + LedgerDBHandle m ExtLedgerState blk -> + SnapshotManager m m blk (StateRef m ExtLedgerState blk) -> + (LedgerDB m (ExtLedgerState blk) blk, TestInternals m (ExtLedgerState blk) blk) implMkLedgerDb h snapManager = ( LedgerDB { getVolatileTip = getEnvSTM h implGetVolatileTip @@ -177,10 +179,12 @@ mkInternals :: forall m blk. ( IOLike m , LedgerSupportsProtocol blk - , ApplyBlock (ExtLedgerState blk) blk + , ApplyBlock ExtLedgerState blk + , LedgerSupportsInMemoryLedgerDB LedgerState blk + , TableConstraints blk UTxOTable ) => - LedgerDBHandle m (ExtLedgerState blk) blk -> - SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) -> + LedgerDBHandle m ExtLedgerState blk -> + SnapshotManager m m blk (StateRef m ExtLedgerState blk) -> TestInternals' m blk mkInternals h snapManager = TestInternals @@ -230,7 +234,7 @@ mkInternals h snapManager = pure $ 1 + maxRollback l } where - pruneLedgerSeq :: LedgerDBEnv m (ExtLedgerState blk) blk -> m () + pruneLedgerSeq :: LedgerDBEnv m ExtLedgerState blk -> m () pruneLedgerSeq env = Monad.join $ atomically $ stateTVar (ldbSeq env) $ pruneToImmTipOnly @@ -244,36 +248,35 @@ implIntTruncateSnapshots snapManager (SomeHasFS fs) = do \h -> hTruncate fs h 0 implGetVolatileTip :: - (MonadSTM m, GetTip l) => + (MonadSTM m, GetTip (l blk)) => LedgerDBEnv m l blk -> - STM m (l EmptyMK) + STM m (l blk EmptyMK) implGetVolatileTip = fmap current . getVolatileLedgerSeq implGetImmutableTip :: - (MonadSTM m, GetTip l) => + (MonadSTM m, GetTip (l blk)) => LedgerDBEnv m l blk -> - STM m (l EmptyMK) + STM m (l blk EmptyMK) implGetImmutableTip = fmap anchor . getVolatileLedgerSeq implGetPastLedgerState :: ( MonadSTM m , HasHeader blk - , IsLedger l - , StandardHash l - , HeaderHash l ~ HeaderHash blk + , IsLedger (l blk) + , StandardHash (l blk) + , HeaderHash (l blk) ~ HeaderHash blk ) => - LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK)) + LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l blk EmptyMK)) implGetPastLedgerState env point = getPastLedgerAt point <$> getVolatileLedgerSeq env implGetHeaderStateHistory :: ( MonadSTM m - , l ~ ExtLedgerState blk , IsLedger (LedgerState blk) , HasHardForkHistory blk , HasAnnTip blk ) => - LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk) + LedgerDBEnv m ExtLedgerState blk -> STM m (HeaderStateHistory blk) implGetHeaderStateHistory env = do ldb <- getVolatileLedgerSeq env let currentLedgerState = ledgerState $ current ldb @@ -292,14 +295,15 @@ implGetHeaderStateHistory env = do $ ldb implValidate :: - forall m l blk. + forall m blk. ( IOLike m , LedgerSupportsProtocol blk , HasCallStack - , l ~ ExtLedgerState blk + , LedgerSupportsInMemoryLedgerDB LedgerState blk + , TableConstraints blk UTxOTable ) => - LedgerDBHandle m l blk -> - LedgerDBEnv m l blk -> + LedgerDBHandle m ExtLedgerState blk -> + LedgerDBEnv m ExtLedgerState blk -> ResourceRegistry m -> (TraceValidateEvent blk -> m ()) -> BlockCache blk -> @@ -328,7 +332,7 @@ implGetPrevApplied env = readTVar (ldbPrevApplied env) -- | Remove 'LedgerSeq' states older than the given slot, and all points with a -- slot older than the given slot from the set of previously applied points. -implGarbageCollect :: (IOLike m, GetTip l) => LedgerDBEnv m l blk -> SlotNo -> m () +implGarbageCollect :: (IOLike m, GetTip (l blk)) => LedgerDBEnv m l blk -> SlotNo -> m () implGarbageCollect env slotNo = do atomically $ modifyTVar (ldbPrevApplied env) $ @@ -341,13 +345,12 @@ implGarbageCollect env slotNo = do pure (close, ()) implTryTakeSnapshot :: - forall m l blk. - ( l ~ ExtLedgerState blk - , IOLike m - , GetTip l + forall m blk. + ( IOLike m + , GetTip (ExtLedgerState blk) ) => - SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) -> - LedgerDBEnv m l blk -> + SnapshotManager m m blk (StateRef m ExtLedgerState blk) -> + LedgerDBEnv m ExtLedgerState blk -> Maybe (Time, Time) -> Word64 -> m SnapCounters @@ -392,9 +395,9 @@ implCloseDB (LDBHandle varState) = do The LedgerDBEnv -------------------------------------------------------------------------------} -type LedgerDBEnv :: (Type -> Type) -> LedgerStateKind -> Type -> Type +type LedgerDBEnv :: (Type -> Type) -> StateKind -> Type -> Type data LedgerDBEnv m l blk = LedgerDBEnv - { ldbSeq :: !(StrictTVar m (LedgerSeq m l)) + { ldbSeq :: !(StrictTVar m (LedgerSeq m l blk)) -- ^ INVARIANT: the tip of the 'LedgerDB' is always in sync with the tip of -- the current chain of the ChainDB. , ldbPrevApplied :: !(StrictTVar m (Set (RealPoint blk))) @@ -428,14 +431,14 @@ data LedgerDBEnv m l blk = LedgerDBEnv , ldbNextForkerKey :: !(StrictTVar m ForkerKey) , ldbSnapshotPolicy :: !SnapshotPolicy , ldbTracer :: !(Tracer m (TraceEvent blk)) - , ldbCfg :: !(LedgerDbCfg l) + , ldbCfg :: !(LedgerDbCfg (l blk)) , ldbHasFS :: !(SomeHasFS m) , ldbResolveBlock :: !(ResolveBlock m blk) , ldbQueryBatchSize :: !QueryBatchSize , ldbRegistry :: !(ResourceRegistry m) -- ^ The registry of the LedgerDB, to give it to forkers to transfer committed -- handles to the LedgerDB. - , ldbToClose :: !(StrictTVar m [LedgerSeq m l]) + , ldbToClose :: !(StrictTVar m [LedgerSeq m l blk]) -- ^ When committing forkers, the discarded part of the LedgerDB will be put -- in this TVar such that the 'garbageCollect' function will release such -- resources. @@ -464,10 +467,8 @@ data LedgerDBEnv m l blk = LedgerDBEnv deriving instance ( IOLike m , LedgerSupportsProtocol blk - , NoThunks (l EmptyMK) - , NoThunks (TxIn l) - , NoThunks (TxOut l) - , NoThunks (LedgerCfg l) + , NoThunks (l blk EmptyMK) + , NoThunks (LedgerCfg (l blk)) , NoThunks (SomeResources m blk) ) => NoThunks (LedgerDBEnv m l blk) @@ -476,7 +477,7 @@ deriving instance The LedgerDBHandle -------------------------------------------------------------------------------} -type LedgerDBHandle :: (Type -> Type) -> LedgerStateKind -> Type -> Type +type LedgerDBHandle :: (Type -> Type) -> StateKind -> Type -> Type newtype LedgerDBHandle m l blk = LDBHandle (StrictTVar m (LedgerDBState m l blk)) deriving Generic @@ -489,10 +490,8 @@ data LedgerDBState m l blk deriving instance ( IOLike m , LedgerSupportsProtocol blk - , NoThunks (l EmptyMK) - , NoThunks (TxIn l) - , NoThunks (TxOut l) - , NoThunks (LedgerCfg l) + , NoThunks (l blk EmptyMK) + , NoThunks (LedgerCfg (l blk)) , NoThunks (SomeResources m blk) ) => NoThunks (LedgerDBState m l blk) @@ -554,8 +553,8 @@ getEnvSTM (LDBHandle varState) f = -- more than one immutable state if we adopted new blocks, but garbage -- collection has not yet been run. getVolatileLedgerSeq :: - (MonadSTM m, GetTip l) => - LedgerDBEnv m l blk -> STM m (LedgerSeq m l) + (MonadSTM m, GetTip (l blk)) => + LedgerDBEnv m l blk -> STM m (LedgerSeq m l blk) getVolatileLedgerSeq env = do volSuffix <- getVolatileSuffix (ldbGetVolatileSuffix env) LedgerSeq . volSuffix . getLedgerSeq <$> readTVar (ldbSeq env) @@ -569,11 +568,11 @@ getVolatileLedgerSeq env = do -- returned; for the simple use case of getting a single 'StateRef', use @t ~ -- 'Solo'@. getStateRef :: - (IOLike m, Traversable t, GetTip l) => + (IOLike m, Traversable t, GetTip (l blk)) => LedgerDBEnv m l blk -> ResourceRegistry m -> - (LedgerSeq m l -> t (StateRef m l)) -> - m (t (ResourceKey m, StateRef m l)) + (LedgerSeq m l blk -> t (StateRef m l blk)) -> + m (t (ResourceKey m, StateRef m l blk)) getStateRef ldbEnv reg project = RAWLock.withReadAccess (ldbOpenHandlesLock ldbEnv) $ \() -> do tst <- project <$> atomically (getVolatileLedgerSeq ldbEnv) @@ -584,25 +583,24 @@ getStateRef ldbEnv reg project = -- | Like 'StateRef', but takes care of closing the handle when the given action -- returns or errors. withStateRef :: - (IOLike m, Traversable t, GetTip l) => + (IOLike m, Traversable t, GetTip (l blk)) => LedgerDBEnv m l blk -> - (LedgerSeq m l -> t (StateRef m l)) -> - (t (ResourceKey m, StateRef m l) -> m a) -> + (LedgerSeq m l blk -> t (StateRef m l blk)) -> + (t (ResourceKey m, StateRef m l blk) -> m a) -> m a withStateRef ldbEnv project f = withRegistry $ \reg -> getStateRef ldbEnv reg project >>= f acquireAtTarget :: - ( HeaderHash l ~ HeaderHash blk - , IOLike m - , GetTip l - , StandardHash l + ( IOLike m + , GetTip (ExtLedgerState blk) + , StandardHash (ExtLedgerState blk) , LedgerSupportsProtocol blk ) => - LedgerDBEnv m l blk -> + LedgerDBEnv m ExtLedgerState blk -> Either Word64 (Target (Point blk)) -> ResourceRegistry m -> - m (Either GetForkerError (ResourceKey m, StateRef m l)) + m (Either GetForkerError (ResourceKey m, StateRef m ExtLedgerState blk)) acquireAtTarget ldbEnv target reg = getStateRef ldbEnv reg $ \l -> case target of Right VolatileTip -> pure $ currentHandle l @@ -626,32 +624,34 @@ acquireAtTarget ldbEnv target reg = Just l' -> pure $ currentHandle l' newForkerAtTarget :: - ( HeaderHash l ~ HeaderHash blk - , IOLike m - , IsLedger l - , HasLedgerTables l + ( IOLike m + , IsLedger (ExtLedgerState blk) + , HasLedgerTables ExtLedgerState blk , LedgerSupportsProtocol blk - , StandardHash l + , StandardHash (ExtLedgerState blk) + , LedgerSupportsInMemoryLedgerDB LedgerState blk + , TableConstraints blk UTxOTable ) => - LedgerDBHandle m l blk -> + LedgerDBHandle m ExtLedgerState blk -> ResourceRegistry m -> Target (Point blk) -> - m (Either GetForkerError (Forker m l blk)) + m (Either GetForkerError (Forker m (ExtLedgerState blk) blk)) newForkerAtTarget h rr pt = getEnv h $ \ldbEnv -> acquireAtTarget ldbEnv (Right pt) rr >>= traverse (newForker h ldbEnv rr) newForkerByRollback :: - ( HeaderHash l ~ HeaderHash blk - , IOLike m - , IsLedger l - , StandardHash l - , HasLedgerTables l + ( IOLike m + , IsLedger (ExtLedgerState blk) + , StandardHash (ExtLedgerState blk) + , HasLedgerTables ExtLedgerState blk , LedgerSupportsProtocol blk + , LedgerSupportsInMemoryLedgerDB LedgerState blk + , TableConstraints blk UTxOTable ) => - LedgerDBHandle m l blk -> + LedgerDBHandle m ExtLedgerState blk -> ResourceRegistry m -> Word64 -> - m (Either GetForkerError (Forker m l blk)) + m (Either GetForkerError (Forker m (ExtLedgerState blk) blk)) newForkerByRollback h rr n = getEnv h $ \ldbEnv -> acquireAtTarget ldbEnv (Left n) rr >>= traverse (newForker h ldbEnv rr) @@ -742,17 +742,18 @@ implForkerClose (LDBHandle varState) forkerKey forkerEnv = do newForker :: ( IOLike m - , HasLedgerTables l + , HasLedgerTables ExtLedgerState blk , LedgerSupportsProtocol blk - , NoThunks (l EmptyMK) - , GetTip l - , StandardHash l + , NoThunks (ExtLedgerState blk EmptyMK) + , GetTip (ExtLedgerState blk) + , StandardHash (ExtLedgerState blk) + , TableConstraints blk UTxOTable ) => - LedgerDBHandle m l blk -> - LedgerDBEnv m l blk -> + LedgerDBHandle m ExtLedgerState blk -> + LedgerDBEnv m ExtLedgerState blk -> ResourceRegistry m -> - (ResourceKey m, StateRef m l) -> - m (Forker m l blk) + (ResourceKey m, StateRef m ExtLedgerState blk) -> + m (Forker m (ExtLedgerState blk) blk) newForker h ldbEnv rr (rk, st) = do forkerKey <- atomically $ stateTVar (ldbNextForkerKey ldbEnv) $ \r -> (r, r + 1) let tr = LedgerDBForkerEvent . TraceForkerEventWithKey forkerKey >$< ldbTracer ldbEnv diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Backend.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Backend.hs index 409dd021b4..be3302a9fc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Backend.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Backend.hs @@ -64,7 +64,7 @@ class NoThunks (Resources m backend) => Backend m backend blk where ResourceRegistry m -> Resources m backend -> ExtLedgerState blk ValuesMK -> - m (LedgerTablesHandle m (ExtLedgerState blk)) + m (LedgerTablesHandle m ExtLedgerState blk) -- | Create a new handle from a snapshot. newHandleFromSnapshot :: @@ -83,7 +83,7 @@ class NoThunks (Resources m backend) => Backend m backend blk where CodecConfig blk -> Tracer m (TraceSnapshotEvent blk) -> SomeHasFS m -> - SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) + SnapshotManager m m blk (StateRef m ExtLedgerState blk) {------------------------------------------------------------------------------- Existentials diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs index a819063fd7..3beae77af3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs @@ -1,9 +1,12 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.LedgerDB.V2.Forker @@ -25,6 +28,7 @@ import Control.Tracer import Data.Functor.Contravariant ((>$<)) import Data.Maybe (fromMaybe) import GHC.Generics +import Lens.Micro ((&), (.~)) import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract @@ -47,14 +51,14 @@ import Prelude hiding (read) -------------------------------------------------------------------------------} data ForkerEnv m l blk = ForkerEnv - { foeLedgerSeq :: !(StrictTVar m (LedgerSeq m l)) + { foeLedgerSeq :: !(StrictTVar m (LedgerSeq m l blk)) -- ^ Local version of the LedgerSeq - , foeSwitchVar :: !(StrictTVar m (LedgerSeq m l)) + , foeSwitchVar :: !(StrictTVar m (LedgerSeq m l blk)) -- ^ This TVar is the same as the LedgerDB one , foeLedgerDbRegistry :: !(ResourceRegistry m) -- ^ The registry in the LedgerDB to move handles to in case we commit the -- forker. - , foeLedgerDbToClose :: !(StrictTVar m [LedgerSeq m l]) + , foeLedgerDbToClose :: !(StrictTVar m [LedgerSeq m l blk]) , foeTracer :: !(Tracer m TraceForkerEvent) -- ^ Config , foeResourceRegistry :: !(ResourceRegistry m) @@ -75,17 +79,15 @@ data ForkerEnv m l blk = ForkerEnv deriving instance ( IOLike m , LedgerSupportsProtocol blk - , NoThunks (l EmptyMK) - , NoThunks (TxIn l) - , NoThunks (TxOut l) + , NoThunks (l blk EmptyMK) ) => NoThunks (ForkerEnv m l blk) implForkerReadTables :: - (IOLike m, GetTip l) => + (IOLike m, GetTip (l blk)) => ForkerEnv m l blk -> - LedgerTables l KeysMK -> - m (LedgerTables l ValuesMK) + LedgerTables blk KeysMK -> + m (LedgerTables blk ValuesMK) implForkerReadTables env ks = encloseTimedWith (ForkerReadTables >$< foeTracer env) $ do lseq <- readTVarIO (foeLedgerSeq env) @@ -93,40 +95,44 @@ implForkerReadTables env ks = read (tables stateRef) (state stateRef) ks implForkerRangeReadTables :: - (IOLike m, GetTip l, HasLedgerTables l) => + forall m l blk. + (IOLike m, GetTip (l blk), HasLedgerTables l blk, TableConstraints blk UTxOTable) => QueryBatchSize -> ForkerEnv m l blk -> - RangeQueryPrevious l -> - m (LedgerTables l ValuesMK, Maybe (TxIn l)) + RangeQueryPrevious blk -> + m (LedgerTables blk ValuesMK, Maybe TxIn) implForkerRangeReadTables qbs env rq0 = encloseTimedWith (ForkerRangeReadTables >$< foeTracer env) $ do ldb <- readTVarIO $ foeLedgerSeq env let n = fromIntegral $ defaultQueryBatchSize qbs stateRef = currentHandle ldb case rq0 of - NoPreviousQuery -> readRange (tables stateRef) (state stateRef) (Nothing, n) - PreviousQueryWasFinal -> pure (LedgerTables emptyMK, Nothing) + NoPreviousQuery -> + (\(t, k) -> (emptyLedgerTables & onUTxOTable (Proxy @blk) .~ t, k)) + <$> readRange (tables stateRef) (Proxy @UTxOTable) (state stateRef) (Nothing, n) + PreviousQueryWasFinal -> pure (emptyLedgerTables, Nothing) PreviousQueryWasUpTo k -> - readRange (tables stateRef) (state stateRef) (Just k, n) + (\(t, kk) -> (emptyLedgerTables & onUTxOTable (Proxy @blk) .~ t, kk)) + <$> readRange (tables stateRef) (Proxy @UTxOTable) (state stateRef) (Just k, n) implForkerGetLedgerState :: - (MonadSTM m, GetTip l) => + (MonadSTM m, GetTip (l blk)) => ForkerEnv m l blk -> - STM m (l EmptyMK) + STM m (l blk EmptyMK) implForkerGetLedgerState env = current <$> readTVar (foeLedgerSeq env) implForkerReadStatistics :: - (MonadSTM m, GetTip l) => + (MonadSTM m, GetTip (l blk)) => ForkerEnv m l blk -> - m (Maybe Statistics) + m (Maybe (Statistics blk)) implForkerReadStatistics env = do traceWith (foeTracer env) ForkerReadStatistics fmap (fmap Statistics) . tablesSize . tables . currentHandle =<< readTVarIO (foeLedgerSeq env) implForkerPush :: - (IOLike m, GetTip l, HasLedgerTables l, HasCallStack) => + (IOLike m, GetTip (l blk), HasLedgerTables l blk, HasCallStack) => ForkerEnv m l blk -> - l DiffMK -> + l blk DiffMK -> m () implForkerPush env newState = encloseTimedWith (ForkerPush >$< foeTracer env) $ do @@ -147,7 +153,7 @@ implForkerPush env newState = ) implForkerCommit :: - (IOLike m, GetTip l, StandardHash l) => + (IOLike m, GetTip (l blk), StandardHash (l blk)) => ForkerEnv m l blk -> STM m () implForkerCommit env = do diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs index 93f2ed831d..f6bbee1625 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs @@ -8,10 +8,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -45,12 +48,17 @@ import qualified Data.ByteString as BS import Data.ByteString.Builder.Extra (defaultChunkSize) import Data.Functor.Contravariant ((>$<)) import Data.Functor.Identity +import Data.Functor.Product import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Maybe import Data.MemPack +import Data.SOP.BasicFunctors +import Data.SOP.Constraint (All, Top) +import Data.SOP.Strict +import Data.Singletons import Data.Void -import GHC.Generics +import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract @@ -72,15 +80,14 @@ import qualified Streaming as S import qualified Streaming.Prelude as S import System.FS.API import System.FS.CRC -import qualified System.FilePath as F import Prelude hiding (read) {------------------------------------------------------------------------------- InMemory implementation of LedgerTablesHandles -------------------------------------------------------------------------------} -data LedgerTablesHandleState l - = LedgerTablesHandleOpen !(LedgerTables l ValuesMK) +data LedgerTablesHandleState blk + = LedgerTablesHandleOpen !(LedgerTables blk ValuesMK) | LedgerTablesHandleClosed deriving Generic @@ -94,16 +101,15 @@ guardClosed LedgerTablesHandleClosed _ = error $ show InMemoryClosedExn guardClosed (LedgerTablesHandleOpen st) f = f st newInMemoryLedgerTablesHandle :: - forall m l. + forall m blk. ( IOLike m - , HasLedgerTables l - , CanUpgradeLedgerTables l - , SerializeTablesWithHint l + , LedgerSupportsInMemoryLedgerDB LedgerState blk + , HasLedgerTables LedgerState blk ) => Tracer m LedgerDBV2Trace -> SomeHasFS m -> - LedgerTables l ValuesMK -> - m (LedgerTablesHandle m l) + LedgerTables blk ValuesMK -> + m (LedgerTablesHandle m ExtLedgerState blk) newInMemoryLedgerTablesHandle tracer someFS@(SomeHasFS hasFS) l = do !tv <- newTVarIO (LedgerTablesHandleOpen l) traceWith tracer TraceLedgerTablesHandleCreate @@ -142,15 +148,14 @@ implClose tracer tv = do implDuplicate :: ( IOLike m - , HasLedgerTables l - , CanUpgradeLedgerTables l - , SerializeTablesWithHint l + , LedgerSupportsInMemoryLedgerDB LedgerState blk + , HasLedgerTables LedgerState blk ) => Tracer m LedgerDBV2Trace -> - StrictTVar m (LedgerTablesHandleState l) -> + StrictTVar m (LedgerTablesHandleState blk) -> SomeHasFS m -> ResourceRegistry m -> - m (ResourceKey m, LedgerTablesHandle m l) + m (ResourceKey m, LedgerTablesHandle m ExtLedgerState blk) implDuplicate tracer tv someFS rr = do hs <- readTVarIO tv !x <- guardClosed hs $ \v -> @@ -162,12 +167,12 @@ implDuplicate tracer tv someFS rr = do implRead :: ( IOLike m - , HasLedgerTables l + , HasLedgerTables l blk ) => - StrictTVar m (LedgerTablesHandleState l) -> - l EmptyMK -> - LedgerTables l KeysMK -> - m (LedgerTables l ValuesMK) + StrictTVar m (LedgerTablesHandleState blk) -> + l blk EmptyMK -> + LedgerTables blk KeysMK -> + m (LedgerTables blk ValuesMK) implRead tv _ keys = do hs <- readTVarIO tv guardClosed @@ -175,39 +180,49 @@ implRead tv _ keys = do (pure . flip (ltliftA2 (\(ValuesMK v) (KeysMK k) -> ValuesMK $ v `Map.restrictKeys` k)) keys) implReadRange :: - (IOLike m, HasLedgerTables l) => - StrictTVar m (LedgerTablesHandleState l) -> - l EmptyMK -> - (Maybe (TxIn l), Int) -> - m (LedgerTables l ValuesMK, Maybe (TxIn l)) -implReadRange tv _ (f, t) = do + forall m l blk table. + (IOLike m, HasLedgerTables l blk, TableConstraints blk table) => + StrictTVar m (LedgerTablesHandleState blk) -> + Proxy table -> + l blk EmptyMK -> + (Maybe (Key table), Int) -> + m (Table ValuesMK blk table, Maybe (Key table)) +implReadRange tv _ _ (f, t) = do hs <- readTVarIO tv guardClosed hs - ( \(LedgerTables (ValuesMK m)) -> - let m' = Map.take t . (maybe id (\g -> snd . Map.split g) f) $ m - in pure (LedgerTables (ValuesMK m'), fst <$> Map.lookupMax m') + ( \tbs -> + let tbs' = + getTableByTag (sing @table) tbs + in pure + ( maybe (Table (ValuesMK mempty)) g tbs' + , fst <$> (Map.lookupMax . ((\(ValuesMK m) -> m)) . getTable @ValuesMK @blk @table =<< tbs') + ) ) + where + g (Table (ValuesMK m)) = + let m' = Map.take t . (maybe id (\k -> snd . Map.split k) f) $ m + in Table (ValuesMK m') implReadAll :: IOLike m => - StrictTVar m (LedgerTablesHandleState l) -> + StrictTVar m (LedgerTablesHandleState blk) -> l EmptyMK -> - m (LedgerTables l ValuesMK) + m (LedgerTables blk ValuesMK) implReadAll tv _ = do hs <- readTVarIO tv guardClosed hs pure implPushDiffs :: ( IOLike m - , HasLedgerTables l - , CanUpgradeLedgerTables l + , LedgerSupportsInMemoryLedgerDB LedgerState blk + , HasLedgerTables LedgerState blk ) => - StrictTVar m (LedgerTablesHandleState l) -> - l mk1 -> - l DiffMK -> + StrictTVar m (LedgerTablesHandleState blk) -> + ExtLedgerState blk mk1 -> + ExtLedgerState blk DiffMK -> m () -implPushDiffs tv st0 !diffs = +implPushDiffs tv (ledgerState -> st0) (ledgerState -> !diffs) = atomically $ modifyTVar tv @@ -223,30 +238,36 @@ implPushDiffs tv st0 !diffs = ) implTakeHandleSnapshot :: - (IOLike m, SerializeTablesWithHint l) => - StrictTVar m (LedgerTablesHandleState l) -> + forall m blk h. + (IOLike m, LedgerSupportsInMemoryLedgerDB LedgerState blk) => + StrictTVar m (LedgerTablesHandleState blk) -> HasFS m h -> - l EmptyMK -> + ExtLedgerState blk EmptyMK -> String -> - m (Maybe CRC) + m (NP (K (Maybe CRC)) (TablesForBlock blk)) implTakeHandleSnapshot tv hasFS hint snapshotName = do createDirectoryIfMissing hasFS True $ mkFsPath [snapshotName] h <- readTVarIO tv guardClosed h $ - \values -> - withFile hasFS (mkFsPath [snapshotName, "tables"]) (WriteMode MustBeNew) $ \hf -> - fmap (Just . snd) $ - hPutAllCRC hasFS hf $ - CBOR.toLazyByteString $ - valuesMKEncoder hint values + \tbs -> + hctraverse' + (Proxy @TableLabel) + f + $ valuesMKEncoder (ledgerState hint) tbs + where + f :: forall (table :: TABLE). TableLabel table => K Encoding table -> m (K (Maybe CRC) table) + f (K e) = withFile hasFS (mkFsPath [snapshotName, tableLabel (Proxy @table)]) (WriteMode MustBeNew) $ \hf -> + fmap (K . Just . snd) $ + hPutAllCRC hasFS hf $ + CBOR.toLazyByteString e implTablesSize :: - IOLike m => - StrictTVar m (LedgerTablesHandleState l) -> - m (Maybe Int) + (IOLike m, LedgerSupportsInMemoryLedgerDB LedgerState blk) => + StrictTVar m (LedgerTablesHandleState blk) -> + m (Maybe (NP (K Int) (TablesForBlock blk))) implTablesSize tv = do hs <- readTVarIO tv - guardClosed hs (pure . Just . Map.size . getValuesMK . getLedgerTables) + guardClosed hs (pure . Just . hmap (K . Map.size . getValuesMK . getTable) . getLedgerTables) {------------------------------------------------------------------------------- Snapshots @@ -260,7 +281,7 @@ snapshotManager :: CodecConfig blk -> Tracer m (TraceSnapshotEvent blk) -> SomeHasFS m -> - SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) + SnapshotManager m m blk (StateRef m ExtLedgerState blk) snapshotManager ccfg tracer fs = SnapshotManager { listSnapshots = defaultListSnapshots fs @@ -270,6 +291,7 @@ snapshotManager ccfg tracer fs = {-# INLINE implTakeSnapshot #-} implTakeSnapshot :: + forall m blk. ( IOLike m , LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk @@ -278,7 +300,7 @@ implTakeSnapshot :: Tracer m (TraceSnapshotEvent blk) -> SomeHasFS m -> Maybe String -> - StateRef m (ExtLedgerState blk) -> + StateRef m ExtLedgerState blk -> m (Maybe (DiskSnapshot, RealPoint blk)) implTakeSnapshot ccfg tracer shfs@(SomeHasFS hasFS) suffix st = do case pointToWithOriginRealPoint (castPoint (getTip $ state st)) of @@ -298,7 +320,8 @@ implTakeSnapshot ccfg tracer shfs@(SomeHasFS hasFS) suffix st = do writeSnapshot ds = do createDirectoryIfMissing hasFS True $ snapshotToDirPath ds crc1 <- writeExtLedgerState shfs (encodeDiskExtLedgerState ccfg) (snapshotToStatePath ds) $ state st - crc2 <- takeHandleSnapshot (tables st) (state st) $ snapshotToDirName ds + npcrc2 <- takeHandleSnapshot (tables st) (state st) $ snapshotToDirName ds + let crc2 = hcfoldMap (Proxy @Top) unK npcrc2 writeSnapshotMetadata shfs ds $ SnapshotMetadata { snapshotBackend = UTxOHDMemSnapshot @@ -315,7 +338,7 @@ loadSnapshot :: ( LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk , IOLike m - , LedgerSupportsInMemoryLedgerDB (LedgerState blk) + , LedgerSupportsInMemoryLedgerDB LedgerState blk ) => Tracer m LedgerDBV2Trace -> ResourceRegistry m -> @@ -339,20 +362,38 @@ loadSnapshot tracer _rr ccfg fs@(SomeHasFS hfs) ds = do case pointToWithOriginRealPoint (castPoint (getTip extLedgerSt)) of Origin -> throwE InitFailureGenesis NotOrigin pt -> do - (values, Identity crcTables) <- - withExceptT (InitFailureRead . ReadSnapshotFailed) $ - ExceptT $ - readIncremental - fs - Identity - (valuesMKDecoder extLedgerSt) - (snapshotToDirPath ds mkFsPath ["tables"]) + decodedTables <- + let decs = valuesMKDecoder (ledgerState extLedgerSt) + in hctraverse' (Proxy @TableLabel) f decs + + let crcTables = hcfoldMap (Proxy @Top) (\(Pair _ (K (Identity crc))) -> crc) decodedTables let computedCRC = crcOfConcat checksumAsRead crcTables Monad.when (computedCRC /= snapshotChecksum snapshotMeta) $ throwE $ InitFailureRead $ ReadSnapshotDataCorruption - (,pt) <$> lift (empty extLedgerSt values (newInMemoryLedgerTablesHandle tracer fs)) + (,pt) + <$> lift + ( empty + extLedgerSt + (LedgerTables $ hmap (\(Pair a _) -> a) decodedTables) + (newInMemoryLedgerTablesHandle tracer fs) + ) + where + f :: + forall s table. + (PrimState m ~ s, TableLabel table) => + (Decoder s :.: Table ValuesMK blk) table -> + ExceptT (SnapshotFailure blk) m (Product (Table ValuesMK blk) (K (Identity CRC)) table) + f (Comp dec) = + fmap (\(t, crc) -> Pair t (K crc)) $ + withExceptT (InitFailureRead . ReadSnapshotFailed) $ + ExceptT $ + readIncremental + fs + Identity + dec + (snapshotToDirPath ds mkFsPath [tableLabel (Proxy @table)]) type data Mem @@ -360,7 +401,7 @@ instance ( IOLike m , LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk - , LedgerSupportsInMemoryLedgerDB (LedgerState blk) + , LedgerSupportsInMemoryLedgerDB LedgerState blk ) => Backend m Mem blk where @@ -384,34 +425,39 @@ mkInMemoryArgs :: ( IOLike m , LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk - , LedgerSupportsInMemoryLedgerDB (LedgerState blk) + , LedgerSupportsInMemoryLedgerDB LedgerState blk ) => a -> (LedgerDbBackendArgs m blk, a) mkInMemoryArgs = (,) $ LedgerDbBackendArgsV2 $ SomeBackendArgs InMemArgs -instance IOLike m => StreamingBackend m Mem l where - data YieldArgs m Mem l +instance + (All SingI (TablesForBlock blk), IOLike m, All TableLabel (TablesForBlock blk)) => + StreamingBackend m Mem blk + where + data YieldArgs m Mem blk = -- \| Yield an in-memory snapshot YieldInMemory -- \| How to make a SomeHasFS for @m@ (MountPoint -> SomeHasFS m) - -- \| The file path at which the HasFS has to be opened + -- \| The file path at which the HasFS has to be opened, must be the snapshot directory FilePath - (Decoders l) + -- \| Codecs + (TablesCodecs blk) - data SinkArgs m Mem l + data SinkArgs m Mem blk = SinkInMemory Int - (TxIn l -> Encoding) - (TxOut l -> Encoding) + -- \| Codecs + (TablesCodecs blk) (SomeHasFS m) + -- \| The file path at which the HasFS has to be opened, must be the snapshot directory FilePath - yield _ (YieldInMemory mkFs fp (Decoders decK decV)) = - yieldInMemoryS mkFs fp decK decV + yield _ (YieldInMemory mkFs fp (TablesCodecs dec)) = + hcmap (Proxy @TableLabel) (\cdc -> yieldInMemoryS mkFs fp (decK cdc) (decV cdc)) dec - sink _ (SinkInMemory chunkSize encK encV shfs fp) = - sinkInMemoryS chunkSize encK encV shfs fp + sink _ (SinkInMemory chunkSize (TablesCodecs dec) shfs fp) = + hcmap (Proxy @TableLabel) (\cdc -> sinkInMemoryS chunkSize (encK cdc) (encV cdc) shfs fp) dec {------------------------------------------------------------------------------- Streaming @@ -451,13 +497,13 @@ yieldCborMapS :: (forall s. Decoder s b) -> Stream (Of ByteString) m (Maybe CRC) -> Stream (Of (a, b)) (ExceptT DeserialiseFailure m) (Stream (Of ByteString) m (Maybe CRC)) -yieldCborMapS decK decV = execStateT $ do +yieldCborMapS decKey decValue = execStateT $ do hoist lift (decodeCbor decodeListLen >> decodeCbor decodeMapLenOrIndef) >>= \case Nothing -> go Just n -> replicateM_ n yieldKV where yieldKV = do - kv <- hoist lift $ decodeCbor $ (,) <$> decK <*> decV + kv <- hoist lift $ decodeCbor $ (,) <$> decKey <*> decValue lift $ S.yield kv go = do @@ -476,41 +522,44 @@ yieldCborMapS decK decV = execStateT $ do Codec.CBOR.Read.Fail _bs _off err -> throwError err yieldInMemoryS :: - (MonadThrow m, MonadST m) => + forall m blk table. + (MonadThrow m, MonadST m, TableLabel table) => (MountPoint -> SomeHasFS m) -> FilePath -> - (forall s. Decoder s (TxIn l)) -> - (forall s. Decoder s (TxOut l)) -> - Yield m l -yieldInMemoryS mkFs (F.splitFileName -> (fp, fn)) decK decV _ k = - streamingFile (mkFs $ MountPoint fp) (mkFsPath [fn]) $ \s -> do - k $ yieldCborMapS decK decV s + (forall s. Decoder s (Key table)) -> + (forall s. Decoder s (Value table blk)) -> + Yield m blk table +yieldInMemoryS mkFs fp decKey decValue = Yield $ \_ k -> + streamingFile (mkFs $ MountPoint fp) (mkFsPath [tableLabel (Proxy @table)]) $ \s -> do + k $ yieldCborMapS decKey decValue s sinkInMemoryS :: - forall m l. - MonadThrow m => + forall m blk table. + (MonadThrow m, TableLabel table) => Int -> - (TxIn l -> Encoding) -> - (TxOut l -> Encoding) -> + (Key table -> Encoding) -> + (Value table blk -> Encoding) -> SomeHasFS m -> FilePath -> - Sink m l -sinkInMemoryS writeChunkSize encK encV (SomeHasFS fs) fp _ s = - ExceptT $ withFile fs (mkFsPath [fp]) (WriteMode MustBeNew) $ \hdl -> do - let bs = toStrictByteString (encodeListLen 1 <> encodeMapLenIndef) - let !crc0 = updateCRC bs initCRC - void $ hPutSome fs hdl bs - e <- runExceptT $ go hdl crc0 writeChunkSize mempty s - case e of - Left err -> pure $ Left err - Right (r, crc1) -> do - let bs1 = toStrictByteString encodeBreak - void $ hPutSome fs hdl bs1 - let !crc2 = updateCRC bs1 crc1 - pure $ Right (fmap (,Just crc2) r) + Sink m blk table +sinkInMemoryS writeChunkSize encKey encValue (SomeHasFS fs) fp = Sink $ \_ s -> + ExceptT $ + withFile fs (mkFsPath [fp, tableLabel (Proxy @table)]) (WriteMode MustBeNew) $ + \hdl -> do + let bs = toStrictByteString (encodeListLen 1 <> encodeMapLenIndef) + let !crc0 = updateCRC bs initCRC + void $ hPutSome fs hdl bs + e <- runExceptT $ go hdl crc0 writeChunkSize mempty s + case e of + Left err -> pure $ Left err + Right (r, crc1) -> do + let bs1 = toStrictByteString encodeBreak + void $ hPutSome fs hdl bs1 + let !crc2 = updateCRC bs1 crc1 + pure $ Right (fmap (,Just crc2) r) where go tb !crc 0 m s' = do - let bs = toStrictByteString $ mconcat [encK k <> encV v | (k, v) <- reverse m] + let bs = toStrictByteString $ mconcat [encKey k <> encValue v | (k, v) <- reverse m] lift $ void $ hPutSome fs tb bs let !crc1 = updateCRC bs crc go tb crc1 writeChunkSize mempty s' @@ -518,7 +567,7 @@ sinkInMemoryS writeChunkSize encK encV (SomeHasFS fs) fp _ s = mbs <- S.uncons s' case mbs of Nothing -> do - let bs = toStrictByteString $ mconcat [encK k <> encV v | (k, v) <- reverse m] + let bs = toStrictByteString $ mconcat [encKey k <> encValue v | (k, v) <- reverse m] lift $ void $ hPutSome fs tb bs let !crc1 = updateCRC bs crc (,crc1) <$> S.effects s' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs index f1f10d2d30..60c5ad1828 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs @@ -1,19 +1,17 @@ +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NamedFieldPuns #-} -- | The data structure that holds the cached ledger states. module Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq @@ -51,11 +49,14 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq , snapshots , tip , volatileStatesBimap + , castLedgerTablesHandle ) where import Cardano.Ledger.BaseTypes import Control.ResourceRegistry import Data.Function (on) +import Data.SOP.BasicFunctors +import Data.SOP.Strict import Data.Word import GHC.Generics import NoThunks.Class @@ -81,12 +82,12 @@ import Prelude hiding (read) -------------------------------------------------------------------------------} -- | The interface fulfilled by handles on both the InMemory and LSM handles. -data LedgerTablesHandle m l = LedgerTablesHandle +data LedgerTablesHandle m l blk = LedgerTablesHandle { close :: !(m ()) , transfer :: !(ResourceKey m -> m ()) -- ^ Update the closing action in this handle with a new resource key, as the -- handle has moved to a different registry. - , duplicate :: !(ResourceRegistry m -> m (ResourceKey m, LedgerTablesHandle m l)) + , duplicate :: !(ResourceRegistry m -> m (ResourceKey m, LedgerTablesHandle m l blk)) -- ^ Create a copy of the handle. -- -- A duplicated handle must provide access to all the data that was there in @@ -96,10 +97,10 @@ data LedgerTablesHandle m l = LedgerTablesHandle -- When applying diffs to a table, we will first duplicate the handle, then -- apply the diffs in the copy. It is expected that duplicating the handle -- takes constant time. - , read :: !(l EmptyMK -> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)) + , read :: !(l blk EmptyMK -> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)) -- ^ Read values for the given keys from the tables, and deserialize them as -- if they were from the same era as the given ledger state. - , readRange :: !(l EmptyMK -> (Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK, Maybe (TxIn l))) + , readRange :: !(forall table. TableConstraints blk table => Proxy table -> l blk EmptyMK -> (Maybe (Key table), Int) -> m (Table ValuesMK blk table, Maybe (Key table))) -- ^ Read the requested number of values, possibly starting from the given -- key, from the tables, and deserialize them as if they were from the same -- era as the given ledger state. @@ -114,11 +115,11 @@ data LedgerTablesHandle m l = LedgerTablesHandle -- back into the next iteration of the range read. If the function returns -- Nothing, it means the read returned no results, or in other words, we -- reached the end of the ledger tables. - , readAll :: !(l EmptyMK -> m (LedgerTables l ValuesMK)) + , readAll :: !(l blk EmptyMK -> m (LedgerTables blk ValuesMK)) -- ^ Costly read all operation, not to be used in Consensus but only in -- snapshot-converter executable. The values will be read as if they were from -- the same era as the given ledger state. - , pushDiffs :: !(forall mk. l mk -> l DiffMK -> m ()) + , pushDiffs :: !(forall mk. l blk mk -> l blk DiffMK -> m ()) -- ^ Push some diffs into the ledger tables handle. -- -- The first argument has to be the ledger state before applying @@ -126,16 +127,42 @@ data LedgerTablesHandle m l = LedgerTablesHandle -- applying a block. See 'CanUpgradeLedgerTables'. -- -- Note 'CanUpgradeLedgerTables' is only used in the InMemory backend. - , takeHandleSnapshot :: !(l EmptyMK -> String -> m (Maybe CRC)) + , takeHandleSnapshot :: !(l blk EmptyMK -> String -> m (NP (K (Maybe CRC)) (TablesForBlock blk))) -- ^ Take a snapshot of a handle. The given ledger state is used to decide the -- encoding of the values based on the current era. -- -- It returns a CRC only on backends that support it, as the InMemory backend. - , tablesSize :: !(m (Maybe Int)) + , tablesSize :: !(m (Maybe (NP (K Int) (TablesForBlock blk)))) -- ^ Consult the size of the ledger tables in the database. This will return -- 'Nothing' in backends that do not support this operation. } - deriving NoThunks via OnlyCheckWhnfNamed "LedgerTablesHandle" (LedgerTablesHandle m l) + deriving NoThunks via OnlyCheckWhnfNamed "LedgerTablesHandle" (LedgerTablesHandle m l blk) + +castLedgerTablesHandle :: Functor m => LedgerTablesHandle m LedgerState blk -> LedgerTablesHandle m ExtLedgerState blk +castLedgerTablesHandle h = + LedgerTablesHandle { + close + , transfer + , duplicate = \reg -> (\(x, y) -> (x, castLedgerTablesHandle y)) <$> duplicate reg + , read = \l -> read (ledgerState l) + , readRange = \p l -> readRange p (ledgerState l) + , readAll = \l -> readAll (ledgerState l) + , pushDiffs = \l1 l2 -> pushDiffs (ledgerState l1) (ledgerState l2) + , takeHandleSnapshot = \l -> takeHandleSnapshot (ledgerState l) + , tablesSize + } + where + LedgerTablesHandle { + close + , transfer + , duplicate + , read + , readRange + , readAll + , pushDiffs + , takeHandleSnapshot + , tablesSize + } = h {------------------------------------------------------------------------------- StateRef, represents a full ledger state, i.e. with a handle for its tables @@ -158,21 +185,21 @@ data LedgerTablesHandle m l = LedgerTablesHandle -- Therefore it sounds reasonable to hold a @LedgerState blk EmptyMK@ with no -- values, and a @LedgerTables blk ValuesMK@ next to it, that will live its -- entire lifetime as @LedgerTables@ of the @HardForkBlock@. -data StateRef m l = StateRef - { state :: !(l EmptyMK) - , tables :: !(LedgerTablesHandle m l) +data StateRef m l blk = StateRef + { state :: !(l blk EmptyMK) + , tables :: !(LedgerTablesHandle m l blk) } deriving Generic -deriving instance (IOLike m, NoThunks (l EmptyMK)) => NoThunks (StateRef m l) +deriving instance (IOLike m, NoThunks (l blk EmptyMK)) => NoThunks (StateRef m l blk) -instance Eq (l EmptyMK) => Eq (StateRef m l) where +instance Eq (l blk EmptyMK) => Eq (StateRef m l blk) where (==) = (==) `on` state -instance Show (l EmptyMK) => Show (StateRef m l) where +instance Show (l blk EmptyMK) => Show (StateRef m l blk) where show = show . state -instance GetTip l => Anchorable (WithOrigin SlotNo) (StateRef m l) (StateRef m l) where +instance GetTip (l blk) => Anchorable (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk) where asAnchor = id getAnchorMeasure _ = getTipSlot . state @@ -180,17 +207,17 @@ instance GetTip l => Anchorable (WithOrigin SlotNo) (StateRef m l) (StateRef m l The LedgerSeq -------------------------------------------------------------------------------} -newtype LedgerSeq m l = LedgerSeq - { getLedgerSeq :: AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l) +newtype LedgerSeq m l blk = LedgerSeq + { getLedgerSeq :: AnchoredSeq (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk) } deriving Generic -deriving newtype instance (IOLike m, NoThunks (l EmptyMK)) => NoThunks (LedgerSeq m l) +deriving newtype instance (IOLike m, NoThunks (l blk EmptyMK)) => NoThunks (LedgerSeq m l blk) -deriving newtype instance Eq (l EmptyMK) => Eq (LedgerSeq m l) -deriving newtype instance Show (l EmptyMK) => Show (LedgerSeq m l) +deriving newtype instance Eq (l blk EmptyMK) => Eq (LedgerSeq m l blk) +deriving newtype instance Show (l blk EmptyMK) => Show (LedgerSeq m l blk) -type LedgerSeq' m blk = LedgerSeq m (ExtLedgerState blk) +type LedgerSeq' m blk = LedgerSeq m ExtLedgerState blk {------------------------------------------------------------------------------- Construction @@ -198,29 +225,29 @@ type LedgerSeq' m blk = LedgerSeq m (ExtLedgerState blk) -- | Creates an empty @LedgerSeq@ empty :: - ( GetTip l + ( GetTip (l blk) , IOLike m ) => - l EmptyMK -> + l blk EmptyMK -> init -> - (init -> m (LedgerTablesHandle m l)) -> - m (LedgerSeq m l) + (init -> m (LedgerTablesHandle m l blk)) -> + m (LedgerSeq m l blk) empty st tbs new = LedgerSeq . AS.Empty . StateRef st <$> new tbs -- | Creates an empty @LedgerSeq@ empty' :: - ( GetTip l + ( GetTip (l blk) , IOLike m - , HasLedgerTables l + , HasLedgerTables l blk ) => - l ValuesMK -> - (l ValuesMK -> m (LedgerTablesHandle m l)) -> - m (LedgerSeq m l) + l blk ValuesMK -> + (l blk ValuesMK -> m (LedgerTablesHandle m l blk)) -> + m (LedgerSeq m l blk) empty' st = empty (forgetLedgerTables st) st -- | Close all 'LedgerTablesHandle' in this 'LedgerSeq', in particular that on -- the anchor. -closeLedgerSeq :: Monad m => LedgerSeq m l -> m () +closeLedgerSeq :: Monad m => LedgerSeq m l blk -> m () closeLedgerSeq (LedgerSeq l) = mapM_ (close . tables) $ AS.anchor l : AS.toOldestFirst l @@ -235,10 +262,10 @@ closeLedgerSeq (LedgerSeq l) = reapplyThenPush :: (IOLike m, ApplyBlock l blk) => ResourceRegistry m -> - LedgerDbCfg l -> + LedgerDbCfg (l blk) -> blk -> - LedgerSeq m l -> - m (m (), LedgerSeq m l) + LedgerSeq m l blk -> + m (m (), LedgerSeq m l blk) reapplyThenPush rr cfg ap db = (\current' -> pruneToImmTipOnly $ extend current' db) <$> reapplyBlock (ledgerDbCfgComputeLedgerEvents cfg) (ledgerDbCfg cfg) ap rr db @@ -247,11 +274,11 @@ reapplyBlock :: forall m l blk. (ApplyBlock l blk, IOLike m) => ComputeLedgerEvents -> - LedgerCfg l -> + LedgerCfg (l blk) -> blk -> ResourceRegistry m -> - LedgerSeq m l -> - m (StateRef m l) + LedgerSeq m l blk -> + m (StateRef m l blk) reapplyBlock evs cfg b rr db = do let ks = getBlockKeySets b StateRef st tbs = currentHandle db @@ -275,10 +302,10 @@ reapplyBlock evs cfg b rr db = do -- -- where @lX@ is a ledger state from slot @X-1@ (or 'Origin' for @l0@). prune :: - (Monad m, GetTip l) => + (Monad m, GetTip (l blk)) => LedgerDbPrune -> - LedgerSeq m l -> - (m (), LedgerSeq m l) + LedgerSeq m l blk -> + (m (), LedgerSeq m l blk) prune howToPrune (LedgerSeq ldb) = case howToPrune of LedgerDbPruneAll -> (closeButHead before, LedgerSeq after) @@ -316,10 +343,10 @@ prune howToPrune (LedgerSeq ldb) = case howToPrune of -- >>> AS.toOldestFirst ldb' == [l1, l2, l3, l4] -- True extend :: - GetTip l => - StateRef m l -> - LedgerSeq m l -> - LedgerSeq m l + GetTip (l blk) => + StateRef m l blk -> + LedgerSeq m l blk -> + LedgerSeq m l blk extend newState = LedgerSeq . (:> newState) . getLedgerSeq @@ -334,9 +361,9 @@ extend newState = -- >>> AS.anchor ldb' == l3 && AS.toOldestFirst ldb' == [] -- True pruneToImmTipOnly :: - (Monad m, GetTip l) => - LedgerSeq m l -> - (m (), LedgerSeq m l) + (Monad m, GetTip (l blk)) => + LedgerSeq m l blk -> + (m (), LedgerSeq m l blk) pruneToImmTipOnly = prune LedgerDbPruneAll {------------------------------------------------------------------------------- @@ -352,10 +379,10 @@ pruneToImmTipOnly = prune LedgerDbPruneAll -- >>> fmap (([l1] ==) . AS.toOldestFirst . getLedgerSeq) (rollbackN 2 ldb) -- Just True rollbackN :: - GetTip l => + GetTip (l blk) => Word64 -> - LedgerSeq m l -> - Maybe (LedgerSeq m l) + LedgerSeq m l blk -> + Maybe (LedgerSeq m l blk) rollbackN n ldb | n <= maxRollback ldb = Just $ LedgerSeq (AS.dropNewest (fromIntegral n) $ getLedgerSeq ldb) @@ -371,10 +398,10 @@ rollbackN n ldb -- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3] -- >>> l3s == current ldb -- True -current :: GetTip l => LedgerSeq m l -> l EmptyMK +current :: GetTip (l blk) => LedgerSeq m l blk -> l blk EmptyMK current = state . currentHandle -currentHandle :: GetTip l => LedgerSeq m l -> StateRef m l +currentHandle :: GetTip (l blk) => LedgerSeq m l blk -> StateRef m l blk currentHandle = headAnchor . getLedgerSeq -- | The ledger state at the anchor of the Volatile chain (i.e. the immutable @@ -383,10 +410,10 @@ currentHandle = headAnchor . getLedgerSeq -- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3] -- >>> l0s == anchor ldb -- True -anchor :: LedgerSeq m l -> l EmptyMK +anchor :: LedgerSeq m l blk -> l blk EmptyMK anchor = state . anchorHandle -anchorHandle :: LedgerSeq m l -> StateRef m l +anchorHandle :: LedgerSeq m l blk -> StateRef m l blk anchorHandle = AS.anchor . getLedgerSeq -- | All snapshots currently stored by the ledger DB (new to old) @@ -397,7 +424,7 @@ anchorHandle = AS.anchor . getLedgerSeq -- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3] -- >>> [(0, l3s), (1, l2s), (2, l1s)] == snapshots ldb -- True -snapshots :: LedgerSeq m l -> [(Word64, l EmptyMK)] +snapshots :: LedgerSeq m l blk -> [(Word64, l blk EmptyMK)] snapshots = zip [0 ..] . map state @@ -409,7 +436,7 @@ snapshots = -- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3] -- >>> maxRollback ldb -- 3 -maxRollback :: GetTip l => LedgerSeq m l -> Word64 +maxRollback :: GetTip (l blk) => LedgerSeq m l blk -> Word64 maxRollback = fromIntegral . AS.length @@ -420,7 +447,7 @@ maxRollback = -- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3] -- >>> tip ldb == getTip l3s -- True -tip :: GetTip l => LedgerSeq m l -> Point l +tip :: GetTip (l blk) => LedgerSeq m l blk -> Point (l blk) tip = castPoint . getTip . current -- | Have we seen at least @k@ blocks? @@ -430,7 +457,7 @@ tip = castPoint . getTip . current -- True -- >>> isSaturated (SecurityParam (unsafeNonZero 4)) ldb -- False -isSaturated :: GetTip l => SecurityParam -> LedgerSeq m l -> Bool +isSaturated :: GetTip (l blk) => SecurityParam -> LedgerSeq m l blk -> Bool isSaturated (SecurityParam k) db = maxRollback db >= unNonZero k @@ -448,13 +475,13 @@ isSaturated (SecurityParam k) db = -- True getPastLedgerAt :: ( HasHeader blk - , GetTip l - , HeaderHash l ~ HeaderHash blk - , StandardHash l + , GetTip (l blk) + , HeaderHash (l blk) ~ HeaderHash blk + , StandardHash (l blk) ) => Point blk -> - LedgerSeq m l -> - Maybe (l EmptyMK) + LedgerSeq m l blk -> + Maybe (l blk EmptyMK) getPastLedgerAt pt db = current <$> rollback pt db -- | Roll back the volatile states up to the specified point. @@ -469,10 +496,10 @@ getPastLedgerAt pt db = current <$> rollback pt db -- >>> AS.anchor ldb' == l0 && AS.toOldestFirst ldb' == [l1, l2] -- True rollbackToPoint :: - ( StandardHash l - , GetTip l + ( StandardHash (l blk) + , GetTip (l blk) ) => - Point l -> LedgerSeq m l -> Maybe (LedgerSeq m l) + Point (l blk) -> LedgerSeq m l blk -> Maybe (LedgerSeq m l blk) rollbackToPoint pt (LedgerSeq ldb) = do LedgerSeq <$> AS.rollback @@ -487,8 +514,8 @@ rollbackToPoint pt (LedgerSeq ldb) = do -- >>> AS.anchor ldb' == l0 && AS.toOldestFirst ldb' == [] -- True rollbackToAnchor :: - GetTip l => - LedgerSeq m l -> LedgerSeq m l + GetTip (l blk) => + LedgerSeq m l blk -> LedgerSeq m l blk rollbackToAnchor (LedgerSeq vol) = LedgerSeq (AS.Empty (AS.anchor vol)) @@ -499,14 +526,14 @@ rollbackToAnchor (LedgerSeq vol) = -- When no ledger state (or anchor) has the given 'Point', 'Nothing' is -- returned. rollback :: - ( HasHeader blk - , GetTip l - , HeaderHash l ~ HeaderHash blk - , StandardHash l + ( GetTip (l blk) + , StandardHash (l blk) + , StandardHash blk + , HeaderHash (l blk) ~ HeaderHash blk ) => Point blk -> - LedgerSeq m l -> - Maybe (LedgerSeq m l) + LedgerSeq m l blk -> + Maybe (LedgerSeq m l blk) rollback pt db | pt == castPoint (getTip (anchor db)) = Just $ rollbackToAnchor db @@ -514,8 +541,8 @@ rollback pt db rollbackToPoint (castPoint pt) db immutableTipSlot :: - GetTip l => - LedgerSeq m l -> WithOrigin SlotNo + GetTip (l blk) => + LedgerSeq m l blk -> WithOrigin SlotNo immutableTipSlot = getTipSlot . state @@ -525,9 +552,9 @@ immutableTipSlot = -- | Transform the underlying volatile 'AnchoredSeq' using the given functions. volatileStatesBimap :: AS.Anchorable (WithOrigin SlotNo) a b => - (l EmptyMK -> a) -> - (l EmptyMK -> b) -> - LedgerSeq m l -> + (l blk EmptyMK -> a) -> + (l blk EmptyMK -> b) -> + LedgerSeq m l blk -> AS.AnchoredSeq (WithOrigin SlotNo) a b volatileStatesBimap f g = AS.bimap (f . state) (g . state) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs index afeda4e651..1b066ebeae 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs @@ -22,7 +22,6 @@ module Ouroboros.Consensus.TypeFamilyWrappers , WrapTentativeHeaderState (..) , WrapTentativeHeaderView (..) , WrapTipInfo (..) - , WrapTxIn (..) , WrapTxMeasure (..) , WrapTxOut (..) , WrapValidatedGenTx (..) @@ -89,8 +88,7 @@ newtype WrapValidatedGenTx blk = WrapValidatedGenTx {unwrapValidatedGenTx :: Val newtype WrapTxMeasure blk = WrapTxMeasure {unwrapTxMeasure :: TxMeasure blk} -newtype WrapTxIn blk = WrapTxIn {unwrapTxIn :: TxIn (LedgerState blk)} -newtype WrapTxOut blk = WrapTxOut {unwrapTxOut :: TxOut (LedgerState blk)} +newtype WrapTxOut blk = WrapTxOut {unwrapTxOut :: TxOut blk} {------------------------------------------------------------------------------- Consensus based @@ -159,15 +157,10 @@ deriving instance deriving instance NoThunks (Validated (GenTx blk)) => NoThunks (WrapValidatedGenTx blk) -deriving instance Show (TxIn (LedgerState blk)) => Show (WrapTxIn blk) -deriving instance Eq (TxIn (LedgerState blk)) => Eq (WrapTxIn blk) -deriving instance Ord (TxIn (LedgerState blk)) => Ord (WrapTxIn blk) -deriving instance NoThunks (TxIn (LedgerState blk)) => NoThunks (WrapTxIn blk) - -deriving instance Show (TxOut (LedgerState blk)) => Show (WrapTxOut blk) -deriving instance Eq (TxOut (LedgerState blk)) => Eq (WrapTxOut blk) -deriving instance Ord (TxOut (LedgerState blk)) => Ord (WrapTxOut blk) -deriving instance NoThunks (TxOut (LedgerState blk)) => NoThunks (WrapTxOut blk) +deriving instance Show (TxOut blk) => Show (WrapTxOut blk) +deriving instance Eq (TxOut blk) => Eq (WrapTxOut blk) +deriving instance Ord (TxOut blk) => Ord (WrapTxOut blk) +deriving instance NoThunks (TxOut blk) => NoThunks (WrapTxOut blk) {------------------------------------------------------------------------------- .. consensus based diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CRC.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CRC.hs index a7388755e4..8d5fa87a09 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CRC.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CRC.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Util.CRC ( CRCError (..) @@ -17,6 +18,12 @@ import System.FS.API import System.FS.API.Lazy import System.FS.CRC +instance Semigroup CRC where + (<>) = crcOfConcat + +instance Monoid CRC where + mempty = initCRC + crcOfConcat :: CRC -> CRC -> CRC crcOfConcat crc1 crc2 = computeCRC $ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IndexedMemPack.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IndexedMemPack.hs index ae972120f1..8992a96b30 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IndexedMemPack.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IndexedMemPack.hs @@ -1,7 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- | This module is a derivative of "Data.MemPack" but we provide something that -- will be used to " index " the serialization. @@ -26,73 +30,113 @@ import Control.Monad.Trans.Fail import Data.Array.Byte (ByteArray (..)) import Data.Bifunctor (first) import Data.ByteString +import Data.Kind (Constraint, Type) import Data.MemPack import Data.MemPack.Buffer import Data.MemPack.Error +import Data.Proxy import GHC.Stack +import Ouroboros.Consensus.Ledger.LedgerStateType +import Ouroboros.Consensus.Ledger.Tables.MapKind (EmptyMK) -- | See 'MemPack'. -class IndexedMemPack idx a where - indexedPackedByteCount :: idx -> a -> Int - indexedPackM :: idx -> a -> Pack s () - indexedUnpackM :: Buffer b => forall s. idx -> Unpack s b a - indexedTypeName :: idx -> String +type IndexedMemPack :: StateKind -> Type -> k -> Constraint +class IndexedMemPack l blk table where + type IndexedValue l table blk + indexedPackedByteCount :: + Proxy l -> + Proxy blk -> + Proxy table -> + l blk EmptyMK -> + IndexedValue l table blk -> + Int + + indexedPackM :: + Proxy l -> + Proxy blk -> + Proxy table -> + l blk EmptyMK -> + IndexedValue l table blk -> + Pack s () + + indexedUnpackM :: + Buffer b => + Proxy l -> + Proxy blk -> + Proxy table -> + forall s. l blk EmptyMK -> Unpack s b (IndexedValue l table blk) + + indexedTypeName :: Proxy l -> Proxy blk -> Proxy table -> String indexedPackByteString :: - forall a idx. (IndexedMemPack idx a, HasCallStack) => idx -> a -> ByteString -indexedPackByteString idx = pinnedByteArrayToByteString . indexedPackByteArray True idx + forall table l blk. + (IndexedMemPack l blk table, HasCallStack) => + l blk EmptyMK -> IndexedValue l table blk -> ByteString +indexedPackByteString idx = pinnedByteArrayToByteString . indexedPackByteArray @table True idx {-# INLINE indexedPackByteString #-} indexedPackByteArray :: - forall a idx. - (IndexedMemPack idx a, HasCallStack) => + forall table (l :: StateKind) blk. + (IndexedMemPack l blk table, HasCallStack) => Bool -> - idx -> - a -> + l blk EmptyMK -> + IndexedValue l table blk -> ByteArray indexedPackByteArray isPinned idx a = packWithByteArray isPinned - (indexedTypeName @idx @a idx) - (indexedPackedByteCount idx a) - (indexedPackM idx a) + (indexedTypeName (Proxy @l) (Proxy @blk) (Proxy @table)) + (indexedPackedByteCount (Proxy @l) (Proxy @blk) (Proxy @table) idx a) + (indexedPackM (Proxy @l) (Proxy @blk) (Proxy @table) idx a) {-# INLINE indexedPackByteArray #-} indexedUnpackError :: - forall idx a b. (Buffer b, IndexedMemPack idx a, HasCallStack) => idx -> b -> a -indexedUnpackError idx = errorFail . indexedUnpackFail idx + forall table l blk b. + (Buffer b, IndexedMemPack l blk table, HasCallStack) => + l blk EmptyMK -> b -> IndexedValue l table blk +indexedUnpackError idx = errorFail . indexedUnpackFail @table idx {-# INLINEABLE indexedUnpackError #-} indexedUnpackFail :: - forall idx a b. (IndexedMemPack idx a, Buffer b, HasCallStack) => idx -> b -> Fail SomeError a + forall table l blk b. + (IndexedMemPack l blk table, Buffer b, HasCallStack) => + l blk EmptyMK -> b -> Fail SomeError (IndexedValue l table blk) indexedUnpackFail idx b = do let len = bufferByteCount b - (a, consumedBytes) <- indexedUnpackLeftOver idx b + (a, consumedBytes) <- indexedUnpackLeftOver @table idx b Monad.when (consumedBytes /= len) $ - unpackFailNotFullyConsumed (indexedTypeName @idx @a idx) consumedBytes len + unpackFailNotFullyConsumed + (indexedTypeName (Proxy @l) (Proxy @blk) (Proxy @table)) + consumedBytes + len pure a {-# INLINEABLE indexedUnpackFail #-} indexedUnpackLeftOver :: - forall idx a b. - (IndexedMemPack idx a, Buffer b, HasCallStack) => idx -> b -> Fail SomeError (a, Int) -indexedUnpackLeftOver idx b = FailT $ pure $ runST $ runFailAggT $ indexedUnpackLeftOverST idx b + forall table l blk b. + (IndexedMemPack l blk table, Buffer b, HasCallStack) => + l blk EmptyMK -> b -> Fail SomeError (IndexedValue l table blk, Int) +indexedUnpackLeftOver idx b = FailT $ pure $ runST $ runFailAggT $ indexedUnpackLeftOverST @table idx b {-# INLINEABLE indexedUnpackLeftOver #-} indexedUnpackLeftOverST :: - forall idx a b s. - (IndexedMemPack idx a, Buffer b, HasCallStack) => idx -> b -> FailT SomeError (ST s) (a, Int) + forall table l blk b s. + (IndexedMemPack l blk table, Buffer b, HasCallStack) => + l blk EmptyMK -> b -> FailT SomeError (ST s) (IndexedValue l table blk, Int) indexedUnpackLeftOverST idx b = do let len = bufferByteCount b - res@(_, consumedBytes) <- runStateT (runUnpack (indexedUnpackM idx) b) 0 - Monad.when (consumedBytes > len) $ errorLeftOver (indexedTypeName @idx @a idx) consumedBytes len + res@(_, consumedBytes) <- + runStateT (runUnpack (indexedUnpackM (Proxy @l) (Proxy @blk) (Proxy @table) idx) b) 0 + Monad.when (consumedBytes > len) $ + errorLeftOver (indexedTypeName (Proxy @l) (Proxy @blk) (Proxy @table)) consumedBytes len pure res {-# INLINEABLE indexedUnpackLeftOverST #-} indexedUnpackEither :: - forall idx a b. - (IndexedMemPack idx a, Buffer b, HasCallStack) => idx -> b -> Either SomeError a -indexedUnpackEither idx = first fromMultipleErrors . runFailAgg . indexedUnpackFail idx + forall table l blk b. + (IndexedMemPack l blk table, Buffer b, HasCallStack) => + l blk EmptyMK -> b -> Either SomeError (IndexedValue l table blk) +indexedUnpackEither idx = first fromMultipleErrors . runFailAgg . indexedUnpackFail @table idx {-# INLINEABLE indexedUnpackEither #-} unpackEither :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/TypeLevel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/TypeLevel.hs new file mode 100644 index 0000000000..7d19b806ea --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/TypeLevel.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Ouroboros.Consensus.Util.TypeLevel + ( Unions + , withAllDict + , ToAllDict (..) + , AllDict + , getNPByTag + , findIndex + ) where + +import Data.Kind (Type) +import Data.List.Singletons hiding (All) +import Data.SOP.Constraint (All, SListI) +import qualified Data.SOP.Dict as Dict +import Data.SOP.Index +import Data.SOP.Strict +import Data.Singletons (SingI, sing) +import Data.Type.Equality (TestEquality (testEquality), (:~:) (Refl)) + +type Unions :: [[k]] -> [k] +type family Unions xxs where + Unions '[x] = x + Unions (x ': y ': xs) = Unions (Union x y ': xs) + +type AllDict c xs = NP (Dict.Dict c) xs + +class All c xs => ToAllDict c xs where + toAllDict :: AllDict c xs + +instance ToAllDict c '[] where + toAllDict = Nil + +instance (c x, ToAllDict c xs) => ToAllDict c (x ': xs) where + toAllDict = Dict.Dict :* toAllDict + +withAllDict :: AllDict c xs -> (All c xs => r) -> r +withAllDict Nil k = k +withAllDict (Dict.Dict :* rest) k = withAllDict rest k + +getNPByTag :: + forall k (table :: k) f (tables :: [k]). + ( TestEquality (Sing :: k -> Type) + , SingI tables + , SListI tables + ) => + Sing table -> + NP f tables -> + Maybe (f table) +getNPByTag stag ad = + let mem = findIndex (sing @tables) stag + in fmap (flip projectNP ad) mem + +findIndex :: + forall k (xs :: [k]) (x :: k). + TestEquality (Sing :: k -> Type) => + SList xs -> + Sing x -> + Maybe (Index xs x) +findIndex SNil _ = Nothing +findIndex (SCons sy sxs) sx = + case testEquality sx sy of + Just Refl -> Just IZ + Nothing -> IS <$> findIndex sxs sx diff --git a/sop-extras/src/Data/SOP/InPairs.hs b/sop-extras/src/Data/SOP/InPairs.hs index de1877d63b..98dddac0f6 100644 --- a/sop-extras/src/Data/SOP/InPairs.hs +++ b/sop-extras/src/Data/SOP/InPairs.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | Intended for qualified import diff --git a/strict-sop-core/src/Data/SOP/Strict/NP.hs b/strict-sop-core/src/Data/SOP/Strict/NP.hs index a4c623e1a8..1035847c3d 100644 --- a/strict-sop-core/src/Data/SOP/Strict/NP.hs +++ b/strict-sop-core/src/Data/SOP/Strict/NP.hs @@ -26,11 +26,13 @@ module Data.SOP.Strict.NP , npToSListI , singletonNP , tl + , toStrict ) where import Data.Coerce import Data.Kind (Type) import Data.SOP hiding (NP (..), hd, tl) +import qualified Data.SOP as SOP import Data.SOP.Classes import Data.SOP.Constraint import NoThunks.Class @@ -42,6 +44,10 @@ data NP f xs where infixr 5 :* +toStrict :: SOP.NP f xs -> NP f xs +toStrict SOP.Nil = Nil +toStrict (x SOP.:* xs) = x :* toStrict xs + type instance CollapseTo NP a = [a] type instance AllN NP c = All c type instance AllZipN NP c = AllZip c