{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

-- | 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
  , SomeBackendTrace (..)
  , SomeBackendArgs (..)
  , Backend (..)
  ) where

import Cardano.Slotting.Slot
import Control.Tracer
import Data.Proxy
import Ouroboros.Consensus.Ledger.Basics
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API
import System.FS.API

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

-- | Overwrite the 'BackingStore' tables with the snapshot's tables
restoreBackingStore ::
  Tracer m SomeBackendTrace ->
  SomeBackendArgs m l ->
  SnapshotsFS m ->
  l EmptyMK ->
  FsPath ->
  m (LedgerBackingStore m l)
restoreBackingStore :: forall (m :: * -> *) (l :: LedgerStateKind).
Tracer m SomeBackendTrace
-> SomeBackendArgs m l
-> SnapshotsFS m
-> l EmptyMK
-> FsPath
-> m (LedgerBackingStore m l)
restoreBackingStore Tracer m SomeBackendTrace
trcr (SomeBackendArgs Args m backend
bArgs) SnapshotsFS m
fs l EmptyMK
st FsPath
loadPath =
  Tracer m SomeBackendTrace
-> Args m backend -> SnapshotsFS m -> BackingStoreInitialiser m l
forall (m :: * -> *) backend (l :: LedgerStateKind).
Backend m backend l =>
Tracer m SomeBackendTrace
-> Args m backend -> SnapshotsFS m -> BackingStoreInitialiser m l
newBackingStoreInitialiser Tracer m SomeBackendTrace
trcr Args m backend
bArgs 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 ::
  Tracer m SomeBackendTrace ->
  SomeBackendArgs m l ->
  SnapshotsFS m ->
  l EmptyMK ->
  LedgerTables l ValuesMK ->
  m (LedgerBackingStore m l)
newBackingStore :: forall (m :: * -> *) (l :: LedgerStateKind).
Tracer m SomeBackendTrace
-> SomeBackendArgs m l
-> SnapshotsFS m
-> l EmptyMK
-> LedgerTables l ValuesMK
-> m (LedgerBackingStore m l)
newBackingStore Tracer m SomeBackendTrace
trcr (SomeBackendArgs Args m backend
bArgs) SnapshotsFS m
fs l EmptyMK
st LedgerTables l ValuesMK
tables =
  Tracer m SomeBackendTrace
-> Args m backend -> SnapshotsFS m -> BackingStoreInitialiser m l
forall (m :: * -> *) backend (l :: LedgerStateKind).
Backend m backend l =>
Tracer m SomeBackendTrace
-> Args m backend -> SnapshotsFS m -> BackingStoreInitialiser m l
newBackingStoreInitialiser Tracer m SomeBackendTrace
trcr Args m backend
bArgs 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)

data SomeBackendArgs m l where
  SomeBackendArgs :: Backend m backend l => Args m backend -> SomeBackendArgs m l

data SomeBackendTrace where
  SomeBackendTrace :: Show (Trace m backend) => Trace m backend -> SomeBackendTrace

instance Show SomeBackendTrace where
  show :: SomeBackendTrace -> String
show (SomeBackendTrace Trace m backend
tr) = Trace m backend -> String
forall a. Show a => a -> String
show Trace m backend
tr

class Backend m backend l where
  data Args m backend

  data Trace m backend

  isRightBackendForSnapshot ::
    Proxy l ->
    Args m backend ->
    SnapshotBackend ->
    Bool

  newBackingStoreInitialiser ::
    Tracer m SomeBackendTrace ->
    Args m backend ->
    SnapshotsFS m ->
    BackingStoreInitialiser m l