{-# LANGUAGE BangPatterns #-}
{-# 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 Control.Monad.Trans.Class
import Control.ResourceRegistry
import Data.Functor.Contravariant ((>$<))
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.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

-- | Open the LedgerDB database
--
-- It's crucial that this is scoped within the same 'runWithTempRegistry' call
-- that includes the allocation of the ChainDB itself into the top-level
-- resource registry. That's why the whole 'openDB' function is in
-- WithTempRegistry even though there's just the one part of it that actually
-- puts stuff in that registry.
openDB ::
  forall m blk st.
  ( IOLike m
  , LedgerSupportsProtocol blk
  , InspectLedger blk
  , HasCallStack
  , HasHardForkHistory 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 ->
  WithTempRegistry st m (LedgerDB' m blk)
openDB :: forall (m :: * -> *) blk st.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack, HasHardForkHistory blk) =>
Complete LedgerDbArgs m blk
-> StreamAPI m blk blk
-> Point blk
-> ResolveBlock m blk
-> GetVolatileSuffix m blk
-> WithTempRegistry st m (LedgerDB' m blk)
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
      LedgerDbBackendArgsV2 (SomeBackendArgs Args m backend
bArgs) -> do
        -- Note this is the only step that cares about the temporary
        -- registry. Note also that the final state is an polymorphic and
        -- unconstrained 'st' so it is clear that this function will allocate
        -- resources with 'impossibleToNotTransfer'.
        res <-
          Proxy blk
-> Tracer m LedgerDBV2Trace
-> Args m backend
-> SomeHasFS m
-> WithTempRegistry st m (Resources m backend)
forall fState.
Proxy blk
-> Tracer m LedgerDBV2Trace
-> Args m backend
-> SomeHasFS m
-> WithTempRegistry fState m (Resources m backend)
forall (m :: * -> *) backend blk fState.
Backend m backend blk =>
Proxy blk
-> Tracer m LedgerDBV2Trace
-> Args m backend
-> SomeHasFS m
-> WithTempRegistry fState 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 (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 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 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 :: StateKind) blk.
LedgerDbCfgF f l blk -> HKD f (LedgerCfg l blk)
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)
                Tracer m (TraceSnapshotEvent blk)
snapTracer
                (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 blk (StateRef m ExtLedgerState blk)
-> GetVolatileSuffix m blk
-> Resources m backend
-> InitDB (LedgerSeq' m blk) m blk
forall (m :: * -> *) blk backend.
(LedgerSupportsProtocol 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 blk (StateRef m ExtLedgerState blk)
snapManager GetVolatileSuffix m blk
getVolatileSuffix Resources m backend
res
        lift $ doOpenDB args initDb snapManager stream replayGoal
       where
        !tr :: Tracer m (TraceEvent blk)
tr = 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
        !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)
tr

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

doOpenDB ::
  forall m blk db st.
  ( IOLike m
  , LedgerSupportsProtocol blk
  , InspectLedger blk
  , HasCallStack
  ) =>
  Complete LedgerDbArgs m blk ->
  InitDB db m blk ->
  SnapshotManager m blk st ->
  StreamAPI m blk blk ->
  Point blk ->
  m (LedgerDB' m blk)
doOpenDB :: forall (m :: * -> *) blk db st.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> SnapshotManager m blk st
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk)
doOpenDB Complete LedgerDbArgs m blk
args InitDB db m blk
initDb SnapshotManager m blk st
snapManager StreamAPI m blk blk
stream Point blk
replayGoal =
  (LedgerDB' m blk, TestInternals' m blk) -> LedgerDB' m blk
forall a b. (a, b) -> a
fst ((LedgerDB' m blk, TestInternals' m blk) -> LedgerDB' m blk)
-> m (LedgerDB' m blk, TestInternals' m blk) -> m (LedgerDB' m blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Complete LedgerDbArgs m blk
-> InitDB db m blk
-> SnapshotManager m blk st
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, TestInternals' m blk)
forall (m :: * -> *) blk db st.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> SnapshotManager m blk st
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, TestInternals' m blk)
openDBInternal Complete LedgerDbArgs m blk
args InitDB db m blk
initDb SnapshotManager m blk st
snapManager StreamAPI m blk blk
stream Point blk
replayGoal

-- | 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 blk st ->
  StreamAPI m blk blk ->
  Point blk ->
  m (LedgerDB' m blk, TestInternals' m blk)
openDBInternal :: forall (m :: * -> *) blk db st.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> SnapshotManager m blk st
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, 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 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) <-
    Tracer m (TraceReplayEvent blk)
-> Tracer m (TraceSnapshotEvent blk)
-> LedgerDbCfg ExtLedgerState blk
-> StreamAPI m blk blk
-> Point blk
-> InitDB db m blk
-> SnapshotManager m blk st
-> Maybe DiskSnapshot
-> m (InitLog blk, db)
forall (m :: * -> *) 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 blk st
-> Maybe DiskSnapshot
-> m (InitLog blk, db)
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 blk st
snapManager
      Maybe DiskSnapshot
lgrStartSnapshot
  (ledgerDb, internal) <- mkLedgerDb initDb db
  return (ledgerDb, 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