{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Ouroboros.Consensus.Storage.LedgerDB
  ( -- * API
    module Ouroboros.Consensus.Storage.LedgerDB.API
  , module Ouroboros.Consensus.Storage.LedgerDB.Args
  , module Ouroboros.Consensus.Storage.LedgerDB.Forker
  , module Ouroboros.Consensus.Storage.LedgerDB.TraceEvent

    -- * Impl
  , openDB
  , openDBInternal
  ) where

import Data.Functor.Contravariant ((>$<))
import Data.Word
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Abstract
import Ouroboros.Consensus.Ledger.Extended
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 Ouroboros.Consensus.Storage.LedgerDB.V2.Backend
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
  ) =>
  -- | Stateless initializaton arguments
  Complete LedgerDbArgs m blk ->
  -- | Stream source for blocks.
  --
  -- After reading a snapshot from disk, the ledger DB will be brought up to
  -- date with the tip of this steam of blocks. The corresponding ledger state
  -- can then be used as the starting point for chain selection in the ChainDB
  -- driver.
  StreamAPI m blk blk ->
  -- | The Replay goal i.e. the tip of the stream of blocks.
  Point blk ->
  -- | How to get blocks from the ChainDB
  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 -> LedgerDbBackendArgs m blk
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbBackendArgs m blk
lgrBackendArgs Complete LedgerDbArgs m blk
args of
      LedgerDbBackendArgsV1 LedgerDbBackendArgs m (ExtLedgerState blk)
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
-> LedgerDbBackendArgs m (ExtLedgerState blk)
-> 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
-> LedgerDbBackendArgs m (ExtLedgerState blk)
-> 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
                LedgerDbBackendArgs m (ExtLedgerState blk)
bss
                ResolveBlock m blk
getBlock
                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
                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 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))
snapManager StreamAPI m blk blk
stream Point blk
replayGoal
      LedgerDbBackendArgsV2 (SomeBackendArgs Args m backend
bArgs) -> do
        res <-
          Proxy blk
-> Tracer m LedgerDBV2Trace
-> Args m backend
-> ResourceRegistry m
-> SomeHasFS m
-> m (Resources m backend)
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Proxy blk
-> Tracer m LedgerDBV2Trace
-> Args m backend
-> ResourceRegistry m
-> SomeHasFS m
-> m (Resources m backend)
mkResources
            (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
            (FlavorImplSpecificTrace -> TraceEvent blk
forall blk. FlavorImplSpecificTrace -> TraceEvent blk
LedgerDBFlavorImplEvent (FlavorImplSpecificTrace -> TraceEvent blk)
-> (LedgerDBV2Trace -> FlavorImplSpecificTrace)
-> LedgerDBV2Trace
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBV2Trace -> FlavorImplSpecificTrace
FlavorImplSpecificTraceV2 (LedgerDBV2Trace -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m LedgerDBV2Trace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Complete LedgerDbArgs m blk -> Tracer m (TraceEvent blk)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
lgrTracer Complete LedgerDbArgs m blk
args)
            Args m backend
bArgs
            (Complete LedgerDbArgs m blk -> HKD Identity (ResourceRegistry m)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (ResourceRegistry m)
lgrRegistry Complete LedgerDbArgs m blk
args)
            (Complete LedgerDbArgs m blk -> HKD Identity (SomeHasFS m)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (SomeHasFS m)
lgrHasFS Complete LedgerDbArgs m blk
args)
        let snapManager =
              Proxy blk
-> Resources m backend
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Proxy blk
-> Resources m backend
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
snapshotManager
                (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
                Resources m backend
res
                (TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec (TopLevelConfig blk -> CodecConfig blk)
-> (LedgerDbCfgF Identity (ExtLedgerState blk)
    -> TopLevelConfig blk)
-> LedgerDbCfgF Identity (ExtLedgerState blk)
-> CodecConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg (ExtLedgerCfg blk -> TopLevelConfig blk)
-> (LedgerDbCfgF Identity (ExtLedgerState blk) -> ExtLedgerCfg blk)
-> LedgerDbCfgF Identity (ExtLedgerState blk)
-> TopLevelConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDbCfgF Identity (ExtLedgerState blk)
-> HKD Identity (LedgerCfg (ExtLedgerState blk))
LedgerDbCfgF Identity (ExtLedgerState blk) -> ExtLedgerCfg blk
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (LedgerDbCfgF Identity (ExtLedgerState blk) -> CodecConfig blk)
-> LedgerDbCfgF Identity (ExtLedgerState blk) -> CodecConfig blk
forall a b. (a -> b) -> a -> b
$ Complete LedgerDbArgs m blk
-> LedgerDbCfgF Identity (ExtLedgerState blk)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbCfgF f (ExtLedgerState blk)
lgrConfig Complete LedgerDbArgs m blk
args)
                (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
>$< Complete LedgerDbArgs m blk -> Tracer m (TraceEvent blk)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
lgrTracer Complete LedgerDbArgs m blk
args)
                (Complete LedgerDbArgs m blk -> HKD Identity (SomeHasFS m)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (SomeHasFS m)
lgrHasFS Complete LedgerDbArgs m blk
args)
        let initDb = Complete LedgerDbArgs m blk
-> ResolveBlock m blk
-> SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
-> GetVolatileSuffix m blk
-> Resources m backend
-> InitDB (LedgerSeq' m blk) m blk
forall (m :: * -> *) blk backend.
(LedgerSupportsProtocol blk, LedgerDbSerialiseConstraints blk,
 HasHardForkHistory blk, Backend m backend blk, IOLike m) =>
Complete LedgerDbArgs m blk
-> ResolveBlock m blk
-> SnapshotManagerV2 m blk
-> GetVolatileSuffix m blk
-> Resources m backend
-> InitDB (LedgerSeq' m blk) m blk
V2.mkInitDb Complete LedgerDbArgs m blk
args ResolveBlock m blk
getBlock SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
snapManager GetVolatileSuffix m blk
getVolatileSuffix Resources m backend
res
        doOpenDB args initDb snapManager stream replayGoal

{-------------------------------------------------------------------------------
  Opening a LedgerDB
-------------------------------------------------------------------------------}

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)

-- | Open the ledger DB and expose internals for testing purposes
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 :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbCfgF f (ExtLedgerState blk)
lgrConfig :: LedgerDbCfg (ExtLedgerState blk)
lgrConfig
    , Tracer m (TraceEvent blk)
lgrTracer :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
lgrTracer :: 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