Skip to content

Commit d7da947

Browse files
jasagredojasagredo
committed
Track HasBlockIO in the resource registry
1 parent 89cc096 commit d7da947

File tree

9 files changed

+110
-68
lines changed

9 files changed

+110
-68
lines changed

‎ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs‎

Lines changed: 16 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -85,24 +85,23 @@ openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.L
8585
(ds, bss') <- case args of
8686
V2.V2Args V2.InMemoryHandleArgs -> pure (defaultDeleteSnapshot, V2.InMemoryHandleEnv)
8787
V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)) -> do
88+
(rk1, V2.SomeHasFSAndBlockIO fs' blockio) <- mkFS (LedgerDB.lgrRegistry lgrDbArgs) "lsm"
8889
session <-
89-
snd
90-
<$> allocate
91-
(LedgerDB.lgrRegistry lgrDbArgs)
92-
( \_ -> do
93-
V2.SomeHasFSAndBlockIO fs' blockio <- mkFS "lsm"
94-
salt <- genSalt
95-
LSM.openSession
96-
( LedgerDBFlavorImplEvent . LedgerDB.FlavorImplSpecificTraceV2 . V2.LSMTrace
97-
>$< LedgerDB.lgrTracer lgrDbArgs
98-
)
99-
fs'
100-
blockio
101-
salt
102-
(mkFsPath [path])
103-
)
104-
LSM.closeSession
105-
pure (LSM.deleteSnapshot session, V2.LSMHandleEnv session)
90+
allocate
91+
(LedgerDB.lgrRegistry lgrDbArgs)
92+
( \_ -> do
93+
salt <- genSalt
94+
LSM.openSession
95+
( LedgerDBFlavorImplEvent . LedgerDB.FlavorImplSpecificTraceV2 . V2.LSMTrace
96+
>$< LedgerDB.lgrTracer lgrDbArgs
97+
)
98+
fs'
99+
blockio
100+
salt
101+
(mkFsPath [path])
102+
)
103+
LSM.closeSession
104+
pure (LSM.deleteSnapshot (snd session), V2.LSMHandleEnv session rk1)
106105
(ledgerDB, _, intLedgerDB) <-
107106
LedgerDB.openDBInternal
108107
lgrDbArgs

‎ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -83,7 +83,6 @@ library
8383
contra-tracer,
8484
deepseq,
8585
filepath,
86-
blockio,
8786
fs-api ^>=0.4,
8887
hashable,
8988
io-classes:{io-classes, si-timers, strict-stm} ^>=1.8,

‎ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs‎

Lines changed: 8 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -128,6 +128,7 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
128128
import Ouroboros.Consensus.Storage.LedgerDB.Args
129129
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
130130
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
131+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM
131132
import Ouroboros.Consensus.Util.Args
132133
import Ouroboros.Consensus.Util.IOLike
133134
import Ouroboros.Consensus.Util.Orphans ()
@@ -177,10 +178,9 @@ import qualified SafeWildCards
177178
import System.Exit (ExitCode (..))
178179
import System.FS.API (SomeHasFS (..))
179180
import System.FS.API.Types (MountPoint (..))
180-
import System.FS.BlockIO.IO
181181
import System.FS.IO (ioHasFS)
182182
import System.FilePath ((</>))
183-
import System.Random (StdGen, genWord64, initStdGen, newStdGen, randomIO, split)
183+
import System.Random (StdGen, newStdGen, randomIO, split)
184184

185185
{-------------------------------------------------------------------------------
186186
The arguments to the Consensus Layer node functionality
@@ -1057,13 +1057,12 @@ stdLowLevelRunNodeArgsIO
10571057
V1LMDB args -> LedgerDbFlavorArgsV1 args
10581058
V2InMemory -> LedgerDbFlavorArgsV2 (V2.V2Args V2.InMemoryHandleArgs)
10591059
V2LSM path ->
1060-
let
1061-
mkFS = \s ->
1062-
uncurry V2.SomeHasFSAndBlockIO
1063-
<$> ioHasBlockIO (MountPoint $ nonImmutableDbPath srnDatabasePath </> s) defaultIOCtxParams
1064-
genSalt = fst . genWord64 <$> initStdGen
1065-
in
1066-
LedgerDbFlavorArgsV2 (V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)))
1060+
LedgerDbFlavorArgsV2
1061+
( V2.V2Args
1062+
( V2.LSMHandleArgs
1063+
(V2.LSMArgs path LSM.stdGenSalt (LSM.stdMkBlockIOFS (nonImmutableDbPath srnDatabasePath)))
1064+
)
1065+
)
10671066
}
10681067
where
10691068
networkMagic :: NetworkMagic

