From 9bda2bce13ee6677e953287d73f997d03d461acc Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 5 Dec 2022 12:09:00 +0100 Subject: [PATCH] Implement backingstore-agnostic `quickcheck-lockstep` tests. About the new modules: * `Registry.hs` defines a small utility for handling a resource through handles. This simplifies the property tests we define in other modules. * `Mock.hs` defines a mocked version of a `BackingStore` that generalises over the types keys, values and diffs we want to use. * `LockStep.hs` instantiates the Lockstep framework. * `BackingStore.hs` sets up and runs the Lockstep tests. Other changes: * Added a utility module that defines a simple `LedgerState` and corresponding `TableStuff` instance. --- .../ouroboros-consensus-test.cabal | 10 + .../src/Test/Util/TestLedgerState.hs | 93 +++ .../Test/Ouroboros/Storage/LedgerDB/HD.hs | 4 +- .../Storage/LedgerDB/HD/BackingStore.hs | 373 +++++++++ .../LedgerDB/HD/BackingStore/Lockstep.hs | 749 ++++++++++++++++++ .../Storage/LedgerDB/HD/BackingStore/Mock.hs | 273 +++++++ .../LedgerDB/HD/BackingStore/Registry.hs | 63 ++ .../Storage/LedgerDB/HD/BackingStore.hs | 2 + 8 files changed, 1566 insertions(+), 1 deletion(-) create mode 100644 ouroboros-consensus-test/src/Test/Util/TestLedgerState.hs create mode 100644 ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore.hs create mode 100644 ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Lockstep.hs create mode 100644 ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Mock.hs create mode 100644 ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Registry.hs diff --git a/ouroboros-consensus-test/ouroboros-consensus-test.cabal b/ouroboros-consensus-test/ouroboros-consensus-test.cabal index 28b94ad1df2..a807714c2bd 100644 --- a/ouroboros-consensus-test/ouroboros-consensus-test.cabal +++ b/ouroboros-consensus-test/ouroboros-consensus-test.cabal @@ -76,6 +76,7 @@ library Test.Util.Stream Test.Util.Tasty.Traceable Test.Util.TestBlock + Test.Util.TestLedgerState Test.Util.TestEnv Test.Util.Time Test.Util.Tracer @@ -241,6 +242,10 @@ test-suite test-storage Test.Ouroboros.Storage.LedgerDB.DbChangelog Test.Ouroboros.Storage.LedgerDB.DiskPolicy Test.Ouroboros.Storage.LedgerDB.HD + Test.Ouroboros.Storage.LedgerDB.HD.BackingStore + Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Registry + Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Lockstep + Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Mock Test.Ouroboros.Storage.LedgerDB.HD.DiffSeq Test.Ouroboros.Storage.LedgerDB.HD.LMDB Test.Ouroboros.Storage.LedgerDB.InMemory @@ -255,6 +260,7 @@ test-suite test-storage build-depends: base , async + , anti-diff , bifunctors , binary , bytestring @@ -262,9 +268,11 @@ test-suite test-storage , cardano-crypto-class , cardano-slotting , cborg + , constraints , containers , contra-tracer , directory + , exceptions , generics-sop , hashable , mtl @@ -272,6 +280,8 @@ test-suite test-storage , nothunks , pretty-show , QuickCheck + , quickcheck-dynamic + , quickcheck-lockstep >=0.2.0 , quickcheck-state-machine >=0.7.0 , random , serialise diff --git a/ouroboros-consensus-test/src/Test/Util/TestLedgerState.hs b/ouroboros-consensus-test/src/Test/Util/TestLedgerState.hs new file mode 100644 index 00000000000..f1ae46ee1cc --- /dev/null +++ b/ouroboros-consensus-test/src/Test/Util/TestLedgerState.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Util.TestLedgerState ( + LedgerTables (..) + , SimpleLedgerState (..) + ) where + +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) + +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) + +import Ouroboros.Consensus.Ledger.Basics + +{------------------------------------------------------------------------------- + Simple ledger state +-------------------------------------------------------------------------------} + +newtype SimpleLedgerState k v (mk :: MapKind) = SimpleLedgerState { + lsSimple :: mk k v + } + +deriving instance (Eq (mk k v)) => Eq (SimpleLedgerState k v mk) +deriving stock instance Show (mk k v) => Show (SimpleLedgerState k v mk) + +instance (ToCBOR k, FromCBOR k, ToCBOR v, FromCBOR v) + => SufficientSerializationForAnyBackingStore (SimpleLedgerState k v) where + codecLedgerTables = SimpleLedgerTables $ CodecMK toCBOR toCBOR fromCBOR fromCBOR + +{------------------------------------------------------------------------------- + Simple ledger tables +-------------------------------------------------------------------------------} + +instance (Ord k, Eq v, Show k, Show v) => TableStuff (SimpleLedgerState k v) where + newtype LedgerTables (SimpleLedgerState k v) mk = SimpleLedgerTables { + ltSimple :: mk k v + } deriving Generic + + projectLedgerTables SimpleLedgerState{lsSimple} = + SimpleLedgerTables lsSimple + + withLedgerTables st SimpleLedgerTables{ltSimple} = + st { lsSimple = ltSimple } + + pureLedgerTables f = + SimpleLedgerTables { ltSimple = f } + + mapLedgerTables f SimpleLedgerTables{ltSimple} = + SimpleLedgerTables $ f ltSimple + + traverseLedgerTables f SimpleLedgerTables{ltSimple} = + SimpleLedgerTables <$> f ltSimple + + zipLedgerTables f l r = + SimpleLedgerTables (f (ltSimple l) (ltSimple r)) + + zipLedgerTablesA f l r = + SimpleLedgerTables <$> f (ltSimple l) (ltSimple r) + + zipLedgerTables2 f l m r = + SimpleLedgerTables $ f (ltSimple l) (ltSimple m) (ltSimple r) + + zipLedgerTables2A f l c r = + SimpleLedgerTables <$> f (ltSimple l) (ltSimple c) (ltSimple r) + + foldLedgerTables f SimpleLedgerTables{ltSimple} = + f ltSimple + + foldLedgerTables2 f l r = + f (ltSimple l) (ltSimple r) + + namesLedgerTables = + SimpleLedgerTables { ltSimple = NameMK "ltSimple" } + +deriving stock instance (Eq (mk k v)) + => Eq (LedgerTables (SimpleLedgerState k v) mk) + +deriving stock instance (Show (mk k v)) + => Show (LedgerTables (SimpleLedgerState k v) mk) + +deriving newtype instance NoThunks (mk k v) + => NoThunks (LedgerTables (SimpleLedgerState k v) mk) + +instance (Show k, Show v) => ShowLedgerState (LedgerTables (SimpleLedgerState k v)) where + showsLedgerState _ = shows diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD.hs index 070b4275a71..b375cbf13de 100644 --- a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD.hs +++ b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD.hs @@ -1,11 +1,13 @@ module Test.Ouroboros.Storage.LedgerDB.HD (tests) where +import qualified Test.Ouroboros.Storage.LedgerDB.HD.BackingStore as BS import qualified Test.Ouroboros.Storage.LedgerDB.HD.DiffSeq as DiffSeq import qualified Test.Ouroboros.Storage.LedgerDB.HD.LMDB as LMDB import Test.Tasty (TestTree, testGroup) tests :: TestTree tests = testGroup "HD" [ - DiffSeq.tests + BS.tests + , DiffSeq.tests , LMDB.tests ] diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore.hs new file mode 100644 index 00000000000..8b8468cb981 --- /dev/null +++ b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use camelCase" #-} + +module Test.Ouroboros.Storage.LedgerDB.HD.BackingStore (tests) where + +import Control.Monad.Class.MonadThrow +import Control.Monad.Except hiding (lift) +import Control.Monad.IOSim +import Control.Monad.Reader +import Control.Tracer (nullTracer) +import qualified Data.Map.Diff.Strict as Diff +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Sequence.NonEmpty (NESeq (..)) +import qualified Data.Sequence.NonEmpty as NESeq +import qualified Data.Set as Set +import Data.Typeable +import qualified System.Directory as Dir +import System.IO.Temp (createTempDirectory) + +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) + +import qualified Test.QuickCheck as QC +import Test.QuickCheck (Arbitrary (..), Property, Testable) +import Test.QuickCheck.Gen.Unsafe +import qualified Test.QuickCheck.Monadic as QC +import Test.QuickCheck.Monadic (PropertyM) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (testProperty) + +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Storage.FS.API hiding (Handle) +import Ouroboros.Consensus.Storage.FS.API.Types hiding (Handle) +import Ouroboros.Consensus.Storage.FS.IO (ioHasFS) +import qualified Ouroboros.Consensus.Storage.LedgerDB.HD.BackingStore as BS +import qualified Ouroboros.Consensus.Storage.LedgerDB.HD.DiffSeq as DS +import qualified Ouroboros.Consensus.Storage.LedgerDB.HD.LMDB as LMDB +import Ouroboros.Consensus.Storage.LedgerDB.OnDisk +import Ouroboros.Consensus.Util ((.:)) +import Ouroboros.Consensus.Util.IOLike hiding (MonadMask (..)) + +import qualified Test.Util.FS.Sim.MockFS as MockFS +import Test.Util.FS.Sim.STM +import Test.Util.Orphans.IOLike () +import Test.Util.Orphans.Slotting.Arbitrary () +import Test.Util.Orphans.ToExpr () +import Test.Util.TestLedgerState + +import Test.QuickCheck.StateModel as StateModel +import Test.QuickCheck.StateModel.Lockstep as Lockstep +import Test.QuickCheck.StateModel.Lockstep.Run as Lockstep + +import Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Lockstep +import qualified Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Mock as Mock +import Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Registry + +{------------------------------------------------------------------------------- + Main test tree +-------------------------------------------------------------------------------} + +-- TODO: use scaling instead of withMaxSuccess +tests :: TestTree +tests = testGroup "BackingStore" [ + testProperty "InMemory IOSim SimHasFS" $ QC.withMaxSuccess 1000 + testWithIOSim + , testProperty "InMemory IO SimHasFS" $ QC.withMaxSuccess 1000 $ + testWithIO $ + setupBSEnv InMemoryBackingStore setupSimHasFS (pure ()) + , testProperty "InMemory IO IOHasFS" $ QC.withMaxSuccess 1000 $ + testWithIO $ do + (fp, cleanup) <- setupTempDir + setupBSEnv InMemoryBackingStore (setupIOHasFS fp) cleanup + , testProperty "LMDB IO IOHasFS" $ QC.withMaxSuccess 200 $ + testWithIO $ do + (fp, cleanup) <- setupTempDir + setupBSEnv (LMDBBackingStore testLMDBLimits) (setupIOHasFS fp) cleanup + , testCase "labelledExamples" labelledExamples + ] + +testLMDBLimits :: LMDB.LMDBLimits +testLMDBLimits = LMDB.LMDBLimits + { -- 100 MiB should be more than sufficient for the tests we're running here. + -- If the database were to grow beyond 100 Mebibytes, resulting in a test + -- error, then something in the LMDB backing store or tests has changed and + -- we should reconsider this value. + LMDB.lmdbMapSize = 100 * 1024 * 1024 + -- 3 internal databases: 1 for the settings, 1 for the state, and 1 for the + -- ledger tables. + , LMDB.lmdbMaxDatabases = 3 + + , LMDB.lmdbMaxReaders = maxOpenValueHandles + } + +testWithIOSim :: Actions (Lockstep (BackingStoreState K V D)) -> Property +testWithIOSim acts = monadicSim $ do + BSEnv {bsSomeHasFS, bsBackingStore, bsCleanup, bsRegistry} <- + QC.run (setupBSEnv InMemoryBackingStore setupSimHasFS (pure ())) + void $ + runPropertyIOLikeMonad $ + runPropertyReaderT (StateModel.runActions acts) (bsSomeHasFS, bsBackingStore, bsRegistry) + QC.run bsCleanup + pure True + +testWithIO:: + IO (BSEnv IO K V D) + -> Actions (Lockstep T) -> Property +testWithIO mkBSEnv = runActionsBracket pT mkBSEnv bsCleanup runner + +runner :: + RealMonad m ks vs d a + -> BSEnv m ks vs d + -> m a +runner c r = unIOLikeMonad . runReaderT c $ + (bsSomeHasFS r, bsBackingStore r, bsRegistry r) + +-- | Generate minimal examples for each label. +labelledExamples :: IO () +labelledExamples = do + -- TODO: remove + threadDelay 1 + QC.labelledExamples $ tagActions pT + +{------------------------------------------------------------------------------- + Resources +-------------------------------------------------------------------------------} + +data BSEnv m ks vs d = BSEnv { + bsSomeHasFS :: SomeHasFS m + , bsBackingStore :: BS.BackingStore m ks vs d + , bsRegistry :: HandleRegistry m (BS.BackingStoreValueHandle m ks vs) + , bsCleanup :: m () + } + +-- | Set up a simulated @'HasFS'@. +setupSimHasFS :: IOLike m => m (SomeHasFS m) +setupSimHasFS = SomeHasFS . simHasFS <$> newTVarIO MockFS.empty + +-- | Set up a @'HasFS'@ for @'IO'@. +setupIOHasFS :: MonadIO m => FilePath -> m (SomeHasFS m) +setupIOHasFS = pure . SomeHasFS . ioHasFS . MountPoint + +-- | In case we are running tests in @'IO'@, we must do some temporary directory +-- management. +setupTempDir :: MonadIO m => m (FilePath, m ()) +setupTempDir = do + sysTmpDir <- liftIO Dir.getTemporaryDirectory + qsmTmpDir <- liftIO $ createTempDirectory sysTmpDir "BS_QSM" + pure (qsmTmpDir, liftIO $ Dir.removeDirectoryRecursive qsmTmpDir) + +setupBSEnv :: + IOLike m + => BackingStoreSelector m + -> m (SomeHasFS m) + -> m () + -> m (BSEnv m K V D) +setupBSEnv bss mkSfhs cleanup = do + bsSomeHasFS@(SomeHasFS hfs) <- mkSfhs + + createDirectory hfs (mkFsPath ["copies"]) + + LedgerBackingStore bsBackingStore <- + newBackingStore + nullTracer + bss + bsSomeHasFS + polyEmptyLedgerTables + + bsRegistry <- initHandleRegistry + + let + bsCleanup = do + catches (BS.bsClose bsBackingStore) closeHandlers + cleanup + + pure BSEnv {bsSomeHasFS, bsBackingStore, bsCleanup, bsRegistry} + +-- | A backing store will throw an error on close if it has already been closed, +-- which we ignore if we are performing a close as part of resource cleanup. +closeHandlers :: IOLike m => [Handler m ()] +closeHandlers = [ + Handler $ \case + BS.TVarBackingStoreClosedExn -> pure () + e -> throwIO e + , Handler $ \case + LMDB.DbErrClosed -> pure () + e -> throwIO e + ] + +{------------------------------------------------------------------------------- + Types under test +-------------------------------------------------------------------------------} + +type T = BackingStoreState K V D + +pT :: Proxy T +pT = Proxy + +type K = LedgerTables (SimpleLedgerState (Fixed Word) (Fixed Word)) KeysMK +type V = LedgerTables (SimpleLedgerState (Fixed Word) (Fixed Word)) ValuesMK +type D = LedgerTables (SimpleLedgerState (Fixed Word) (Fixed Word)) DiffMK + +{------------------------------------------------------------------------------- + @'HasOps'@ instances +-------------------------------------------------------------------------------} + +instance Mock.EmptyValues V where + emptyValues = polyEmptyLedgerTables + +instance Mock.ApplyDiff V D where + applyDiff = zipLedgerTables rawApplyDiffs + +instance Mock.LookupKeysRange K V where + lookupKeysRange = \prev n vs -> + case prev of + Nothing -> + mapLedgerTables (rangeRead n) vs + Just ks -> + zipLedgerTables (rangeRead' n) ks vs + where + rangeRead :: Int -> ValuesMK k v -> ValuesMK k v + rangeRead n (ApplyValuesMK (DS.Values vs)) = + ApplyValuesMK $ DS.Values $ Map.take n vs + + rangeRead' :: + Ord k + => Int + -> KeysMK k v + -> ValuesMK k v + -> ValuesMK k v + rangeRead' n ksmk vsmk = + case Set.lookupMax ks of + Nothing -> ApplyValuesMK $ DS.Values Map.empty + Just k -> ApplyValuesMK $ DS.Values $ + Map.take n $ snd $ Map.split k vs + where + ApplyKeysMK (DS.Keys ks) = ksmk + ApplyValuesMK (DS.Values vs) = vsmk + +instance Mock.LookupKeys K V where + lookupKeys = zipLedgerTables readKeys + where + readKeys :: + Ord k + => KeysMK k v + -> ValuesMK k v + -> ValuesMK k v + readKeys (ApplyKeysMK ks) (ApplyValuesMK vs) = + ApplyValuesMK $ DS.restrictValues vs ks + +instance Mock.ValuesLength V where + valuesLength (SimpleLedgerTables (ApplyValuesMK (DS.Values m))) = + Map.size m + +instance Mock.MakeDiff V D where + diff t1 t2 = zipLedgerTables (rawForgetValues .: rawCalculateDifference) t1 t2 + +instance Mock.DiffSize D where + diffSize (SimpleLedgerTables (ApplyDiffMK (Diff.Diff m))) = Map.size m + +instance Mock.KeysSize K where + keysSize (SimpleLedgerTables (ApplyKeysMK (Diff.Keys s))) = Set.size s + +instance Mock.HasOps K V D + +{------------------------------------------------------------------------------- + Utilities + + TODO: should become available in a newer version of @quickcheck-dynamic@. +-------------------------------------------------------------------------------} + +-- | Copied from the @Test.QuickCheck.Extras@ module in the @quickcheck-dynamic@ +-- package. +runPropertyReaderT :: + Monad m + => PropertyM (ReaderT e m) a + -> e + -> PropertyM m a +runPropertyReaderT p e = QC.MkPropertyM $ \k -> do + m <- QC.unPropertyM p $ fmap lift . k + return $ runReaderT m e + +runPropertyIOLikeMonad :: + IOLikeMonadC m + => PropertyM (IOLikeMonad m) a + -> PropertyM m a +runPropertyIOLikeMonad p = QC.MkPropertyM $ \k -> do + m <- QC.unPropertyM p $ fmap ioLikeMonad . k + return $ unIOLikeMonad m + +-- | Copied from @Ouroboros.Network.Testing.QuickCheck@. +runSimGen :: (forall s. QC.Gen (IOSim s a)) -> QC.Gen a +runSimGen f = do + Capture eval <- capture + return $ runSimOrThrow (eval f) + +-- | Copied from @Ouroboros.Network.Testing.QuickCheck@. +monadicSim :: Testable a => (forall s. PropertyM (IOSim s) a) -> Property +monadicSim m = QC.property (runSimGen (QC.monadic' m)) + +{------------------------------------------------------------------------------- + Orphan Arbitrary instances +-------------------------------------------------------------------------------} + +deriving newtype instance QC.Arbitrary (ApplyMapKind' mk k v) + => QC.Arbitrary ( + LedgerTables + (SimpleLedgerState k v) + (ApplyMapKind' mk) + ) + +instance (Ord k, QC.Arbitrary k) + => QC.Arbitrary (KeysMK k v) where + arbitrary = ApplyKeysMK <$> QC.arbitrary + shrink (ApplyKeysMK ks) = ApplyKeysMK <$> QC.shrink ks + +instance (Ord k, QC.Arbitrary k, QC.Arbitrary v) + => QC.Arbitrary (DiffMK k v) where + arbitrary = ApplyDiffMK <$> QC.arbitrary + shrink (ApplyDiffMK d)= ApplyDiffMK <$> QC.shrink d + +instance (Ord k, QC.Arbitrary k, QC.Arbitrary v) + => QC.Arbitrary (ValuesMK k v) where + arbitrary = ApplyValuesMK <$> QC.arbitrary + shrink (ApplyValuesMK d)= ApplyValuesMK <$> QC.shrink d + +deriving newtype instance (Ord k, QC.Arbitrary k, QC.Arbitrary v) + => QC.Arbitrary (DS.Values k v) + +deriving newtype instance (Ord k, QC.Arbitrary k) + => QC.Arbitrary (DS.Keys k v) + +deriving newtype instance (Ord k, QC.Arbitrary k, QC.Arbitrary v) + => QC.Arbitrary (DS.Diff k v) + +instance QC.Arbitrary v => QC.Arbitrary (DS.NEDiffHistory v) where + arbitrary = DS.NEDiffHistory <$> ((:<||) <$> QC.arbitrary <*> QC.arbitrary) + shrink (DS.NEDiffHistory h) = + fmap DS.NEDiffHistory $ mapMaybe NESeq.nonEmptySeq $ QC.shrink (NESeq.toSeq h) + +instance QC.Arbitrary v => QC.Arbitrary (DS.DiffEntry v) where + arbitrary = do + constr <- QC.elements [ + DS.Insert + , DS.Delete + , DS.UnsafeAntiInsert + , DS.UnsafeAntiDelete + ] + constr <$> QC.arbitrary + +instance QC.Arbitrary ks => QC.Arbitrary (BS.RangeQuery ks) where + arbitrary = BS.RangeQuery <$> QC.arbitrary <*> QC.arbitrary + shrink (BS.RangeQuery x y) = BS.RangeQuery <$> QC.shrink x <*> QC.shrink y + +newtype Fixed a = Fixed a + deriving newtype (Show, Eq, Ord) + deriving newtype (NoThunks, ToCBOR, FromCBOR) + +deriving via QC.Fixed a instance QC.Arbitrary a => QC.Arbitrary (Fixed a) diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Lockstep.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Lockstep.hs new file mode 100644 index 00000000000..ba76716f514 --- /dev/null +++ b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Lockstep.hs @@ -0,0 +1,749 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Lockstep ( + -- * Facilitate running the tests in @'IO'@ or @'IOSim'@. + IOLikeMonad (..) + , IOLikeMonadC (..) + , RealMonad + , unIOLikeMonad + -- * Model state + , BackingStoreState (..) + , maxOpenValueHandles + ) where + +import Control.Monad +import Control.Monad.Class.MonadThrow +import Control.Monad.IOSim +import Control.Monad.Reader +import Data.Bifunctor +import Data.Constraint +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable + +import qualified Test.QuickCheck as QC +import Test.QuickCheck (Gen) +import Test.QuickCheck.StateModel +import Test.QuickCheck.StateModel.Lockstep as Lockstep +import Test.QuickCheck.StateModel.Lockstep.Defaults as Lockstep +import Test.QuickCheck.StateModel.Lockstep.Op as Lockstep +import Test.QuickCheck.StateModel.Lockstep.Op.SumProd as Lockstep + +import Cardano.Slotting.Slot + +import Ouroboros.Consensus.Storage.FS.API hiding (Handle) +import Ouroboros.Consensus.Storage.FS.API.Types hiding (Handle) +import qualified Ouroboros.Consensus.Storage.LedgerDB.HD.BackingStore as BS +import Ouroboros.Consensus.Storage.LedgerDB.HD.LMDB as LMDB + (DbErr (..)) +import Ouroboros.Consensus.Util.IOLike hiding (MonadMask (..), handle) + +import Test.Util.Orphans.Slotting.Arbitrary () +import Test.Util.Orphans.ToExpr () + +import qualified Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Mock as Mock +import Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Mock (Err (..), + Mock (..), MockValueHandle (..), runMockState) +import Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Registry + +{------------------------------------------------------------------------------- + Facilitate running the tests in @'IO'@ or @'IOSim'@. + + TODO: put this in a separate module? +-------------------------------------------------------------------------------} + +-- This wrapper allows us to run the tests both in @'IO'@ and @'IOSim'@, without +-- having to duplicate code for both @'IO'@ and @'IOSim'@. +data IOLikeMonad m a where + RealIO :: IO a -> IOLikeMonad IO a + SimIO :: IOSim s a -> IOLikeMonad (IOSim s) a + +-- | Retrieve the wrapped @'IOLike'@ monad. +unIOLikeMonad :: IOLikeMonad m a -> m a +unIOLikeMonad (RealIO x) = x +unIOLikeMonad (SimIO x) = x + +-- | Create a wrapper @'IOLike'@ monad. +class IOLikeMonadC m where + ioLikeMonad :: m a -> IOLikeMonad m a + +instance IOLikeMonadC IO where + ioLikeMonad x = RealIO x + +instance IOLikeMonadC (IOSim s) where + ioLikeMonad x = SimIO x + +instance (Functor m, IOLikeMonadC m) => Functor (IOLikeMonad m) where + fmap f x = ioLikeMonad $ fmap f (unIOLikeMonad x) + +instance (Applicative m, IOLikeMonadC m) =>Applicative (IOLikeMonad m) where + x <*> y = ioLikeMonad $ unIOLikeMonad x <*> unIOLikeMonad y + pure = ioLikeMonad . pure + +instance (Monad m, IOLikeMonadC m) => Monad (IOLikeMonad m) where + m >>= fm = ioLikeMonad $ unIOLikeMonad m >>= unIOLikeMonad . fm + +-- | Since the tests do not return any types specific to the underlying +-- @'IOLike'@ monad, @'Realized' ('IOLikeMonad' m)@ behaves just like +-- @'Realized' 'IO'@. +type instance Realized (IOLikeMonad m) a = a + +{------------------------------------------------------------------------------- + @'Values'@ wrapper +-------------------------------------------------------------------------------} + +-- | Wrapper for preventing nonsenical pattern matches. +-- +-- A logical step is to have the @'BSVHRangeRead'@ and @'BSVHRead'@ actions +-- declare that the result of the action should be something of type @'vs'@. +-- However, this means that in theory @'vs'@ could be instantiated to any type +-- (like @'Handle'@). Consequentially, if we match on a value that is returned +-- by running an action, we would always have to match on the case where it is a +-- result of running @'BSVHRangeRead'@ and @'BSVHRead'@ as well, even if the +-- return type is @'Handle'@, which we don't expect to use as our @vs@ type. As +-- such, we define this wrapper to prevent having to match on this nonsensical +-- case. +newtype Values vs = Values {unValues :: vs} + deriving stock (Show, Eq, Ord, Typeable) + deriving newtype QC.Arbitrary + +{------------------------------------------------------------------------------- + Model state +-------------------------------------------------------------------------------} + +data BackingStoreState ks vs d = BackingStoreState { + bssMock :: Mock vs + , bssStats :: Stats ks vs d + } + deriving (Show, Eq) + +initState :: Mock.EmptyValues vs => BackingStoreState ks vs d +initState = BackingStoreState { + bssMock = Mock.emptyMock + , bssStats = initStats + } + +-- | Maximum number of LMDB readers that can be active at a time. +-- +-- 32 is an arbitrary number of readers. We can increase or decrease this at +-- will. +-- +-- TODO: should the LMDB backing store keep track of the number of open value +-- handles itself, and throw a custom error if the maximum is exceeded? +maxOpenValueHandles :: Int +maxOpenValueHandles = 32 + +{------------------------------------------------------------------------------- + @'StateModel'@ and @'RunModel'@ instances +-------------------------------------------------------------------------------} + +type RealEnv m ks vs d = ( + SomeHasFS m + , BS.BackingStore m ks vs d + , HandleRegistry m (BS.BackingStoreValueHandle m ks vs) + ) + +type RealMonad m ks vs d = ReaderT (RealEnv m ks vs d) (IOLikeMonad m) + +type BSAct ks vs d a = + Action + (Lockstep (BackingStoreState ks vs d)) + (Either Err a) +type BSVar ks vs d a = + ModelVar (BackingStoreState ks vs d) a + +instance ( Show ks, Show vs, Show d + , Eq ks, Eq vs, Eq d + , Typeable ks, Typeable vs, Typeable d + , QC.Arbitrary ks, QC.Arbitrary vs, QC.Arbitrary d + , QC.Arbitrary (BS.RangeQuery ks) + , Mock.HasOps ks vs d + ) => StateModel (Lockstep (BackingStoreState ks vs d)) where + data Action (Lockstep (BackingStoreState ks vs d)) a where + BSClose :: BSAct ks vs d () + BSCopy :: BS.BackingStorePath + -> BSAct ks vs d () + BSValueHandle :: BSAct ks vs d (WithOrigin SlotNo, Handle) + BSWrite :: SlotNo + -> d + -> BSAct ks vs d () + BSVHClose :: BSVar ks vs d Handle + -> BSAct ks vs d () + BSVHRangeRead :: BSVar ks vs d Handle + -> BS.RangeQuery ks + -> BSAct ks vs d (Values vs) + BSVHRead :: BSVar ks vs d Handle + -> ks + -> BSAct ks vs d (Values vs) + + initialState = Lockstep.initialState initState + nextState = Lockstep.nextState + precondition st act = Lockstep.precondition st act + && modelPrecondition (getModel st) act + arbitraryAction = Lockstep.arbitraryAction + shrinkAction = Lockstep.shrinkAction + +deriving stock instance (Show ks, Show vs, Show d) + => Show (LockstepAction (BackingStoreState ks vs d) a) +deriving stock instance (Eq ks, Eq vs, Eq d) + => Eq (LockstepAction (BackingStoreState ks vs d) a) + +instance ( Show ks, Show vs, Show d + , Eq ks, Eq vs, Eq d + , Typeable ks, Typeable vs, Typeable d + , QC.Arbitrary ks, QC.Arbitrary vs, QC.Arbitrary d + , QC.Arbitrary (BS.RangeQuery ks) + , IOLike m + , Mock.HasOps ks vs d + , IOLikeMonadC m + ) => RunModel + (Lockstep (BackingStoreState ks vs d)) + (RealMonad m ks vs d) where + perform = \_st -> runIO + postcondition = Lockstep.postcondition + monitoring = Lockstep.monitoring (Proxy @(RealMonad m ks vs d)) + +-- | Custom precondition that prevents errors in the @'LMDB'@ backing store due +-- to exceeding the maximum number of LMDB readers. +-- +-- See @'maxOpenValueHandles'@. +modelPrecondition :: + BackingStoreState ks vs d + -> LockstepAction (BackingStoreState ks vs d) a + -> Bool +modelPrecondition (BackingStoreState mock _stats) action = case action of + BSCopy _ -> canOpenReader + BSValueHandle -> canOpenReader + _ -> True + where + canOpenReader = Map.size openValueHandles < maxOpenValueHandles + openValueHandles = Map.filter not (valueHandles mock) + +{------------------------------------------------------------------------------- + @'InLockstep'@ instance +-------------------------------------------------------------------------------} + +type BSVal ks vs d a = ModelValue (BackingStoreState ks vs d) a +type BSObs ks vs d a = Observable (BackingStoreState ks vs d) a + +instance ( Show ks, Show vs, Show d + , Eq ks, Eq vs, Eq d + , Typeable ks, Typeable vs, Typeable d + , QC.Arbitrary ks, QC.Arbitrary vs, QC.Arbitrary d + , QC.Arbitrary (BS.RangeQuery ks) + , Mock.HasOps ks vs d + ) => InLockstep (BackingStoreState ks vs d) where + + data instance ModelValue (BackingStoreState ks vs d) a where + MValueHandle :: MockValueHandle vs -> BSVal ks vs d Handle + + MErr :: Err + -> BSVal ks vs d Err + MSlotNo :: WithOrigin SlotNo + -> BSVal ks vs d (WithOrigin SlotNo) + MValues :: vs + -> BSVal ks vs d (Values vs) + MUnit :: () + -> BSVal ks vs d () + + MEither :: Either (BSVal ks vs d a) (BSVal ks vs d b) + -> BSVal ks vs d (Either a b) + MPair :: (BSVal ks vs d a, BSVal ks vs d b) + -> BSVal ks vs d (a, b) + + data instance Observable (BackingStoreState ks vs d) a where + OValueHandle :: BSObs ks vs d Handle + OValues :: (Show a, Eq a, Typeable a) => a -> BSObs ks vs d (Values a) + OId :: (Show a, Eq a, Typeable a) => a -> BSObs ks vs d a + OEither :: Either (BSObs ks vs d a) (BSObs ks vs d b) + -> BSObs ks vs d (Either a b) + OPair :: (BSObs ks vs d a, BSObs ks vs d b) -> BSObs ks vs d (a, b) + + observeModel :: BSVal ks vs d a -> BSObs ks vs d a + observeModel = \case + MValueHandle _ -> OValueHandle + MErr x -> OId x + MSlotNo x -> OId x + MValues x -> OValues x + MUnit x -> OId x + MEither x -> OEither $ bimap observeModel observeModel x + MPair x -> OPair $ bimap observeModel observeModel x + + modelNextState :: forall a. + LockstepAction (BackingStoreState ks vs d) a + -> ModelLookUp (BackingStoreState ks vs d) + -> BackingStoreState ks vs d -> (BSVal ks vs d a, BackingStoreState ks vs d) + modelNextState action lookUp (BackingStoreState mock stats) = + auxStats $ runMock lookUp action mock + where + auxStats :: + (BSVal ks vs d a, Mock vs) + -> (BSVal ks vs d a, BackingStoreState ks vs d) + auxStats (result, state') = + ( result + , BackingStoreState state' $ updateStats action lookUp result stats + ) + + type ModelOp (BackingStoreState ks vs d) = Op + + usedVars :: + LockstepAction (BackingStoreState ks vs d) a + -> [AnyGVar (ModelOp (BackingStoreState ks vs d))] + usedVars = \case + BSClose -> [] + BSCopy _ -> [] + BSValueHandle -> [] + BSWrite _ _ -> [] + BSVHClose h -> [SomeGVar h] + BSVHRangeRead h _ -> [SomeGVar h] + BSVHRead h _ -> [SomeGVar h] + + arbitraryWithVars :: + ModelFindVariables (BackingStoreState ks vs d) + -> BackingStoreState ks vs d + -> Gen (Any (LockstepAction (BackingStoreState ks vs d))) + arbitraryWithVars = arbitraryBackingStoreAction + + shrinkWithVars :: + ModelFindVariables (BackingStoreState ks vs d) + -> BackingStoreState ks vs d + -> LockstepAction (BackingStoreState ks vs d) a + -> [Any (LockstepAction (BackingStoreState ks vs d))] + shrinkWithVars = shrinkBackingStoreAction + + tagStep :: + (BackingStoreState ks vs d, BackingStoreState ks vs d) + -> LockstepAction (BackingStoreState ks vs d) a + -> BSVal ks vs d a + -> [String] + tagStep (_before, BackingStoreState _ after) action val = + map show $ tagBSAction after action val + +deriving stock instance (Show ks, Show vs, Show d) => Show (BSVal ks vs d a) + +deriving stock instance (Show ks, Show vs, Show d) => Show (BSObs ks vs d a) +deriving stock instance (Eq ks, Eq vs, Eq d) => Eq (BSObs ks vs d a) + +{------------------------------------------------------------------------------- + @'RunLockstep'@ instance +-------------------------------------------------------------------------------} + +instance ( Show ks, Show vs, Show d + , Eq ks, Eq vs, Eq d + , Typeable ks, Typeable vs, Typeable d + , QC.Arbitrary ks, QC.Arbitrary vs, QC.Arbitrary d + , QC.Arbitrary (BS.RangeQuery ks) + , IOLike m + , Mock.HasOps ks vs d + , IOLikeMonadC m + ) => RunLockstep (BackingStoreState ks vs d) (RealMonad m ks vs d) where + observeReal :: + Proxy (RealMonad m ks vs d) + -> LockstepAction (BackingStoreState ks vs d) a + -> Realized (RealMonad m ks vs d) a + -> BSObs ks vs d a + observeReal _proxy = \case + BSClose -> OEither . bimap OId OId + BSCopy _ -> OEither . bimap OId OId + BSValueHandle -> OEither . bimap OId (OPair . bimap OId (const OValueHandle)) + BSWrite _ _ -> OEither . bimap OId OId + BSVHClose _ -> OEither . bimap OId OId + BSVHRangeRead _ _ -> OEither . bimap OId (OValues . unValues) + BSVHRead _ _ -> OEither . bimap OId (OValues . unValues) + + showRealResponse :: + Proxy (RealMonad m ks vs d) + -> LockstepAction (BackingStoreState ks vs d) a + -> Maybe (Dict (Show (Realized (RealMonad m ks vs d) a))) + showRealResponse _proxy = \case + BSClose -> Just Dict + BSCopy _ -> Just Dict + BSValueHandle -> Nothing + BSWrite _ _ -> Just Dict + BSVHClose _ -> Just Dict + BSVHRangeRead _ _ -> Just Dict + BSVHRead _ _ -> Just Dict + +{------------------------------------------------------------------------------- + Interpreter against the model +-------------------------------------------------------------------------------} + +runMock :: + Mock.HasOps ks vs d + => ModelLookUp (BackingStoreState ks vs d) + -> Action (Lockstep (BackingStoreState ks vs d)) a + -> Mock vs + -> ( BSVal ks vs d a + , Mock vs + ) +runMock lookUp = \case + BSClose -> + wrap MUnit . runMockState Mock.mBSClose + BSCopy bsp -> + wrap MUnit . runMockState (Mock.mBSCopy bsp) + BSValueHandle -> + wrap mBSValueHandle . runMockState Mock.mBSValueHandle + BSWrite sl d -> + wrap MUnit . runMockState (Mock.mBSWrite sl d) + BSVHClose h -> + wrap MUnit . runMockState (Mock.mBSVHClose (getHandle $ lookUp h)) + BSVHRangeRead h rq -> + wrap MValues . runMockState (Mock.mBSVHRangeRead (getHandle $ lookUp h) rq) + BSVHRead h ks -> + wrap MValues . runMockState (Mock.mBSVHRead (getHandle $ lookUp h) ks) + where + wrap :: + (a -> BSVal ks vs d b) + -> (Either Err a, Mock vs) + -> (BSVal ks vs d (Either Err b), Mock vs) + wrap f = first (MEither . bimap MErr f) + + mBSValueHandle :: + (WithOrigin SlotNo, MockValueHandle vs) + -> BSVal ks vs d (WithOrigin SlotNo, Handle) + mBSValueHandle (sl, h) = MPair (MSlotNo sl, MValueHandle h) + + getHandle :: BSVal ks vs d Handle -> MockValueHandle vs + getHandle (MValueHandle h) = h + +{------------------------------------------------------------------------------- + Generator +-------------------------------------------------------------------------------} + +arbitraryBackingStoreAction :: + forall ks vs d. + ( Eq ks, Eq vs, Eq d, Typeable vs + , QC.Arbitrary ks, QC.Arbitrary vs + , QC.Arbitrary (BS.RangeQuery ks) + , Mock.MakeDiff vs d + ) + => ModelFindVariables (BackingStoreState ks vs d) + -> BackingStoreState ks vs d + -> Gen (Any (LockstepAction (BackingStoreState ks vs d))) +arbitraryBackingStoreAction findVars (BackingStoreState mock _stats) = + QC.frequency $ + withoutVars + ++ case findVars (Proxy @(Either Err (WithOrigin SlotNo, Handle))) of + [] -> [] + vars -> withVars (QC.elements vars) + where + withoutVars :: [(Int, Gen (Any (LockstepAction (BackingStoreState ks vs d))))] + withoutVars = [ + (1, pure $ Some BSClose) + , (5, fmap Some $ BSCopy <$> genBackingStorePath) + , (5, pure $ Some BSValueHandle) + , (5, fmap Some $ BSWrite <$> genSlotNo <*> genDiff) + ] + + withVars :: + Gen (BSVar ks vs d (Either Err (WithOrigin SlotNo, Handle))) + -> [(Int, Gen (Any (LockstepAction (BackingStoreState ks vs d))))] + withVars genVar = [ + (2, fmap Some $ BSVHClose <$> (fhandle <$> genVar)) + , (10, fmap Some $ BSVHRangeRead <$> (fhandle <$> genVar) <*> QC.arbitrary) + , (10, fmap Some $ BSVHRead <$> (fhandle <$> genVar) <*> QC.arbitrary) + ] + where + fhandle :: + GVar Op (Either Err (WithOrigin SlotNo, Handle)) + -> GVar Op Handle + fhandle = mapGVar (\op -> OpSnd `OpComp` OpRight `OpComp` op) + + genBackingStorePath :: Gen BS.BackingStorePath + genBackingStorePath = do + file <- genBSPFile + pure . BS.BackingStorePath . mkFsPath $ ["copies", file] + + -- Generate a file name for a copy of the backing store contents. We keep + -- the set of possible file names small, such that errors (i.e., file alread + -- exists) occur most of the time. + genBSPFile :: Gen String + genBSPFile = QC.elements ["a", "b", "c", "d"] + + -- Generate a slot number that is close before, at, or after the backing + -- store's current slot number. A + genSlotNo :: Gen SlotNo + genSlotNo = do + n :: Int <- QC.choose (-5, 5) + pure $ maybe 0 (+ fromIntegral n) (withOriginToMaybe seqNo) + where + seqNo = backingSeqNo mock + + -- Generate valid diffs most of the time, and generate fully arbitrary + -- (probably invalid) diffs some of the time. + genDiff :: Gen d + genDiff = QC.frequency [ + (9, Mock.diff (backingValues mock) <$> QC.arbitrary) + --TODO: enable @, (1, QC.arbitrary)@ + ] + +{------------------------------------------------------------------------------- + Shrinker +-------------------------------------------------------------------------------} + +shrinkBackingStoreAction :: + forall ks vs d a. + ( Typeable vs, Eq ks, Eq vs, Eq d + , QC.Arbitrary d, QC.Arbitrary (BS.RangeQuery ks), QC.Arbitrary ks + ) + => ModelFindVariables (BackingStoreState ks vs d) + -> BackingStoreState ks vs d + -> LockstepAction (BackingStoreState ks vs d) a + -> [Any (LockstepAction (BackingStoreState ks vs d))] +shrinkBackingStoreAction _findVars (BackingStoreState _mock _) = \case + BSWrite sl d -> + [Some $ BSWrite sl d' | d' <- QC.shrink d] + ++ [Some $ BSWrite sl' d | sl' <- QC.shrink sl] + BSVHRangeRead h rq -> + [Some $ BSVHRangeRead h rq' | rq' <- QC.shrink rq] + BSVHRead h ks -> + [Some $ BSVHRead h ks' | ks' <- QC.shrink ks] + _ -> [] + +{------------------------------------------------------------------------------- + Interpret @'Op'@ against @'ModelValue'@ +-------------------------------------------------------------------------------} + +instance InterpretOp Op (ModelValue (BackingStoreState ks vs d)) where + intOp OpId = Just + intOp OpFst = \case MPair x -> Just (fst x) + intOp OpSnd = \case MPair x -> Just (snd x) + intOp OpLeft = \case MEither x -> either Just (const Nothing) x + intOp OpRight = \case MEither x -> either (const Nothing) Just x + intOp (OpComp g f) = intOp g <=< intOp f + +{------------------------------------------------------------------------------- + Interpreter for implementation (@'RealMonad'@) +-------------------------------------------------------------------------------} + +runIO :: + forall m ks vs d a. (IOLike m, IOLikeMonadC m) => + LockstepAction (BackingStoreState ks vs d) a + -> LookUp (RealMonad m ks vs d) + -> RealMonad m ks vs d (Realized (RealMonad m ks vs d) a) +runIO action lookUp = ReaderT $ \(sfhs, bs, rr) -> + ioLikeMonad $ aux sfhs bs rr action + where + aux :: + SomeHasFS m + -> BS.BackingStore m ks vs d + -> HandleRegistry m (BS.BackingStoreValueHandle m ks vs) + -> LockstepAction (BackingStoreState ks vs d) a + -> m a + aux sfhs bs rr = \case + BSClose -> catchErr $ + BS.bsClose bs + BSCopy bsp -> catchErr $ + BS.bsCopy bs sfhs bsp + BSValueHandle -> catchErr $ + BS.bsValueHandle bs >>= mapM (registerHandle rr) + BSWrite sl d -> catchErr $ + BS.bsWrite bs sl d + BSVHClose h -> catchErr $ + readHandle rr (lookUp' h) >>= \vh -> BS.bsvhClose vh + BSVHRangeRead h rq -> catchErr $ Values <$> + (readHandle rr (lookUp' h) >>= \vh -> BS.bsvhRangeRead vh rq) + BSVHRead h ks -> catchErr $ Values <$> + (readHandle rr (lookUp' h) >>= \vh -> BS.bsvhRead vh ks) + where + lookUp' :: BSVar ks vs d x -> Realized (RealMonad m ks vs d) x + lookUp' = lookUpGVar (Proxy @(RealMonad m ks vs d)) lookUp + +instance InterpretOp Op (WrapRealized (IOLikeMonad m)) where + intOp = intOpRealizedId intOpId + +catchErr :: forall m a. IOLike m => m a -> m (Either Err a) +catchErr act = catches (Right <$> act) + [mkHandler fromTVarExn, mkHandler fromDbErr] + +{------------------------------------------------------------------------------- + Statistics and tagging +-------------------------------------------------------------------------------} + +data Stats ks vs d = Stats { + -- | Slots that value handles were created in + handleSlots :: Map (MockValueHandle vs) (WithOrigin SlotNo) + -- | Slots in which writes were performed + , writeSlots :: Map SlotNo Int + -- | A value handle was created before a write, and read after the write + , readAfterWrite :: Bool + -- | A value handle was created before a write, and range read after the + -- write + , rangeReadAfterWrite :: Bool + -- | Actions that caused a @'ErrBackingStoreClosed'@ error to be thrown + , bsClosedThrown :: Set TagAction + } + deriving stock (Show, Eq) + + +initStats :: Stats ks vs d +initStats = Stats { + handleSlots = Map.empty + , writeSlots = Map.empty + , readAfterWrite = False + , rangeReadAfterWrite = False + , bsClosedThrown = Set.empty + } + +updateStats :: + forall ks vs d a. Mock.HasOps ks vs d + => LockstepAction (BackingStoreState ks vs d) a + -> ModelLookUp (BackingStoreState ks vs d) + -> BSVal ks vs d a + -> Stats ks vs d + -> Stats ks vs d +updateStats action lookUp result stats@Stats{handleSlots, writeSlots, bsClosedThrown} = + updateHandleSlots + . updateWriteSlots + . updateReadAfterWrite + . updateRangeReadAfterWrite + . updateBSClosedThrown + $ stats + where + getHandle :: BSVal ks vs d Handle -> MockValueHandle vs + getHandle (MValueHandle h) = h + + updateHandleSlots :: Stats ks vs d -> Stats ks vs d + updateHandleSlots s = case (action, result) of + (BSValueHandle, MEither (Right (MPair (MSlotNo sl, MValueHandle h)))) + -> s {handleSlots = Map.insert h sl handleSlots} + _ -> s + + updateWriteSlots :: Stats ks vs d -> Stats ks vs d + updateWriteSlots s = case (action, result) of + (BSWrite sl d, MEither (Right (MUnit ()))) + | 1 <= Mock.diffSize d + -> s {writeSlots = Map.insert sl (Mock.diffSize d) writeSlots} + _ -> s + + updateReadAfterWrite :: Stats ks vs d -> Stats ks vs d + updateReadAfterWrite s = case (action, result) of + (BSVHRead h _, MEither (Right (MValues vs))) + | h' <- getHandle $ lookUp h + , Just wosl <- Map.lookup h' handleSlots + , Just (sl, _) <- Map.lookupMax writeSlots + , wosl < at sl + , 1 <= Mock.valuesLength vs + -> s {readAfterWrite = True} + _ -> s + + updateRangeReadAfterWrite :: Stats ks vs d -> Stats ks vs d + updateRangeReadAfterWrite s = case (action, result) of + (BSVHRangeRead h _, MEither (Right (MValues vs))) + | h' <- getHandle $ lookUp h + , Just wosl <- Map.lookup h' handleSlots + , Just (sl, _) <- Map.lookupMax writeSlots + , wosl < at sl + , 1 <= Mock.valuesLength vs + -> s {rangeReadAfterWrite = True} + _ -> s + + updateBSClosedThrown :: Stats ks vs d -> Stats ks vs d + updateBSClosedThrown s = case (action, result) of + (_, MEither (Left (MErr ErrBackingStoreClosed))) + -> s { bsClosedThrown = Set.insert (tAction action) bsClosedThrown} + _ -> s + +data TagAction = + TBSClose + | TBSCopy + | TBSValueHandle + | TBSWrite + | TBSVHClose + | TBSVHRangeRead + | TBSVHRead + deriving (Show, Eq, Ord, Bounded, Enum) + +-- | Identify actions by their constructor. +tAction :: LockstepAction (BackingStoreState ks vs d) a -> TagAction +tAction = \case + BSClose -> TBSClose + BSCopy _ -> TBSCopy + BSValueHandle -> TBSValueHandle + BSWrite _ _ -> TBSWrite + BSVHClose _ -> TBSVHClose + BSVHRangeRead _ _ -> TBSVHRangeRead + BSVHRead _ _ -> TBSVHRead + +data Tag = + -- | A value handle is created before a write, and read after the write. The + -- write should not affect the result of the read. + ReadAfterWrite + -- | A value handle is created before a write, and read after the write. The + -- write should not affect the result of the read. + | RangeReadAfterWrite + | AllActionsErrorBecauseBackingStoreIsClosed + deriving (Show) + +tagBSAction :: + Stats ks vs d + -> LockstepAction (BackingStoreState ks vs d) a + -> BSVal ks vs d a + -> [Tag] +tagBSAction Stats{readAfterWrite, rangeReadAfterWrite, bsClosedThrown} _ _ = + globalTags + where + globalTags = mconcat [ + [ ReadAfterWrite + | readAfterWrite + ] + , [ RangeReadAfterWrite + | rangeReadAfterWrite + ] + , [ AllActionsErrorBecauseBackingStoreIsClosed + | Set.fromList [minBound .. maxBound] == bsClosedThrown + ] + ] + +{------------------------------------------------------------------------------- + Errors +-------------------------------------------------------------------------------} + +mkHandler :: + (IOLike m, Exception e) + => (e -> Maybe Err) + -> Handler m (Either Err a) +mkHandler fhandler = Handler $ + \e -> maybe (throwIO e) (return . Left) (fhandler e) + +-- | Map LMDB errors to mock errors. +fromDbErr :: LMDB.DbErr -> Maybe Err +fromDbErr = \case + DbErrStr _ -> Nothing + DbErrNoDbState -> Nothing + DbErrNonMonotonicSeq wo wo' -> Just $ ErrNonMonotonicSeqNo wo wo' + DbErrInitialisingNonEmpty _ -> Nothing + DbErrNoValueHandle _ -> Just ErrBSVHDoesNotExist + DbErrBadRead -> Nothing + DbErrBadRangeRead -> Nothing + DbErrDirExists _ -> Just ErrCopyPathAlreadyExists + DbErrDirDoesntExist _ -> Nothing + DbErrDirIsNotLMDB _ -> Nothing + DbErrClosed -> Just ErrBackingStoreClosed + +-- | Map InMemory (i.e., @TVarBackingStore@) errors to mock errors. +fromTVarExn :: BS.TVarBackingStoreExn -> Maybe Err +fromTVarExn = \case + BS.TVarBackingStoreClosedExn -> Just ErrBackingStoreClosed + BS.TVarBackingStoreValueHandleClosedExn -> Just ErrBSVHDoesNotExist + BS.TVarBackingStoreDirectoryExists -> Just ErrCopyPathAlreadyExists + BS.TVarBackingStoreNonMonotonicSeq wo wo' -> Just $ ErrNonMonotonicSeqNo wo wo' + BS.TVarBackingStoreDeserialiseExn _ -> Nothing + BS.TVarIncompleteDeserialiseExn -> Nothing diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Mock.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Mock.hs new file mode 100644 index 00000000000..fc17feac845 --- /dev/null +++ b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Mock.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Mock ( + -- * Types + Err (..) + , ID (..) + , Mock (..) + , MockValueHandle (..) + , emptyMock + -- * Type classes + , ApplyDiff (..) + , DiffSize (..) + , EmptyValues (..) + , HasOps + , KeysSize (..) + , LookupKeys (..) + , LookupKeysRange (..) + , MakeDiff (..) + , ValuesLength (..) + -- * State monad to run the mock in + , MockState (..) + , runMockState + -- * Mocked @'BackingStore'@ operations + , mBSClose + , mBSCopy + , mBSVHClose + , mBSVHRangeRead + , mBSVHRead + , mBSValueHandle + , mBSWrite + , mGuardBSClosed + , mGuardBSVHClosed + ) where + +import Control.Monad +import Control.Monad.Except (ExceptT (..), MonadError (throwError), + runExceptT) +import Control.Monad.State (MonadState, State, StateT (StateT), gets, + modify, runState) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set + +import Ouroboros.Consensus.Block.Abstract (SlotNo, WithOrigin (..)) +import qualified Ouroboros.Consensus.Storage.LedgerDB.HD.BackingStore as BS + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +data Mock vs = Mock { + backingValues :: vs + , backingSeqNo :: WithOrigin SlotNo + , copies :: Set BS.BackingStorePath + , isClosed :: Bool + -- | Track whether value handles have been closed. + , valueHandles :: Map ID Bool + -- | The next id to use if a new value handle is opened. + , nextId :: ID + } + deriving stock (Show, Eq) + +data MockValueHandle values = MockValueHandle { + getId :: ID + , values :: values + , seqNo :: WithOrigin SlotNo + } + deriving stock Show + +instance Eq (MockValueHandle vs) where + x == y = getId x == getId y + +instance Ord (MockValueHandle vs) where + x <= y = getId x < getId y + +-- | An ID for a mocked value handle. +newtype ID = ID Word + deriving stock (Show, Eq, Ord) + deriving newtype Num + +-- | An empty mock state. +emptyMock :: EmptyValues vs => Mock vs +emptyMock = Mock { + backingValues = emptyValues + , backingSeqNo = Origin + , copies = Set.empty + , isClosed = False + , valueHandles = Map.empty + , nextId = 0 + } + +data Err = + ErrBackingStoreClosed + | ErrCopyPathAlreadyExists + | ErrNonMonotonicSeqNo (WithOrigin SlotNo) (WithOrigin SlotNo) + | ErrBSVHDoesNotExist + deriving stock (Show, Eq) + +{------------------------------------------------------------------------------- + Type classes +-------------------------------------------------------------------------------} + +-- | Abstract over interactions between values, keys and diffs. +class ( EmptyValues vs, ApplyDiff vs d, LookupKeysRange ks vs + , LookupKeys ks vs, ValuesLength vs, MakeDiff vs d + , DiffSize d, KeysSize ks + ) => HasOps ks vs d + +class EmptyValues vs where + emptyValues :: vs + +class ApplyDiff vs d where + applyDiff :: vs -> d -> vs + +class LookupKeysRange ks vs where + lookupKeysRange :: Maybe ks -> Int -> vs -> vs + +class LookupKeys ks vs where + lookupKeys :: ks -> vs -> vs + +class ValuesLength vs where + valuesLength :: vs -> Int + +class MakeDiff vs d where + diff :: vs -> vs -> d + +class DiffSize d where + diffSize :: d -> Int + +class KeysSize ks where + keysSize :: ks -> Int + +{------------------------------------------------------------------------------- + State monad to run the mock in +-------------------------------------------------------------------------------} + +-- | State within which the mock runs. +newtype MockState ks vs d a = + MockState (ExceptT Err (State (Mock vs)) a) + deriving stock Functor + deriving newtype ( Applicative + , Monad + , MonadState (Mock vs) + , MonadError Err + ) + +runMockState :: + MockState ks vs d a + -> Mock vs + -> (Either Err a, Mock vs) +runMockState (MockState t) = runState . runExceptT $ t + +{------------------------------------------------------------------------------ + Mocked @'BackingStore'@ operations +------------------------------------------------------------------------------} + +-- | Throw an error if the backing store has been closed, which prevents any +-- other operations from succeeding. +mGuardBSClosed :: (MonadState (Mock vs) m, MonadError Err m) => m () +mGuardBSClosed = do + closed <- gets isClosed + when closed $ + throwError ErrBackingStoreClosed + +-- | Close the backing store. +mBSClose :: (MonadState (Mock vs) m, MonadError Err m) => m () +mBSClose = do + mGuardBSClosed + modify (\m -> m { + isClosed = True + }) + +-- | Copy the contents of the backing store to the given path. +mBSCopy :: (MonadState (Mock vs) m, MonadError Err m) => BS.BackingStorePath -> m () +mBSCopy bsp = do + mGuardBSClosed + cps <- gets copies + when (bsp `elem` cps) $ + throwError ErrCopyPathAlreadyExists + modify (\m -> m { + copies = bsp `Set.insert` copies m + }) + +-- | Open a new value handle, which captures the state of the backing store +-- at the time of opening the handle. +mBSValueHandle :: + (MonadState (Mock vs) m, MonadError Err m) + => m (WithOrigin SlotNo, MockValueHandle vs) +mBSValueHandle = do + mGuardBSClosed + vs <- gets backingValues + seqNo <- gets backingSeqNo + nxt <- gets nextId + let + vh = MockValueHandle nxt vs seqNo + modify (\m -> m { + valueHandles = Map.insert nxt False (valueHandles m) + , nextId = nxt + 1 + }) + + pure (seqNo, vh) + +-- | Write a diff to the backing store. +mBSWrite :: + (MonadState (Mock vs) m, MonadError Err m, ApplyDiff vs d) + => SlotNo + -> d + -> m () +mBSWrite sl d = do + mGuardBSClosed + vs <- gets backingValues + seqNo <- gets backingSeqNo + when (seqNo > NotOrigin sl) $ + throwError $ ErrNonMonotonicSeqNo (NotOrigin sl) seqNo + modify (\m -> m { + backingValues = applyDiff vs d + , backingSeqNo = NotOrigin sl + }) + +-- | Throw an error if the required backing store value handle has been closed. +mGuardBSVHClosed :: + (MonadState (Mock vs) m, MonadError Err m) + => MockValueHandle vs + -> m () +mGuardBSVHClosed vh = do + vhs <- gets valueHandles + case Map.lookup (getId vh) vhs of + Nothing -> error "Value handle not found" + Just b -> when b $ throwError ErrBSVHDoesNotExist + +-- | Close a backing store value handle. +mBSVHClose :: + (MonadState (Mock vs) m, MonadError Err m) + => MockValueHandle vs + -> m () +mBSVHClose vh = do + mGuardBSClosed + mGuardBSVHClosed vh + vhs <- gets valueHandles + modify (\m -> m { + valueHandles = Map.adjust (const True) (getId vh) vhs + }) + +-- | Perform a range read on a backing store value handle. +mBSVHRangeRead :: + (MonadState (Mock vs) m, MonadError Err m, LookupKeysRange ks vs) + => MockValueHandle vs + -> BS.RangeQuery ks + -> m vs +mBSVHRangeRead vh BS.RangeQuery{BS.rqPrev, BS.rqCount} = do + mGuardBSClosed + mGuardBSVHClosed vh + let + vs = values vh + pure $ lookupKeysRange rqPrev rqCount vs + +-- | Perform a regular read on a backing store value handle +mBSVHRead :: + (MonadState (Mock vs) m, MonadError Err m, LookupKeys ks vs) + => MockValueHandle vs + -> ks + -> m vs +mBSVHRead vh ks = do + mGuardBSClosed + mGuardBSVHClosed vh + let vs = values vh + pure $ lookupKeys ks vs diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Registry.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Registry.hs new file mode 100644 index 00000000000..87810bfe22f --- /dev/null +++ b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/HD/BackingStore/Registry.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A utility for storing and retrieving resources in a registry using handles +-- to identify resources in the registry. +module Test.Ouroboros.Storage.LedgerDB.HD.BackingStore.Registry ( + Handle + , HandleRegistry + , initHandleRegistry + , readHandle + , registerHandle + ) where + +import Control.Monad.Class.MonadSTM.Internal as STM + (MonadSTM (TVar, atomically, newTVarIO, readTVar, writeTVar)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import Ouroboros.Consensus.Util.IOLike (IOLike) + +newtype Handle = Handle Word + deriving stock (Show, Eq, Ord) + deriving newtype Num + +data HandleRegistry m a = HandleRegistry { + handles :: TVar m (Map Handle a) + , nextHandle :: TVar m Handle + } + +initHandleRegistry :: IOLike m => m (HandleRegistry m a) +initHandleRegistry = do + handles <- STM.newTVarIO Map.empty + nextHandle <- STM.newTVarIO 0 + pure $ HandleRegistry { handles, nextHandle } + +registerHandle :: + IOLike m + => HandleRegistry m a + -> a + -> m Handle +registerHandle HandleRegistry{handles, nextHandle} bsvh = STM.atomically $ do + vhs <- STM.readTVar handles + nh <- STM.readTVar nextHandle + let + vhs' = Map.insert nh bsvh vhs + STM.writeTVar handles vhs' + STM.writeTVar nextHandle (nh + 1) + pure nh + +readHandle :: + IOLike m + => HandleRegistry m a + -> Handle + -> m a +readHandle HandleRegistry{handles} h = STM.atomically $ do + vhs <- STM.readTVar handles + case Map.lookup h vhs of + Nothing -> error "Handle not found" + Just vh -> pure vh diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/HD/BackingStore.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/HD/BackingStore.hs index 0933a6e41ff..998d8b6543c 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/HD/BackingStore.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/HD/BackingStore.hs @@ -70,6 +70,7 @@ deriving via OnlyCheckWhnfNamed "BackingStore" (BackingStore m keys values diff) instance NoThunks (BackingStore m keys values diff) newtype BackingStorePath = BackingStorePath FS.FsPath + deriving stock (Show, Eq, Ord) deriving newtype NoThunks -- | An ephemeral handle to an immutable value of the entire database @@ -109,6 +110,7 @@ data RangeQuery keys = RangeQuery { -- of them were deleted in the changelog? , rqCount :: !Int } + deriving stock (Show, Eq) -- | TODO Is there a good way to not assume that any function that creates a -- 'BackingStoreValueHandle' doesn't hold space leaks in its closure?