{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Storage.LedgerDB.V1.Args
  ( BackingStoreArgs (..)
  , FlushFrequency (..)
  , LedgerDbFlavorArgs (..)
  , defaultLedgerDbFlavorArgs
  , shouldFlush
  ) where

import Control.Monad.IO.Class
import Control.Monad.Primitive
import qualified Data.SOP.Dict as Dict
import Data.Word
import GHC.Generics
import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB
import Ouroboros.Consensus.Util.Args

-- | The number of blocks in the immutable part of the chain that we have to see
-- before we flush the ledger tables to disk. See 'onDiskShouldFlush'.
data FlushFrequency
  = -- | A default value, which is determined by a specific 'SnapshotPolicy'. See
    -- 'defaultSnapshotPolicy' as an example.
    DefaultFlushFrequency
  | -- | A requested value: the number of diffs in the immutable part of the
    -- chain required before flushing.
    RequestedFlushFrequency Word64
  | -- | To disable flushing, to be used in tests
    DisableFlushing
  deriving (Int -> FlushFrequency -> ShowS
[FlushFrequency] -> ShowS
FlushFrequency -> String
(Int -> FlushFrequency -> ShowS)
-> (FlushFrequency -> String)
-> ([FlushFrequency] -> ShowS)
-> Show FlushFrequency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FlushFrequency -> ShowS
showsPrec :: Int -> FlushFrequency -> ShowS
$cshow :: FlushFrequency -> String
show :: FlushFrequency -> String
$cshowList :: [FlushFrequency] -> ShowS
showList :: [FlushFrequency] -> ShowS
Show, FlushFrequency -> FlushFrequency -> Bool
(FlushFrequency -> FlushFrequency -> Bool)
-> (FlushFrequency -> FlushFrequency -> Bool) -> Eq FlushFrequency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FlushFrequency -> FlushFrequency -> Bool
== :: FlushFrequency -> FlushFrequency -> Bool
$c/= :: FlushFrequency -> FlushFrequency -> Bool
/= :: FlushFrequency -> FlushFrequency -> Bool
Eq, (forall x. FlushFrequency -> Rep FlushFrequency x)
-> (forall x. Rep FlushFrequency x -> FlushFrequency)
-> Generic FlushFrequency
forall x. Rep FlushFrequency x -> FlushFrequency
forall x. FlushFrequency -> Rep FlushFrequency x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FlushFrequency -> Rep FlushFrequency x
from :: forall x. FlushFrequency -> Rep FlushFrequency x
$cto :: forall x. Rep FlushFrequency x -> FlushFrequency
to :: forall x. Rep FlushFrequency x -> FlushFrequency
Generic)

shouldFlush :: FlushFrequency -> (Word64 -> Bool)
shouldFlush :: FlushFrequency -> Word64 -> Bool
shouldFlush FlushFrequency
requestedFlushFrequency = case FlushFrequency
requestedFlushFrequency of
  RequestedFlushFrequency Word64
value -> (Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
value)
  FlushFrequency
DefaultFlushFrequency -> (Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
100)
  FlushFrequency
DisableFlushing -> Bool -> Word64 -> Bool
forall a b. a -> b -> a
const Bool
False

data LedgerDbFlavorArgs f m = V1Args
  { forall (f :: * -> *) (m :: * -> *).
LedgerDbFlavorArgs f m -> FlushFrequency
v1FlushFrequency :: FlushFrequency
  , forall (f :: * -> *) (m :: * -> *).
LedgerDbFlavorArgs f m -> BackingStoreArgs f m
v1BackendArgs :: BackingStoreArgs f m
  }

data BackingStoreArgs f m
  = LMDBBackingStoreArgs FilePath (HKD f LMDBLimits) (Dict.Dict MonadIOPrim m)
  | InMemoryBackingStoreArgs

class (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m
instance (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m

defaultLedgerDbFlavorArgs :: Incomplete LedgerDbFlavorArgs m
defaultLedgerDbFlavorArgs :: forall (m :: * -> *). Incomplete LedgerDbFlavorArgs m
defaultLedgerDbFlavorArgs = FlushFrequency
-> BackingStoreArgs Defaults m -> LedgerDbFlavorArgs Defaults m
forall (f :: * -> *) (m :: * -> *).
FlushFrequency -> BackingStoreArgs f m -> LedgerDbFlavorArgs f m
V1Args FlushFrequency
DefaultFlushFrequency BackingStoreArgs Defaults m
forall (m :: * -> *). Incomplete BackingStoreArgs m
defaultBackingStoreArgs

defaultBackingStoreArgs :: Incomplete BackingStoreArgs m
defaultBackingStoreArgs :: forall (m :: * -> *). Incomplete BackingStoreArgs m
defaultBackingStoreArgs = BackingStoreArgs Defaults m
forall (f :: * -> *) (m :: * -> *). BackingStoreArgs f m
InMemoryBackingStoreArgs