Skip to content

Commit bf42d6c

Browse files
jasagredojasagredo
committed
Adapt tests to use types from the extracted sublibraries
1 parent b4cd898 commit bf42d6c

File tree

5 files changed

+53
-65
lines changed

5 files changed

+53
-65
lines changed

‎ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/LedgerTables.hs‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,7 @@
11
{-# LANGUAGE DerivingStrategies #-}
22
{-# LANGUAGE FlexibleContexts #-}
33
{-# LANGUAGE FlexibleInstances #-}
4-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
54
{-# LANGUAGE ScopedTypeVariables #-}
6-
{-# LANGUAGE StandaloneDeriving #-}
75
{-# LANGUAGE TypeApplications #-}
86
{-# LANGUAGE TypeFamilies #-}
97
{-# LANGUAGE TypeOperators #-}

‎ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs‎

Lines changed: 7 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -14,15 +14,14 @@ module Test.Util.ChainDB
1414
import Control.Concurrent.Class.MonadSTM.Strict
1515
import Control.ResourceRegistry (ResourceRegistry)
1616
import Control.Tracer (nullTracer)
17-
import Ouroboros.Consensus.Block.Abstract
1817
import Ouroboros.Consensus.Config
1918
( TopLevelConfig (topLevelConfigLedger)
2019
, configCodec
2120
)
2221
import Ouroboros.Consensus.HardFork.History.EraParams (eraEpochSize)
2322
import Ouroboros.Consensus.Ledger.Basics
2423
import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState)
25-
import Ouroboros.Consensus.Protocol.Abstract
24+
import Ouroboros.Consensus.Ledger.SupportsProtocol
2625
import Ouroboros.Consensus.Storage.ChainDB hiding
2726
( TraceFollowerEvent (..)
2827
)
@@ -31,7 +30,8 @@ import Ouroboros.Consensus.Storage.ImmutableDB
3130
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
3231
import Ouroboros.Consensus.Storage.LedgerDB
3332
import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB
34-
import Ouroboros.Consensus.Storage.LedgerDB.V2.Args
33+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2
34+
import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
3535
import Ouroboros.Consensus.Storage.VolatileDB
3636
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
3737
import Ouroboros.Consensus.Util.Args
@@ -84,10 +84,9 @@ mkTestChunkInfo = simpleChunkInfo . eraEpochSize . tblcHardForkParams . topLevel
8484

8585
-- | Creates a default set of of arguments for ChainDB tests.
8686
fromMinimalChainDbArgs ::
87-
( MonadThrow m
88-
, MonadSTM m
89-
, ConsensusProtocol (BlockProtocol blk)
90-
, PrimMonad m
87+
( IOLike m
88+
, LedgerSupportsProtocol blk
89+
, LedgerSupportsLedgerDB blk
9190
) =>
9291
MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk
9392
fromMinimalChainDbArgs MinimalChainDbArgs{..} =
@@ -131,7 +130,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} =
131130
, lgrTracer = nullTracer
132131
, lgrRegistry = mcdbRegistry
133132
, lgrConfig = configLedgerDb mcdbTopLevelConfig OmitLedgerEvents
134-
, lgrFlavorArgs = LedgerDbFlavorArgsV2 (V2Args InMemoryHandleArgs)
133+
, lgrBackendArgs = LedgerDbBackendArgsV2 $ V2.SomeBackendArgs InMemArgs
135134
, lgrQueryBatchSize = DefaultQueryBatchSize
136135
, lgrStartSnapshot = Nothing
137136
}

‎ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,8 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Stream hiding
4545
import Ouroboros.Consensus.Storage.LedgerDB
4646
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
4747
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
48-
import Ouroboros.Consensus.Storage.LedgerDB.V1.Args
48+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2
49+
import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
4950
import Ouroboros.Consensus.Util.IOLike hiding (newTVarIO)
5051
import Ouroboros.Network.Mock.Chain (Chain (..))
5152
import qualified Ouroboros.Network.Mock.Chain as Chain
@@ -231,7 +232,7 @@ initLedgerDB s c = do
231232
, lgrHasFS = SomeHasFS $ simHasFS fs
232233
, lgrGenesis = return testInitExtLedger
233234
, lgrTracer = nullTracer
234-
, lgrFlavorArgs = LedgerDbFlavorArgsV1 $ V1Args DefaultFlushFrequency InMemoryBackingStoreArgs
235+
, lgrBackendArgs = LedgerDbBackendArgsV2 $ V2.SomeBackendArgs InMemArgs
235236
, lgrConfig = LedgerDB.configLedgerDb (testCfg s) OmitLedgerEvents
236237
, lgrQueryBatchSize = DefaultQueryBatchSize
237238
, lgrRegistry = reg

‎ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs‎

Lines changed: 38 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@
1616
{-# LANGUAGE RankNTypes #-}
1717
{-# LANGUAGE ScopedTypeVariables #-}
1818
{-# LANGUAGE StandaloneDeriving #-}
19+
{-# LANGUAGE TypeApplications #-}
1920
{-# LANGUAGE TypeFamilies #-}
2021
{-# LANGUAGE UndecidableInstances #-}
2122
{-# OPTIONS_GHC -Wno-orphans #-}
@@ -61,18 +62,17 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
6162
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
6263
import Ouroboros.Consensus.Storage.LedgerDB.V1 as V1
6364
import Ouroboros.Consensus.Storage.LedgerDB.V1.Args hiding
64-
( LedgerDbFlavorArgs
65+
( LedgerDbBackendArgs
6566
)
67+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1
68+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory as V1.InMemory
69+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB
6670
import Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1
6771
import Ouroboros.Consensus.Storage.LedgerDB.V2 as V2
68-
import Ouroboros.Consensus.Storage.LedgerDB.V2.Args hiding
69-
( LedgerDbFlavorArgs
70-
)
71-
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
72-
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
72+
import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2
73+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as V2.InMemory
7374
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM
7475
import Ouroboros.Consensus.Util hiding (Some)
75-
import Ouroboros.Consensus.Util.Args
7676
import Ouroboros.Consensus.Util.IOLike
7777
import qualified Ouroboros.Network.AnchoredSeq as AS
7878
import Ouroboros.Network.Protocol.LocalStateQuery.Type
@@ -176,7 +176,7 @@ initialEnvironment fsOps getDiskDir mkTestArguments cdb rr = do
176176
-------------------------------------------------------------------------------}
177177

178178
data TestArguments m = TestArguments
179-
{ argFlavorArgs :: !(Complete LedgerDbFlavorArgs m)
179+
{ argFlavorArgs :: !(LedgerDbBackendArgs m TestBlock)
180180
, argLedgerDbCfg :: !(LedgerDbCfg (ExtLedgerState TestBlock))
181181
}
182182

@@ -212,7 +212,8 @@ inMemV1TestArguments ::
212212
TestArguments IO
213213
inMemV1TestArguments secParam _ _ =
214214
TestArguments
215-
{ argFlavorArgs = LedgerDbFlavorArgsV1 $ V1Args DisableFlushing InMemoryBackingStoreArgs
215+
{ argFlavorArgs =
216+
LedgerDbBackendArgsV1 $ V1Args DisableFlushing $ V1.SomeBackendArgs V1.InMemory.InMemArgs
216217
, argLedgerDbCfg = extLedgerDbConfig secParam
217218
}
218219

@@ -223,7 +224,7 @@ inMemV2TestArguments ::
223224
TestArguments IO
224225
inMemV2TestArguments secParam _ _ =
225226
TestArguments
226-
{ argFlavorArgs = LedgerDbFlavorArgsV2 $ V2Args InMemoryHandleArgs
227+
{ argFlavorArgs = LedgerDbBackendArgsV2 $ SomeBackendArgs V2.InMemory.InMemArgs
227228
, argLedgerDbCfg = extLedgerDbConfig secParam
228229
}
229230

@@ -235,10 +236,9 @@ lsmTestArguments ::
235236
lsmTestArguments secParam salt fp =
236237
TestArguments
237238
{ argFlavorArgs =
238-
LedgerDbFlavorArgsV2 $
239-
V2Args $
240-
LSMHandleArgs $
241-
LSMArgs (mkFsPath $ FilePath.splitDirectories fp) salt (LSM.stdMkBlockIOFS fp)
239+
LedgerDbBackendArgsV2 $
240+
SomeBackendArgs $
241+
LSM.LSMArgs (mkFsPath $ FilePath.splitDirectories fp) salt (LSM.stdMkBlockIOFS fp)
242242
, argLedgerDbCfg = extLedgerDbConfig secParam
243243
}
244244

@@ -250,9 +250,10 @@ lmdbTestArguments ::
250250
lmdbTestArguments secParam _ fp =
251251
TestArguments
252252
{ argFlavorArgs =
253-
LedgerDbFlavorArgsV1 $
253+
LedgerDbBackendArgsV1 $
254254
V1Args DisableFlushing $
255-
LMDBBackingStoreArgs fp (testLMDBLimits 16) Dict.Dict
255+
V1.SomeBackendArgs $
256+
LMDB.LMDBBackingStoreArgs fp (testLMDBLimits 16) Dict.Dict
256257
, argLedgerDbCfg = extLedgerDbConfig secParam
257258
}
258259

@@ -527,7 +528,7 @@ blockNotFound =
527528
-------------------------------------------------------------------------------}
528529

529530
openLedgerDB ::
530-
Complete LedgerDbFlavorArgs IO ->
531+
LedgerDbBackendArgs IO TestBlock ->
531532
ChainDB IO ->
532533
LedgerDbCfg (ExtLedgerState TestBlock) ->
533534
SomeHasFS IO ->
@@ -549,8 +550,8 @@ openLedgerDB flavArgs env cfg fs rr = do
549550
rr
550551
DefaultQueryBatchSize
551552
Nothing
552-
(ldb, _, od) <- case flavArgs of
553-
LedgerDbFlavorArgsV1 bss ->
553+
(ldb, _, od) <- case lgrBackendArgs args of
554+
LedgerDbBackendArgsV1 bss ->
554555
let snapManager = V1.snapshotManager args
555556
initDb =
556557
V1.mkInitDb
@@ -560,34 +561,22 @@ openLedgerDB flavArgs env cfg fs rr = do
560561
snapManager
561562
(praosGetVolatileSuffix $ ledgerDbCfgSecParam cfg)
562563
in openDBInternal args initDb snapManager stream replayGoal
563-
LedgerDbFlavorArgsV2 bss -> do
564-
(snapManager, bss') <- case bss of
565-
V2.V2Args V2.InMemoryHandleArgs -> pure (InMemory.snapshotManager args, V2.InMemoryHandleEnv)
566-
V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path salt mkFS)) -> do
567-
(rk1, V2.SomeHasFSAndBlockIO fs' blockio) <- mkFS (lgrRegistry args)
568-
session <-
569-
allocate
570-
(lgrRegistry args)
571-
( \_ ->
572-
LSM.openSession
573-
(LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args)
574-
fs'
575-
blockio
576-
salt
577-
path
578-
)
579-
LSM.closeSession
580-
pure
581-
( LSM.snapshotManager (snd session) args
582-
, V2.LSMHandleEnv (V2.LSMResources (fst session) (snd session) rk1)
583-
)
584-
let initDb =
585-
V2.mkInitDb
586-
args
587-
bss'
588-
getBlock
589-
snapManager
590-
(praosGetVolatileSuffix $ ledgerDbCfgSecParam cfg)
564+
LedgerDbBackendArgsV2 (V2.SomeBackendArgs bArgs) -> do
565+
res <-
566+
mkResources
567+
(Proxy @TestBlock)
568+
(LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 >$< lgrTracer args)
569+
bArgs
570+
(lgrRegistry args)
571+
(lgrHasFS args)
572+
let snapManager =
573+
V2.snapshotManager
574+
(Proxy @TestBlock)
575+
res
576+
(configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig args)
577+
(LedgerDBSnapshotEvent >$< lgrTracer args)
578+
(lgrHasFS args)
579+
let initDb = V2.mkInitDb args getBlock snapManager (praosGetVolatileSuffix $ ledgerDbCfgSecParam cfg) res
591580
openDBInternal args initDb snapManager stream replayGoal
592581
withRegistry $ \reg -> do
593582
vr <- validateFork ldb reg (const $ pure ()) BlockCache.empty 0 (map getHeader volBlocks)
@@ -623,6 +612,7 @@ instance RunModel Model (StateT Environment IO) where
623612
Environment _ _ chainDb mkArgs fs _ cleanup rr <- get
624613
(ldb, testInternals, getNumOpenHandles) <- lift $ do
625614
let args = mkArgs secParam salt
615+
-- TODO after a drop and restore we restart the db but the session has been closed below where I wrote blahblahblah
626616
openLedgerDB (argFlavorArgs args) chainDb (argLedgerDbCfg args) fs rr
627617
put (Environment ldb testInternals chainDb mkArgs fs getNumOpenHandles cleanup rr)
628618
pure $ pure ()
@@ -659,6 +649,7 @@ instance RunModel Model (StateT Environment IO) where
659649
Environment _ testInternals chainDb _ _ _ _ _ <- get
660650
lift $ do
661651
atomically $ modifyTVar (dbChain chainDb) (drop (fromIntegral n))
652+
-- blahblahblah
662653
closeLedgerDB testInternals
663654
perform state (Init secParam salt) lk
664655
perform _ OpenAndCloseForker _ = do

‎ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore.hs‎

Lines changed: 5 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -36,11 +36,9 @@ import Data.Typeable
3636
import Ouroboros.Consensus.Ledger.Tables
3737
import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
3838
import Ouroboros.Consensus.Ledger.Tables.Utils
39-
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as BS
4039
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as BS
4140
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory as InMemory
4241
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB
43-
import Ouroboros.Consensus.Util.Args
4442
import Ouroboros.Consensus.Util.IOLike hiding
4543
( MonadMask (..)
4644
, newMVar
@@ -80,19 +78,19 @@ tests =
8078
[ adjustOption (scaleQuickCheckTests 10) $
8179
testProperty "InMemory IO SimHasFS" $
8280
testWithIO $
83-
setupBSEnv BS.InMemoryBackingStoreArgs setupSimHasFS (pure ())
81+
setupBSEnv InMemory.InMemArgs setupSimHasFS (pure ())
8482
, adjustOption (scaleQuickCheckTests 10) $
8583
testProperty "InMemory IO IOHasFS" $
8684
testWithIO $ do
8785
(fp, cleanup) <- setupTempDir
88-
setupBSEnv BS.InMemoryBackingStoreArgs (setupIOHasFS fp) cleanup
86+
setupBSEnv InMemory.InMemArgs (setupIOHasFS fp) cleanup
8987
, adjustOption (scaleQuickCheckTests 2) $
9088
testProperty "LMDB IO IOHasFS" $
9189
testWithIO $ do
9290
(fp, cleanup) <- setupTempDir
9391
lmdbTmpDir <- (FilePath.</> "BS_LMDB") <$> Dir.getTemporaryDirectory
9492
setupBSEnv
95-
(BS.LMDBBackingStoreArgs lmdbTmpDir (testLMDBLimits maxOpenValueHandles) Dict.Dict)
93+
(LMDB.LMDBBackingStoreArgs lmdbTmpDir (testLMDBLimits maxOpenValueHandles) Dict.Dict)
9694
(setupIOHasFS fp)
9795
(cleanup >> Dir.removeDirectoryRecursive lmdbTmpDir)
9896
]
@@ -142,8 +140,9 @@ setupTempDir = do
142140
pure (qsmTmpDir, liftIO $ Dir.removeDirectoryRecursive qsmTmpDir)
143141

144142
setupBSEnv ::
143+
BS.Backend m backend (OTLedgerState (QC.Fixed Word) (QC.Fixed Word)) =>
145144
IOLike m =>
146-
Complete BS.BackingStoreArgs m ->
145+
BS.Args m backend ->
147146
m (SomeHasFS m) ->
148147
m () ->
149148
m (BSEnv m K K' V D)

0 commit comments

Comments
 (0)