‎ouroboros-consensus/ouroboros-consensus.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -296,7 +296,9 @@ library
296296
build-depends:
297297
FailT ^>=0.1.2,
298298
blockio,
299+
random,
299300
aeson,
301+
filepath,
300302
base >=4.14 && <4.22,
301303
base-deriving-via,
302304
base16-bytestring,

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs‎

Lines changed: 14 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -78,22 +78,21 @@ openDB
7878
(ds, bss') <- case bss of
7979
V2.V2Args V2.InMemoryHandleArgs -> pure (defaultDeleteSnapshot, V2.InMemoryHandleEnv)
8080
V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)) -> do
81+
(rk1, V2.SomeHasFSAndBlockIO fs blockio) <- mkFS (lgrRegistry args) "lsm"
8182
session <-
82-
snd
83-
<$> allocate
84-
(lgrRegistry args)
85-
( \_ -> do
86-
V2.SomeHasFSAndBlockIO fs blockio <- mkFS "lsm"
87-
salt <- genSalt
88-
LSM.openSession
89-
(LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args)
90-
fs
91-
blockio
92-
salt
93-
(mkFsPath [path])
94-
)
95-
LSM.closeSession
96-
pure (LSM.deleteSnapshot session, V2.LSMHandleEnv session)
83+
allocate
84+
(lgrRegistry args)
85+
( \_ -> do
86+
salt <- genSalt
87+
LSM.openSession
88+
(LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args)
89+
fs
90+
blockio
91+
salt
92+
(mkFsPath [path])
93+
)
94+
LSM.closeSession
95+
pure (LSM.deleteSnapshot (snd session), V2.LSMHandleEnv session rk1)
9796
let initDb =
9897
V2.mkInitDb
9998
args

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs‎

