diff --git a/cabal.project b/cabal.project index de98dab224..e4c2b948fb 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- update either of these. index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2025-06-03T21:29:34Z + , hackage.haskell.org 2025-06-17T07:53:04Z -- Bump this if you need newer packages from CHaP , cardano-haskell-packages 2025-06-03T13:42:38Z @@ -57,13 +57,8 @@ if impl (ghc >= 9.12) -- https://github.com/kapralVV/Unique/issues/11 , Unique:hashable -source-repository-package - type: git - location: https://github.com/IntersectMBO/ouroboros-network - tag: 3e8d3b4b8c87ead794876c62d7fe25f32efb5142 - --sha256: 08fpkx3iagj83nn413h9a865zjcj3lrf7017a756qd2wg2jg3amq - subdir: - ouroboros-network-api + -- https://github.com/phadej/regression-simple/pull/14 + , regression-simple:base source-repository-package type: git @@ -97,3 +92,33 @@ source-repository-package libs/set-algebra libs/small-steps libs/vector-map + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network + tag: 06d72973b3187758dd57d8f1e2c48c53f23aae1c + --sha256: sha256-i574WLPFteQjyxhogejbNyhQt2E0A0cDmNqWDOfkAw0= + subdir: + network-mux + ouroboros-network + ouroboros-network-api + ouroboros-network-framework + ouroboros-network-mock + ouroboros-network-protocols + ouroboros-network-testing + +source-repository-package + type: git + location: https://github.com/input-output-hk/fs-sim + tag: ee0b75bee5bcd426cfc5433b6c69c67fe6319c1b + --sha256: 0ss4n302khl13fj5f4l6cxfj5vn558s2wk533ikmxhgigf9qas0q + subdir: fs-api + fs-sim + +source-repository-package + type: git + location: https://github.com/jasagredo/lsm-tree + tag: 0fe8b227b78a78503d0201755d50435635da5a22 + subdir: + . + blockio diff --git a/flake.lock b/flake.lock index 8cc47e8ac7..b966f3fc42 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1749025734, - "narHash": "sha256-Gcnpwo+Yp5I+HwQjm7jWAVleHsYhzP34oX/1xJmkgpI=", + "lastModified": 1750632370, + "narHash": "sha256-tg2brm14jly5TLAIgSSYw3Z+ktagPWFTYzuWjukS8+M=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "3d1d71d40bf3dcd129ba0e3fdce7904a4f04b57c", + "rev": "95b0fc262496bd5f85e9686231e497e47657fdff", "type": "github" }, "original": { @@ -254,11 +254,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1749428898, - "narHash": "sha256-IUKLK2emvXkyLIPG7QFZYXgUjy8fjikJ8Hf6KJg/Ck0=", + "lastModified": 1750777164, + "narHash": "sha256-Fg+IpsuF+z/I/5QcCDFbKc6VVzvmWZzUE6ddySuqwqw=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "74c08c2338088dc27041cd9a851ece70accc2d07", + "rev": "e1c181c71d166437e1c09950b1b80a5cd9f9b3b3", "type": "github" }, "original": { diff --git a/ouroboros-consensus-cardano/app/snapshot-converter.hs b/ouroboros-consensus-cardano/app/snapshot-converter.hs index cfc070e4cc..70572a2154 100644 --- a/ouroboros-consensus-cardano/app/snapshot-converter.hs +++ b/ouroboros-consensus-cardano/app/snapshot-converter.hs @@ -166,8 +166,7 @@ checkSnapshotFileStructure m p (SomeHasFS fs) = case m of load :: forall blk. - ( LedgerDbSerialiseConstraints blk - , CanStowLedgerTables (LedgerState blk) + ( CanStowLedgerTables (LedgerState blk) , LedgerSupportsProtocol blk , LedgerSupportsLedgerDB blk ) => @@ -200,7 +199,7 @@ load config@Config{inpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS), pa checkSnapshotFileStructure Mem path fs (ls, _) <- withExceptT SnapshotError $ V2.loadSnapshot nullTracer rr ccfg fs ds let h = V2.currentHandle ls - (V2.state h,) <$> Trans.lift (V2.readAll (V2.tables h)) + (V2.state h,) <$> Trans.lift (V2.readAll (V2.tables h) (V2.state h)) LMDB -> do checkSnapshotFileStructure LMDB path fs ((dbch, k, bstore), _) <- @@ -218,8 +217,7 @@ load config@Config{inpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS), pa load _ _ _ _ = error "Malformed input path!" store :: - ( LedgerDbSerialiseConstraints blk - , CanStowLedgerTables (LedgerState blk) + ( CanStowLedgerTables (LedgerState blk) , LedgerSupportsProtocol blk , LedgerSupportsLedgerDB blk ) => diff --git a/ouroboros-consensus-cardano/golden/shelley/QueryVersion2/ShelleyNodeToClientVersion11/Result_GetBigLedgerPeerSnapshot b/ouroboros-consensus-cardano/golden/shelley/QueryVersion2/ShelleyNodeToClientVersion11/Result_GetBigLedgerPeerSnapshot index 9fdbcecb87..e7f9cd456b 100644 --- a/ouroboros-consensus-cardano/golden/shelley/QueryVersion2/ShelleyNodeToClientVersion11/Result_GetBigLedgerPeerSnapshot +++ b/ouroboros-consensus-cardano/golden/shelley/QueryVersion2/ShelleyNodeToClientVersion11/Result_GetBigLedgerPeerSnapshot @@ -1,3 +1,3 @@ -‚‚‚*Ÿ‚‚ +‚‚‚*Ÿ‚‚ ‚‚ -ŸƒÒŸÿÿÿ \ No newline at end of file +ŸƒŸÿÒÿÿ \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion12/Result_GetBigLedgerPeerSnapshot b/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion12/Result_GetBigLedgerPeerSnapshot index 9fdbcecb87..e7f9cd456b 100644 --- a/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion12/Result_GetBigLedgerPeerSnapshot +++ b/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion12/Result_GetBigLedgerPeerSnapshot @@ -1,3 +1,3 @@ -‚‚‚*Ÿ‚‚ +‚‚‚*Ÿ‚‚ ‚‚ -ŸƒÒŸÿÿÿ \ No newline at end of file +ŸƒŸÿÒÿÿ \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion13/Result_GetBigLedgerPeerSnapshot b/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion13/Result_GetBigLedgerPeerSnapshot index 9fdbcecb87..e7f9cd456b 100644 --- a/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion13/Result_GetBigLedgerPeerSnapshot +++ b/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion13/Result_GetBigLedgerPeerSnapshot @@ -1,3 +1,3 @@ -‚‚‚*Ÿ‚‚ +‚‚‚*Ÿ‚‚ ‚‚ -ŸƒÒŸÿÿÿ \ No newline at end of file +ŸƒŸÿÒÿÿ \ No newline at end of file diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 41b714e2b4..a3370de934 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -163,15 +163,18 @@ library microlens, mtl, nothunks, + lsm-tree, ouroboros-consensus ^>=0.27, + vector, ouroboros-consensus-protocol ^>=0.12, - ouroboros-network-api ^>=0.14, + ouroboros-network-api ^>=0.15, serialise ^>=0.2, singletons ^>=3.0, small-steps, sop-core ^>=0.5, sop-extras ^>=0.4, strict-sop-core ^>=0.1, + primitive, text, these ^>=1.2, validation, @@ -399,6 +402,7 @@ library unstable-cardano-testlib build-depends: QuickCheck, + lsm-tree, base, cardano-crypto-class, cardano-crypto-wrapper, @@ -498,7 +502,7 @@ test-suite cardano-test tasty-hunit, tasty-quickcheck, temporary, - typed-protocols ^>=0.3, + typed-protocols ^>=1.0, unstable-byron-testlib, unstable-cardano-testlib, unstable-shelley-testlib, @@ -580,7 +584,7 @@ library unstable-cardano-tools directory, dot, filepath, - fs-api ^>=0.3, + fs-api ^>=0.4, githash, microlens, mtl, @@ -593,7 +597,7 @@ library unstable-cardano-tools ouroboros-consensus-protocol:{ouroboros-consensus-protocol, unstable-protocol-testlib} ^>=0.12, ouroboros-network, ouroboros-network-api, - ouroboros-network-framework ^>=0.18, + ouroboros-network-framework ^>=0.19, ouroboros-network-protocols, resource-registry, singletons, 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..bfdb9641a9 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/ByronHFC.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/ByronHFC.hs @@ -11,6 +11,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Byron.ByronHFC @@ -29,6 +30,7 @@ import Data.MemPack import Data.SOP.Index (Index (..)) import Data.Void (Void, absurd) import Data.Word +import qualified Database.LSMTree as LSM import GHC.Generics import NoThunks.Class import Ouroboros.Consensus.Block @@ -45,6 +47,7 @@ import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Serialisation import Ouroboros.Consensus.Protocol.PBFT (PBft, PBftCrypto) +import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.IndexedMemPack @@ -292,7 +295,7 @@ instance HasCanonicalTxIn '[ByronBlock] where { getByronHFCTxIn :: Void } deriving stock (Show, Eq, Ord) - deriving newtype (NoThunks, MemPack) + deriving newtype (NoThunks, MemPack, LSM.SerialiseKey) injectCanonicalTxIn IZ key = absurd key injectCanonicalTxIn (IS idx') _ = case idx' of {} @@ -311,6 +314,14 @@ deriving via instance IndexedMemPack (LedgerState (HardForkBlock '[ByronBlock]) EmptyMK) Void +type instance + LSMTxOut (LedgerState (HardForkBlock '[ByronBlock])) = + TxOut (LedgerState (HardForkBlock '[ByronBlock])) + +instance HasLSMTxOut (LedgerState (HardForkBlock '[ByronBlock])) where + toLSMTxOut _ = id + fromLSMTxOut _ = id + 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 {} 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..7626298417 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 @@ -14,6 +14,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Instances requires for consensus/ledger integration @@ -202,6 +203,11 @@ instance IsLedger (LedgerState ByronBlock) where type instance TxIn (LedgerState ByronBlock) = Void type instance TxOut (LedgerState ByronBlock) = Void +type instance LSMTxOut (LedgerState ByronBlock) = TxOut (LedgerState ByronBlock) + +instance HasLSMTxOut (LedgerState ByronBlock) where + toLSMTxOut _ = id + fromLSMTxOut _ = id instance LedgerTablesAreTrivial (LedgerState ByronBlock) where convertMapKind (ByronLedgerState x y z) = ByronLedgerState x y z 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 8eaadc707d..35ab1afe41 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 @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,6 +14,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -39,6 +41,7 @@ import Codec.CBOR.Decoding import Codec.CBOR.Encoding import qualified Data.Map as Map import Data.MemPack +import qualified Data.Primitive.ByteArray as PBA import Data.Proxy import Data.SOP.BasicFunctors import Data.SOP.Functors @@ -46,7 +49,9 @@ import Data.SOP.Index import Data.SOP.Strict import qualified Data.SOP.Tails as Tails import qualified Data.SOP.Telescope as Telescope +import Data.Vector.Primitive (Vector (..)) import Data.Void +import qualified Database.LSMTree as LSM import GHC.Generics (Generic) import Lens.Micro import NoThunks.Class @@ -63,6 +68,7 @@ import Ouroboros.Consensus.Shelley.Ledger , ShelleyCompatible , shelleyLedgerState ) +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.IndexedMemPack @@ -74,7 +80,7 @@ instance { getCardanoTxIn :: SL.TxIn } deriving stock (Show, Eq, Ord) - deriving newtype NoThunks + deriving newtype (NoThunks, LSM.SerialiseKey) injectCanonicalTxIn IZ byronTxIn = absurd byronTxIn injectCanonicalTxIn (IS idx) shelleyTxIn = case idx of @@ -112,13 +118,27 @@ data CardanoTxOut c deriving stock (Show, Eq, Generic) deriving anyclass NoThunks +type instance LSMTxOut (LedgerState (CardanoBlock c)) = LSM.RawBytes + +instance LSM.SerialiseValue LSM.RawBytes where + serialiseValue = id + deserialiseValue = id + +deriving via LSM.ResolveAsFirst LSM.RawBytes instance LSM.ResolveValue LSM.RawBytes + +instance CardanoHardForkConstraints c => HasLSMTxOut (LedgerState (CardanoBlock c)) where + toLSMTxOut _ txout = + let barr = eliminateCardanoTxOut (const pack) txout + in LSM.RawBytes (Vector 0 (PBA.sizeofByteArray barr) barr) + fromLSMTxOut st (LSM.RawBytes (Vector _ _ barr)) = + indexedUnpackError st barr + -- | Eliminate the wrapping of CardanoTxOut with the provided function. Similar -- to 'hcimap' on an 'NS'. eliminateCardanoTxOut :: forall r c. CardanoHardForkConstraints c => ( forall x. - -- TODO ProtoCrypto constraint should be in IsShelleyBlock IsShelleyBlock x => Index (CardanoEras c) x -> TxOut (LedgerState x) -> @@ -181,6 +201,8 @@ instance :* (Fn $ const $ Comp $ K . ConwayTxOut <$> unpackM) :* Nil ) + -- TODO, we can extract the tip before this function! The class would be + -- IndexedMemPack (NS (Flip LedgerState EmptyMK) (CardanoEras c)) (CardanoTxOut c) hcollapse <$> (hsequence' $ hap np $ Telescope.tip idx) instance 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 33b8a12dde..cdf25e2641 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 @@ -379,6 +379,7 @@ instance supportedNodeToNodeVersions _ = Map.fromList $ [ (NodeToNodeV_14, CardanoNodeToNodeVersion2) + , (NodeToNodeV_15, CardanoNodeToNodeVersion2) ] supportedNodeToClientVersions _ = @@ -391,10 +392,7 @@ instance , (NodeToClientV_21, CardanoNodeToClientVersion17) ] - -- This is not set to NodeToClientV_21 on purpose because that one is just a - -- stub. Once we have a proper ouroboros-network to integrate that comes with - -- said version and we remove the SRP then we can bump this value. - latestReleasedNodeVersion _prx = (Just NodeToNodeV_14, Just NodeToClientV_20) + latestReleasedNodeVersion _prx = (Just NodeToNodeV_15, Just NodeToClientV_21) {------------------------------------------------------------------------------- ProtocolInfo diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs index 30d9f1b465..2b54785fdd 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs @@ -1,11 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -77,11 +79,13 @@ import Control.Monad.Except import Control.State.Transition (PredicateFailure) import Data.Data (Proxy (Proxy)) import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Database.LSMTree as LSM import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Ledger.SupportsMempool ( WhetherToIntervene (..) ) import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto) +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM {------------------------------------------------------------------------------- Eras instantiated with standard crypto @@ -404,3 +408,34 @@ instance Core.TranslateEra ConwayEra WrapTx where . Core.translateEra @ConwayEra ctxt . Conway.Tx . unwrapTx + +{------------------------------------------------------------------------------- + SerialiseValue +-------------------------------------------------------------------------------} + +instance LSM.SerialiseValue (SL.ShelleyTxOut ShelleyEra) where + serialiseValue = serialiseLSMViaMemPack + deserialiseValue = deserialiseLSMViaMemPack + +deriving via + LSM.ResolveAsFirst (SL.ShelleyTxOut ShelleyEra) + instance + LSM.ResolveValue (SL.ShelleyTxOut ShelleyEra) + +-- instance LSM.SerialiseValue (SL.ShelleyTxOut AllegraEra) where +-- serialiseValue = serialiseLSMViaMemPack +-- deserialiseValue = deserialiseLSMViaMemPack + +-- deriving via +-- LSM.ResolveAsFirst (SL.ShelleyTxOut AllegraEra) +-- instance +-- LSM.ResolveValue (SL.ShelleyTxOut AllegraEra) + +-- instance LSM.SerialiseValue (SL.ShelleyTxOut MaryEra) where +-- serialiseValue = serialiseLSMViaMemPack +-- deserialiseValue = deserialiseLSMViaMemPack + +-- deriving via +-- LSM.ResolveAsFirst (SL.ShelleyTxOut MaryEra) +-- instance +-- LSM.ResolveValue (SL.ShelleyTxOut MaryEra) 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 ef1b79921b..48d172dc89 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 @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -103,6 +104,7 @@ import Data.MemPack import qualified Data.Text as T import qualified Data.Text as Text import Data.Word +import qualified Database.LSMTree as LSM import GHC.Generics (Generic) import Lens.Micro import Lens.Micro.Extras (view) @@ -130,6 +132,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract , mkHeaderView ) import Ouroboros.Consensus.Storage.LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM import Ouroboros.Consensus.Util.CBOR ( decodeWithOrigin , encodeWithOrigin @@ -320,6 +323,28 @@ instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era) type instance TxIn (LedgerState (ShelleyBlock proto era)) = SL.TxIn type instance TxOut (LedgerState (ShelleyBlock proto era)) = Core.TxOut era +newtype LSMTxIn = LSMTxIn {lsmTxIn :: SL.TxIn} + +instance MemPack LSMTxIn where + packedByteCount = packedByteCount . lsmTxIn + packM (LSMTxIn (SL.TxIn txid txix)) = packM txix >> packM txid + unpackM = do + txix <- unpackM + txid <- unpackM + pure . LSMTxIn $ SL.TxIn txid txix + +instance LSM.SerialiseKey SL.TxIn where + serialiseKey = serialiseLSMViaMemPack . LSMTxIn + deserialiseKey = lsmTxIn . deserialiseLSMViaMemPack + +type instance + LSMTxOut (LedgerState (ShelleyBlock proto era)) = + TxOut (LedgerState (ShelleyBlock proto era)) + +instance HasLSMTxOut (LedgerState (ShelleyBlock proto era)) where + toLSMTxOut _ = id + fromLSMTxOut _ = id + instance (txout ~ Core.TxOut era, MemPack txout) => IndexedMemPack (LedgerState (ShelleyBlock proto era) EmptyMK) txout diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs index ea7cc2e5a4..210c9d82a1 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs @@ -38,6 +38,7 @@ instance SupportedNetworkProtocolVersion (ShelleyBlock proto era) where supportedNodeToNodeVersions _ = Map.fromList [ (NodeToNodeV_14, ShelleyNodeToNodeVersion1) + , (NodeToNodeV_15, ShelleyNodeToNodeVersion1) ] supportedNodeToClientVersions _ = Map.fromList diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs index f8c1d45be0..fae846a943 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs @@ -29,7 +29,7 @@ import Ouroboros.Consensus.Shelley.Ledger.Ledger instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto era) where getPeers ShelleyLedgerState{shelleyLedgerState} = catMaybes - [ (poolStake,) <$> Map.lookup stakePool poolRelayAccessPoints + [ (poolStake,) <$> Map.lookup stakePool poolLedgerRelayAccessPoints | (stakePool, poolStake) <- orderByStake poolDistr ] where @@ -60,41 +60,46 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto . SL.nesEs $ shelleyLedgerState - relayToRelayAccessPoint :: SL.StakePoolRelay -> Maybe RelayAccessPoint - relayToRelayAccessPoint (SL.SingleHostAddr (SJust (Port port)) (SJust ipv4) _) = - Just $ RelayAccessAddress (IPv4 ipv4) (fromIntegral port) - relayToRelayAccessPoint + relayToLedgerRelayAccessPoint :: SL.StakePoolRelay -> Maybe LedgerRelayAccessPoint + relayToLedgerRelayAccessPoint (SL.SingleHostAddr (SJust (Port port)) (SJust ipv4) _) = + Just $ LedgerRelayAccessAddress (IPv4 ipv4) (fromIntegral port) + relayToLedgerRelayAccessPoint ( SL.SingleHostAddr (SJust (Port port)) SNothing (SJust ipv6) ) = - Just $ RelayAccessAddress (IPv6 ipv6) (fromIntegral port) - relayToRelayAccessPoint (SL.SingleHostName (SJust (Port port)) dnsName) = - Just $ RelayAccessDomain (encodeUtf8 $ dnsToText dnsName) (fromIntegral port) - relayToRelayAccessPoint _ = - -- This could be an unsupported relay (SRV records) or an unusable - -- relay such as a relay with an IP address but without a port number. - Nothing + Just $ LedgerRelayAccessAddress (IPv6 ipv6) (fromIntegral port) + -- no IP address or no port number + relayToLedgerRelayAccessPoint (SL.SingleHostAddr SNothing _ _) = Nothing + relayToLedgerRelayAccessPoint (SL.SingleHostAddr _ SNothing _) = Nothing + relayToLedgerRelayAccessPoint (SL.SingleHostName (SJust (Port port)) dnsName) = + Just $ LedgerRelayAccessDomain (encodeUtf8 $ dnsToText dnsName) (fromIntegral port) + -- srv support: either `SingleHostName` without port number or + -- `MultiHostName` + relayToLedgerRelayAccessPoint (SL.SingleHostName SNothing dnsName) = + Just $ LedgerRelayAccessSRVDomain (encodeUtf8 $ dnsToText dnsName) + relayToLedgerRelayAccessPoint (SL.MultiHostName dnsName) = + Just $ LedgerRelayAccessSRVDomain (encodeUtf8 $ dnsToText dnsName) -- \| Note that a stake pool can have multiple registered relays - pparamsRelayAccessPoints :: - (RelayAccessPoint -> StakePoolRelay) -> + pparamsLedgerRelayAccessPoints :: + (LedgerRelayAccessPoint -> StakePoolRelay) -> SL.PoolParams -> Maybe (NonEmpty StakePoolRelay) - pparamsRelayAccessPoints injStakePoolRelay = + pparamsLedgerRelayAccessPoints injStakePoolRelay = NE.nonEmpty . force - . mapMaybe (fmap injStakePoolRelay . relayToRelayAccessPoint) + . mapMaybe (fmap injStakePoolRelay . relayToLedgerRelayAccessPoint) . toList . SL.ppRelays -- \| Combine the stake pools registered in the future and the current pool -- parameters, and remove duplicates. - poolRelayAccessPoints :: + poolLedgerRelayAccessPoints :: Map (SL.KeyHash 'SL.StakePool) (NonEmpty StakePoolRelay) - poolRelayAccessPoints = + poolLedgerRelayAccessPoints = Map.unionWith (\futureRelays currentRelays -> NE.nub (futureRelays <> currentRelays)) - (Map.mapMaybe (pparamsRelayAccessPoints FutureRelay) futurePoolParams) - (Map.mapMaybe (pparamsRelayAccessPoints CurrentRelay) poolParams) + (Map.mapMaybe (pparamsLedgerRelayAccessPoints FutureRelay) futurePoolParams) + (Map.mapMaybe (pparamsLedgerRelayAccessPoints CurrentRelay) poolParams) 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 98e00d3804..138851ece1 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 @@ -1337,17 +1337,12 @@ answerShelleyTraversingQueries ejTxOut ejTxIn filt cfg q forker = case q of ) vs - vnull :: ValuesMK k v -> Bool - vnull (ValuesMK vs) = Map.null vs - - toMaxKey (LedgerTables (ValuesMK vs)) = fst $ Map.findMax vs - loop queryPredicate !prev !acc = do - extValues <- LedgerDB.roforkerRangeReadTables forker prev - if ltcollapse $ ltmap (K2 . vnull) extValues - then pure acc - else + (extValues, k) <- LedgerDB.roforkerRangeReadTables forker prev + case k of + Nothing -> pure acc + Just k' -> loop queryPredicate - (PreviousQueryWasUpTo $ toMaxKey extValues) + (PreviousQueryWasUpTo k') (combUtxo acc $ partial queryPredicate extValues) 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..560b0150fb 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs @@ -26,10 +26,12 @@ module Ouroboros.Consensus.Shelley.Node , validateGenesis ) where +import Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (Crypto) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Database.LSMTree as LSM import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) @@ -121,5 +123,7 @@ instance , TxLimits (ShelleyBlock proto era) , SerialiseNodeToClientConstraints (ShelleyBlock proto era) , Crypto (ProtoCrypto proto) + , LSM.SerialiseValue (Core.TxOut era) + , LSM.ResolveValue (Core.TxOut era) ) => RunNode (ShelleyBlock proto era) 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 222dbdd847..1c117b665c 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -64,6 +64,7 @@ import qualified Data.Text as T (pack) import Data.Typeable import Data.Void (Void) import Data.Word +import qualified Database.LSMTree as LSM import Lens.Micro ((^.)) import NoThunks.Class import Ouroboros.Consensus.Block @@ -92,6 +93,7 @@ import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect import Ouroboros.Consensus.Shelley.Node () import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.IndexedMemPack @@ -168,6 +170,8 @@ instance , LedgerSupportsProtocol (ShelleyBlock proto era) , TxLimits (ShelleyBlock proto era) , Crypto (ProtoCrypto proto) + , LSM.SerialiseValue (SL.TxOut era) + , LSM.ResolveValue (SL.TxOut era) ) => SerialiseHFC '[ShelleyBlock proto era] @@ -429,7 +433,7 @@ instance { getShelleyBlockHFCTxIn :: SL.TxIn } deriving stock (Show, Eq, Ord) - deriving newtype NoThunks + deriving newtype (NoThunks, MemPack, LSM.SerialiseKey) injectCanonicalTxIn IZ txIn = ShelleyBlockHFCTxIn txIn injectCanonicalTxIn (IS idx') _ = case idx' of {} @@ -437,7 +441,13 @@ instance ejectCanonicalTxIn IZ txIn = getShelleyBlockHFCTxIn txIn ejectCanonicalTxIn (IS idx') _ = case idx' of {} -deriving newtype instance MemPack (CanonicalTxIn '[ShelleyBlock proto era]) +type instance + LSMTxOut (LedgerState (HardForkBlock '[ShelleyBlock proto era])) = + TxOut (LedgerState (HardForkBlock '[ShelleyBlock proto era])) + +instance HasLSMTxOut (LedgerState (HardForkBlock '[ShelleyBlock proto era])) where + toLSMTxOut _ = id + fromLSMTxOut _ = id {------------------------------------------------------------------------------- HardForkTxOut diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index 71802ae9f5..5d6289e6fa 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -67,6 +67,7 @@ import Data.SOP.Strict import qualified Data.SOP.Tails as Tails import qualified Data.SOP.Telescope as Telescope import Data.Void (Void) +import qualified Database.LSMTree as LSM import Lens.Micro ((^.)) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Forging (BlockForging) @@ -95,6 +96,7 @@ import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) import Ouroboros.Consensus.Storage.LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (eitherToMaybe) import Ouroboros.Consensus.Util.IOLike (IOLike) @@ -513,6 +515,21 @@ deriving newtype instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 => MemPack (CanonicalTxIn (ShelleyBasedHardForkEras proto1 era1 proto2 era2)) +type instance + LSMTxOut (LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2))) = + TxOut (LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2))) + +instance HasLSMTxOut (LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2))) where + toLSMTxOut _ = id + fromLSMTxOut _ = id + +instance + ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 => + LSM.SerialiseKey (CanonicalTxIn (ShelleyBasedHardForkEras proto1 era1 proto2 era2)) + where + serialiseKey = serialiseLSMViaMemPack + deserialiseKey = deserialiseLSMViaMemPack + instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 => HasHardForkTxOut (ShelleyBasedHardForkEras proto1 era1 proto2 era2) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index 3c63f5d2ee..56df38181f 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs @@ -15,6 +15,7 @@ import Cardano.Tools.DBAnalyser.HasAnalysis import Cardano.Tools.DBAnalyser.Types import Control.ResourceRegistry import Control.Tracer (Tracer (..), nullTracer) +import Data.Functor.Contravariant ((>$<)) import qualified Data.SOP.Dict as Dict import Data.Singletons (Sing, SingI (..)) import qualified Debug.Trace as Debug @@ -34,16 +35,21 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.ImmutableDB.Stream as ImmutableDB +import Ouroboros.Consensus.Storage.LedgerDB (TraceEvent (..)) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (defaultDeleteSnapshot) import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as LedgerDB.V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as LedgerDB.V2 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as LedgerDB.V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Network.Block (genesisPoint) +import System.FS.API import System.IO import Text.Printf (printf) @@ -54,7 +60,6 @@ import Text.Printf (printf) openLedgerDB :: ( LedgerSupportsProtocol blk , InspectLedger blk - , LedgerDB.LedgerDbSerialiseConstraints blk , HasHardForkHistory blk , LedgerDB.LedgerSupportsLedgerDB blk ) => @@ -67,6 +72,7 @@ openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.L (ledgerDB, _, intLedgerDB) <- LedgerDB.openDBInternal lgrDbArgs + defaultDeleteSnapshot ( LedgerDB.V1.mkInitDb lgrDbArgs bss @@ -76,12 +82,33 @@ openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.L genesisPoint pure (ledgerDB, intLedgerDB) openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.LedgerDbFlavorArgsV2 args} = do + (ds, bss') <- case args of + V2.V2Args V2.InMemoryHandleArgs -> pure (defaultDeleteSnapshot, V2.InMemoryHandleEnv) + V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)) -> do + (rk1, V2.SomeHasFSAndBlockIO fs' blockio) <- mkFS (LedgerDB.lgrRegistry lgrDbArgs) "lsm" + session <- + allocate + (LedgerDB.lgrRegistry lgrDbArgs) + ( \_ -> do + salt <- genSalt + LSM.openSession + ( LedgerDBFlavorImplEvent . LedgerDB.FlavorImplSpecificTraceV2 . V2.LSMTrace + >$< LedgerDB.lgrTracer lgrDbArgs + ) + fs' + blockio + salt + (mkFsPath [path]) + ) + LSM.closeSession + pure (LSM.deleteSnapshot (snd session), V2.LSMHandleEnv session rk1) (ledgerDB, _, intLedgerDB) <- LedgerDB.openDBInternal lgrDbArgs + ds ( LedgerDB.V2.mkInitDb lgrDbArgs - args + bss' (\_ -> error "no replay") ) emptyStream diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs index fa281c9083..1934876474 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs @@ -25,7 +25,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDbArgs (..)) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Network.ErrorPolicy (nullErrorPolicies) import Ouroboros.Network.IOManager (withIOManager) import Ouroboros.Network.Mux import qualified Ouroboros.Network.NodeToNode as N2N @@ -33,8 +32,11 @@ import Ouroboros.Network.PeerSelection.PeerSharing.Codec ( decodeRemoteAddress , encodeRemoteAddress ) +import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) +import qualified Ouroboros.Network.Protocol.Handshake as Handshake +import qualified Ouroboros.Network.Server.Simple as Server import qualified Ouroboros.Network.Snocket as Snocket -import Ouroboros.Network.Socket (configureSocket) +import Ouroboros.Network.Socket (SomeResponderApplication (..), configureSocket) import System.FS.API (SomeHasFS (..)) import System.FS.API.Types (MountPoint (MountPoint)) import System.FS.IO (ioHasFS) @@ -48,32 +50,23 @@ serve :: N2N.NodeToNodeVersionData (OuroborosApplicationWithMinimalCtx 'Mux.ResponderMode SockAddr BL.ByteString IO Void ()) -> IO Void -serve sockAddr application = withIOManager \iocp -> do - let sn = Snocket.socketSnocket iocp - family = Snocket.addrFamily sn sockAddr - bracket (Snocket.open sn family) (Snocket.close sn) \socket -> do - networkMutableState <- N2N.newNetworkMutableState - configureSocket socket (Just sockAddr) - Snocket.bind sn socket sockAddr - Snocket.listen sn socket - N2N.withServer - sn - N2N.nullNetworkServerTracers - { N2N.nstHandshakeTracer = show >$< stdoutTracer - , N2N.nstErrorPolicyTracer = show >$< stdoutTracer - } - networkMutableState - acceptedConnectionsLimit - socket - application - nullErrorPolicies - where - acceptedConnectionsLimit = - N2N.AcceptedConnectionsLimit - { N2N.acceptedConnectionsHardLimit = maxBound - , N2N.acceptedConnectionsSoftLimit = maxBound - , N2N.acceptedConnectionsDelay = 0 +serve sockAddr application = withIOManager \iocp -> + Server.with + (Snocket.socketSnocket iocp) + Snocket.makeSocketBearer + (\sock addr -> configureSocket sock (Just addr)) + sockAddr + HandshakeArguments + { haHandshakeTracer = show >$< stdoutTracer + , haBearerTracer = show >$< stdoutTracer + , haHandshakeCodec = Handshake.nodeToNodeHandshakeCodec + , haVersionDataCodec = Handshake.cborTermVersionDataCodec N2N.nodeToNodeCodecCBORTerm + , haAcceptVersion = Handshake.acceptableVersion + , haQueryVersion = Handshake.queryVersion + , haTimeLimits = Handshake.timeLimitsHandshake } + (SomeResponderApplication <$> application) + (\_ serverAsync -> wait serverAsync) run :: forall blk. diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs index e33c77309b..797d1da8ac 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs @@ -199,7 +199,7 @@ fromShelleyLedgerExamples ( AccPoolStake 0.9 , ( PoolStake 0.9 - , RelayAccessAddress (IPv4 "1.1.1.1") 1234 :| [] + , LedgerRelayAccessAddress (IPv4 "1.1.1.1") 1234 :| [] ) ) ] @@ -335,7 +335,7 @@ fromShelleyLedgerExamplesPraos ( AccPoolStake 0.9 , ( PoolStake 0.9 - , RelayAccessAddress (IPv4 "1.1.1.1") 1234 :| [] + , LedgerRelayAccessAddress (IPv4 "1.1.1.1") 1234 :| [] ) ) ] diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index 257e13a8f7..b328cebb1a 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -60,7 +60,6 @@ library Ouroboros.Consensus.Node Ouroboros.Consensus.Node.DbLock Ouroboros.Consensus.Node.DbMarker - Ouroboros.Consensus.Node.ErrorPolicy Ouroboros.Consensus.Node.Exit Ouroboros.Consensus.Node.ExitPolicy Ouroboros.Consensus.Node.GSM @@ -83,29 +82,25 @@ library containers >=0.5 && <0.8, contra-tracer, deepseq, - dns, filepath, - fs-api ^>=0.3, + fs-api ^>=0.4, hashable, - io-classes ^>=1.5, + io-classes:{io-classes, si-timers, strict-stm} ^>=1.8, mtl, - network-mux ^>=0.8, + network-mux ^>=0.9, ouroboros-consensus ^>=0.27, - ouroboros-network ^>=0.21, - ouroboros-network-api ^>=0.14, - ouroboros-network-framework ^>=0.18, - ouroboros-network-protocols ^>=0.14, + ouroboros-network:{cardano-diffusion, ouroboros-network} ^>=0.22, + ouroboros-network-api ^>=0.15, + ouroboros-network-framework ^>=0.19, + ouroboros-network-protocols ^>=0.15, random, resource-registry ^>=0.1, safe-wild-cards ^>=1.0, serialise ^>=0.2, - si-timers ^>=1.5, - strict-stm ^>=1.5, text, time, transformers, - typed-protocols, - typed-protocols-stateful, + typed-protocols:{stateful, typed-protocols}, library unstable-diffusion-testlib import: common-lib @@ -135,9 +130,9 @@ library unstable-diffusion-testlib containers, contra-tracer, fgl, - fs-sim ^>=0.3, + fs-sim ^>=0.4, graphviz >=2999.20.1.0, - io-classes, + io-classes:{io-classes, si-timers, strict-stm}, io-sim, mtl, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, @@ -150,11 +145,9 @@ library unstable-diffusion-testlib quiet ^>=0.2, random, resource-registry, - si-timers, sop-core ^>=0.5, sop-extras ^>=0.4, strict-sop-core ^>=0.1, - strict-stm, text, typed-protocols, @@ -286,13 +279,14 @@ test-suite consensus-test cardano-ledger-core, cardano-slotting:{cardano-slotting, testlib}, cardano-strict-containers, + lsm-tree, containers, contra-tracer, directory, - fs-api ^>=0.3, - fs-sim ^>=0.3, + fs-api ^>=0.4, + fs-sim ^>=0.4, hashable, - io-classes, + io-classes:{io-classes, si-timers, strict-stm}, io-sim, mempack, mtl, @@ -310,12 +304,10 @@ test-suite consensus-test random, resource-registry, serialise, - si-timers, sop-core, sop-extras, strict-checked-vars, strict-sop-core, - strict-stm, tasty, tasty-hunit, tasty-quickcheck, diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 701d0c9a91..85c4109a52 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -37,9 +37,6 @@ module Ouroboros.Consensus.Network.NodeToNode -- ** Projections , initiator , initiatorAndResponder - - -- * Re-exports - , ChainSyncTimeout (..) ) where import Codec.CBOR.Decoding (Decoder) @@ -151,6 +148,7 @@ import Ouroboros.Network.TxSubmission.Mempool.Reader ( mapTxSubmissionMempoolReader ) import Ouroboros.Network.TxSubmission.Outbound +import System.Random (StdGen, split) {------------------------------------------------------------------------------- Handlers @@ -602,18 +600,22 @@ mkApps :: ) => -- | Needed for bracketing only NodeKernel m addrNTN addrNTC blk -> + StdGen -> Tracers m addrNTN blk e -> (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bKA bPS) -> ByteLimits bCS bBF bTX bKA -> - m ChainSyncTimeout -> + -- Chain-Sync timeouts for chain-sync client (using `Header blk`) as well as + -- the server (`SerialisedHeader blk`). + (forall header. ProtocolTimeLimitsWithRnd (ChainSync header (Point blk) (Tip blk))) -> CsClient.ChainSyncLoPBucketConfig -> CsClient.CSJConfig -> ReportPeerMetrics m (ConnectionId addrNTN) -> Handlers m addrNTN blk -> Apps m addrNTN bCS bBF bTX bKA bPS NodeToNodeInitiatorResult () -mkApps kernel Tracers{..} mkCodecs ByteLimits{..} genChainSyncTimeout lopBucketConfig csjConfig ReportPeerMetrics{..} Handlers{..} = +mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucketConfig csjConfig ReportPeerMetrics{..} Handlers{..} = Apps{..} where + (chainSyncRng, chainSyncRng') = split rng NodeKernel{getDiffusionPipeliningSupport} = kernel aChainSyncClient :: @@ -650,13 +652,13 @@ mkApps kernel Tracers{..} mkCodecs ByteLimits{..} genChainSyncTimeout lopBucketC csjConfig getDiffusionPipeliningSupport $ \csState -> do - chainSyncTimeout <- genChainSyncTimeout (r, trailing) <- - runPipelinedPeerWithLimits + runPipelinedPeerWithLimitsRnd (contramap (TraceLabelPeer them) tChainSyncTracer) + chainSyncRng (cChainSyncCodec (mkCodecs version)) blChainSync - (timeLimitsChainSync chainSyncTimeout) + chainSyncTimeouts channel $ chainSyncClientPeerPipelined $ hChainSyncClient @@ -681,7 +683,6 @@ mkApps kernel Tracers{..} mkCodecs ByteLimits{..} genChainSyncTimeout lopBucketC m ((), Maybe bCS) aChainSyncServer version ResponderContext{rcConnectionId = them} channel = do labelThisThread "ChainSyncServer" - chainSyncTimeout <- genChainSyncTimeout bracketWithPrivateRegistry ( chainSyncHeaderServerFollower (getChainDB kernel) @@ -692,11 +693,12 @@ mkApps kernel Tracers{..} mkCodecs ByteLimits{..} genChainSyncTimeout lopBucketC ) ChainDB.followerClose $ \flr -> - runPeerWithLimits + runPeerWithLimitsRnd (contramap (TraceLabelPeer them) tChainSyncSerialisedTracer) + chainSyncRng' (cChainSyncCodecSerialised (mkCodecs version)) blChainSync - (timeLimitsChainSync chainSyncTimeout) + chainSyncTimeouts channel $ chainSyncServerPeer $ hChainSyncServer them version flr diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index c233ee9241..992d8e698e 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -26,8 +26,6 @@ module Ouroboros.Consensus.Node -- * Standard arguments , StdRunNodeArgs (..) , stdBfcSaltIO - , stdGsmAntiThunderingHerdIO - , stdKeepAliveRngIO , stdLowLevelRunNodeArgsIO , stdMkChainDbHasFS , stdRunDataDiffusion @@ -35,9 +33,6 @@ module Ouroboros.Consensus.Node , stdVersionDataNTN , stdWithCheckedDB - -- ** P2P Switch - , NetworkP2PMode (..) - -- * Exposed by 'run' et al , ChainDB.RelativeMountPoint (..) , ChainDB.TraceEvent (..) @@ -57,6 +52,8 @@ module Ouroboros.Consensus.Node , Tracers' (..) , pattern DoDiskSnapshotChecksum , pattern NoDoDiskSnapshotChecksum + , ChainSyncIdleTimeout (..) + , LedgerDbBackendArgs (..) -- * Internal helpers , mkNodeKernelArgs @@ -64,22 +61,24 @@ module Ouroboros.Consensus.Node , openChainDB ) where -import Cardano.Network.PeerSelection.Bootstrap - ( UseBootstrapPeers (..) - ) -import Cardano.Network.Types (LedgerStateJudgement (..)) +import qualified Cardano.Network.Diffusion as Cardano.Diffusion +import Cardano.Network.Diffusion.Configuration (ChainSyncIdleTimeout (..)) +import qualified Cardano.Network.Diffusion.Policies as Cardano.Diffusion +import qualified Cardano.Network.LedgerPeerConsensusInterface as Cardano +import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) +import Cardano.Network.PeerSelection.Churn (ChurnMode (..)) import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (DeserialiseFailure) import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM import Control.DeepSeq (NFData) -import Control.Exception (IOException) import Control.Monad (forM_, when) import Control.Monad.Class.MonadTime.SI (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.ResourceRegistry import Control.Tracer (Tracer, contramap, traceWith) import Data.ByteString.Lazy (ByteString) +import Data.Functor (void) import Data.Functor.Contravariant (Predicate (..)) import Data.Hashable (Hashable) import Data.Kind (Type) @@ -88,11 +87,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isNothing) import Data.Time (NominalDiffTime) import Data.Typeable (Typeable) -import Network.DNS.Resolver (Resolver) -import Network.Mux.Types -import qualified Ouroboros.Cardano.Network.ArgumentsExtra as Cardano -import qualified Ouroboros.Cardano.Network.LedgerPeerConsensusInterface as Cardano -import qualified Ouroboros.Cardano.Network.PeerSelection.Governor.PeerSelectionState as Cardano import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime hiding (getSystemStart) import Ouroboros.Consensus.Config @@ -108,13 +102,12 @@ import qualified Ouroboros.Consensus.Network.NodeToClient as NTC import qualified Ouroboros.Consensus.Network.NodeToNode as NTN import Ouroboros.Consensus.Node.DbLock import Ouroboros.Consensus.Node.DbMarker -import Ouroboros.Consensus.Node.ErrorPolicy import Ouroboros.Consensus.Node.ExitPolicy import Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..)) import qualified Ouroboros.Consensus.Node.GSM as GSM import Ouroboros.Consensus.Node.Genesis ( GenesisConfig (..) - , GenesisNodeKernelArgs + , GenesisNodeKernelArgs (..) , mkGenesisNodeKernelArgs ) import Ouroboros.Consensus.Node.InitStorage @@ -134,24 +127,22 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) import Ouroboros.Network.BlockFetch ( BlockFetchConfiguration (..) - , FetchMode ) import qualified Ouroboros.Network.Diffusion as Diffusion -import qualified Ouroboros.Network.Diffusion.Common as Diffusion import qualified Ouroboros.Network.Diffusion.Configuration as Diffusion -import qualified Ouroboros.Network.Diffusion.NonP2P as NonP2P -import qualified Ouroboros.Network.Diffusion.P2P as Diffusion.P2P +import qualified Ouroboros.Network.Diffusion.Policies as Diffusion import Ouroboros.Network.Magic import Ouroboros.Network.NodeToClient ( ConnectionId , LocalAddress - , LocalSocket , NodeToClientVersionData (..) , combineVersions , simpleSingletonVersions @@ -162,17 +153,14 @@ import Ouroboros.Network.NodeToNode , MiniProtocolParameters , NodeToNodeVersionData (..) , RemoteAddress - , Socket , blockFetchPipeliningMax , defaultMiniProtocolParameters ) import Ouroboros.Network.PeerSelection.Governor.Types - ( PeerSelectionState - , PublicPeerSelectionState + ( PublicPeerSelectionState ) import Ouroboros.Network.PeerSelection.LedgerPeers ( LedgerPeersConsensusInterface (..) - , UseLedgerPeers (..) ) import Ouroboros.Network.PeerSelection.PeerMetric ( PeerMetrics @@ -184,9 +172,7 @@ import Ouroboros.Network.PeerSelection.PeerSharing.Codec ( decodeRemoteAddress , encodeRemoteAddress ) -import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers - ( TracePublicRootPeers - ) +import Ouroboros.Network.Protocol.ChainSync.Codec (timeLimitsChainSync) import Ouroboros.Network.RethrowPolicy import qualified SafeWildCards import System.Exit (ExitCode (..)) @@ -227,9 +213,8 @@ type RunNodeArgs :: Type -> Type -> Type -> - Diffusion.P2P -> Type -data RunNodeArgs m addrNTN addrNTC blk p2p = RunNodeArgs +data RunNodeArgs m addrNTN addrNTC blk = RunNodeArgs { rnTraceConsensus :: Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -- ^ Consensus tracers , rnTraceNTN :: NTN.Tracers m addrNTN blk DeserialiseFailure @@ -246,8 +231,6 @@ data RunNodeArgs m addrNTN addrNTC blk p2p = RunNodeArgs -- -- Called on the 'NodeKernel' after creating it, but before the network -- layer is initialised. - , rnEnableP2P :: NetworkP2PMode p2p - -- ^ Network P2P Mode switch , rnPeerSharing :: PeerSharing -- ^ Network PeerSharing miniprotocol willingness flag , rnGetUseBootstrapPeers :: STM m UseBootstrapPeers @@ -265,10 +248,8 @@ type LowLevelRunNodeArgs :: Type -> Type -> Type -> - Diffusion.P2P -> - Type -> Type -data LowLevelRunNodeArgs m addrNTN addrNTC blk p2p extraAPI +data LowLevelRunNodeArgs m addrNTN addrNTC blk = LowLevelRunNodeArgs { llrnWithCheckedDB :: forall a. @@ -301,30 +282,28 @@ data LowLevelRunNodeArgs m addrNTN addrNTC blk p2p extraAPI -- ^ Customise the 'NodeArgs' , llrnBfcSalt :: Int -- ^ Ie 'bfcSalt' - , llrnGsmAntiThunderingHerd :: StdGen - -- ^ Ie 'gsmAntiThunderingHerd' - , llrnKeepAliveRng :: StdGen - -- ^ Ie 'keepAliveRng' + , llrnRng :: StdGen + -- ^ StdGen for various applications, e.g. keep-alive, chain-sync, gsm anti + -- thundering herd , llrnCustomiseHardForkBlockchainTimeArgs :: HardForkBlockchainTimeArgs m blk -> HardForkBlockchainTimeArgs m blk -- ^ Customise the 'HardForkBlockchainTimeArgs' - , llrnChainSyncTimeout :: m NTN.ChainSyncTimeout - -- ^ See 'NTN.ChainSyncTimeout' + , llrnChainSyncIdleTimeout :: ChainSyncIdleTimeout + -- ^ custom Chain-Sync idle timeout , llrnGenesisConfig :: GenesisConfig , llrnRunDataDiffusion :: NodeKernel m addrNTN (ConnectionId addrNTC) blk -> - Diffusion.Applications + Cardano.Diffusion.CardanoConsensusArguments addrNTN m -> + Cardano.Diffusion.Applications addrNTN NodeToNodeVersion NodeToNodeVersionData addrNTC NodeToClientVersion NodeToClientVersionData - extraAPI m NodeToNodeInitiatorResult -> - Diffusion.ApplicationsExtra p2p addrNTN m NodeToNodeInitiatorResult -> m () -- ^ How to run the data diffusion applications -- @@ -377,17 +356,6 @@ data StdRunNodeArgs m blk - (p2p :: Diffusion.P2P) - extraArgs - extraState - extraDebugState - extraActions - extraAPI - extraPeers - extraFlags - extraChurnArgs - extraCounters - exception = StdRunNodeArgs { srnBfcMaxConcurrencyBulkSync :: Maybe Word , srnBfcMaxConcurrencyDeadline :: Maybe Word @@ -395,84 +363,9 @@ data -- ^ If @True@, validate the ChainDB on init no matter what , srnDatabasePath :: NodeDatabasePaths -- ^ Location of the DBs - , srnDiffusionArguments :: - Diffusion.Arguments - IO - Socket - RemoteAddress - LocalSocket - LocalAddress - , srnDiffusionArgumentsExtra :: - Diffusion.P2PDecision p2p (Tracer IO TracePublicRootPeers) () -> - Diffusion.P2PDecision p2p (STM IO FetchMode) () -> - Diffusion.P2PDecision p2p extraAPI () -> - Diffusion.ArgumentsExtra - p2p - extraArgs - extraState - extraDebugState - extraFlags - extraPeers - extraAPI - extraChurnArgs - extraCounters - exception - RemoteAddress - LocalAddress - Resolver - IOException - IO - , srnDiffusionTracers :: - Diffusion.Tracers - RemoteAddress - NodeToNodeVersion - LocalAddress - NodeToClientVersion - IO - , srnDiffusionTracersExtra :: - Diffusion.ExtraTracers p2p extraState extraDebugState extraFlags extraPeers extraCounters IO - , srnSigUSR1SignalHandler :: - ( forall (mode :: Mode) x y. - Diffusion.ExtraTracers - p2p - extraState - Cardano.DebugPeerSelectionState - extraFlags - extraPeers - extraCounters - IO -> - STM IO UseLedgerPeers -> - PeerSharing -> - STM IO UseBootstrapPeers -> - STM IO LedgerStateJudgement -> - Diffusion.P2P.NodeToNodeConnectionManager - mode - Socket - RemoteAddress - NodeToNodeVersionData - NodeToNodeVersion - IO - x - y -> - StrictSTM.StrictTVar - IO - ( PeerSelectionState - extraState - extraFlags - extraPeers - RemoteAddress - ( Diffusion.P2P.NodeToNodePeerConnectionHandle - mode - RemoteAddress - NodeToNodeVersionData - IO - x - y - ) - ) -> - PeerMetrics IO RemoteAddress -> - IO () - ) + , srnDiffusionArguments :: Cardano.Diffusion.CardanoNodeArguments m + , srnDiffusionConfiguration :: Cardano.Diffusion.CardanoConfiguration m + , srnDiffusionTracers :: Cardano.Diffusion.CardanoTracers m , srnEnableInDevelopmentVersions :: Bool -- ^ If @False@, then the node will limit the negotiated NTN and NTC -- versions to the latest " official " release (as chosen by Network and @@ -481,52 +374,25 @@ data , srnMaybeMempoolCapacityOverride :: Maybe MempoolCapacityBytesOverride -- ^ Determine whether to use the system default mempool capacity or explicitly set -- capacity of the mempool. - , srnChainSyncTimeout :: Maybe (m NTN.ChainSyncTimeout) - -- ^ A custom timeout for ChainSync. + , srnChainSyncIdleTimeout :: ChainSyncIdleTimeout , -- Ad hoc values to replace default ChainDB configurations srnSnapshotPolicyArgs :: SnapshotPolicyArgs , srnQueryBatchSize :: QueryBatchSize - , srnLdbFlavorArgs :: Complete LedgerDbFlavorArgs m + , srnLdbFlavorArgs :: LedgerDbBackendArgs m } {------------------------------------------------------------------------------- Entrypoints to the Consensus Layer node functionality -------------------------------------------------------------------------------} --- | P2P Switch -data NetworkP2PMode (p2p :: Diffusion.P2P) where - EnabledP2PMode :: NetworkP2PMode 'Diffusion.P2P - DisabledP2PMode :: NetworkP2PMode 'Diffusion.NonP2P - -deriving instance Eq (NetworkP2PMode p2p) -deriving instance Show (NetworkP2PMode p2p) - pure [] -- | Combination of 'runWith' and 'stdLowLevelRunArgsIO' run :: - forall blk p2p extraState extraActions extraPeers extraFlags extraChurnArgs extraCounters exception. - ( RunNode blk - , Monoid extraPeers - , Eq extraCounters - , Eq extraFlags - , Exception exception - ) => - RunNodeArgs IO RemoteAddress LocalAddress blk p2p -> - StdRunNodeArgs - IO - blk - p2p - (Cardano.ExtraArguments IO) - extraState - Cardano.DebugPeerSelectionState - extraActions - (Cardano.LedgerPeersConsensusInterface IO) - extraPeers - extraFlags - extraChurnArgs - extraCounters - exception -> + forall blk. + RunNode blk => + RunNodeArgs IO RemoteAddress LocalAddress blk -> + StdRunNodeArgs IO blk -> IO () run args stdArgs = stdLowLevelRunNodeArgsIO args stdArgs @@ -596,17 +462,17 @@ type NetworkAddr addr = -- TODO: Ideally, the ChainDB and LedgerDB should follow a consistent -- approach to resource deallocation. runWith :: - forall m addrNTN addrNTC blk p2p. + forall m addrNTN addrNTC blk. ( RunNode blk , IOLike m , Hashable addrNTN -- the constraint comes from `initNodeKernel` , NetworkIO m , NetworkAddr addrNTN ) => - RunNodeArgs m addrNTN addrNTC blk p2p -> + RunNodeArgs m addrNTN addrNTC blk -> (NodeToNodeVersion -> addrNTN -> CBOR.Encoding) -> (NodeToNodeVersion -> forall s. CBOR.Decoder s addrNTN) -> - LowLevelRunNodeArgs m addrNTN addrNTC blk p2p (Cardano.LedgerPeersConsensusInterface m) -> + LowLevelRunNodeArgs m addrNTN addrNTC blk -> m () runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = llrnWithCheckedDB $ \(LastShutDownWasClean lastShutDownWasClean) continueWithCleanChainDB -> @@ -704,8 +570,8 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = mkNodeKernelArgs registry llrnBfcSalt - llrnGsmAntiThunderingHerd - llrnKeepAliveRng + gsmAntiThunderingHerd + keepAliveRng cfg rnTraceConsensus btime @@ -721,21 +587,48 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = DiffusionPipeliningOn nodeKernel <- initNodeKernel nodeKernelArgs rnNodeKernelHook registry nodeKernel + churnModeVar <- StrictSTM.newTVarIO ChurnModeNormal + churnMetrics <- newPeerMetric Diffusion.peerMetricsConfiguration + let consensusDiffusionArgs = + Cardano.Diffusion.CardanoConsensusArguments + { Cardano.Diffusion.churnModeVar + , Cardano.Diffusion.churnMetrics + , Cardano.Diffusion.ledgerPeersAPI = + LedgerPeersConsensusInterface + { lpGetLatestSlot = getImmTipSlot nodeKernel + , lpGetLedgerPeers = fromMaybe [] <$> getPeersFromCurrentLedger nodeKernel (const True) + , lpExtraAPI = + Cardano.LedgerPeersConsensusInterface + { Cardano.readFetchMode = getFetchMode nodeKernel + , Cardano.getLedgerStateJudgement = GSM.gsmStateToLedgerJudgement <$> getGsmState nodeKernel + , Cardano.updateOutboundConnectionsState = + let varOcs = getOutboundConnectionsState nodeKernel + in \newOcs -> do + oldOcs <- readTVar varOcs + when (newOcs /= oldOcs) $ writeTVar varOcs newOcs + } + } + , Cardano.Diffusion.readUseBootstrapPeers = rnGetUseBootstrapPeers + } - peerMetrics <- newPeerMetric Diffusion.peerMetricsConfiguration - let ntnApps = mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics encAddrNtN decAddrNtN + stdGen <- StrictSTM.newTVarIO peerSelectionRng + let ntnApps = mkNodeToNodeApps nodeKernelArgs nodeKernel churnMetrics encAddrNtN decAddrNtN ntcApps = mkNodeToClientApps nodeKernelArgs nodeKernel - (apps, appsExtra) = + apps = mkDiffusionApplications - rnEnableP2P + stdGen + consensusDiffusionArgs (miniProtocolParameters nodeKernelArgs) ntnApps ntcApps nodeKernel - peerMetrics - llrnRunDataDiffusion nodeKernel apps appsExtra + llrnRunDataDiffusion nodeKernel consensusDiffusionArgs apps where + (gsmAntiThunderingHerd, rng') = split llrnRng + (peerSelectionRng, rng'') = split rng' + (keepAliveRng, ntnAppsRng) = split rng'' + ProtocolInfo { pInfoConfig = cfg , pInfoInitLedger = initLedger @@ -764,10 +657,11 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics encAddrNTN decAddrNTN version = NTN.mkApps nodeKernel + ntnAppsRng rnTraceNTN (NTN.defaultCodecs codecConfig version encAddrNTN decAddrNTN) NTN.byteLimits - llrnChainSyncTimeout + (timeLimitsChainSync llrnChainSyncIdleTimeout) (gcChainSyncLoPBucketConfig llrnGenesisConfig) (gcCSJConfig llrnGenesisConfig) (reportMetric Diffusion.peerMetricsConfiguration peerMetrics) @@ -787,7 +681,8 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = (NTC.mkHandlers nodeKernelArgs nodeKernel) mkDiffusionApplications :: - NetworkP2PMode p2p -> + StrictSTM.StrictTVar m StdGen -> + Cardano.Diffusion.CardanoConsensusArguments addrNTN m -> MiniProtocolParameters -> ( BlockNodeToNodeVersion blk -> NTN.Apps @@ -813,45 +708,23 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = () ) -> NodeKernel m addrNTN (ConnectionId addrNTC) blk -> - PeerMetrics m addrNTN -> - ( Diffusion.Applications - addrNTN - NodeToNodeVersion - NodeToNodeVersionData - addrNTC - NodeToClientVersion - NodeToClientVersionData - (Cardano.LedgerPeersConsensusInterface m) - m - NodeToNodeInitiatorResult - , Diffusion.ApplicationsExtra p2p addrNTN m NodeToNodeInitiatorResult - ) + Cardano.Diffusion.Applications + addrNTN + NodeToNodeVersion + NodeToNodeVersionData + addrNTC + NodeToClientVersion + NodeToClientVersionData + m + NodeToNodeInitiatorResult mkDiffusionApplications - enP2P + stdGenVar + consensusDiffusionArgs miniProtocolParams ntnApps ntcApps - kernel - peerMetrics = - case enP2P of - EnabledP2PMode -> - ( apps - , Diffusion.P2PApplicationsExtra - Diffusion.P2P.ApplicationsExtra - { Diffusion.P2P.daRethrowPolicy = consensusRethrowPolicy (Proxy @blk) - , Diffusion.P2P.daReturnPolicy = returnPolicy - , Diffusion.P2P.daLocalRethrowPolicy = localRethrowPolicy - , Diffusion.P2P.daPeerMetrics = peerMetrics - , Diffusion.P2P.daPeerSharingRegistry = getPeerSharingRegistry kernel - } - ) - DisabledP2PMode -> - ( apps - , Diffusion.NonP2PApplicationsExtra - NonP2P.ApplicationsExtra - { NonP2P.daErrorPolicies = consensusErrorPolicy (Proxy @blk) - } - ) + kernel = + apps where apps = Diffusion.Applications @@ -889,20 +762,16 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = (\versionData -> NTC.responder version versionData $ ntcApps blockVersion version) | (version, blockVersion) <- Map.toList llrnNodeToClientVersions ] - , Diffusion.daLedgerPeersCtx = - LedgerPeersConsensusInterface - { lpGetLatestSlot = getImmTipSlot kernel - , lpGetLedgerPeers = fromMaybe [] <$> getPeersFromCurrentLedger kernel (const True) - , lpExtraAPI = - Cardano.LedgerPeersConsensusInterface - { Cardano.getLedgerStateJudgement = GSM.gsmStateToLedgerJudgement <$> getGsmState kernel - , Cardano.updateOutboundConnectionsState = - let varOcs = getOutboundConnectionsState kernel - in \newOcs -> do - oldOcs <- readTVar varOcs - when (newOcs /= oldOcs) $ writeTVar varOcs newOcs - } - } + , Diffusion.daRethrowPolicy = consensusRethrowPolicy (Proxy @blk) + , Diffusion.daReturnPolicy = returnPolicy + , Diffusion.daRepromoteErrorDelay = Diffusion.repromoteErrorDelay + , Diffusion.daLocalRethrowPolicy = localRethrowPolicy + , daPeerSelectionPolicy = + Cardano.Diffusion.simpleChurnModePeerSelectionPolicy + stdGenVar + (StrictSTM.readTVar $ Cardano.Diffusion.churnModeVar consensusDiffusionArgs) + (Cardano.Diffusion.churnMetrics consensusDiffusionArgs) + , Diffusion.daPeerSharingRegistry = getPeerSharingRegistry kernel } localRethrowPolicy :: RethrowPolicy @@ -1086,12 +955,6 @@ stdMkChainDbHasFS rootPath (ChainDB.RelativeMountPoint relPath) = stdBfcSaltIO :: IO Int stdBfcSaltIO = randomIO -stdGsmAntiThunderingHerdIO :: IO StdGen -stdGsmAntiThunderingHerdIO = newStdGen - -stdKeepAliveRngIO :: IO StdGen -stdKeepAliveRngIO = newStdGen - stdVersionDataNTN :: NetworkMagic -> DiffusionMode -> @@ -1113,208 +976,64 @@ stdVersionDataNTC networkMagic = } stdRunDataDiffusion :: - ( Monoid extraPeers - , Eq extraCounters - , Eq extraFlags - , Exception exception - ) => - ( forall (mode :: Mode) x y. - Diffusion.P2P.NodeToNodeConnectionManager - mode - Socket - RemoteAddress - NodeToNodeVersionData - NodeToNodeVersion - IO - x - y -> - StrictSTM.StrictTVar - IO - ( PeerSelectionState - extraState - extraFlags - extraPeers - RemoteAddress - ( Diffusion.P2P.NodeToNodePeerConnectionHandle - mode - RemoteAddress - NodeToNodeVersionData - IO - x - y - ) - ) -> - PeerMetrics IO RemoteAddress -> - IO () - ) -> - Diffusion.Tracers - RemoteAddress - NodeToNodeVersion - LocalAddress - NodeToClientVersion - IO -> - Diffusion.ExtraTracers - p2p - extraState - extraDebugState - extraFlags - extraPeers - extraCounters - IO -> - Diffusion.Arguments - IO - Socket - RemoteAddress - LocalSocket - LocalAddress -> - Diffusion.ArgumentsExtra - p2p - extraArgs - extraState - extraDebugState - extraFlags - extraPeers - extraAPI - extraChurnArgs - extraCounters - exception - RemoteAddress - LocalAddress - Resolver - IOException - IO -> - Diffusion.Applications - RemoteAddress - NodeToNodeVersion - NodeToNodeVersionData - LocalAddress - NodeToClientVersion - NodeToClientVersionData - extraAPI - IO - a -> - Diffusion.ApplicationsExtra p2p RemoteAddress IO a -> + Cardano.Diffusion.CardanoNodeArguments IO -> + Cardano.Diffusion.CardanoConsensusArguments RemoteAddress IO -> + Cardano.Diffusion.CardanoTracers IO -> + Cardano.Diffusion.CardanoConfiguration IO -> + Cardano.Diffusion.CardanoApplications IO a -> IO () -stdRunDataDiffusion = Diffusion.run +stdRunDataDiffusion = \nodeArgs consensusArgs tracers config apps -> + void $ Cardano.Diffusion.run nodeArgs consensusArgs tracers config apps -- | Conveniently packaged 'LowLevelRunNodeArgs' arguments from a standard -- non-testing invocation. stdLowLevelRunNodeArgsIO :: - forall blk p2p extraState extraActions extraPeers extraFlags extraChurnArgs extraCounters exception. - ( RunNode blk - , Monoid extraPeers - , Eq extraCounters - , Eq extraFlags - , Exception exception - ) => - RunNodeArgs IO RemoteAddress LocalAddress blk p2p -> - StdRunNodeArgs - IO - blk - p2p - (Cardano.ExtraArguments IO) - extraState - Cardano.DebugPeerSelectionState - extraActions - (Cardano.LedgerPeersConsensusInterface IO) - extraPeers - extraFlags - extraChurnArgs - extraCounters - exception -> + forall blk. + RunNode blk => + RunNodeArgs IO RemoteAddress LocalAddress blk -> + StdRunNodeArgs IO blk -> IO ( LowLevelRunNodeArgs IO RemoteAddress LocalAddress blk - p2p - (Cardano.LedgerPeersConsensusInterface IO) ) stdLowLevelRunNodeArgsIO RunNodeArgs { rnProtocolInfo - , rnEnableP2P , rnPeerSharing , rnGenesisConfig - , rnGetUseBootstrapPeers } $(SafeWildCards.fields 'StdRunNodeArgs) = do llrnBfcSalt <- stdBfcSaltIO - llrnGsmAntiThunderingHerd <- stdGsmAntiThunderingHerdIO - llrnKeepAliveRng <- stdKeepAliveRngIO + llrnRng <- newStdGen pure LowLevelRunNodeArgs { llrnBfcSalt - , llrnChainSyncTimeout = fromMaybe Diffusion.defaultChainSyncTimeout srnChainSyncTimeout + , llrnChainSyncIdleTimeout = srnChainSyncIdleTimeout , llrnGenesisConfig = rnGenesisConfig , llrnCustomiseHardForkBlockchainTimeArgs = id - , llrnGsmAntiThunderingHerd - , llrnKeepAliveRng + , llrnRng , llrnMkImmutableHasFS = stdMkChainDbHasFS $ immutableDbPath srnDatabasePath , llrnMkVolatileHasFS = stdMkChainDbHasFS $ nonImmutableDbPath srnDatabasePath , llrnChainDbArgsDefaults = updateChainDbDefaults ChainDB.defaultArgs , llrnCustomiseChainDbArgs = id , llrnCustomiseNodeKernelArgs , llrnRunDataDiffusion = - \kernel apps extraApps -> do - case rnEnableP2P of - EnabledP2PMode -> - case srnDiffusionTracersExtra of - Diffusion.P2PTracers extraTracers -> do - let srnDiffusionArgumentsExtra' = - srnDiffusionArgumentsExtra - (Diffusion.P2PDecision (Diffusion.P2P.dtTracePublicRootPeersTracer extraTracers)) - (Diffusion.P2PDecision (getFetchMode kernel)) - (Diffusion.P2PDecision (lpExtraAPI (Diffusion.daLedgerPeersCtx apps))) - case srnDiffusionArgumentsExtra' of - Diffusion.P2PArguments extraArgs -> - stdRunDataDiffusion - ( srnSigUSR1SignalHandler - srnDiffusionTracersExtra - (Diffusion.P2P.daReadUseLedgerPeers extraArgs) - rnPeerSharing - rnGetUseBootstrapPeers - (GSM.gsmStateToLedgerJudgement <$> getGsmState kernel) - ) - srnDiffusionTracers - srnDiffusionTracersExtra - srnDiffusionArguments - srnDiffusionArgumentsExtra' - apps - extraApps - DisabledP2PMode -> - stdRunDataDiffusion - ( srnSigUSR1SignalHandler - (Diffusion.NonP2PTracers NonP2P.nullTracers) - (pure DontUseLedgerPeers) - rnPeerSharing - (pure DontUseBootstrapPeers) - (pure TooOld) - ) - srnDiffusionTracers - srnDiffusionTracersExtra - srnDiffusionArguments - ( srnDiffusionArgumentsExtra - (Diffusion.NonP2PDecision ()) - (Diffusion.NonP2PDecision ()) - (Diffusion.NonP2PDecision ()) - ) - apps - extraApps + \_kernel cardanoConsensusDiffusionArgs apps -> + stdRunDataDiffusion + srnDiffusionArguments + cardanoConsensusDiffusionArgs + srnDiffusionTracers + srnDiffusionConfiguration + apps , llrnVersionDataNTC = stdVersionDataNTC networkMagic , llrnVersionDataNTN = stdVersionDataNTN networkMagic - ( case rnEnableP2P of - EnabledP2PMode -> Diffusion.daMode srnDiffusionArguments - -- Every connection in non-p2p mode is unidirectional; We connect - -- from an ephemeral port. We still pass `srnDiffusionArguments` - -- to the diffusion layer, so the server side will be run also in - -- `InitiatorAndResponderDiffusionMode`. - DisabledP2PMode -> InitiatorOnlyDiffusionMode - ) + (Diffusion.dcMode srnDiffusionConfiguration) rnPeerSharing , llrnNodeToNodeVersions = limitToLatestReleasedVersion @@ -1332,9 +1051,18 @@ stdLowLevelRunNodeArgsIO , llrnMaxClockSkew = InFutureCheck.defaultClockSkew , llrnPublicPeerSelectionStateVar = - Diffusion.daPublicPeerSelectionVar srnDiffusionArguments + Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration , llrnLdbFlavorArgs = - srnLdbFlavorArgs + case srnLdbFlavorArgs of + V1LMDB args -> LedgerDbFlavorArgsV1 args + V2InMemory -> LedgerDbFlavorArgsV2 (V2.V2Args V2.InMemoryHandleArgs) + V2LSM path -> + LedgerDbFlavorArgsV2 + ( V2.V2Args + ( V2.LSMHandleArgs + (V2.LSMArgs path LSM.stdGenSalt (LSM.stdMkBlockIOFS (nonImmutableDbPath srnDatabasePath))) + ) + ) } where networkMagic :: NetworkMagic diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs deleted file mode 100644 index bbc3bc3f57..0000000000 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Ouroboros.Consensus.Node.ErrorPolicy (consensusErrorPolicy) where - -import Control.Monad.Class.MonadAsync (ExceptionInLinkedThread (..)) -import Control.ResourceRegistry - ( RegistryClosedException - , ResourceRegistryThreadException - , TempRegistryException - ) -import Data.Proxy (Proxy) -import Data.Time.Clock (DiffTime) -import Data.Typeable (Typeable) -import Ouroboros.Consensus.Block (StandardHash) -import Ouroboros.Consensus.BlockchainTime -import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server - ( BlockFetchServerException - ) -import Ouroboros.Consensus.MiniProtocol.ChainSync.Client - ( ChainSyncClientException - ) -import Ouroboros.Consensus.Node.DbLock -import Ouroboros.Consensus.Node.DbMarker (DbMarkerError) -import Ouroboros.Consensus.Storage.ChainDB.API - ( ChainDbError (..) - , ChainDbFailure - ) -import Ouroboros.Consensus.Storage.ImmutableDB.API (ImmutableDBError) -import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB -import Ouroboros.Consensus.Storage.VolatileDB.API (VolatileDBError) -import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB -import Ouroboros.Network.ErrorPolicy -import System.FS.API.Types (FsError) - -consensusErrorPolicy :: - forall blk. - (Typeable blk, StandardHash blk) => - Proxy blk -> - ErrorPolicies -consensusErrorPolicy pb = - ErrorPolicies - { -- Exception raised during connect - -- - -- This is entirely a network-side concern. - epConErrorPolicies = [] - , -- Exception raised during interaction with the peer - -- - -- The list below should contain an entry for every type declared as an - -- instance of 'Exception' within ouroboros-consensus. - -- - -- If a particular exception is not handled by any policy, a default - -- kicks in, which currently means logging the exception and disconnecting - -- from the peer (in both directions), but allowing an immediate - -- reconnect. This is fine for exceptions that only affect that peer. - -- It is however essential that we handle exceptions here that /must/ - -- shut down the node (mainly storage layer errors). - -- - -- TODO: Talk to devops about what they should do when the node does - -- terminate with a storage layer exception (restart with full recovery). - epAppErrorPolicies = - [ -- Any exceptions in the storage layer should terminate the node - -- - -- NOTE: We do not catch IOExceptions here; they /ought/ to be caught - -- by the FS layer (and turn into FsError). If we do want to catch - -- them, we'd somehow have to distinguish between IO exceptions - -- arising from disk I/O (shutdownNode) and those arising from - -- network failures (SuspendConsumer). - ErrorPolicy $ \(_ :: DbMarkerError) -> Just shutdownNode - , ErrorPolicy $ \(_ :: DbLocked) -> Just shutdownNode - , ErrorPolicy $ \(_ :: ChainDbFailure blk) -> Just shutdownNode - , ErrorPolicy $ \(e :: VolatileDBError blk) -> - case e of - VolatileDB.ApiMisuse{} -> Just ourBug - VolatileDB.UnexpectedFailure{} -> Just shutdownNode - , ErrorPolicy $ \(e :: ImmutableDBError blk) -> - case e of - ImmutableDB.ApiMisuse{} -> Just ourBug - ImmutableDB.UnexpectedFailure{} -> Just shutdownNode - , ErrorPolicy $ \(_ :: FsError) -> Just shutdownNode - , -- When the system clock moved back, we have to restart the node. - ErrorPolicy $ \(_ :: SystemClockMovedBackException) -> Just shutdownNode - , -- Some chain DB errors are indicative of a bug in our code, others - -- indicate an invalid request from the peer. If the DB is closed - -- entirely, it will only be reopened after a node restart. - ErrorPolicy $ \(e :: ChainDbError blk) -> - case e of - ClosedDBError{} -> Just shutdownNode - ClosedFollowerError{} -> Just ourBug - InvalidIteratorRange{} -> Just theyBuggyOrEvil - , -- We have some resource registries that are used per-connection, - -- and so if we have ResourceRegistry related exception, we close - -- the connection but leave the rest of the node running. - ErrorPolicy $ \(_ :: RegistryClosedException) -> Just ourBug - , ErrorPolicy $ \(_ :: ResourceRegistryThreadException) -> Just ourBug - , ErrorPolicy $ \(_ :: TempRegistryException) -> Just ourBug - , -- An exception in the block fetch server meant the client asked - -- for some blocks we used to have but got GCed. This means the - -- peer is on a chain that forks off more than @k@ blocks away. - ErrorPolicy $ \(_ :: BlockFetchServerException) -> Just distantPeer - , -- Chain sync client exceptions indicate malicious behaviour. When we - -- have diverged too much from a client, making it no longer - -- interesting to us, we terminate with a result. - ErrorPolicy $ \(_ :: ChainSyncClientException) -> Just theyBuggyOrEvil - , -- Dispatch on nested exception - ErrorPolicy $ \(ExceptionInLinkedThread _ e) -> - evalErrorPolicies e (epAppErrorPolicies (consensusErrorPolicy pb)) - ] - } - where - -- Shutdown the node. If we have a storage layer failure, the node /must/ - -- be restarted (triggering recovery). - shutdownNode :: SuspendDecision DiffTime - shutdownNode = Throw - - -- Peer is either on a distant chain (one that forks more than k blocks ago) - -- or else is just too far behind; the chain sync client doesn't really have - -- any way of distinguishing between these two cases. If they are merely - -- far behind, we might want to reconnect to them later. - distantPeer :: SuspendDecision DiffTime - distantPeer = SuspendConsumer defaultDelay - - -- The peer sent us some data that they could have known was invalid. - -- This can only be due to a bug or malice. - theyBuggyOrEvil :: SuspendDecision DiffTime - theyBuggyOrEvil = SuspendPeer defaultDelay defaultDelay - - -- Something went wrong due to a bug in our code. We disconnect from the - -- peer, but allow to try again later in the hope the bug was transient. - -- We do not close the connection in the other direction; if the bug was - -- indeed local, it might not affect communication in the other direction. - ourBug :: SuspendDecision DiffTime - ourBug = SuspendConsumer defaultDelay - - -- Default delay - -- - -- We might want to tweak the delays for the various different kinds of - -- problems, but we'd need to establish a policy on how to set them. - defaultDelay :: DiffTime - defaultDelay = 200 -- seconds 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 a7aa8be583..b9c53da498 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 @@ -24,6 +24,7 @@ module Ouroboros.Consensus.NodeKernel , getPeersFromCurrentLedger , getPeersFromCurrentLedgerAfterSlot , initNodeKernel + , toConsensusMode ) where import Cardano.Network.ConsensusMode (ConsensusMode (..)) @@ -482,11 +483,11 @@ initInternalState peerSharingRegistry <- newPeerSharingRegistry return IS{..} - where - toConsensusMode :: forall a. LoEAndGDDConfig a -> ConsensusMode - toConsensusMode = \case - LoEAndGDDDisabled -> PraosMode - LoEAndGDDEnabled _ -> GenesisMode + +toConsensusMode :: forall a. LoEAndGDDConfig a -> ConsensusMode +toConsensusMode = \case + LoEAndGDDDisabled -> PraosMode + LoEAndGDDEnabled _ -> GenesisMode forkBlockForging :: forall m addrNTN addrNTC blk. @@ -495,12 +496,12 @@ forkBlockForging :: BlockForging m blk -> m (Thread m Void) forkBlockForging IS{..} blockForging = - forkLinkedWatcher registry threadLabel $ + forkLinkedWatcher registry label $ knownSlotWatcher btime $ \currentSlot -> withRegistry (\rr -> withEarlyExit_ $ go rr currentSlot) where - threadLabel :: String - threadLabel = + label :: String + label = "NodeKernel.blockForging." <> Text.unpack (forgeLabel blockForging) go :: ResourceRegistry m -> SlotNo -> WithEarlyExit m () @@ -899,7 +900,7 @@ getPeersFromCurrentLedger :: (IOLike m, LedgerSupportsPeerSelection blk) => NodeKernel m addrNTN addrNTC blk -> (LedgerState blk EmptyMK -> Bool) -> - STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]) + STM m (Maybe [(PoolStake, NonEmpty LedgerRelayAccessPoint)]) getPeersFromCurrentLedger kernel p = do immutableLedger <- ledgerState <$> ChainDB.getImmutableLedger (getChainDB kernel) @@ -920,7 +921,7 @@ getPeersFromCurrentLedgerAfterSlot :: ) => NodeKernel m addrNTN addrNTC blk -> SlotNo -> - STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]) + STM m (Maybe [(PoolStake, NonEmpty LedgerRelayAccessPoint)]) getPeersFromCurrentLedgerAfterSlot kernel slotNo = getPeersFromCurrentLedger kernel afterSlotNo where diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 88cb87e9ff..d34e717e76 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -12,6 +12,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -132,7 +133,7 @@ import Ouroboros.Network.PeerSelection.PeerMetric (nullMetric) import Ouroboros.Network.Point (WithOrigin (..)) import qualified Ouroboros.Network.Protocol.ChainSync.Type as CS import Ouroboros.Network.Protocol.KeepAlive.Type -import Ouroboros.Network.Protocol.Limits (waitForever) +import Ouroboros.Network.Protocol.Limits (ProtocolTimeLimitsWithRnd (..), waitForever) import Ouroboros.Network.Protocol.LocalStateQuery.Type import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharing) import Ouroboros.Network.Protocol.TxSubmission2.Type @@ -703,7 +704,7 @@ runThreadNetwork let emptySt = emptySt' doRangeQuery = roforkerRangeReadTables forker fullLedgerSt <- fmap ledgerState $ do - fullUTxO <- doRangeQuery NoPreviousQuery + (fullUTxO, _) <- doRangeQuery NoPreviousQuery pure $! withLedgerTables emptySt fullUTxO roforkerClose forker -- Combine the node's seed with the current slot number, to make sure @@ -1034,7 +1035,9 @@ runThreadNetwork let rng = case seed of Seed s -> mkStdGen s - (kaRng, psRng) = split rng + (kaRng, rng') = split rng + (gsmRng, rng'') = split rng' + (psRng, chainSyncRng) = split rng'' publicPeerSelectionStateVar <- makePublicPeerSelectionStateVar let nodeKernelArgs = NodeKernelArgs @@ -1073,7 +1076,7 @@ runThreadNetwork } , gsmArgs = GSM.GsmNodeKernelArgs - { gsmAntiThunderingHerd = kaRng + { gsmAntiThunderingHerd = gsmRng , gsmDurationUntilTooOld = Nothing , gsmMarkerFileView = GSM.MarkerFileView @@ -1105,18 +1108,12 @@ runThreadNetwork nodeKernel -- these tracers report every message sent/received by this -- node + chainSyncRng nullDebugProtocolTracers (customNodeToNodeCodecs pInfoConfig) NTN.noByteLimits -- see #1882, tests that can't cope with timeouts. - ( pure $ - NTN.ChainSyncTimeout - { canAwaitTimeout = waitForever - , intersectTimeout = waitForever - , mustReplyTimeout = waitForever - , idleTimeout = waitForever - } - ) + (ProtocolTimeLimitsWithRnd $ \_state -> (waitForever,)) CSClient.ChainSyncLoPBucketDisabled CSClient.CSJDisabled nullMetric diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs index 1146c7ff73..3ce9dcd237 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs @@ -26,9 +26,6 @@ import Ouroboros.Consensus.Protocol.Abstract ) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Protocol.ChainSync.Codec - ( ChainSyncTimeout (..) - ) import Ouroboros.Network.Protocol.Limits (shortWait) import qualified Test.Consensus.BlockTree as BT import Test.Consensus.PointSchedule diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/CSJ.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/CSJ.hs index 5ac1e20ac6..c7a7e31115 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/CSJ.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/CSJ.hs @@ -20,10 +20,6 @@ import Ouroboros.Consensus.Util.Condense , condenseListWithPadding ) import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Protocol.ChainSync.Codec - ( ChainSyncTimeout (mustReplyTimeout) - , idleTimeout - ) import Test.Consensus.BlockTree (BlockTree (..)) import Test.Consensus.Genesis.Setup import Test.Consensus.Genesis.Tests.Uniform (genUniformSchedulePoints) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs index 548aab7fa9..c90c0ee246 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs @@ -30,9 +30,6 @@ import Ouroboros.Consensus.Block.Abstract (WithOrigin (NotOrigin)) import Ouroboros.Consensus.Util.Condense (condense) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (blockNo, blockSlot, unBlockNo) -import Ouroboros.Network.Protocol.ChainSync.Codec - ( ChainSyncTimeout (..) - ) import Ouroboros.Network.Protocol.Limits (shortWait) import Test.Consensus.BlockTree (BlockTree (..), btbSuffix) import Test.Consensus.Genesis.Setup diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index 2f069bf576..b6579bd3dd 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -14,6 +14,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Consensus.HardFork.Combinator (tests) where @@ -33,6 +34,7 @@ import qualified Data.SOP.Tails as Tails import qualified Data.SOP.Telescope as Telescope import Data.Void (Void, absurd) import Data.Word +import qualified Database.LSMTree as LSM import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block @@ -56,6 +58,7 @@ import Ouroboros.Consensus.Protocol.LeaderSchedule ( LeaderSchedule (..) , leaderScheduleFor ) +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.IndexedMemPack import Ouroboros.Consensus.Util.Orphans () @@ -412,7 +415,7 @@ instance HasCanonicalTxIn '[BlockA, BlockB] where { getBlockABTxIn :: Void } deriving stock (Show, Eq, Ord) - deriving newtype (NoThunks, MemPack) + deriving newtype (NoThunks, MemPack, LSM.SerialiseKey) injectCanonicalTxIn IZ key = absurd key injectCanonicalTxIn (IS IZ) key = absurd key @@ -472,6 +475,14 @@ instance SupportedNetworkProtocolVersion TestBlock where latestReleasedNodeVersion = latestReleasedNodeVersionDefault +type instance + LSMTxOut (LedgerState (HardForkBlock [BlockA, BlockB])) = + TxOut (LedgerState (HardForkBlock [BlockA, BlockB])) + +instance HasLSMTxOut (LedgerState (HardForkBlock [BlockA, BlockB])) where + toLSMTxOut _ = id + fromLSMTxOut _ = id + instance SerialiseHFC '[BlockA, BlockB] -- Use defaults diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs index 3af2750702..054b2be6bf 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs @@ -63,10 +63,8 @@ import Ouroboros.Network.Protocol.ChainSync.ClientPipelined , chainSyncClientPeerPipelined ) import Ouroboros.Network.Protocol.ChainSync.Codec - ( ChainSyncTimeout (..) - , byteLimitsChainSync + ( byteLimitsChainSync , codecChainSyncId - , timeLimitsChainSync ) import Ouroboros.Network.Protocol.ChainSync.PipelineDecision ( pipelineDecisionLowHighMark @@ -86,6 +84,7 @@ import Test.Consensus.PeerSimulator.Trace ( TraceChainSyncClientTerminationEvent (..) , TraceEvent (..) ) +import Test.Consensus.PointSchedule (ChainSyncTimeout (..), timeLimitsChainSync) import Test.Consensus.PointSchedule.Peers (PeerId) import Test.Util.Orphans.IOLike () diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index d3f6a76ed8..2bb1c13a97 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -58,7 +58,6 @@ import Ouroboros.Network.ControlMessage ( ControlMessage (..) , ControlMessageSTM ) -import Ouroboros.Network.Protocol.ChainSync.Codec import Ouroboros.Network.Util.ShowProxy (ShowProxy) import qualified Test.Consensus.PeerSimulator.BlockFetch as BlockFetch import qualified Test.Consensus.PeerSimulator.CSJInvariants as CSJInvariants @@ -74,6 +73,7 @@ import Test.Consensus.PeerSimulator.Trace import Test.Consensus.PointSchedule ( BlockFetchTimeout , CSJParams (..) + , ChainSyncTimeout , GenesisTest (..) , GenesisTestFull , LoPBucketParams (..) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs index c16d826849..f1d8fcb2de 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs @@ -14,7 +14,6 @@ import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Driver.Limits ( ProtocolLimitFailure (ExceededTimeLimit) ) -import Ouroboros.Network.Protocol.ChainSync.Codec (mustReplyTimeout) import Test.Consensus.BlockTree (BlockTree (..)) import Test.Consensus.Genesis.Setup import Test.Consensus.PeerSimulator.Run diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs index 1efb0e5418..1a8d8744fe 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs @@ -15,7 +15,6 @@ import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Driver.Limits ( ProtocolLimitFailure (ExceededTimeLimit) ) -import Ouroboros.Network.Protocol.ChainSync.Codec (mustReplyTimeout) import Test.Consensus.BlockTree (btTrunk) import Test.Consensus.Genesis.Setup import Test.Consensus.PeerSimulator.Run diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs index 98eba03fbb..55a1a72999 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -45,6 +48,8 @@ module Test.Consensus.PointSchedule , prettyPointSchedule , stToGen , uniformPoints + , ChainSyncTimeout (..) + , timeLimitsChainSync ) where import Cardano.Ledger.BaseTypes (unNonZero) @@ -63,11 +68,11 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Time (DiffTime) import Data.Word (Word64) +import Network.TypedProtocol import Ouroboros.Consensus.Block.Abstract (withOriginToMaybe) import Ouroboros.Consensus.Ledger.SupportsProtocol ( GenesisWindow (..) ) -import Ouroboros.Consensus.Network.NodeToNode (ChainSyncTimeout (..)) import Ouroboros.Consensus.Protocol.Abstract ( SecurityParam (SecurityParam) , maxRollbacks @@ -79,7 +84,9 @@ import Ouroboros.Consensus.Util.Condense ) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (SlotNo (..), blockSlot) +import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits (..)) import Ouroboros.Network.Point (withOrigin) +import Ouroboros.Network.Protocol.ChainSync.Type import System.Random.Stateful (STGenM, StatefulGen, runSTGen_) import qualified System.Random.Stateful as Random import Test.Consensus.BlockTree @@ -555,6 +562,43 @@ data BlockFetchTimeout = BlockFetchTimeout , streamingTimeout :: Maybe DiffTime } +-- | Configurable chain-sync timeouts +data ChainSyncTimeout = ChainSyncTimeout + { canAwaitTimeout :: Maybe DiffTime + , intersectTimeout :: Maybe DiffTime + , mustReplyTimeout :: Maybe DiffTime + , idleTimeout :: Maybe DiffTime + } + +-- | Time Limits +-- +-- > 'TokIdle' 'waitForever' (ie never times out) +-- > 'TokNext TokCanAwait' the given 'canAwaitTimeout' +-- > 'TokNext TokMustReply' the given 'mustReplyTimeout' +-- > 'TokIntersect' the given 'intersectTimeout' +timeLimitsChainSync :: + forall header point tip. + ChainSyncTimeout -> + ProtocolTimeLimits (ChainSync header point tip) +timeLimitsChainSync csTimeouts = ProtocolTimeLimits stateToLimit + where + ChainSyncTimeout + { canAwaitTimeout + , intersectTimeout + , mustReplyTimeout + , idleTimeout + } = csTimeouts + + stateToLimit :: + forall (st :: ChainSync header point tip). + ActiveState st => + StateToken st -> Maybe DiffTime + stateToLimit SingIdle = idleTimeout + stateToLimit (SingNext SingCanAwait) = canAwaitTimeout + stateToLimit (SingNext SingMustReply) = mustReplyTimeout + stateToLimit SingIntersect = intersectTimeout + stateToLimit a@SingDone = notActiveState a + -- | All the data used by point schedule tests. data GenesisTest blk schedule = GenesisTest { gtSecurityParam :: SecurityParam @@ -654,20 +698,22 @@ ensureScheduleDuration gt PointSchedule{psSchedule, psStartOrder, psMinEndTime} } where endingDelay = - let cst = gtChainSyncTimeouts gt - bft = gtBlockFetchTimeouts gt - bfGracePeriodDelay = fromIntegral adversaryCount * 10 - in 1 - + bfGracePeriodDelay - + fromIntegral peerCount - * maximum - ( 0 - : catMaybes - [ canAwaitTimeout cst - , intersectTimeout cst - , busyTimeout bft - , streamingTimeout bft - ] - ) + let + -- cst = gtChainSyncTimeouts gt + bft = gtBlockFetchTimeouts gt + bfGracePeriodDelay = fromIntegral adversaryCount * 10 + in + 1 + + bfGracePeriodDelay + + fromIntegral peerCount + * maximum + ( 0 + : catMaybes + -- [ canAwaitTimeout cst + -- , intersectTimeout cst + [ busyTimeout bft + , streamingTimeout bft + ] + ) peerCount = length (peersList psSchedule) adversaryCount = Map.size (adversarialPeers psSchedule) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index cbfffc1026..23aa832339 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -253,6 +253,7 @@ library Ouroboros.Consensus.Storage.LedgerDB.V2.Args Ouroboros.Consensus.Storage.LedgerDB.V2.Forker Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory + Ouroboros.Consensus.Storage.LedgerDB.V2.LSM Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq Ouroboros.Consensus.Storage.Serialisation Ouroboros.Consensus.Storage.VolatileDB @@ -294,7 +295,10 @@ library build-depends: FailT ^>=0.1.2, + blockio, + random, aeson, + filepath, base >=4.14 && <4.22, base-deriving-via, base16-bytestring, @@ -316,18 +320,18 @@ library diff-containers >=1.2, filelock, fingertree-rm >=1.0, - fs-api ^>=0.3, + fs-api ^>=0.4, hashable, - io-classes ^>=1.5, + io-classes:{io-classes, si-timers, strict-mvar, strict-stm} ^>=1.8.0.1, measures, mempack, monoid-subclasses, mtl, multiset ^>=0.3, nothunks ^>=0.2, - ouroboros-network-api ^>=0.14, + ouroboros-network-api ^>=0.15, ouroboros-network-mock ^>=0.1, - ouroboros-network-protocols ^>=0.14, + ouroboros-network-protocols ^>=0.15, primitive, psqueues ^>=0.2.3, quiet ^>=0.2, @@ -335,7 +339,6 @@ library resource-registry ^>=0.1, semialign >=1.1, serialise ^>=0.2, - si-timers ^>=1.5, singletons, small-steps ^>=1.1, sop-core ^>=0.5, @@ -343,16 +346,15 @@ library streaming, strict >=0.1 && <0.6, strict-checked-vars ^>=0.2, - strict-mvar ^>=1.5, strict-sop-core ^>=0.1, - strict-stm ^>=1.5, text, these ^>=1.2, time, transformers, transformers-base, - typed-protocols ^>=0.3, + typed-protocols ^>=1.0, vector ^>=0.13, + lsm-tree, x-docspec-extra-packages: directory @@ -446,10 +448,10 @@ library unstable-consensus-testlib directory, file-embed, filepath, - fs-api ^>=0.3, - fs-sim ^>=0.3, + fs-api ^>=0.4, + fs-sim ^>=0.4, generics-sop, - io-classes, + io-classes:{io-classes, si-timers, strict-mvar, strict-stm}, io-sim, mempack, mtl, @@ -466,12 +468,9 @@ library unstable-consensus-testlib random, resource-registry, serialise, - si-timers, sop-core, sop-extras, - strict-mvar, strict-sop-core, - strict-stm, tasty, tasty-golden, tasty-hunit, @@ -522,6 +521,7 @@ library unstable-mock-block cardano-ledger-core, cardano-slotting:{cardano-slotting, testlib}, cborg, + lsm-tree, containers, deepseq, hashable, @@ -545,9 +545,9 @@ library unstable-mempool-test-utils base, contra-tracer, deepseq, + io-classes:strict-stm, ouroboros-consensus, resource-registry, - strict-stm, library unstable-tutorials import: common-lib @@ -611,10 +611,10 @@ test-suite consensus-test deepseq, diff-containers, fingertree-rm, - fs-api ^>=0.3, + fs-api ^>=0.4, fs-sim, hashable, - io-classes, + io-classes:{io-classes, si-timers, strict-mvar, strict-stm}, io-sim, measures, mtl, @@ -632,12 +632,9 @@ test-suite consensus-test random, resource-registry, serialise, - si-timers, sop-core, sop-extras, - strict-mvar, strict-sop-core, - strict-stm, tasty, tasty-hunit, tasty-quickcheck, @@ -645,9 +642,7 @@ test-suite consensus-test transformers, transformers-base, tree-diff, - typed-protocols ^>=0.3, - typed-protocols-examples, - typed-protocols-stateful, + typed-protocols:{examples, stateful, typed-protocols} ^>=1, unstable-consensus-testlib, unstable-mock-block, @@ -728,6 +723,7 @@ test-suite storage-test aeson, base, bifunctors, + lsm-tree, binary, bytestring, cardano-binary, @@ -743,11 +739,11 @@ test-suite storage-test diff-containers, directory, filepath, - fs-api ^>=0.3, - fs-sim ^>=0.3, + fs-api ^>=0.4, + fs-sim ^>=0.4, generics-sop, hashable, - io-classes, + io-classes:{io-classes, strict-mvar, strict-stm}, io-sim, mempack, mtl, @@ -763,8 +759,6 @@ test-suite storage-test resource-registry, serialise, sop-core, - strict-mvar, - strict-stm, tasty, tasty-hunit, tasty-quickcheck, @@ -828,7 +822,7 @@ benchmark ChainSync-client-bench ouroboros-network-protocols, resource-registry, time, - typed-protocols-examples, + typed-protocols:examples, unstable-consensus-testlib, with-utf8, 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..f535b177f4 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 @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -73,6 +74,7 @@ import qualified Data.SOP.Tails as Tails import Data.SOP.Telescope (Telescope (..)) import qualified Data.SOP.Telescope as Telescope import Data.Typeable +import qualified Database.LSMTree as LSM import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block @@ -102,6 +104,7 @@ import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Storage.LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IndexedMemPack (IndexedMemPack) @@ -1293,6 +1296,15 @@ composeTxOutTranslations = \case class MemPack (TxOut (LedgerState x)) => MemPackTxOut x instance MemPack (TxOut (LedgerState x)) => MemPackTxOut x +instance MemPack (DefaultHardForkTxOut xs) => LSM.SerialiseValue (DefaultHardForkTxOut xs) where + serialiseValue = serialiseLSMViaMemPack + deserialiseValue = deserialiseLSMViaMemPack + +deriving via + LSM.ResolveAsFirst (DefaultHardForkTxOut xs) + instance + LSM.ResolveValue (DefaultHardForkTxOut xs) + instance (All MemPackTxOut xs, Typeable xs) => MemPack (DefaultHardForkTxOut xs) 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 da84be8441..ecb65f33c0 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 @@ -105,6 +105,7 @@ 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) @@ -200,7 +201,7 @@ class , -- LedgerTables on the HardForkBlock might not be compositionally -- defined, but we need to require this instances for any instantiation. HasLedgerTables (LedgerState (HardForkBlock xs)) - , SerializeTablesWithHint (LedgerState (HardForkBlock xs)) + , LedgerSupportsLedgerDB (HardForkBlock xs) ) => SerialiseHFC xs where 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 09d27ae447..1549359bce 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -1103,6 +1103,11 @@ decodeDualLedgerState decodeMain = do type instance TxIn (LedgerState (DualBlock m a)) = TxIn (LedgerState m) type instance TxOut (LedgerState (DualBlock m a)) = TxOut (LedgerState m) +type instance LSMTxOut (LedgerState (DualBlock m a)) = TxOut (LedgerState m) + +instance HasLSMTxOut (LedgerState (DualBlock m a)) where + toLSMTxOut _ = id + fromLSMTxOut _ = id instance CanUpgradeLedgerTables (LedgerState (DualBlock m a)) where upgradeTables _ _ = id diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs index 8edb3edd83..68483ded16 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs @@ -5,10 +5,9 @@ module Ouroboros.Consensus.Ledger.SupportsPeerSelection , stakePoolRelayAccessPoint -- * Re-exports for convenience - , DomainAccessPoint (..) , IP (..) , PortNumber - , RelayAccessPoint (..) + , LedgerRelayAccessPoint (..) ) where import Control.DeepSeq (NFData (..)) @@ -18,25 +17,24 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Type ( PoolStake (..) ) import Ouroboros.Network.PeerSelection.RelayAccessPoint - ( DomainAccessPoint (..) - , IP (..) + ( IP (..) + , LedgerRelayAccessPoint (..) , PortNumber - , RelayAccessPoint (..) ) -- | A relay registered for a stake pool data StakePoolRelay = -- | One of the current relays - CurrentRelay RelayAccessPoint + CurrentRelay LedgerRelayAccessPoint | -- | One of the future relays - FutureRelay RelayAccessPoint + FutureRelay LedgerRelayAccessPoint deriving (Show, Eq) instance NFData StakePoolRelay where rnf (CurrentRelay ra) = rnf ra rnf (FutureRelay ra) = rnf ra -stakePoolRelayAccessPoint :: StakePoolRelay -> RelayAccessPoint +stakePoolRelayAccessPoint :: StakePoolRelay -> LedgerRelayAccessPoint stakePoolRelayAccessPoint (CurrentRelay ra) = ra stakePoolRelayAccessPoint (FutureRelay ra) = ra 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 8a3429842a..46c2b024cb 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 @@ -723,12 +723,6 @@ data TraceEvent blk | TraceChainSelStarvationEvent (TraceChainSelStarvationEvent blk) deriving Generic -deriving instance - ( Eq (Header blk) - , LedgerSupportsProtocol blk - , InspectLedger blk - ) => - Eq (TraceEvent blk) deriving instance ( Show (Header blk) , LedgerSupportsProtocol blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs index 0235a8be6a..0c1308a55e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs @@ -804,6 +804,7 @@ openPrimaryIndex cacheEnv chunk allowExisting = do flip onException (hClose pHnd) $ do newCurrentChunkInfo <- case allowExisting of MustBeNew -> return $ emptyCurrentChunkInfo chunk + MustExist -> loadCurrentChunkInfo hasFS chunkInfo chunk AllowExisting -> loadCurrentChunkInfo hasFS chunkInfo chunk mbEvicted <- modifyMVar cacheVar $ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs index 79ef405aa0..a4755b5aec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs @@ -424,6 +424,13 @@ open hasFS@HasFS{hOpen, hClose} chunk allowExisting = do flip onException (hClose pHnd) $ do case allowExisting of AllowExisting -> return () + MustExist -> + -- create the file if it doesn't exist + void $ + hPut hasFS pHnd $ + Put.execPut $ + Put.putWord8 currentVersionNumber + <> putSecondaryOffset 0 -- If the file is new, write the version number and the first offset, -- i.e. 0. MustBeNew -> 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 77129b8a56..5060684ec1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -17,6 +17,7 @@ module Ouroboros.Consensus.Storage.LedgerDB , openDBInternal ) where +import Control.ResourceRegistry import Data.Functor.Contravariant ((>$<)) import Data.Word import Ouroboros.Consensus.Block @@ -27,9 +28,12 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Stream import Ouroboros.Consensus.Storage.LedgerDB.API 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.V2 as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike @@ -39,7 +43,6 @@ openDB :: forall m blk. ( IOLike m , LedgerSupportsProtocol blk - , LedgerDbSerialiseConstraints blk , InspectLedger blk , HasCallStack , HasHardForkHistory blk @@ -70,14 +73,32 @@ openDB args bss getBlock - in doOpenDB args initDb stream replayGoal - LedgerDbFlavorArgsV2 bss -> + in doOpenDB args defaultDeleteSnapshot initDb stream replayGoal + LedgerDbFlavorArgsV2 bss -> do + (ds, bss') <- case bss of + V2.V2Args V2.InMemoryHandleArgs -> pure (defaultDeleteSnapshot, V2.InMemoryHandleEnv) + V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)) -> do + (rk1, V2.SomeHasFSAndBlockIO fs blockio) <- mkFS (lgrRegistry args) "lsm" + session <- + allocate + (lgrRegistry args) + ( \_ -> do + salt <- genSalt + LSM.openSession + (LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args) + fs + blockio + salt + (mkFsPath [path]) + ) + LSM.closeSession + pure (LSM.deleteSnapshot (snd session), V2.LSMHandleEnv session rk1) let initDb = V2.mkInitDb args - bss + bss' getBlock - in doOpenDB args initDb stream replayGoal + doOpenDB args ds initDb stream replayGoal {------------------------------------------------------------------------------- Opening a LedgerDB @@ -91,12 +112,13 @@ doOpenDB :: , HasCallStack ) => Complete LedgerDbArgs m blk -> + (SomeHasFS m -> DiskSnapshot -> m ()) -> InitDB db m blk -> StreamAPI m blk blk -> Point blk -> m (LedgerDB' m blk, Word64) -doOpenDB args initDb stream replayGoal = - f <$> openDBInternal args initDb stream replayGoal +doOpenDB args deleteSnapshot initDb stream replayGoal = + f <$> openDBInternal args deleteSnapshot initDb stream replayGoal where f (ldb, replayCounter, _) = (ldb, replayCounter) @@ -108,11 +130,12 @@ openDBInternal :: , HasCallStack ) => Complete LedgerDbArgs m blk -> + (SomeHasFS m -> DiskSnapshot -> m ()) -> InitDB db m blk -> StreamAPI m blk blk -> Point blk -> m (LedgerDB' m blk, Word64, TestInternals' m blk) -openDBInternal args@(LedgerDbArgs{lgrHasFS = SomeHasFS fs}) initDb stream replayGoal = do +openDBInternal args@(LedgerDbArgs{lgrHasFS = SomeHasFS fs}) deleteSnapshot initDb stream replayGoal = do createDirectoryIfMissing fs True (mkFsPath []) (_initLog, db, replayCounter) <- initialize @@ -124,6 +147,7 @@ openDBInternal args@(LedgerDbArgs{lgrHasFS = SomeHasFS fs}) initDb stream replay replayGoal initDb lgrStartSnapshot + deleteSnapshot (ledgerDb, internal) <- mkLedgerDb initDb db return (ledgerDb, replayCounter, internal) where 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 3491f343da..cdc33d51da 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 @@ -117,7 +117,10 @@ module Ouroboros.Consensus.Storage.LedgerDB.API , LedgerDbSerialiseConstraints , LedgerSupportsInMemoryLedgerDB , LedgerSupportsLedgerDB - , LedgerSupportsOnDiskLedgerDB + , LedgerSupportsLMDBLedgerDB + , LedgerSupportsLSMLedgerDB + , LSMTxOut + , HasLSMTxOut (..) , ResolveBlock , currentPoint @@ -171,6 +174,7 @@ import Data.MemPack import Data.Set (Set) import Data.Void (absurd) import Data.Word +import qualified Database.LSMTree as LSM import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block @@ -502,6 +506,7 @@ initialize :: Point blk -> InitDB db m blk -> Maybe DiskSnapshot -> + (SomeHasFS m -> DiskSnapshot -> m ()) -> m (InitLog blk, db, Word64) initialize replayTracer @@ -511,7 +516,8 @@ initialize stream replayGoal dbIface - fromSnapshot = + fromSnapshot + deleteSnapshot = case fromSnapshot of Nothing -> listSnapshots hasFS >>= tryNewestFirst id Just snap -> tryNewestFirst id [snap] @@ -762,12 +768,36 @@ instance Supporting On-Disk backing stores -------------------------------------------------------------------------------} -type LedgerSupportsOnDiskLedgerDB blk = +type LedgerSupportsLMDBLedgerDB blk = (IndexedMemPack (LedgerState blk EmptyMK) (TxOut (LedgerState blk))) +type LedgerSupportsLSMLedgerDB blk = + ( LSM.SerialiseKey (TxIn (LedgerState blk)) + , LSM.SerialiseValue (LSMTxOut (LedgerState blk)) + , LSM.ResolveValue (LSMTxOut (LedgerState blk)) + , HasLSMTxOut (LedgerState blk) + ) + +-- | LSM trees need to be able to serialize and deserialize values several +-- times, without any context. Therefore the approach of using a ledger state to +-- hint the era in which values need to be deserialized cannot work with LSM. +-- +-- Therefore, we will instead store 'LSMTxOut' in the LSM database, which will +-- be 'TxOut' for most of the unitary blocks and basic hard fork blocks, but +-- will be 'ByteArray's for the Cardano Block. +type LSMTxOut :: LedgerStateKind -> Type +type family LSMTxOut l + +-- | Conversion of 'TxOut's to and from 'LSMTxOut'. +class HasLSMTxOut l where + toLSMTxOut :: Proxy l -> TxOut l -> LSMTxOut l + fromLSMTxOut :: l EmptyMK -> LSMTxOut l -> TxOut l + type LedgerSupportsLedgerDB blk = - ( LedgerSupportsOnDiskLedgerDB blk + ( LedgerSupportsLMDBLedgerDB blk , LedgerSupportsInMemoryLedgerDB blk + , LedgerSupportsLSMLedgerDB blk + , LedgerDbSerialiseConstraints 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 63935c89fa..28e8b1bfce 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 @@ -18,6 +18,7 @@ -- | Arguments for LedgerDB initialization. module Ouroboros.Consensus.Storage.LedgerDB.Args ( LedgerDbArgs (..) + , LedgerDbBackendArgs (..) , LedgerDbFlavorArgs (..) , QueryBatchSize (..) , defaultArgs @@ -40,6 +41,8 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 import Ouroboros.Consensus.Util.Args import System.FS.API +data LedgerDbBackendArgs m = V1LMDB (Complete V1.LedgerDbFlavorArgs m) | V2InMemory | V2LSM FilePath + {------------------------------------------------------------------------------- Arguments -------------------------------------------------------------------------------} 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 cea2fc630d..fa0a981e91 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 @@ -55,6 +55,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.Forker , TraceValidateEvent (..) ) where +import Data.Bifunctor (first) import Control.Monad (void) import Control.Monad.Base import Control.Monad.Except @@ -105,7 +106,7 @@ data Forker m l blk = Forker forkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)) -- ^ Read ledger tables from disk. - , forkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK)) + , forkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l))) -- ^ Range-read ledger tables from disk. -- -- This range read will return as many values as the 'QueryBatchSize' that @@ -206,7 +207,7 @@ ledgerStateReadOnlyForker frk = ReadOnlyForker { roforkerClose = roforkerClose , roforkerReadTables = fmap castLedgerTables . roforkerReadTables . castLedgerTables - , roforkerRangeReadTables = fmap castLedgerTables . roforkerRangeReadTables . castRangeQueryPrevious + , roforkerRangeReadTables = fmap (first castLedgerTables) . roforkerRangeReadTables . castRangeQueryPrevious , roforkerGetLedgerState = ledgerState <$> roforkerGetLedgerState , roforkerReadStatistics = roforkerReadStatistics } @@ -239,7 +240,7 @@ data ReadOnlyForker m l blk = ReadOnlyForker -- ^ See 'forkerClose' , roforkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)) -- ^ See 'forkerReadTables' - , roforkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK)) + , roforkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l))) -- ^ See 'forkerRangeReadTables'. , roforkerGetLedgerState :: !(STM m (l EmptyMK)) -- ^ See 'forkerGetLedgerState' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs index 0148964163..cba86ef909 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs @@ -43,7 +43,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.Snapshots , snapshotToMetadataPath -- * Management - , deleteSnapshot + , defaultDeleteSnapshot , listSnapshots , loadSnapshotMetadata , trimSnapshots @@ -183,17 +183,20 @@ instance FromJSON SnapshotMetadata where data SnapshotBackend = UTxOHDMemSnapshot | UTxOHDLMDBSnapshot + | UTxOHDLSMSnapshot deriving (Eq, Show) instance ToJSON SnapshotBackend where toJSON = \case UTxOHDMemSnapshot -> "utxohd-mem" UTxOHDLMDBSnapshot -> "utxohd-lmdb" + UTxOHDLSMSnapshot -> "utxohd-lsm" instance FromJSON SnapshotBackend where parseJSON = Aeson.withText "SnapshotBackend" $ \case "utxohd-mem" -> pure UTxOHDMemSnapshot "utxohd-lmdb" -> pure UTxOHDLMDBSnapshot + "utxohd-lsm" -> pure UTxOHDLSMSnapshot _ -> fail "unknown SnapshotBackend" data MetadataErr @@ -236,8 +239,8 @@ listSnapshots (SomeHasFS HasFS{listDirectory}) = aux = List.sortOn (Down . dsNumber) . mapMaybe snapshotFromPath . Set.toList -- | Delete snapshot from disk -deleteSnapshot :: (Monad m, HasCallStack) => SomeHasFS m -> DiskSnapshot -> m () -deleteSnapshot (SomeHasFS HasFS{doesDirectoryExist, removeDirectoryRecursive}) ss = do +defaultDeleteSnapshot :: (Monad m, HasCallStack) => SomeHasFS m -> DiskSnapshot -> m () +defaultDeleteSnapshot (SomeHasFS HasFS{doesDirectoryExist, removeDirectoryRecursive}) ss = do let p = snapshotToDirPath ss exists <- doesDirectoryExist p when exists (removeDirectoryRecursive p) @@ -338,9 +341,10 @@ trimSnapshots :: Monad m => Tracer m (TraceSnapshotEvent r) -> SomeHasFS m -> + (SomeHasFS m -> DiskSnapshot -> m ()) -> SnapshotPolicy -> m [DiskSnapshot] -trimSnapshots tracer fs SnapshotPolicy{onDiskNumSnapshots} = do +trimSnapshots tracer fs deleteSnapshot SnapshotPolicy{onDiskNumSnapshots} = do -- We only trim temporary snapshots ss <- filter diskSnapshotIsTemporary <$> listSnapshots fs -- The snapshot are most recent first, so we can simply drop from the 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 1072efa1fb..1bc193cd87 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 @@ -26,7 +26,7 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 data FlavorImplSpecificTrace = FlavorImplSpecificTraceV1 V1.FlavorImplSpecificTrace | FlavorImplSpecificTraceV2 V2.FlavorImplSpecificTrace - deriving (Show, Eq) + deriving Show data TraceEvent blk = LedgerDBSnapshotEvent !(TraceSnapshotEvent blk) @@ -38,6 +38,3 @@ data TraceEvent blk deriving instance (StandardHash blk, InspectLedger blk) => Show (TraceEvent blk) -deriving instance - (StandardHash blk, InspectLedger blk) => - Eq (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 aa08ce0cec..4d6490e553 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 @@ -75,7 +75,6 @@ mkInitDb :: forall m blk. ( LedgerSupportsProtocol blk , IOLike m - , LedgerDbSerialiseConstraints blk , HasHardForkHistory blk , LedgerSupportsLedgerDB blk ) => @@ -306,6 +305,7 @@ implTryTakeSnapshot env mTime nrBlocks = trimSnapshots (LedgerDBSnapshotEvent >$< ldbTracer env) (snapshotsFs $ ldbHasFS env) + defaultDeleteSnapshot (ldbSnapshotPolicy env) (`SnapCounters` 0) . Just <$> maybe getMonotonicTime (pure . snd) mTime else diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs index 405f3d2581..841f79cda3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs @@ -13,7 +13,6 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.Args ( BackingStoreArgs (..) , FlushFrequency (..) , LedgerDbFlavorArgs (..) - , defaultLedgerDbFlavorArgs , shouldFlush ) where @@ -55,9 +54,3 @@ data BackingStoreArgs f m class (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m instance (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m - -defaultLedgerDbFlavorArgs :: Incomplete LedgerDbFlavorArgs m -defaultLedgerDbFlavorArgs = V1Args DefaultFlushFrequency defaultBackingStoreArgs - -defaultBackingStoreArgs :: Incomplete BackingStoreArgs m -defaultBackingStoreArgs = InMemoryBackingStoreArgs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs index aa1e162932..54f3389ea1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs @@ -146,7 +146,7 @@ implForkerRangeReadTables :: QueryBatchSize -> ForkerEnv m l blk -> RangeQueryPrevious l -> - m (LedgerTables l ValuesMK) + m (LedgerTables l ValuesMK, Maybe (TxIn l)) implForkerRangeReadTables qbs env rq0 = do traceWith (foeTracer env) ForkerRangeReadTablesStart ldb <- readTVarIO $ foeChangelog env @@ -175,7 +175,8 @@ implForkerRangeReadTables qbs env rq0 = do bsvh <- getValueHandle env values <- BackingStore.bsvhRangeRead bsvh st (rq{BackingStore.rqCount = nrequested}) traceWith (foeTracer env) ForkerRangeReadTablesEnd - pure $ ltliftA2 (doFixupReadResult nrequested) diffs values + let res@(LedgerTables (ValuesMK resValues)) = ltliftA2 (doFixupReadResult nrequested) diffs values + pure (res, fst <$> Map.lookupMax resValues) where rq = BackingStore.RangeQuery rq1 (fromIntegral $ defaultQueryBatchSize qbs) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs index 64f0840551..ebab73b823 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs @@ -252,7 +252,6 @@ snapshotToTablesPath = mkFsPath . (\x -> [x, "tables"]) . snapshotToDirName loadSnapshot :: forall m blk. ( IOLike m - , LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk , LedgerSupportsLedgerDB blk ) => 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 b7c523d469..c6ed0db950 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 @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -13,6 +14,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Storage.LedgerDB.V2 (mkInitDb) where @@ -33,7 +35,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Traversable (for) import Data.Tuple (Solo (..)) -import Data.Void import Data.Word import GHC.Generics import NoThunks.Class @@ -56,6 +57,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent import Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 import Ouroboros.Consensus.Storage.LedgerDB.V2.Forker import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.CallStack @@ -72,13 +74,14 @@ mkInitDb :: , IOLike m , LedgerDbSerialiseConstraints blk , HasHardForkHistory blk + , LSM.LedgerSupportsLSMLedgerDB (LedgerState blk) , LedgerSupportsInMemoryLedgerDB blk ) => Complete LedgerDbArgs m blk -> - Complete V2.LedgerDbFlavorArgs m -> + HandleEnv m -> ResolveBlock m blk -> InitDB (LedgerSeq' m blk) m blk -mkInitDb args flavArgs getBlock = +mkInitDb args bss getBlock = InitDB { initFromGenesis = emptyF =<< lgrGenesis , initFromSnapshot = @@ -112,6 +115,9 @@ mkInitDb args flavArgs getBlock = , ldbResolveBlock = getBlock , ldbQueryBatchSize = lgrQueryBatchSize , ldbOpenHandlesLock = lock + , ldbSession = case bss of + InMemoryHandleEnv -> Nothing + LSMHandleEnv (s, _) k -> Just (s, k) } h <- LDBHandle <$> newTVarIO (LedgerDBOpen env) pure $ implMkLedgerDb h bss @@ -127,8 +133,6 @@ mkInitDb args flavArgs getBlock = , lgrRegistry } = args - bss = case flavArgs of V2Args bss0 -> bss0 - v2Tracer :: Tracer m V2.FlavorImplSpecificTrace v2Tracer = LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 >$< lgrTracer @@ -137,8 +141,11 @@ mkInitDb args flavArgs getBlock = m (LedgerSeq' m blk) emptyF st = empty' st $ case bss of - InMemoryHandleArgs -> InMemory.newInMemoryLedgerTablesHandle v2Tracer lgrHasFS - LSMHandleArgs x -> absurd x + InMemoryHandleEnv -> InMemory.newInMemoryLedgerTablesHandle v2Tracer lgrHasFS + LSMHandleEnv (_, session) _ -> + \values -> do + table <- LSM.tableFromValuesMK lgrRegistry session values + LSM.newLSMLedgerTablesHandle v2Tracer lgrRegistry session table loadSnapshot :: CodecConfig blk -> @@ -146,8 +153,8 @@ mkInitDb args flavArgs getBlock = DiskSnapshot -> m (Either (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk)) loadSnapshot ccfg fs ds = case bss of - InMemoryHandleArgs -> runExceptT $ InMemory.loadSnapshot v2Tracer lgrRegistry ccfg fs ds - LSMHandleArgs x -> absurd x + InMemoryHandleEnv -> runExceptT $ InMemory.loadSnapshot v2Tracer lgrRegistry ccfg fs ds + LSMHandleEnv (_, session) _ -> runExceptT $ LSM.loadSnapshot v2Tracer lgrRegistry ccfg fs session ds implMkLedgerDb :: forall m l blk. @@ -162,7 +169,7 @@ implMkLedgerDb :: , HasHardForkHistory blk ) => LedgerDBHandle m l blk -> - HandleArgs -> + HandleEnv m -> (LedgerDB m l blk, TestInternals m l blk) implMkLedgerDb h bss = ( LedgerDB @@ -188,7 +195,7 @@ mkInternals :: , LedgerSupportsProtocol blk , ApplyBlock (ExtLedgerState blk) blk ) => - HandleArgs -> + HandleEnv m -> LedgerDBHandle m (ExtLedgerState blk) blk -> TestInternals' m blk mkInternals bss h = @@ -226,9 +233,10 @@ mkInternals bss h = (st `withLedgerTables` tables) forkerPush frk st' >> atomically (forkerCommit frk) >> forkerClose frk , wipeLedgerDB = getEnv h $ destroySnapshots . ldbHasFS - , closeLedgerDB = + , closeLedgerDB = do let LDBHandle tvar = h - in atomically (writeTVar tvar LedgerDBClosed) + getEnv h $ \env -> maybe (pure ()) (\(x, y) -> unsafeRelease x >> unsafeRelease y >> pure ()) (ldbSession env) + atomically (writeTVar tvar LedgerDBClosed) , truncateSnapshots = getEnv h $ implIntTruncateSnapshots . ldbHasFS , getNumLedgerTablesHandles = getEnv h $ \env -> do l <- readTVarIO (ldbSeq env) @@ -244,8 +252,8 @@ mkInternals bss h = StateRef m (ExtLedgerState blk) -> m (Maybe (DiskSnapshot, RealPoint blk)) takeSnapshot = case bss of - InMemoryHandleArgs -> InMemory.takeSnapshot - LSMHandleArgs x -> absurd x + InMemoryHandleEnv -> InMemory.takeSnapshot + LSMHandleEnv{} -> LSM.takeSnapshot -- | Testing only! Truncate all snapshots in the DB. implIntTruncateSnapshots :: MonadThrow m => SomeHasFS m -> m () @@ -359,7 +367,7 @@ implTryTakeSnapshot :: , LedgerSupportsProtocol blk , LedgerDbSerialiseConstraints blk ) => - HandleArgs -> + HandleEnv m -> LedgerDBEnv m l blk -> Maybe (Time, Time) -> Word64 -> @@ -378,6 +386,7 @@ implTryTakeSnapshot bss env mTime nrBlocks = trimSnapshots (LedgerDBSnapshotEvent >$< ldbTracer env) (ldbHasFS env) + deleteSnapshot (ldbSnapshotPolicy env) (`SnapCounters` 0) . Just <$> maybe getMonotonicTime (pure . snd) mTime else @@ -390,14 +399,26 @@ implTryTakeSnapshot bss env mTime nrBlocks = StateRef m (ExtLedgerState blk) -> m (Maybe (DiskSnapshot, RealPoint blk)) takeSnapshot config trcr fs ref = case bss of - InMemoryHandleArgs -> + InMemoryHandleEnv -> InMemory.takeSnapshot config trcr fs Nothing ref - LSMHandleArgs x -> absurd x + LSMHandleEnv{} -> + LSM.takeSnapshot + config + trcr + fs + Nothing + ref + + deleteSnapshot = case bss of + InMemoryHandleEnv -> + defaultDeleteSnapshot + LSMHandleEnv (_, session) _ -> + LSM.deleteSnapshot session -- In the first version of the LedgerDB for UTxO-HD, there is a need to -- periodically flush the accumulated differences to the disk. However, in the @@ -474,6 +495,7 @@ data LedgerDBEnv m l blk = LedgerDBEnv -- -- * Modify 'ldbSeq' while holding a write lock, and then close the removed -- handles without any locking. + , ldbSession :: !(Maybe (ResourceKey m, ResourceKey m)) } deriving Generic @@ -487,6 +509,10 @@ deriving instance ) => NoThunks (LedgerDBEnv m l blk) +instance NoThunks (LSM.Session m) where + showTypeOf _ = "Session" + wNoThunks _ _ = pure Nothing + {------------------------------------------------------------------------------- The LedgerDBHandle -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs index 99eaad0d28..5dadab5149 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs @@ -1,29 +1,40 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Storage.LedgerDB.V2.Args ( FlavorImplSpecificTrace (..) , HandleArgs (..) + , HandleEnv (..) , LedgerDbFlavorArgs (..) + , SomeHasFSAndBlockIO (..) + , LSMHandleArgs (..) ) where -import Data.Void (Void) -import GHC.Generics -import NoThunks.Class +import Control.ResourceRegistry +import Data.Typeable +import Database.LSMTree (LSMTreeTrace (..), Salt, Session) +import Ouroboros.Consensus.Util.Args +import System.FS.API +import System.FS.BlockIO.API -data LedgerDbFlavorArgs f m = V2Args HandleArgs +data LedgerDbFlavorArgs f m = V2Args (HandleArgs f m) -data HandleArgs +data HandleArgs f m = InMemoryHandleArgs - | LSMHandleArgs Void - deriving (Generic, NoThunks) + | LSMHandleArgs (LSMHandleArgs f m) + +data LSMHandleArgs f m = LSMArgs + { lsmFilePath :: HKD f FilePath + , lsmGenSalt :: HKD f (m Salt) + , lsmMkFS :: HKD f (ResourceRegistry m -> FilePath -> m (ResourceKey m, SomeHasFSAndBlockIO m)) + } + +data SomeHasFSAndBlockIO m where + SomeHasFSAndBlockIO :: (Eq h, Typeable h) => HasFS m h -> HasBlockIO m h -> SomeHasFSAndBlockIO m + +data HandleEnv m + = InMemoryHandleEnv + | LSMHandleEnv (ResourceKey m, Session m) (ResourceKey m) data FlavorImplSpecificTrace = -- | Created a new 'LedgerTablesHandle', potentially by duplicating an @@ -31,4 +42,5 @@ data FlavorImplSpecificTrace TraceLedgerTablesHandleCreate | -- | Closed a 'LedgerTablesHandle'. TraceLedgerTablesHandleClose - deriving (Show, Eq) + | LSMTrace LSMTreeTrace + deriving Show 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 3a2e7f8940..983c767d6e 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 @@ -75,7 +75,8 @@ implForkerReadTables :: implForkerReadTables env ks = do traceWith (foeTracer env) ForkerReadTablesStart lseq <- readTVarIO (foeLedgerSeq env) - tbs <- read (tables $ currentHandle lseq) ks + let stateRef = currentHandle lseq + tbs <- read (tables stateRef) (state stateRef) ks traceWith (foeTracer env) ForkerReadTablesEnd pure tbs @@ -84,16 +85,17 @@ implForkerRangeReadTables :: QueryBatchSize -> ForkerEnv m l blk -> RangeQueryPrevious l -> - m (LedgerTables l ValuesMK) + m (LedgerTables l ValuesMK, Maybe (TxIn l)) implForkerRangeReadTables qbs env rq0 = do traceWith (foeTracer env) ForkerRangeReadTablesStart ldb <- readTVarIO $ foeLedgerSeq env let n = fromIntegral $ defaultQueryBatchSize qbs + stateRef = currentHandle ldb case rq0 of - NoPreviousQuery -> readRange (tables $ currentHandle ldb) (Nothing, n) - PreviousQueryWasFinal -> pure $ LedgerTables emptyMK + NoPreviousQuery -> readRange (tables stateRef) (state stateRef) (Nothing, n) + PreviousQueryWasFinal -> pure (LedgerTables emptyMK, Nothing) PreviousQueryWasUpTo k -> do - tbs <- readRange (tables $ currentHandle ldb) (Just k, n) + tbs <- readRange (tables stateRef) (state stateRef) (Just k, n) traceWith (foeTracer env) ForkerRangeReadTablesEnd pure tbs 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 35f569d99c..3dc25dd67b 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 @@ -102,19 +102,20 @@ newInMemoryLedgerTablesHandle tracer someFS@(SomeHasFS hasFS) l = do hs <- readTVarIO tv !x <- guardClosed hs $ newInMemoryLedgerTablesHandle tracer someFS pure x - , read = \keys -> do + , read = \_ keys -> do hs <- readTVarIO tv guardClosed hs (pure . flip (ltliftA2 (\(ValuesMK v) (KeysMK k) -> ValuesMK $ v `Map.restrictKeys` k)) keys) - , readRange = \(f, t) -> do + , readRange = \_ (f, t) -> do hs <- readTVarIO tv guardClosed hs ( \(LedgerTables (ValuesMK m)) -> - pure . LedgerTables . ValuesMK . Map.take t . (maybe id (\g -> snd . Map.split g) f) $ m + let m' = Map.take t . (maybe id (\g -> snd . Map.split g) f) $ m + in pure (LedgerTables (ValuesMK m'), fst <$> Map.lookupMax m') ) - , readAll = do + , readAll = \_ -> do hs <- readTVarIO tv guardClosed hs pure , pushDiffs = \st0 !diffs -> @@ -137,7 +138,7 @@ newInMemoryLedgerTablesHandle tracer someFS@(SomeHasFS hasFS) l = do guardClosed h $ \values -> withFile hasFS (mkFsPath [snapshotName, "tables", "tvar"]) (WriteMode MustBeNew) $ \hf -> - fmap snd $ + fmap (Just . snd) $ hPutAllCRC hasFS hf $ CBOR.toLazyByteString $ valuesMKEncoder hint values @@ -172,7 +173,7 @@ writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do writeSnapshotMetadata fs ds $ SnapshotMetadata { snapshotBackend = UTxOHDMemSnapshot - , snapshotChecksum = crcOfConcat crc1 crc2 + , snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2 } takeSnapshot :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs new file mode 100644 index 0000000000..f94065c99f --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Implementation of the 'LedgerTablesHandle' interface with LSM trees. +module Ouroboros.Consensus.Storage.LedgerDB.V2.LSM + ( -- * LedgerTablesHandle + newLSMLedgerTablesHandle + , tableFromValuesMK + + -- * Constraints + , LedgerSupportsLSMLedgerDB + + -- * LSM TxOuts + , LSMTxOut + , HasLSMTxOut (..) + + -- * Snapshots + , loadSnapshot + , snapshotToStatePath + , takeSnapshot + , deleteSnapshot + + -- * Serialise helpers + , serialiseLSMViaMemPack + , deserialiseLSMViaMemPack + + -- * Re-exports + , LSM.Entry (..) + , LSM.SerialiseKey (..) + , LSM.SerialiseValue (..) + , LSM.ResolveValue (..) + , LSM.ResolveAsFirst (..) + , LSM.RawBytes (..) + , LSM.Salt + , Session + , LSM.openSession + , LSM.closeSession + , stdGenSalt + , stdMkBlockIOFS + ) where + +import Cardano.Binary as CBOR +import Codec.Serialise (decode) +import qualified Control.Monad as Monad +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Except +import Control.ResourceRegistry +import Control.Tracer +import Data.Functor.Contravariant ((>$<)) +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 qualified Data.Set as Set +import Data.String (fromString) +import qualified Data.Vector as V +import Data.Vector.Primitive (Vector (..)) +import Data.Void +import Database.LSMTree (Session, Table) +import qualified Database.LSMTree as LSM +import qualified Database.LSMTree.Internal.Types as LSM +import GHC.Generics +import NoThunks.Class +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.SupportsProtocol +import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff +import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Storage.LedgerDB.API hiding (LedgerSupportsLSMLedgerDB) +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq +import Ouroboros.Consensus.Util.CRC +import Ouroboros.Consensus.Util.Enclose +import Ouroboros.Consensus.Util.IOLike +import System.FS.API +import qualified System.FS.BlockIO.API as BIO +import System.FS.BlockIO.IO +import qualified System.FilePath as FilePath +import System.Random +import Prelude hiding (read) + +type LedgerSupportsLSMLedgerDB l = + ( LSM.SerialiseKey (TxIn l) + , LSM.SerialiseValue (LSMTxOut l) + , LSM.ResolveValue (LSMTxOut l) + , HasLSMTxOut l + ) + +-- | Type alias for convenience +type UTxOTable m l = Table m (TxIn l) (LSMTxOut l) Void + +data LedgerTablesHandleState m l + = LedgerTablesHandleOpen !(UTxOTable m l) + | LedgerTablesHandleClosed + deriving Generic + +deriving instance NoThunks (LedgerTablesHandleState m l) + +instance NoThunks (Table m txin txout Void) where + showTypeOf _ = "Table" + wNoThunks _ (LSM.Table _tbl) = pure Nothing + +data LSMClosedExn = LSMClosedExn + deriving (Show, Exception) + +-- | Create the initial LSM table from values, which should happen only at the +-- Genesis. +tableFromValuesMK :: + forall m l. + IOLike m => + LedgerSupportsLSMLedgerDB l => + ResourceRegistry m -> + Session m -> + LedgerTables l ValuesMK -> + m (ResourceKey m, UTxOTable m l) +tableFromValuesMK rr session (LedgerTables (ValuesMK values)) = do + res@(_, table) <- allocate rr (\_ -> LSM.newTable session) LSM.closeTable + LSM.inserts table $ + V.fromList $ + [(k, (toLSMTxOut (Proxy @l) v), Nothing) | (k, v) <- Map.toList values] + pure res + +guardClosed :: + MonadSTM m => StrictTVar m (LedgerTablesHandleState m l) -> (UTxOTable m l -> m a) -> m a +guardClosed tv f = do + readTVarIO tv >>= \case + LedgerTablesHandleClosed -> error $ show LSMClosedExn + LedgerTablesHandleOpen st -> f st + +newLSMLedgerTablesHandle :: + forall m l. + ( IOLike m + , HasLedgerTables l + , LedgerSupportsLSMLedgerDB l + ) => + Tracer m V2.FlavorImplSpecificTrace -> + ResourceRegistry m -> + Session m -> + (ResourceKey m, UTxOTable m l) -> + m (LedgerTablesHandle m l) +newLSMLedgerTablesHandle tracer rr session (resKey, t0) = do + !tv <- newTVarIO (LedgerTablesHandleOpen t0) + traceWith tracer V2.TraceLedgerTablesHandleCreate + pure + LedgerTablesHandle + { close = do + Monad.void $ release resKey + atomically $ writeTVar tv LedgerTablesHandleClosed + traceWith tracer V2.TraceLedgerTablesHandleClose + , duplicate = do + guardClosed tv $ \t -> do + table <- allocate rr (\_ -> LSM.duplicate t) LSM.closeTable + newLSMLedgerTablesHandle tracer rr session table + , read = \st (LedgerTables (KeysMK keys)) -> do + guardClosed + tv + ( \t -> do + let keys' = Set.toList keys + res <- LSM.lookups t (V.fromList keys') + pure $ + LedgerTables $ + ValuesMK $ + Map.fromList [(k, fromLSMTxOut st v) | (k, LSM.Found v) <- zip keys' (V.toList res)] + ) + , readRange = implReadRange tv + , readAll = \st -> + let readAll' m = do + (v, n) <- implReadRange tv st (m, 100000) + maybe (pure v) (\k -> fmap (ltliftA2 unionValues v) $ readAll' (Just k)) n + in readAll' Nothing + , pushDiffs = const (implPushDiffs tv) + , takeHandleSnapshot = \_ snapshotName -> do + guardClosed tv $ + \table -> do + Monad.void $ LSM.saveSnapshot (fromString snapshotName) "UTxO table" table + pure Nothing + , tablesSize = pure Nothing + } + +implReadRange :: + IOLike m => + HasLedgerTables l => + LedgerSupportsLSMLedgerDB l => + StrictTVar m (LedgerTablesHandleState m l) -> + l EmptyMK -> + (Maybe (TxIn l), Int) -> + m (LedgerTables l ValuesMK, Maybe (TxIn l)) +implReadRange tv st = \(mPrev, num) -> + guardClosed + tv + ( \table -> + let + cursorFromStart = LSM.withCursor table (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 k (LSM.take $ num + 1) + in + do + entries <- V.toList <$> maybe cursorFromStart cursorFromKey mPrev + pure + ( LedgerTables . ValuesMK . Map.fromList $ + [(k, (fromLSMTxOut st v)) | LSM.Entry k v <- entries] + , case snd <$> List.unsnoc entries of + Nothing -> Nothing + Just (LSM.Entry k _) -> Just k + Just (LSM.EntryWithBlob k _ _) -> Just k + ) + ) + +implPushDiffs :: + forall m l. + ( LedgerSupportsLSMLedgerDB l + , IOLike m + , HasLedgerTables l + ) => + StrictTVar m (LedgerTablesHandleState m l) -> l DiffMK -> m () +implPushDiffs tv !st1 = do + let LedgerTables (DiffMK (Diff.Diff diffs)) = projectLedgerTables st1 + guardClosed + tv + ( \t -> + LSM.updates t $ + V.fromList + [ ( k + , case h of + Diff.Insert v -> LSM.Insert (toLSMTxOut (Proxy @l) v) Nothing + Diff.Delete -> LSM.Delete + ) + | (k, h) <- Map.toList diffs + ] + ) + +-- | The path within the LedgerDB's filesystem to the file that contains the +-- snapshot's serialized ledger state +snapshotToStatePath :: DiskSnapshot -> FsPath +snapshotToStatePath = mkFsPath . (\x -> [x, "state"]) . snapshotToDirName + +type instance LSMTxOut (ExtLedgerState blk) = LSMTxOut (LedgerState blk) + +instance HasLSMTxOut (LedgerState blk) => HasLSMTxOut (ExtLedgerState blk) where + toLSMTxOut _ txout = toLSMTxOut (Proxy @(LedgerState blk)) txout + fromLSMTxOut l txout = fromLSMTxOut (ledgerState l) txout + +takeSnapshot :: + ( IOLike m + , LedgerDbSerialiseConstraints blk + , LedgerSupportsProtocol blk + ) => + CodecConfig blk -> + Tracer m (TraceSnapshotEvent blk) -> + SomeHasFS m -> + Maybe String -> + StateRef m (ExtLedgerState blk) -> + m (Maybe (DiskSnapshot, RealPoint blk)) +takeSnapshot ccfg tracer hasFS suffix st = do + case pointToWithOriginRealPoint (castPoint (getTip $ state st)) of + Origin -> return Nothing + NotOrigin t -> do + let number = unSlotNo (realPointSlot t) + snapshot = DiskSnapshot number suffix + diskSnapshots <- listSnapshots hasFS + if List.any (== DiskSnapshot number suffix) diskSnapshots + then + return Nothing + else do + encloseTimedWith (TookSnapshot snapshot t >$< tracer) $ + writeSnapshot hasFS (encodeDiskExtLedgerState ccfg) snapshot st + return $ Just (snapshot, t) + +writeSnapshot :: + MonadThrow m => + SomeHasFS m -> + (ExtLedgerState blk EmptyMK -> Encoding) -> + DiskSnapshot -> + StateRef m (ExtLedgerState blk) -> + m () +writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do + createDirectoryIfMissing hasFs True $ snapshotToDirPath ds + crc1 <- writeExtLedgerState fs encLedger (snapshotToStatePath ds) $ state st + crc2 <- + takeHandleSnapshot (tables st) (state st) $ + show (dsNumber ds) <> (maybe "" (("_" <>) . show) (dsSuffix ds)) + writeSnapshotMetadata fs ds $ + SnapshotMetadata + { snapshotBackend = UTxOHDLSMSnapshot + , snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2 + } + +-- | Delete snapshot from disk and also from the LSM tree database. +deleteSnapshot :: IOLike m => Session m -> SomeHasFS m -> DiskSnapshot -> m () +deleteSnapshot session (SomeHasFS HasFS{doesDirectoryExist, removeDirectoryRecursive}) ss = do + let p = snapshotToDirPath ss + exists <- doesDirectoryExist p + Monad.when exists (removeDirectoryRecursive p) + LSM.deleteSnapshot + session + (fromString $ show (dsNumber ss) <> (maybe "" (("_" <>) . show) (dsSuffix ss))) + +-- | Read snapshot from disk. +-- +-- Fail on data corruption, i.e. when the checksum of the read data differs +-- from the one tracked by @'DiskSnapshot'@. +loadSnapshot :: + forall blk m. + ( LedgerDbSerialiseConstraints blk + , LedgerSupportsProtocol blk + , IOLike m + , LedgerSupportsLSMLedgerDB (ExtLedgerState blk) + ) => + Tracer m V2.FlavorImplSpecificTrace -> + ResourceRegistry m -> + CodecConfig blk -> + SomeHasFS m -> + Session m -> + DiskSnapshot -> + ExceptT (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk) +loadSnapshot tracer rr ccfg fs session ds = do + snapshotMeta <- + withExceptT (InitFailureRead . ReadMetadataError (snapshotToMetadataPath ds)) $ + loadSnapshotMetadata fs ds + Monad.when (snapshotBackend snapshotMeta /= UTxOHDMemSnapshot) $ do + throwE $ InitFailureRead $ ReadMetadataError (snapshotToMetadataPath ds) MetadataBackendMismatch + (extLedgerSt, checksumAsRead) <- + withExceptT + (InitFailureRead . ReadSnapshotFailed) + $ readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (snapshotToStatePath ds) + case pointToWithOriginRealPoint (castPoint (getTip extLedgerSt)) of + Origin -> throwE InitFailureGenesis + NotOrigin pt -> do + values <- + lift $ + allocate + rr + ( \_ -> + LSM.openTableFromSnapshot + session + (fromString $ show (dsNumber ds) <> (maybe "" (("_" <>) . show) (dsSuffix ds))) + "UTxO table" + ) + LSM.closeTable + Monad.when (checksumAsRead /= snapshotChecksum snapshotMeta) $ + throwE $ + InitFailureRead $ + ReadSnapshotDataCorruption + (,pt) <$> lift (empty extLedgerSt values (newLSMLedgerTablesHandle tracer rr session)) + +-- | Helper for implementing 'serialiseKey' and 'serialiseValue' for types that +-- are serialized via 'MemPack'. +serialiseLSMViaMemPack :: MemPack a => a -> LSM.RawBytes +serialiseLSMViaMemPack a = + let barr = pack a + in LSM.RawBytes (Vector 0 (PBA.sizeofByteArray barr) barr) + +-- | Helper for implementing 'deserialiseKey' and 'deserialiseValue' for types +-- that are serialized via 'MemPack'. +deserialiseLSMViaMemPack :: MemPack b => LSM.RawBytes -> b +deserialiseLSMViaMemPack (LSM.RawBytes (Vector _ _ barr)) = unpackError barr + +stdGenSalt :: IO LSM.Salt +stdGenSalt = fst . genWord64 <$> initStdGen + +stdMkBlockIOFS :: + FilePath -> ResourceRegistry IO -> FilePath -> IO (ResourceKey IO, V2.SomeHasFSAndBlockIO IO) +stdMkBlockIOFS fastStoragePath rr relPath = do + (rk1, bio) <- + allocate + rr + (\_ -> ioHasBlockIO (MountPoint $ fastStoragePath FilePath. relPath) defaultIOCtxParams) + (BIO.close . snd) + pure $ (rk1, uncurry V2.SomeHasFSAndBlockIO bio) 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 fdf3b75207..d11b7a2d5c 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 @@ -81,22 +81,44 @@ import Prelude hiding (read) LedgerTablesHandles -------------------------------------------------------------------------------} +-- | The interface fulfilled by handles on both the InMemory and LSM handles. data LedgerTablesHandle m l = LedgerTablesHandle { close :: !(m ()) , duplicate :: !(m (LedgerTablesHandle m l)) - -- ^ It is expected that this operation takes constant time. - , read :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)) - , readRange :: !((Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK)) - , readAll :: !(m (LedgerTables l ValuesMK)) + -- ^ Create a copy of the handle. + -- + -- When applying diffs to a table, we will first duplicate the handle, then + -- apply the diffs in the copy. It is expected that this operation takes + -- constant time. + , read :: !(l EmptyMK -> LedgerTables l KeysMK -> m (LedgerTables l 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))) + -- ^ 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. + -- + -- The returned value contains both the read values as well as the last key + -- retrieved. This is necessary because the LSM backend uses an alternative + -- serialization format and the last key in the returned Map might not be the + -- last key read. + , readAll :: !(l EmptyMK -> m (LedgerTables l ValuesMK)) -- ^ Costly read all operation, not to be used in Consensus but only in - -- snapshot-converter executable. + -- 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 ()) -- ^ Push some diffs into the ledger tables handle. -- -- The first argument has to be the ledger state before applying -- the block, the second argument should be the ledger state after -- applying a block. See 'CanUpgradeLedgerTables'. - , takeHandleSnapshot :: !(l EmptyMK -> String -> m CRC) + -- + -- Note 'CanUpgradeLedgerTables' is only used in the InMemory backend. + , takeHandleSnapshot :: !(l EmptyMK -> String -> m (Maybe CRC)) + -- ^ 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)) -- ^ Consult the size of the ledger tables in the database. This will return -- 'Nothing' in backends that do not support this operation. @@ -168,8 +190,8 @@ empty :: , IOLike m ) => l EmptyMK -> - LedgerTables l ValuesMK -> - (LedgerTables l ValuesMK -> m (LedgerTablesHandle m l)) -> + init -> + (init -> m (LedgerTablesHandle m l)) -> m (LedgerSeq m l) empty st tbs new = LedgerSeq . AS.Empty . StateRef st <$> new tbs @@ -222,7 +244,7 @@ reapplyBlock evs cfg b _rr db = do let ks = getBlockKeySets b StateRef st tbs = currentHandle db newtbs <- duplicate tbs - vals <- read newtbs ks + vals <- read newtbs st ks let st' = tickThenReapply evs cfg b (st `withLedgerTables` vals) newst = forgetLedgerTables st' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs index d6d1a80998..4eba0f7c8a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs @@ -265,11 +265,16 @@ instance MonadMask m => MonadMask (WithEarlyExit m) where unmask' = earlyExit . unmask . withEarlyExit in withEarlyExit (f unmask') + getMaskingState = lift getMaskingState + + interruptible f = earlyExit $ interruptible $ withEarlyExit f + instance MonadThread m => MonadThread (WithEarlyExit m) where type ThreadId (WithEarlyExit m) = ThreadId m myThreadId = lift myThreadId labelThread = lift .: labelThread + threadLabel = lift . threadLabel instance (MonadMask m, MonadAsync m, MonadCatch (STM m)) => @@ -318,6 +323,8 @@ instance MonadFork m => MonadFork (WithEarlyExit m) where throwTo = lift .: throwTo yield = lift yield + getNumCapabilities = lift getNumCapabilities + instance PrimMonad m => PrimMonad (WithEarlyExit m) where type PrimState (WithEarlyExit m) = PrimState m primitive = lift . primitive @@ -365,8 +372,8 @@ instance MonadLabelledSTM m => MonadLabelledSTM (WithEarlyExit m) where instance MonadSay m => MonadSay (WithEarlyExit m) where say = lift . say -instance (MonadInspectSTM m, Monad (InspectMonad m)) => MonadInspectSTM (WithEarlyExit m) where - type InspectMonad (WithEarlyExit m) = InspectMonad m +instance (MonadInspectSTM m, Monad (InspectMonadSTM m)) => MonadInspectSTM (WithEarlyExit m) where + type InspectMonadSTM (WithEarlyExit m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) 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 22939e57c7..1da97bb080 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IndexedMemPack.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IndexedMemPack.hs @@ -13,6 +13,7 @@ module Ouroboros.Consensus.Util.IndexedMemPack ( IndexedMemPack (..) , MemPack (..) + , indexedPackByteArray , indexedPackByteString , indexedUnpackError ) where diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs index e0ad053148..d9e7d40258 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs @@ -132,15 +132,15 @@ mkOracularClock BTime.SystemTime{..} numSlots future = , getCurrentSlot = do (slot, _leftInSlot, _slotLength) <- getPresent pure slot - , forkEachSlot_ = \rr threadLabel action -> + , forkEachSlot_ = \rr label action -> fmap cancelThread $ - forkLinkedThread rr threadLabel $ + forkLinkedThread rr label $ fix $ \loop -> do -- INVARIANT the slot returned here ascends monotonically unless -- the underlying 'BTime.SystemTime' jumps backwards (slot, leftInSlot, _slotLength) <- getPresent - let lbl = threadLabel <> " [" <> show slot <> "]" + let lbl = label <> " [" <> show slot <> "]" -- fork the action, so it can't threadDelay us void $ forkLinkedThread rr lbl $ action slot diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs index 4fb64eab9f..f129474087 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs @@ -108,11 +108,11 @@ onTick :: Tick -> m () -> m () -onTick registry clock threadLabel tick action = do +onTick registry clock label tick action = do void $ forkLinkedThread registry - threadLabel + label (waitForTick clock tick >> action) -- | Block until the specified tick diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index f9c6a26ba2..d83d845ef0 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -530,6 +530,11 @@ instance type instance TxIn (LedgerState TestBlock) = Void type instance TxOut (LedgerState TestBlock) = Void +type instance LSMTxOut (LedgerState TestBlock) = Void + +instance HasLSMTxOut (LedgerState TestBlock) where + toLSMTxOut _ = id + fromLSMTxOut _ = id instance LedgerTablesAreTrivial (LedgerState TestBlock) where convertMapKind (TestLedger x EmptyPLDS) = TestLedger x EmptyPLDS diff --git a/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs b/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs index f0e09f43a9..5481c5f261 100644 --- a/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs +++ b/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs @@ -97,7 +97,7 @@ openMockedMempool capacityOverride tracer initialParams = do , roforkerReadTables = \keys -> pure $ projectLedgerTables st `restrictValues'` keys , roforkerReadStatistics = pure Nothing - , roforkerRangeReadTables = \_ -> pure emptyLedgerTables + , roforkerRangeReadTables = \_ -> pure (emptyLedgerTables, Nothing) } ) } diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index a57d6d4d8b..e189d1d151 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} @@ -17,6 +18,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | Simple block to go with the mock ledger -- @@ -86,6 +88,7 @@ import Data.Kind (Type) import Data.Proxy import Data.Typeable import Data.Word +import qualified Database.LSMTree as LSM import GHC.Generics (Generic) import GHC.TypeNats (KnownNat) import NoThunks.Class (NoThunks (..)) @@ -112,6 +115,7 @@ import Ouroboros.Consensus.Storage.Common , SizeInBytes ) import Ouroboros.Consensus.Storage.LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM import Ouroboros.Consensus.Util (ShowProxy (..), hashFromBytesShortE) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IndexedMemPack @@ -525,6 +529,21 @@ instance LedgerSupportsPeerSelection (SimpleBlock c ext) where type instance TxIn (LedgerState (SimpleBlock c ext)) = Mock.TxIn type instance TxOut (LedgerState (SimpleBlock c ext)) = Mock.TxOut +type instance LSMTxOut (LedgerState (SimpleBlock c ext)) = Mock.TxOut + +instance HasLSMTxOut (LedgerState (SimpleBlock c ext)) where + toLSMTxOut _ = id + fromLSMTxOut _ = id + +instance LSM.SerialiseKey Mock.TxIn where + serialiseKey = serialiseLSMViaMemPack + deserialiseKey = deserialiseLSMViaMemPack + +instance LSM.SerialiseValue Mock.TxOut where + serialiseValue = serialiseLSMViaMemPack + deserialiseValue = deserialiseLSMViaMemPack + +deriving via LSM.ResolveAsFirst Mock.TxOut instance LSM.ResolveValue Mock.TxOut instance CanUpgradeLedgerTables (LedgerState (SimpleBlock c ext)) where upgradeTables _ _ = id diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs index f5c72cb409..bbc24a81b5 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs @@ -578,7 +578,7 @@ instance MonadLabelledSTM m => MonadLabelledSTM (OverrideDelay m) where labelTBQueueIO v = OverrideDelay . lift . LazySTM.labelTBQueueIO v instance MonadInspectSTM m => MonadInspectSTM (OverrideDelay m) where - type InspectMonad (OverrideDelay m) = InspectMonad m + type InspectMonadSTM (OverrideDelay m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy :: Proxy m) inspectTMVar _ = inspectTMVar (Proxy :: Proxy m) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs index 434bcfa9c6..7d46b78cf2 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs @@ -716,7 +716,7 @@ withTestMempool setup@TestSetup{..} prop = { roforkerClose = pure () , roforkerReadTables = pure . (projectLedgerTables st `restrictValues'`) - , roforkerRangeReadTables = const $ pure emptyLedgerTables + , roforkerRangeReadTables = const $ pure (emptyLedgerTables, Nothing) , roforkerGetLedgerState = pure $ forgetLedgerTables st , roforkerReadStatistics = pure Nothing } diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs index 8ddb62e312..4a240e0911 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs @@ -107,7 +107,7 @@ testTxSizeFairness TestParams{mempoolMaxCapacity, smallTxSize, largeTxSize, nrOf ReadOnlyForker { roforkerClose = pure () , roforkerReadTables = const $ pure emptyLedgerTables - , roforkerRangeReadTables = const $ pure emptyLedgerTables + , roforkerRangeReadTables = const $ pure (emptyLedgerTables, Nothing) , roforkerGetLedgerState = pure $ testInitLedgerWithState NoPayLoadDependentState , roforkerReadStatistics = pure Nothing } diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs index 8f8d14bf70..7a12b44eee 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs @@ -18,7 +18,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -#if __GLASGOW_HASKELL__ >= 910 +#if __GLASGOW_HASKELL__ >= 908 {-# OPTIONS_GHC -Wno-x-partial #-} #endif @@ -543,7 +543,7 @@ newLedgerInterface initialLedger = do { roforkerClose = pure () , roforkerReadStatistics = pure Nothing , roforkerReadTables = pure . (projectLedgerTables st `restrictValues'`) - , roforkerRangeReadTables = const $ pure emptyLedgerTables + , roforkerRangeReadTables = const $ pure (emptyLedgerTables, Nothing) , roforkerGetLedgerState = pure $ forgetLedgerTables st } ) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs index a5cbbdbffb..842956ce89 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs @@ -1,9 +1,11 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs index 746290b3ae..6a4a3fe0a5 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs @@ -44,6 +44,7 @@ import Control.Monad.Except import Control.Monad.State hiding (state) import Control.ResourceRegistry import Control.Tracer (Tracer (..)) +import Data.Functor.Contravariant ((>$<)) import qualified Data.List as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -68,6 +69,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.V2.Args hiding ( LedgerDbFlavorArgs ) import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import Ouroboros.Consensus.Util hiding (Some) import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike @@ -102,7 +104,9 @@ tests = , testProperty "InMemV2" $ prop_sequential 100000 inMemV2TestArguments noFilePath simulatedFS , testProperty "LMDB" $ - prop_sequential 1000 lmdbTestArguments realFilePath realFS + prop_sequential 1000 lmdbTestArguments (realFilePath "lmdb") realFS + , testProperty "LSM" $ + prop_sequential 1000 lsmTestArguments (realFilePath "lsm") realFS ] prop_sequential :: @@ -156,9 +160,10 @@ data TestArguments m = TestArguments noFilePath :: IO (FilePath, IO ()) noFilePath = pure ("Bogus", pure ()) -realFilePath :: IO (FilePath, IO ()) -realFilePath = liftIO $ do - tmpdir <- (FilePath. "test_lmdb") <$> Dir.getTemporaryDirectory +realFilePath :: String -> IO (FilePath, IO ()) +realFilePath l = liftIO $ do + tmpdir <- (FilePath. ("test_" <> l)) <$> Dir.getTemporaryDirectory + Dir.createDirectoryIfMissing False tmpdir pure ( tmpdir , do @@ -197,6 +202,17 @@ inMemV2TestArguments secParam _ = , argLedgerDbCfg = extLedgerDbConfig secParam } +lsmTestArguments :: + SecurityParam -> + FilePath -> + TestArguments IO +lsmTestArguments secParam fp = + TestArguments + { argFlavorArgs = + LedgerDbFlavorArgsV2 $ V2Args $ LSMHandleArgs $ LSMArgs fp LSM.stdGenSalt (LSM.stdMkBlockIOFS fp) + , argLedgerDbCfg = extLedgerDbConfig secParam + } + lmdbTestArguments :: SecurityParam -> FilePath -> @@ -495,14 +511,32 @@ openLedgerDB flavArgs env cfg fs = do args bss getBlock - in openDBInternal args initDb stream replayGoal - LedgerDbFlavorArgsV2 bss -> + in openDBInternal args defaultDeleteSnapshot initDb stream replayGoal + LedgerDbFlavorArgsV2 bss -> do + (ds, bss') <- case bss of + V2.V2Args V2.InMemoryHandleArgs -> pure (defaultDeleteSnapshot, V2.InMemoryHandleEnv) + V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)) -> do + (rk1, V2.SomeHasFSAndBlockIO fs' blockio) <- mkFS (lgrRegistry args) "lsm" + session <- + allocate + (lgrRegistry args) + ( \_ -> do + salt <- genSalt + LSM.openSession + (LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args) + fs' + blockio + salt + (mkFsPath [path]) + ) + LSM.closeSession + pure (LSM.deleteSnapshot (snd session), V2.LSMHandleEnv session rk1) let initDb = V2.mkInitDb args - bss + bss' getBlock - in openDBInternal args initDb stream replayGoal + openDBInternal args ds initDb stream replayGoal withRegistry $ \reg -> do vr <- validateFork ldb reg (const $ pure ()) BlockCache.empty 0 (map getHeader volBlocks) case vr of @@ -617,6 +651,7 @@ mkTrackOpenHandles = do atomically $ modifyTVar varOpen $ case ev of V2.TraceLedgerTablesHandleCreate -> succ V2.TraceLedgerTablesHandleClose -> pred + _ -> id _ -> pure () pure (tracer, readTVarIO varOpen) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine/TestBlock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine/TestBlock.hs index 1ea2ac2f12..7dd64c907b 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine/TestBlock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine/TestBlock.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -49,6 +50,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.TreeDiff import Data.Word +import qualified Database.LSMTree as LSM import GHC.Generics (Generic) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -58,6 +60,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Storage.LedgerDB.API import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.IndexedMemPack import Ouroboros.Network.Block (Point (Point)) @@ -213,6 +216,21 @@ queryKeys f (LedgerTables (ValuesMK utxovals)) = f utxovals type instance TxIn (LedgerState TestBlock) = Token type instance TxOut (LedgerState TestBlock) = TValue +type instance LSMTxOut (LedgerState TestBlock) = TValue + +instance LSM.SerialiseKey Token where + serialiseKey = serialiseLSMViaMemPack + deserialiseKey = deserialiseLSMViaMemPack + +instance LSM.SerialiseValue TValue where + serialiseValue = serialiseLSMViaMemPack + deserialiseValue = deserialiseLSMViaMemPack + +deriving via LSM.ResolveAsFirst TValue instance LSM.ResolveValue TValue + +instance HasLSMTxOut (LedgerState TestBlock) where + toLSMTxOut _ = id + fromLSMTxOut _ = id instance CanUpgradeLedgerTables (LedgerState TestBlock) where upgradeTables _ _ = id diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs index d957292027..3a7b2b26ad 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs @@ -580,6 +580,11 @@ instance IsLedger (LedgerState TestBlock) where type instance TxIn (LedgerState TestBlock) = Void type instance TxOut (LedgerState TestBlock) = Void +type instance LSMTxOut (LedgerState TestBlock) = Void + +instance HasLSMTxOut (LedgerState TestBlock) where + toLSMTxOut _ = id + fromLSMTxOut _ = id instance LedgerTablesAreTrivial (LedgerState TestBlock) where convertMapKind (TestLedger x y) = TestLedger x y