{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Consensus.Storage.LedgerDB
(
module Ouroboros.Consensus.Storage.LedgerDB.API
, module Ouroboros.Consensus.Storage.LedgerDB.Args
, module Ouroboros.Consensus.Storage.LedgerDB.Forker
, module Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
, openDB
, openDBInternal
) where
import Data.Functor.Contravariant ((>$<))
import Data.Void
import Data.Word
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.HardFork.Abstract
import Ouroboros.Consensus.Ledger.Inspect
import Ouroboros.Consensus.Ledger.SupportsProtocol
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.V1.Snapshots 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.InMemory as InMemory
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.CallStack
import Ouroboros.Consensus.Util.IOLike
import System.FS.API
openDB ::
forall m blk.
( IOLike m
, LedgerSupportsProtocol blk
, InspectLedger blk
, HasCallStack
, HasHardForkHistory blk
, LedgerSupportsLedgerDB blk
) =>
Complete LedgerDbArgs m blk ->
StreamAPI m blk blk ->
Point blk ->
ResolveBlock m blk ->
GetVolatileSuffix m blk ->
m (LedgerDB' m blk, Word64)
openDB :: forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
HasCallStack, HasHardForkHistory blk,
LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> StreamAPI m blk blk
-> Point blk
-> ResolveBlock m blk
-> GetVolatileSuffix m blk
-> m (LedgerDB' m blk, Word64)
openDB
Complete LedgerDbArgs m blk
args
StreamAPI m blk blk
stream
Point blk
replayGoal
ResolveBlock m blk
getBlock
GetVolatileSuffix m blk
getVolatileSuffix = case Complete LedgerDbArgs m blk -> LedgerDbFlavorArgs Identity m
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbFlavorArgs f m
lgrFlavorArgs Complete LedgerDbArgs m blk
args of
LedgerDbFlavorArgsV1 LedgerDbFlavorArgs Identity m
bss ->
let snapManager :: SnapshotManager
m
(ReadLocked m)
blk
(StrictTVar m (DbChangelog' blk), BackingStore' m blk)
snapManager = Complete LedgerDbArgs m blk
-> SnapshotManager
m
(ReadLocked m)
blk
(StrictTVar m (DbChangelog' blk), BackingStore' m blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
LedgerSupportsProtocol blk) =>
Complete LedgerDbArgs m blk
-> SnapshotManager
m
(ReadLocked m)
blk
(StrictTVar m (DbChangelog' blk), BackingStore' m blk)
V1.snapshotManager Complete LedgerDbArgs m blk
args
initDb :: InitDB (DbChangelog' blk, ResourceKey m, BackingStore' m blk) m blk
initDb =
Complete LedgerDbArgs m blk
-> LedgerDbFlavorArgs Identity m
-> ResolveBlock m blk
-> SnapshotManager
m
(ReadLocked m)
blk
(StrictTVar m (DbChangelog' blk), BackingStore' m blk)
-> GetVolatileSuffix m blk
-> InitDB
(DbChangelog' blk, ResourceKey m, BackingStore' m blk) m blk
forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, IOLike m, HasHardForkHistory blk,
LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> Complete LedgerDbFlavorArgs m
-> ResolveBlock m blk
-> SnapshotManagerV1 m blk
-> GetVolatileSuffix m blk
-> InitDB
(DbChangelog' blk, ResourceKey m, BackingStore' m blk) m blk
V1.mkInitDb
Complete LedgerDbArgs m blk
args
LedgerDbFlavorArgs Identity m
bss
ResolveBlock m blk
getBlock
SnapshotManager
m
(ReadLocked m)
blk
(StrictTVar m (DbChangelog' blk), BackingStore' m blk)
snapManager
GetVolatileSuffix m blk
getVolatileSuffix
in Complete LedgerDbArgs m blk
-> InitDB
(DbChangelog' blk, ResourceKey m,
BackingStore
m
(LedgerTables (ExtLedgerState blk) KeysMK)
(TxIn (LedgerState blk))
(LedgerTables (ExtLedgerState blk) ValuesMK)
(LedgerTables (ExtLedgerState blk) DiffMK))
m
blk
-> SnapshotManager
m
(ReadLocked m)
blk
(StrictTVar m (DbChangelog' blk),
BackingStore
m
(LedgerTables (ExtLedgerState blk) KeysMK)
(TxIn (LedgerState blk))
(LedgerTables (ExtLedgerState blk) ValuesMK)
(LedgerTables (ExtLedgerState blk) DiffMK))
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64)
forall (m :: * -> *) (n :: * -> *) blk db st.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> SnapshotManager m n blk st
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64)
doOpenDB Complete LedgerDbArgs m blk
args InitDB
(DbChangelog' blk, ResourceKey m,
BackingStore
m
(LedgerTables (ExtLedgerState blk) KeysMK)
(TxIn (LedgerState blk))
(LedgerTables (ExtLedgerState blk) ValuesMK)
(LedgerTables (ExtLedgerState blk) DiffMK))
m
blk
InitDB (DbChangelog' blk, ResourceKey m, BackingStore' m blk) m blk
initDb SnapshotManager
m
(ReadLocked m)
blk
(StrictTVar m (DbChangelog' blk),
BackingStore
m
(LedgerTables (ExtLedgerState blk) KeysMK)
(TxIn (LedgerState blk))
(LedgerTables (ExtLedgerState blk) ValuesMK)
(LedgerTables (ExtLedgerState blk) DiffMK))
SnapshotManager
m
(ReadLocked m)
blk
(StrictTVar m (DbChangelog' blk), BackingStore' m blk)
snapManager StreamAPI m blk blk
stream Point blk
replayGoal
LedgerDbFlavorArgsV2 LedgerDbFlavorArgs Identity m
bss -> do
(snapManager, bss') <- case LedgerDbFlavorArgs Identity m
bss of
V2.V2Args HandleArgs Identity m
V2.InMemoryHandleArgs -> (SnapshotManager m m blk (StateRef m (ExtLedgerState blk)),
HandleEnv m)
-> m (SnapshotManager m m blk (StateRef m (ExtLedgerState blk)),
HandleEnv m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Complete LedgerDbArgs m blk
-> SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
LedgerSupportsProtocol blk) =>
Complete LedgerDbArgs m blk
-> SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
InMemory.snapshotManager Complete LedgerDbArgs m blk
args, HandleEnv m
forall {k} (m :: k). HandleEnv m
V2.InMemoryHandleEnv)
V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs Void
x)) -> Void
-> m (SnapshotManager m m blk (StateRef m (ExtLedgerState blk)),
HandleEnv m)
forall a. Void -> a
absurd Void
x
let initDb =
Complete LedgerDbArgs m blk
-> HandleEnv m
-> ResolveBlock m blk
-> SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
-> GetVolatileSuffix m blk
-> InitDB (LedgerSeq' m blk) m blk
forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, IOLike m,
LedgerDbSerialiseConstraints blk, HasHardForkHistory blk,
LedgerSupportsV2LedgerDB (LedgerState blk)) =>
Complete LedgerDbArgs m blk
-> HandleEnv m
-> ResolveBlock m blk
-> SnapshotManagerV2 m blk
-> GetVolatileSuffix m blk
-> InitDB (LedgerSeq' m blk) m blk
V2.mkInitDb
Complete LedgerDbArgs m blk
args
HandleEnv m
bss'
ResolveBlock m blk
getBlock
SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
snapManager
GetVolatileSuffix m blk
getVolatileSuffix
doOpenDB args initDb snapManager stream replayGoal
doOpenDB ::
forall m n blk db st.
( IOLike m
, LedgerSupportsProtocol blk
, InspectLedger blk
, HasCallStack
) =>
Complete LedgerDbArgs m blk ->
InitDB db m blk ->
SnapshotManager m n blk st ->
StreamAPI m blk blk ->
Point blk ->
m (LedgerDB' m blk, Word64)
doOpenDB :: forall (m :: * -> *) (n :: * -> *) blk db st.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> SnapshotManager m n blk st
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64)
doOpenDB Complete LedgerDbArgs m blk
args InitDB db m blk
initDb SnapshotManager m n blk st
snapManager StreamAPI m blk blk
stream Point blk
replayGoal =
(LedgerDB' m blk, Word64, TestInternals' m blk)
-> (LedgerDB' m blk, Word64)
forall {a} {b} {c}. (a, b, c) -> (a, b)
f ((LedgerDB' m blk, Word64, TestInternals' m blk)
-> (LedgerDB' m blk, Word64))
-> m (LedgerDB' m blk, Word64, TestInternals' m blk)
-> m (LedgerDB' m blk, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Complete LedgerDbArgs m blk
-> InitDB db m blk
-> SnapshotManager m n blk st
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64, TestInternals' m blk)
forall (m :: * -> *) blk db (n :: * -> *) st.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> SnapshotManager m n blk st
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64, TestInternals' m blk)
openDBInternal Complete LedgerDbArgs m blk
args InitDB db m blk
initDb SnapshotManager m n blk st
snapManager StreamAPI m blk blk
stream Point blk
replayGoal
where
f :: (a, b, c) -> (a, b)
f (a
ldb, b
replayCounter, c
_) = (a
ldb, b
replayCounter)
openDBInternal ::
( IOLike m
, LedgerSupportsProtocol blk
, InspectLedger blk
, HasCallStack
) =>
Complete LedgerDbArgs m blk ->
InitDB db m blk ->
SnapshotManager m n blk st ->
StreamAPI m blk blk ->
Point blk ->
m (LedgerDB' m blk, Word64, TestInternals' m blk)
openDBInternal :: forall (m :: * -> *) blk db (n :: * -> *) st.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> SnapshotManager m n blk st
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64, TestInternals' m blk)
openDBInternal args :: Complete LedgerDbArgs m blk
args@(LedgerDbArgs{lgrHasFS :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (SomeHasFS m)
lgrHasFS = SomeHasFS HasFS m h
fs}) InitDB db m blk
initDb SnapshotManager m n blk st
snapManager StreamAPI m blk blk
stream Point blk
replayGoal = do
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectoryIfMissing HasFS m h
fs Bool
True ([String] -> FsPath
mkFsPath [])
(_initLog, db, replayCounter) <-
Tracer m (TraceReplayEvent blk)
-> Tracer m (TraceSnapshotEvent blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk blk
-> Point blk
-> InitDB db m blk
-> SnapshotManager m n blk st
-> Maybe DiskSnapshot
-> m (InitLog blk, db, Word64)
forall (m :: * -> *) (n :: * -> *) blk db st.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
HasCallStack) =>
Tracer m (TraceReplayEvent blk)
-> Tracer m (TraceSnapshotEvent blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk blk
-> Point blk
-> InitDB db m blk
-> SnapshotManager m n blk st
-> Maybe DiskSnapshot
-> m (InitLog blk, db, Word64)
initialize
Tracer m (TraceReplayEvent blk)
replayTracer
Tracer m (TraceSnapshotEvent blk)
snapTracer
LedgerDbCfg (ExtLedgerState blk)
lgrConfig
StreamAPI m blk blk
stream
Point blk
replayGoal
InitDB db m blk
initDb
SnapshotManager m n blk st
snapManager
Maybe DiskSnapshot
lgrStartSnapshot
(ledgerDb, internal) <- mkLedgerDb initDb db
return (ledgerDb, replayCounter, internal)
where
LedgerDbArgs
{ LedgerDbCfg (ExtLedgerState blk)
lgrConfig :: LedgerDbCfg (ExtLedgerState blk)
lgrConfig :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbCfgF f (ExtLedgerState blk)
lgrConfig
, Tracer m (TraceEvent blk)
lgrTracer :: Tracer m (TraceEvent blk)
lgrTracer :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
lgrTracer
, Maybe DiskSnapshot
lgrStartSnapshot :: Maybe DiskSnapshot
lgrStartSnapshot :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Maybe DiskSnapshot
lgrStartSnapshot
} = Complete LedgerDbArgs m blk
args
replayTracer :: Tracer m (TraceReplayEvent blk)
replayTracer = TraceReplayEvent blk -> TraceEvent blk
forall blk. TraceReplayEvent blk -> TraceEvent blk
LedgerReplayEvent (TraceReplayEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceReplayEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m (TraceEvent blk)
lgrTracer
snapTracer :: Tracer m (TraceSnapshotEvent blk)
snapTracer = TraceSnapshotEvent blk -> TraceEvent blk
forall blk. TraceSnapshotEvent blk -> TraceEvent blk
LedgerDBSnapshotEvent (TraceSnapshotEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceSnapshotEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m (TraceEvent blk)
lgrTracer