Lines changed: 16 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE DataKinds #-}
33
{-# LANGUAGE DeriveAnyClass #-}
44
{-# LANGUAGE DeriveGeneric #-}
5+
{-# LANGUAGE DerivingVia #-}
56
{-# LANGUAGE FlexibleContexts #-}
67
{-# LANGUAGE LambdaCase #-}
78
{-# LANGUAGE NamedFieldPuns #-}
@@ -13,6 +14,7 @@
1314
{-# LANGUAGE TypeFamilies #-}
1415
{-# LANGUAGE TypeOperators #-}
1516
{-# LANGUAGE UndecidableInstances #-}
17+
{-# OPTIONS_GHC -Wno-orphans #-}
1618

1719
module Ouroboros.Consensus.Storage.LedgerDB.V2 (mkInitDb) where
1820

@@ -113,6 +115,9 @@ mkInitDb args bss getBlock =
113115
, ldbResolveBlock = getBlock
114116
, ldbQueryBatchSize = lgrQueryBatchSize
115117
, ldbOpenHandlesLock = lock
118+
, ldbSession = case bss of
119+
InMemoryHandleEnv -> Nothing
120+
LSMHandleEnv (s, _) k -> Just (s, k)
116121
}
117122
h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
118123
pure $ implMkLedgerDb h bss
@@ -137,7 +142,7 @@ mkInitDb args bss getBlock =
137142
emptyF st =
138143
empty' st $ case bss of
139144
InMemoryHandleEnv -> InMemory.newInMemoryLedgerTablesHandle v2Tracer lgrHasFS
140-
LSMHandleEnv session ->
145+
LSMHandleEnv (_, session) _ ->
141146
\values -> do
142147
table <- LSM.tableFromValuesMK lgrRegistry session values
143148
LSM.newLSMLedgerTablesHandle v2Tracer lgrRegistry session table
@@ -149,7 +154,7 @@ mkInitDb args bss getBlock =
149154
m (Either (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk))
150155
loadSnapshot ccfg fs ds = case bss of
151156
InMemoryHandleEnv -> runExceptT $ InMemory.loadSnapshot v2Tracer lgrRegistry ccfg fs ds
152-
LSMHandleEnv session -> runExceptT $ LSM.loadSnapshot v2Tracer lgrRegistry ccfg fs session ds
157+
LSMHandleEnv (_, session) _ -> runExceptT $ LSM.loadSnapshot v2Tracer lgrRegistry ccfg fs session ds
153158

154159
implMkLedgerDb ::
155160
forall m l blk.
@@ -228,9 +233,10 @@ mkInternals bss h =
228233
(st `withLedgerTables` tables)
229234
forkerPush frk st' >> atomically (forkerCommit frk) >> forkerClose frk
230235
, wipeLedgerDB = getEnv h $ destroySnapshots . ldbHasFS
231-
, closeLedgerDB =
236+
, closeLedgerDB = do
232237
let LDBHandle tvar = h
233-
in atomically (writeTVar tvar LedgerDBClosed)
238+
getEnv h $ \env -> maybe (pure ()) (\(x, y) -> unsafeRelease x >> unsafeRelease y >> pure ()) (ldbSession env)
239+
atomically (writeTVar tvar LedgerDBClosed)
234240
, truncateSnapshots = getEnv h $ implIntTruncateSnapshots . ldbHasFS
235241
, getNumLedgerTablesHandles = getEnv h $ \env -> do
236242
l <- readTVarIO (ldbSeq env)
@@ -411,7 +417,7 @@ implTryTakeSnapshot bss env mTime nrBlocks =
411417
deleteSnapshot = case bss of
412418
InMemoryHandleEnv ->
413419
defaultDeleteSnapshot
414-
LSMHandleEnv session ->
420+
LSMHandleEnv (_, session) _ ->
415421
LSM.deleteSnapshot session
416422

417423
-- In the first version of the LedgerDB for UTxO-HD, there is a need to
@@ -489,6 +495,7 @@ data LedgerDBEnv m l blk = LedgerDBEnv
489495
--
490496
-- * Modify 'ldbSeq' while holding a write lock, and then close the removed
491497
-- handles without any locking.
498+
, ldbSession :: !(Maybe (ResourceKey m, ResourceKey m))
492499
}
493500
deriving Generic
494501

@@ -502,6 +509,10 @@ deriving instance
502509
) =>
503510
NoThunks (LedgerDBEnv m l blk)
504511

512+
instance NoThunks (LSM.Session m) where
513+
showTypeOf _ = "Session"
514+
wNoThunks _ _ = pure Nothing
515+
505516
{-------------------------------------------------------------------------------
506517
The LedgerDBHandle
507518
-------------------------------------------------------------------------------}

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.Args
1010
, LSMHandleArgs (..)
1111
) where
1212

13+
import Control.ResourceRegistry
1314
import Data.Typeable
1415
import Database.LSMTree (LSMTreeTrace (..), Salt, Session)
1516
import Ouroboros.Consensus.Util.Args
@@ -25,15 +26,15 @@ data HandleArgs f m
2526
data LSMHandleArgs f m = LSMArgs
2627
{ lsmFilePath :: HKD f FilePath
2728
, lsmGenSalt :: HKD f (m Salt)
28-
, lsmMkFS :: HKD f (FilePath -> m (SomeHasFSAndBlockIO m))
29+
, lsmMkFS :: HKD f (ResourceRegistry m -> FilePath -> m (ResourceKey m, SomeHasFSAndBlockIO m))
2930
}
3031

3132
data SomeHasFSAndBlockIO m where
3233
SomeHasFSAndBlockIO :: (Eq h, Typeable h) => HasFS m h -> HasBlockIO m h -> SomeHasFSAndBlockIO m
3334

3435
data HandleEnv m
3536
= InMemoryHandleEnv
36-
| LSMHandleEnv (Session m)
37+
| LSMHandleEnv (ResourceKey m, Session m) (ResourceKey m)
3738

3839
data FlavorImplSpecificTrace
3940
= -- | Created a new 'LedgerTablesHandle', potentially by duplicating an

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,8 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
5151
, Session
5252
, LSM.openSession
5353
, LSM.closeSession
54+
, stdGenSalt
55+
, stdMkBlockIOFS
5456
) where
5557

5658
import Cardano.Binary as CBOR
@@ -90,6 +92,10 @@ import Ouroboros.Consensus.Util.CRC
9092
import Ouroboros.Consensus.Util.Enclose
9193
import Ouroboros.Consensus.Util.IOLike
9294
import System.FS.API
95+
import qualified System.FS.BlockIO.API as BIO
96+
import System.FS.BlockIO.IO
97+
import qualified System.FilePath as FilePath
98+
import System.Random
9399
import Prelude hiding (read)
94100

95101
type LedgerSupportsLSMLedgerDB l =
@@ -368,3 +374,16 @@ serialiseLSMViaMemPack a =
368374
-- that are serialized via 'MemPack'.
369375
deserialiseLSMViaMemPack :: MemPack b => LSM.RawBytes -> b
370376
deserialiseLSMViaMemPack (LSM.RawBytes (Vector _ _ barr)) = unpackError barr
377+
378+
stdGenSalt :: IO LSM.Salt
379+
stdGenSalt = fst . genWord64 <$> initStdGen
380+
381+
stdMkBlockIOFS ::
382+
FilePath -> ResourceRegistry IO -> FilePath -> IO (ResourceKey IO, V2.SomeHasFSAndBlockIO IO)
383+
stdMkBlockIOFS fastStoragePath rr relPath = do
384+
(rk1, bio) <-
385+
allocate
386+
rr
387+
(\_ -> ioHasBlockIO (MountPoint $ fastStoragePath FilePath.</> relPath) defaultIOCtxParams)
388+
(BIO.close . snd)
389+
pure $ (rk1, uncurry V2.SomeHasFSAndBlockIO bio)

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

Lines changed: 32 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -104,7 +104,9 @@ tests =
104104
, testProperty "InMemV2" $
105105
prop_sequential 100000 inMemV2TestArguments noFilePath simulatedFS
106106
, testProperty "LMDB" $
107-
prop_sequential 1000 lmdbTestArguments realFilePath realFS
107+
prop_sequential 1000 lmdbTestArguments (realFilePath "lmdb") realFS
108+
, testProperty "LSM" $
109+
prop_sequential 1000 lsmTestArguments (realFilePath "lsm") realFS
108110
]
109111

110112
prop_sequential ::
@@ -158,9 +160,10 @@ data TestArguments m = TestArguments
158160
noFilePath :: IO (FilePath, IO ())
159161
noFilePath = pure ("Bogus", pure ())
160162

161-
realFilePath :: IO (FilePath, IO ())
162-
realFilePath = liftIO $ do
163-
tmpdir <- (FilePath.</> "test_lmdb") <$> Dir.getTemporaryDirectory
163+
realFilePath :: String -> IO (FilePath, IO ())
164+
realFilePath l = liftIO $ do
165+
tmpdir <- (FilePath.</> ("test_" <> l)) <$> Dir.getTemporaryDirectory
166+
Dir.createDirectoryIfMissing False tmpdir
164167
pure
165168
( tmpdir
166169
, do
@@ -199,6 +202,17 @@ inMemV2TestArguments secParam _ =
199202
, argLedgerDbCfg = extLedgerDbConfig secParam
200203
}
201204

205+
lsmTestArguments ::
206+
SecurityParam ->
207+
FilePath ->
208+
TestArguments IO
209+
lsmTestArguments secParam fp =
210+
TestArguments
211+
{ argFlavorArgs =
212+
LedgerDbFlavorArgsV2 $ V2Args $ LSMHandleArgs $ LSMArgs fp LSM.stdGenSalt (LSM.stdMkBlockIOFS fp)
213+
, argLedgerDbCfg = extLedgerDbConfig secParam
214+
}
215+
202216
lmdbTestArguments ::
203217
SecurityParam ->
204218
FilePath ->
@@ -502,22 +516,21 @@ openLedgerDB flavArgs env cfg fs = do
502516
(ds, bss') <- case bss of
503517
V2.V2Args V2.InMemoryHandleArgs -> pure (defaultDeleteSnapshot, V2.InMemoryHandleEnv)
504518
V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)) -> do
519+
(rk1, V2.SomeHasFSAndBlockIO fs' blockio) <- mkFS (lgrRegistry args) "lsm"
505520
session <-
506-
snd
507-
<$> allocate
508-
(lgrRegistry args)
509-
( \_ -> do
510-
V2.SomeHasFSAndBlockIO fs' blockio <- mkFS "lsm"
511-
salt <- genSalt
512-
LSM.openSession
513-
(LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args)
514-
fs'
515-
blockio
516-
salt
517-
(mkFsPath [path])
518-
)
519-
LSM.closeSession
520-
pure (LSM.deleteSnapshot session, V2.LSMHandleEnv session)
521+
allocate
522+
(lgrRegistry args)
523+
( \_ -> do
524+
salt <- genSalt
525+
LSM.openSession
526+
(LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args)
527+
fs'
528+
blockio
529+
salt
530+
(mkFsPath [path])
531+
)
532+
LSM.closeSession
533+
pure (LSM.deleteSnapshot (snd session), V2.LSMHandleEnv session rk1)
521534
let initDb =
522535
V2.mkInitDb
523536
args

0 commit comments

Comments
 (0)