{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- | See "Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API" for the
-- documentation. This module just puts together the implementations for the
-- API, currently two:
--
-- * "Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory": a
--   @TVar@ holding a "Data.Map".
--
-- * "Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB": an
--   external disk-based database.
module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore (
    -- * API
    --
    -- | Most of the documentation on the behaviour of the 'BackingStore' lives
    -- in this module.
    module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API
    -- * Initialization
  , newBackingStore
  , restoreBackingStore
    -- * Tracing
  , FlavorImplSpecificTrace (..)
  , FlavorImplSpecificTraceInMemory (..)
  , FlavorImplSpecificTraceOnDisk (..)
    -- * Testing
  , newBackingStoreInitialiser
  ) where

import           Cardano.Slotting.Slot
import           Control.Tracer
import           Data.Functor.Contravariant
import           Data.SOP.Dict (Dict (..))
import           GHC.Stack (HasCallStack)
import           Ouroboros.Consensus.Ledger.Basics
import           Ouroboros.Consensus.Storage.LedgerDB.API
import           Ouroboros.Consensus.Storage.LedgerDB.V1.Args
import           Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory as InMemory
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB
import           Ouroboros.Consensus.Util.Args
import           Ouroboros.Consensus.Util.IOLike
import           System.FS.API
import           System.FS.IO

type BackingStoreInitialiser m l =
     InitFrom (LedgerTables l ValuesMK)
  -> m (LedgerBackingStore m l)

-- | Overwrite the 'BackingStore' tables with the snapshot's tables
restoreBackingStore ::
     ( IOLike m
     , HasLedgerTables l
     , HasCallStack
     , CanUpgradeLedgerTables l
     , MemPackIdx l EmptyMK ~ l EmptyMK
     , SerializeTablesWithHint l
     )
  => Tracer m FlavorImplSpecificTrace
  -> Complete BackingStoreArgs m
  -> SnapshotsFS m
  -> l EmptyMK
  -> FsPath
  -> m (LedgerBackingStore m l)
restoreBackingStore :: forall (m :: * -> *) (l :: LedgerStateKind).
(IOLike m, HasLedgerTables l, HasCallStack,
 CanUpgradeLedgerTables l, MemPackIdx l EmptyMK ~ l EmptyMK,
 SerializeTablesWithHint l) =>
Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> l EmptyMK
-> FsPath
-> m (LedgerBackingStore m l)
restoreBackingStore Tracer m FlavorImplSpecificTrace
trcr Complete BackingStoreArgs m
bss SnapshotsFS m
fs l EmptyMK
st FsPath
loadPath =
    Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> BackingStoreInitialiser m l
forall (m :: * -> *) (l :: LedgerStateKind).
(IOLike m, HasLedgerTables l, HasCallStack,
 CanUpgradeLedgerTables l, MemPackIdx l EmptyMK ~ l EmptyMK,
 SerializeTablesWithHint l) =>
Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> BackingStoreInitialiser m l
newBackingStoreInitialiser Tracer m FlavorImplSpecificTrace
trcr Complete BackingStoreArgs m
bss SnapshotsFS m
fs (InitHint (LedgerTables l ValuesMK)
-> FsPath -> InitFrom (LedgerTables l ValuesMK)
forall values. InitHint values -> FsPath -> InitFrom values
InitFromCopy l EmptyMK
InitHint (LedgerTables l ValuesMK)
st FsPath
loadPath)

-- | Create a 'BackingStore' from the given initial tables.
newBackingStore ::
     ( IOLike m
     , HasLedgerTables l
     , HasCallStack
     , CanUpgradeLedgerTables l
     , MemPackIdx l EmptyMK ~ l EmptyMK
     , SerializeTablesWithHint l
     )
  => Tracer m FlavorImplSpecificTrace
  -> Complete BackingStoreArgs m
  -> SnapshotsFS m
  -> l EmptyMK
  -> LedgerTables l ValuesMK
  -> m (LedgerBackingStore m l)
newBackingStore :: forall (m :: * -> *) (l :: LedgerStateKind).
(IOLike m, HasLedgerTables l, HasCallStack,
 CanUpgradeLedgerTables l, MemPackIdx l EmptyMK ~ l EmptyMK,
 SerializeTablesWithHint l) =>
Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> l EmptyMK
-> LedgerTables l ValuesMK
-> m (LedgerBackingStore m l)
newBackingStore Tracer m FlavorImplSpecificTrace
trcr Complete BackingStoreArgs m
bss SnapshotsFS m
fs l EmptyMK
st LedgerTables l ValuesMK
tables =
    Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> BackingStoreInitialiser m l
forall (m :: * -> *) (l :: LedgerStateKind).
(IOLike m, HasLedgerTables l, HasCallStack,
 CanUpgradeLedgerTables l, MemPackIdx l EmptyMK ~ l EmptyMK,
 SerializeTablesWithHint l) =>
Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> BackingStoreInitialiser m l
newBackingStoreInitialiser Tracer m FlavorImplSpecificTrace
trcr Complete BackingStoreArgs m
bss SnapshotsFS m
fs (WithOrigin SlotNo
-> InitHint (LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK
-> InitFrom (LedgerTables l ValuesMK)
forall values.
WithOrigin SlotNo -> InitHint values -> values -> InitFrom values
InitFromValues WithOrigin SlotNo
forall t. WithOrigin t
Origin l EmptyMK
InitHint (LedgerTables l ValuesMK)
st LedgerTables l ValuesMK
tables)

newBackingStoreInitialiser ::
     forall m l.
     ( IOLike m
     , HasLedgerTables l
     , HasCallStack
     , CanUpgradeLedgerTables l
     , MemPackIdx l EmptyMK ~ l EmptyMK
     , SerializeTablesWithHint l
     )
  => Tracer m FlavorImplSpecificTrace
  -> Complete BackingStoreArgs m
  -> SnapshotsFS m
  -> BackingStoreInitialiser m l
newBackingStoreInitialiser :: forall (m :: * -> *) (l :: LedgerStateKind).
(IOLike m, HasLedgerTables l, HasCallStack,
 CanUpgradeLedgerTables l, MemPackIdx l EmptyMK ~ l EmptyMK,
 SerializeTablesWithHint l) =>
Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> BackingStoreInitialiser m l
newBackingStoreInitialiser Tracer m FlavorImplSpecificTrace
trcr Complete BackingStoreArgs m
bss =
  case Complete BackingStoreArgs m
bss of
    LMDBBackingStoreArgs FilePath
fs HKD Identity LMDBLimits
limits Dict MonadIOPrim m
Dict ->
      Tracer m BackingStoreTrace
-> LMDBLimits
-> LiveLMDBFS m
-> SnapshotsFS m
-> BackingStoreInitialiser m l
forall (m :: * -> *) (l :: LedgerStateKind).
(HasCallStack, HasLedgerTables l, MonadIO m, IOLike m,
 MemPackIdx l EmptyMK ~ l EmptyMK) =>
Tracer m BackingStoreTrace
-> LMDBLimits
-> LiveLMDBFS m
-> SnapshotsFS m
-> InitFrom (LedgerTables l ValuesMK)
-> m (LedgerBackingStore m l)
LMDB.newLMDBBackingStore
        (FlavorImplSpecificTraceOnDisk -> FlavorImplSpecificTrace
FlavorImplSpecificTraceOnDisk (FlavorImplSpecificTraceOnDisk -> FlavorImplSpecificTrace)
-> (BackingStoreTrace -> FlavorImplSpecificTraceOnDisk)
-> BackingStoreTrace
-> FlavorImplSpecificTrace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BackingStoreTrace -> FlavorImplSpecificTraceOnDisk
OnDiskBackingStoreTrace (BackingStoreTrace -> FlavorImplSpecificTrace)
-> Tracer m FlavorImplSpecificTrace -> Tracer m BackingStoreTrace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m FlavorImplSpecificTrace
trcr)
        HKD Identity LMDBLimits
LMDBLimits
limits
        (SomeHasFS m -> LiveLMDBFS m
forall (m :: * -> *). SomeHasFS m -> LiveLMDBFS m
LiveLMDBFS (SomeHasFS m -> LiveLMDBFS m) -> SomeHasFS m -> LiveLMDBFS m
forall a b. (a -> b) -> a -> b
$ HasFS m HandleIO -> SomeHasFS m
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS m HandleIO -> SomeHasFS m)
-> HasFS m HandleIO -> SomeHasFS m
forall a b. (a -> b) -> a -> b
$ MountPoint -> HasFS m HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS (MountPoint -> HasFS m HandleIO) -> MountPoint -> HasFS m HandleIO
forall a b. (a -> b) -> a -> b
$ FilePath -> MountPoint
MountPoint FilePath
fs)
    Complete BackingStoreArgs m
InMemoryBackingStoreArgs ->
      Tracer m BackingStoreTrace
-> SnapshotsFS m -> BackingStoreInitialiser m l
forall (l :: LedgerStateKind) (m :: * -> *).
(IOLike m, HasLedgerTables l, CanUpgradeLedgerTables l,
 SerializeTablesWithHint l) =>
Tracer m BackingStoreTrace
-> SnapshotsFS m
-> InitFrom (LedgerTables l ValuesMK)
-> m (LedgerBackingStore m l)
InMemory.newInMemoryBackingStore
        (FlavorImplSpecificTraceInMemory -> FlavorImplSpecificTrace
FlavorImplSpecificTraceInMemory (FlavorImplSpecificTraceInMemory -> FlavorImplSpecificTrace)
-> (BackingStoreTrace -> FlavorImplSpecificTraceInMemory)
-> BackingStoreTrace
-> FlavorImplSpecificTrace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BackingStoreTrace -> FlavorImplSpecificTraceInMemory
InMemoryBackingStoreTrace (BackingStoreTrace -> FlavorImplSpecificTrace)
-> Tracer m FlavorImplSpecificTrace -> Tracer m BackingStoreTrace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m FlavorImplSpecificTrace
trcr)

{-------------------------------------------------------------------------------
  Tracing
-------------------------------------------------------------------------------}

data FlavorImplSpecificTrace =
    FlavorImplSpecificTraceInMemory FlavorImplSpecificTraceInMemory
  | FlavorImplSpecificTraceOnDisk FlavorImplSpecificTraceOnDisk
  deriving (FlavorImplSpecificTrace -> FlavorImplSpecificTrace -> Bool
(FlavorImplSpecificTrace -> FlavorImplSpecificTrace -> Bool)
-> (FlavorImplSpecificTrace -> FlavorImplSpecificTrace -> Bool)
-> Eq FlavorImplSpecificTrace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FlavorImplSpecificTrace -> FlavorImplSpecificTrace -> Bool
== :: FlavorImplSpecificTrace -> FlavorImplSpecificTrace -> Bool
$c/= :: FlavorImplSpecificTrace -> FlavorImplSpecificTrace -> Bool
/= :: FlavorImplSpecificTrace -> FlavorImplSpecificTrace -> Bool
Eq, Int -> FlavorImplSpecificTrace -> ShowS
[FlavorImplSpecificTrace] -> ShowS
FlavorImplSpecificTrace -> FilePath
(Int -> FlavorImplSpecificTrace -> ShowS)
-> (FlavorImplSpecificTrace -> FilePath)
-> ([FlavorImplSpecificTrace] -> ShowS)
-> Show FlavorImplSpecificTrace
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FlavorImplSpecificTrace -> ShowS
showsPrec :: Int -> FlavorImplSpecificTrace -> ShowS
$cshow :: FlavorImplSpecificTrace -> FilePath
show :: FlavorImplSpecificTrace -> FilePath
$cshowList :: [FlavorImplSpecificTrace] -> ShowS
showList :: [FlavorImplSpecificTrace] -> ShowS
Show)

data FlavorImplSpecificTraceInMemory  =
    InMemoryBackingStoreInitialise
  | InMemoryBackingStoreTrace BackingStoreTrace
  deriving (FlavorImplSpecificTraceInMemory
-> FlavorImplSpecificTraceInMemory -> Bool
(FlavorImplSpecificTraceInMemory
 -> FlavorImplSpecificTraceInMemory -> Bool)
-> (FlavorImplSpecificTraceInMemory
    -> FlavorImplSpecificTraceInMemory -> Bool)
-> Eq FlavorImplSpecificTraceInMemory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FlavorImplSpecificTraceInMemory
-> FlavorImplSpecificTraceInMemory -> Bool
== :: FlavorImplSpecificTraceInMemory
-> FlavorImplSpecificTraceInMemory -> Bool
$c/= :: FlavorImplSpecificTraceInMemory
-> FlavorImplSpecificTraceInMemory -> Bool
/= :: FlavorImplSpecificTraceInMemory
-> FlavorImplSpecificTraceInMemory -> Bool
Eq, Int -> FlavorImplSpecificTraceInMemory -> ShowS
[FlavorImplSpecificTraceInMemory] -> ShowS
FlavorImplSpecificTraceInMemory -> FilePath
(Int -> FlavorImplSpecificTraceInMemory -> ShowS)
-> (FlavorImplSpecificTraceInMemory -> FilePath)
-> ([FlavorImplSpecificTraceInMemory] -> ShowS)
-> Show FlavorImplSpecificTraceInMemory
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FlavorImplSpecificTraceInMemory -> ShowS
showsPrec :: Int -> FlavorImplSpecificTraceInMemory -> ShowS
$cshow :: FlavorImplSpecificTraceInMemory -> FilePath
show :: FlavorImplSpecificTraceInMemory -> FilePath
$cshowList :: [FlavorImplSpecificTraceInMemory] -> ShowS
showList :: [FlavorImplSpecificTraceInMemory] -> ShowS
Show)

data FlavorImplSpecificTraceOnDisk =
    OnDiskBackingStoreInitialise LMDB.LMDBLimits
  | OnDiskBackingStoreTrace BackingStoreTrace
  deriving (FlavorImplSpecificTraceOnDisk
-> FlavorImplSpecificTraceOnDisk -> Bool
(FlavorImplSpecificTraceOnDisk
 -> FlavorImplSpecificTraceOnDisk -> Bool)
-> (FlavorImplSpecificTraceOnDisk
    -> FlavorImplSpecificTraceOnDisk -> Bool)
-> Eq FlavorImplSpecificTraceOnDisk
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FlavorImplSpecificTraceOnDisk
-> FlavorImplSpecificTraceOnDisk -> Bool
== :: FlavorImplSpecificTraceOnDisk
-> FlavorImplSpecificTraceOnDisk -> Bool
$c/= :: FlavorImplSpecificTraceOnDisk
-> FlavorImplSpecificTraceOnDisk -> Bool
/= :: FlavorImplSpecificTraceOnDisk
-> FlavorImplSpecificTraceOnDisk -> Bool
Eq, Int -> FlavorImplSpecificTraceOnDisk -> ShowS
[FlavorImplSpecificTraceOnDisk] -> ShowS
FlavorImplSpecificTraceOnDisk -> FilePath
(Int -> FlavorImplSpecificTraceOnDisk -> ShowS)
-> (FlavorImplSpecificTraceOnDisk -> FilePath)
-> ([FlavorImplSpecificTraceOnDisk] -> ShowS)
-> Show FlavorImplSpecificTraceOnDisk
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FlavorImplSpecificTraceOnDisk -> ShowS
showsPrec :: Int -> FlavorImplSpecificTraceOnDisk -> ShowS
$cshow :: FlavorImplSpecificTraceOnDisk -> FilePath
show :: FlavorImplSpecificTraceOnDisk -> FilePath
$cshowList :: [FlavorImplSpecificTraceOnDisk] -> ShowS
showList :: [FlavorImplSpecificTraceOnDisk] -> ShowS
Show)