{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

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.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.TraceEvent
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as V2
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
  , LedgerDbSerialiseConstraints blk
  , InspectLedger blk
  , HasCallStack
  , HasHardForkHistory blk
  , LedgerSupportsLedgerDB blk
  )
  => Complete LedgerDbArgs m blk
  -- ^ Stateless initializaton arguments
  -> StreamAPI m blk 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.
  -> Point blk
  -- ^ The Replay goal i.e. the tip of the stream of blocks.
  -> ResolveBlock m blk
  -- ^ How to get blocks from the ChainDB
  -> m (LedgerDB' m blk, Word64)
openDB :: forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 LedgerDbSerialiseConstraints blk, InspectLedger blk, HasCallStack,
 HasHardForkHistory blk, LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> StreamAPI m blk blk
-> Point blk
-> ResolveBlock 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 = 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 initDb :: InitDB (DbChangelog' blk, BackingStore' m blk) m blk
initDb = Complete LedgerDbArgs m blk
-> LedgerDbFlavorArgs Identity m
-> ResolveBlock m blk
-> InitDB (DbChangelog' blk, BackingStore' m blk) m blk
forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, IOLike m,
 LedgerDbSerialiseConstraints blk, HasHardForkHistory blk,
 LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> Complete LedgerDbFlavorArgs m
-> ResolveBlock m blk
-> InitDB (DbChangelog' blk, BackingStore' m blk) m blk
V1.mkInitDb
                       Complete LedgerDbArgs m blk
args
                       LedgerDbFlavorArgs Identity m
bss
                       ResolveBlock m blk
getBlock
        in
          Complete LedgerDbArgs m blk
-> InitDB (DbChangelog' blk, BackingStore' m blk) m blk
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64)
forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64)
doOpenDB Complete LedgerDbArgs m blk
args InitDB (DbChangelog' blk, BackingStore' m blk) m blk
initDb StreamAPI m blk blk
stream Point blk
replayGoal
    LedgerDbFlavorArgsV2 LedgerDbFlavorArgs Identity m
bss ->
        let initDb :: InitDB (LedgerSeq' m blk) m blk
initDb = Complete LedgerDbArgs m blk
-> LedgerDbFlavorArgs Identity m
-> ResolveBlock m blk
-> InitDB (LedgerSeq' m blk) m blk
forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, IOLike m,
 LedgerDbSerialiseConstraints blk, HasHardForkHistory blk,
 LedgerSupportsInMemoryLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> Complete LedgerDbFlavorArgs m
-> ResolveBlock m blk
-> InitDB (LedgerSeq' m blk) m blk
V2.mkInitDb
                       Complete LedgerDbArgs m blk
args
                       LedgerDbFlavorArgs Identity m
bss
                       ResolveBlock m blk
getBlock
        in
          Complete LedgerDbArgs m blk
-> InitDB (LedgerSeq' m blk) m blk
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64)
forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64)
doOpenDB Complete LedgerDbArgs m blk
args InitDB (LedgerSeq' m blk) m blk
initDb StreamAPI m blk blk
stream Point blk
replayGoal


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

doOpenDB ::
  forall m blk db. ( IOLike m
  , LedgerSupportsProtocol blk
  , InspectLedger blk
  , HasCallStack
  )
  => Complete LedgerDbArgs m blk
  -> InitDB db m blk
  -> StreamAPI m blk blk
  -> Point blk
  -> m (LedgerDB' m blk, Word64)
doOpenDB :: forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64)
doOpenDB Complete LedgerDbArgs m blk
args InitDB db m blk
initDb 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
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64, TestInternals' m blk)
forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> 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 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
  -> StreamAPI m blk blk
  -> Point blk
  -> m (LedgerDB' m blk, Word64, TestInternals' m blk)
openDBInternal :: forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> 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 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)
-> SomeHasFS m
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk blk
-> Point blk
-> InitDB db m blk
-> Maybe DiskSnapshot
-> m (InitLog blk, db, Word64)
forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Tracer m (TraceReplayEvent blk)
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk blk
-> Point blk
-> InitDB db m blk
-> Maybe DiskSnapshot
-> m (InitLog blk, db, Word64)
initialize
            Tracer m (TraceReplayEvent blk)
replayTracer
            Tracer m (TraceSnapshotEvent blk)
snapTracer
            SomeHasFS m
HKD Identity (SomeHasFS m)
lgrHasFS
            LedgerDbCfg (ExtLedgerState blk)
lgrConfig
            StreamAPI m blk blk
stream
            Point blk
replayGoal
            InitDB db m blk
initDb
            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
      , HKD Identity (SomeHasFS m)
lgrHasFS :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (SomeHasFS m)
lgrHasFS :: HKD Identity (SomeHasFS m)
lgrHasFS
      , 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