{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RecordWildCards #-}

module Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (
    DiskPolicy (..)
  , DiskPolicyArgs (..)
  , NumOfDiskSnapshots (..)
  , SnapshotInterval (..)
  , TimeSinceLast (..)
  , defaultDiskPolicyArgs
  , mkDiskPolicy
  ) where

import           Control.Monad.Class.MonadTime.SI
import           Data.Time.Clock (secondsToDiffTime)
import           Data.Word
import           GHC.Generics
import           NoThunks.Class (NoThunks, OnlyCheckWhnf (..))
import           Ouroboros.Consensus.Config.SecurityParam

-- | Length of time, requested by the user, that has to pass after which
-- a snapshot is taken. It can be:
--
-- 1. either explicitly provided by user in seconds
-- 2. or default value can be requested - the specific DiskPolicy determines
--    what that is exactly, see `mkDiskPolicy` as an example
data SnapshotInterval =
    DefaultSnapshotInterval
  | RequestedSnapshotInterval DiffTime
  deriving stock (SnapshotInterval -> SnapshotInterval -> Bool
(SnapshotInterval -> SnapshotInterval -> Bool)
-> (SnapshotInterval -> SnapshotInterval -> Bool)
-> Eq SnapshotInterval
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotInterval -> SnapshotInterval -> Bool
== :: SnapshotInterval -> SnapshotInterval -> Bool
$c/= :: SnapshotInterval -> SnapshotInterval -> Bool
/= :: SnapshotInterval -> SnapshotInterval -> Bool
Eq, (forall x. SnapshotInterval -> Rep SnapshotInterval x)
-> (forall x. Rep SnapshotInterval x -> SnapshotInterval)
-> Generic SnapshotInterval
forall x. Rep SnapshotInterval x -> SnapshotInterval
forall x. SnapshotInterval -> Rep SnapshotInterval x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SnapshotInterval -> Rep SnapshotInterval x
from :: forall x. SnapshotInterval -> Rep SnapshotInterval x
$cto :: forall x. Rep SnapshotInterval x -> SnapshotInterval
to :: forall x. Rep SnapshotInterval x -> SnapshotInterval
Generic, Int -> SnapshotInterval -> ShowS
[SnapshotInterval] -> ShowS
SnapshotInterval -> String
(Int -> SnapshotInterval -> ShowS)
-> (SnapshotInterval -> String)
-> ([SnapshotInterval] -> ShowS)
-> Show SnapshotInterval
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotInterval -> ShowS
showsPrec :: Int -> SnapshotInterval -> ShowS
$cshow :: SnapshotInterval -> String
show :: SnapshotInterval -> String
$cshowList :: [SnapshotInterval] -> ShowS
showList :: [SnapshotInterval] -> ShowS
Show)

-- | Number of snapshots to be stored on disk. This is either the default value
-- as determined by the DiskPolicy, or it is provided by the user. See the
-- `DiskPolicy` documentation for more information.
data NumOfDiskSnapshots =
    DefaultNumOfDiskSnapshots
  | RequestedNumOfDiskSnapshots Word
  deriving stock (NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool
(NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool)
-> (NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool)
-> Eq NumOfDiskSnapshots
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool
== :: NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool
$c/= :: NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool
/= :: NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool
Eq, (forall x. NumOfDiskSnapshots -> Rep NumOfDiskSnapshots x)
-> (forall x. Rep NumOfDiskSnapshots x -> NumOfDiskSnapshots)
-> Generic NumOfDiskSnapshots
forall x. Rep NumOfDiskSnapshots x -> NumOfDiskSnapshots
forall x. NumOfDiskSnapshots -> Rep NumOfDiskSnapshots x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NumOfDiskSnapshots -> Rep NumOfDiskSnapshots x
from :: forall x. NumOfDiskSnapshots -> Rep NumOfDiskSnapshots x
$cto :: forall x. Rep NumOfDiskSnapshots x -> NumOfDiskSnapshots
to :: forall x. Rep NumOfDiskSnapshots x -> NumOfDiskSnapshots
Generic, Int -> NumOfDiskSnapshots -> ShowS
[NumOfDiskSnapshots] -> ShowS
NumOfDiskSnapshots -> String
(Int -> NumOfDiskSnapshots -> ShowS)
-> (NumOfDiskSnapshots -> String)
-> ([NumOfDiskSnapshots] -> ShowS)
-> Show NumOfDiskSnapshots
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NumOfDiskSnapshots -> ShowS
showsPrec :: Int -> NumOfDiskSnapshots -> ShowS
$cshow :: NumOfDiskSnapshots -> String
show :: NumOfDiskSnapshots -> String
$cshowList :: [NumOfDiskSnapshots] -> ShowS
showList :: [NumOfDiskSnapshots] -> ShowS
Show)

data DiskPolicyArgs = DiskPolicyArgs SnapshotInterval NumOfDiskSnapshots

-- | On-disk policy
--
-- We only write ledger states that are older than @k@ blocks to disk (that is,
-- snapshots that are guaranteed valid). The on-disk policy determines how often
-- we write to disk and how many checkpoints we keep.
data DiskPolicy = DiskPolicy {
      -- | How many snapshots do we want to keep on disk?
      --
      -- A higher number of on-disk snapshots is primarily a safe-guard against
      -- disk corruption: it trades disk space for reliability.
      --
      -- Examples:
      --
      -- * @0@: Delete the snapshot immediately after writing.
      --        Probably not a useful value :-D
      -- * @1@: Delete the previous snapshot immediately after writing the next
      --        Dangerous policy: if for some reason the deletion happens before
      --        the new snapshot is written entirely to disk (we don't @fsync@),
      --        we have no choice but to start at the genesis snapshot on the
      --        next startup.
      -- * @2@: Always keep 2 snapshots around. This means that when we write
      --        the next snapshot, we delete the oldest one, leaving the middle
      --        one available in case of truncation of the write. This is
      --        probably a sane value in most circumstances.
      DiskPolicy -> Word
onDiskNumSnapshots       :: Word

      -- | Should we write a snapshot of the ledger state to disk?
      --
      -- This function is passed two bits of information:
      --
      -- * The time since the last snapshot, or 'NoSnapshotTakenYet' if none was taken yet.
      --   Note that 'NoSnapshotTakenYet' merely means no snapshot had been taking yet
      --   since the node was started; it does not necessarily mean that none
      --   exist on disk.
      --
      -- * The distance in terms of blocks applied to the /oldest/ ledger
      --   snapshot in memory. During normal operation, this is the number of
      --   blocks written to the ImmutableDB since the last snapshot. On
      --   startup, it is computed by counting how many immutable blocks we had
      --   to reapply to get to the chain tip. This is useful, as it allows the
      --   policy to decide to take a snapshot /on node startup/ if a lot of
      --   blocks had to be replayed.
      --
      -- See also 'mkDiskPolicy'
    , DiskPolicy -> TimeSinceLast DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool
    }
  deriving Context -> DiskPolicy -> IO (Maybe ThunkInfo)
Proxy DiskPolicy -> String
(Context -> DiskPolicy -> IO (Maybe ThunkInfo))
-> (Context -> DiskPolicy -> IO (Maybe ThunkInfo))
-> (Proxy DiskPolicy -> String)
-> NoThunks DiskPolicy
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> DiskPolicy -> IO (Maybe ThunkInfo)
noThunks :: Context -> DiskPolicy -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> DiskPolicy -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> DiskPolicy -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy DiskPolicy -> String
showTypeOf :: Proxy DiskPolicy -> String
NoThunks via OnlyCheckWhnf DiskPolicy

data TimeSinceLast time = NoSnapshotTakenYet | TimeSinceLast time
  deriving ((forall a b. (a -> b) -> TimeSinceLast a -> TimeSinceLast b)
-> (forall a b. a -> TimeSinceLast b -> TimeSinceLast a)
-> Functor TimeSinceLast
forall a b. a -> TimeSinceLast b -> TimeSinceLast a
forall a b. (a -> b) -> TimeSinceLast a -> TimeSinceLast b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TimeSinceLast a -> TimeSinceLast b
fmap :: forall a b. (a -> b) -> TimeSinceLast a -> TimeSinceLast b
$c<$ :: forall a b. a -> TimeSinceLast b -> TimeSinceLast a
<$ :: forall a b. a -> TimeSinceLast b -> TimeSinceLast a
Functor, Int -> TimeSinceLast time -> ShowS
[TimeSinceLast time] -> ShowS
TimeSinceLast time -> String
(Int -> TimeSinceLast time -> ShowS)
-> (TimeSinceLast time -> String)
-> ([TimeSinceLast time] -> ShowS)
-> Show (TimeSinceLast time)
forall time. Show time => Int -> TimeSinceLast time -> ShowS
forall time. Show time => [TimeSinceLast time] -> ShowS
forall time. Show time => TimeSinceLast time -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall time. Show time => Int -> TimeSinceLast time -> ShowS
showsPrec :: Int -> TimeSinceLast time -> ShowS
$cshow :: forall time. Show time => TimeSinceLast time -> String
show :: TimeSinceLast time -> String
$cshowList :: forall time. Show time => [TimeSinceLast time] -> ShowS
showList :: [TimeSinceLast time] -> ShowS
Show)

-- | Default on-disk policy arguments suitable to use with cardano-node
--
defaultDiskPolicyArgs :: DiskPolicyArgs
defaultDiskPolicyArgs :: DiskPolicyArgs
defaultDiskPolicyArgs = SnapshotInterval -> NumOfDiskSnapshots -> DiskPolicyArgs
DiskPolicyArgs SnapshotInterval
DefaultSnapshotInterval NumOfDiskSnapshots
DefaultNumOfDiskSnapshots

mkDiskPolicy :: SecurityParam -> DiskPolicyArgs -> DiskPolicy
mkDiskPolicy :: SecurityParam -> DiskPolicyArgs -> DiskPolicy
mkDiskPolicy (SecurityParam Word64
k) (DiskPolicyArgs SnapshotInterval
reqInterval NumOfDiskSnapshots
reqNumOfSnapshots) =
  DiskPolicy {Word
TimeSinceLast DiffTime -> Word64 -> Bool
onDiskNumSnapshots :: Word
onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool
onDiskNumSnapshots :: Word
onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool
..}
  where
    onDiskNumSnapshots :: Word
    onDiskNumSnapshots :: Word
onDiskNumSnapshots = case NumOfDiskSnapshots
reqNumOfSnapshots of
      NumOfDiskSnapshots
DefaultNumOfDiskSnapshots         -> Word
2
      RequestedNumOfDiskSnapshots Word
value -> Word
value

    onDiskShouldTakeSnapshot ::
         TimeSinceLast DiffTime
      -> Word64
      -> Bool
    onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot TimeSinceLast DiffTime
NoSnapshotTakenYet Word64
blocksSinceLast =
      -- If users never leave their wallet running for long, this would mean
      -- that under some circumstances we would never take a snapshot
      -- So, on startup (when the 'time since the last snapshot' is `Nothing`),
      -- we take a snapshot as soon as there are @k@ blocks replayed.
      -- This means that even if users frequently shut down their wallet, we still
      -- take a snapshot roughly every @k@ blocks. It does mean the possibility of
      -- an extra unnecessary snapshot during syncing (if the node is restarted), but
      -- that is not a big deal.
      Word64
blocksSinceLast Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
k

    onDiskShouldTakeSnapshot (TimeSinceLast DiffTime
timeSinceLast) Word64
blocksSinceLast =
         DiffTime
timeSinceLast DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
snapshotInterval
      Bool -> Bool -> Bool
|| Word64 -> DiffTime -> Bool
forall {a}. (Ord a, Num a) => a -> DiffTime -> Bool
substantialAmountOfBlocksWereProcessed Word64
blocksSinceLast DiffTime
timeSinceLast

    -- | We want to create a snapshot after a substantial amount of blocks were
    -- processed (hard-coded to 50k blocks). Given the fact that during bootstrap
    -- a fresh node will see a lot of blocks over a short period of time, we want
    -- to limit this condition to happen not more often then a fixed amount of
    -- time (here hard-coded to 6 minutes)
    substantialAmountOfBlocksWereProcessed :: a -> DiffTime -> Bool
substantialAmountOfBlocksWereProcessed a
blocksSinceLast DiffTime
timeSinceLast =
      let minBlocksBeforeSnapshot :: a
minBlocksBeforeSnapshot      = a
50_000
          minTimeBeforeSnapshot :: DiffTime
minTimeBeforeSnapshot        = DiffTime
6 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* Integer -> DiffTime
secondsToDiffTime Integer
60
      in    a
blocksSinceLast a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
minBlocksBeforeSnapshot
         Bool -> Bool -> Bool
&& DiffTime
timeSinceLast   DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
minTimeBeforeSnapshot

    -- | Requested snapshot interval can be explicitly provided by the
    -- caller (RequestedSnapshotInterval) or the caller might request the default
    -- snapshot interval (DefaultSnapshotInterval). If the latter then the
    -- snapshot interval is defaulted to k * 2 seconds - when @k = 2160@ the interval
    -- defaults to 72 minutes.
    snapshotInterval :: DiffTime
snapshotInterval = case SnapshotInterval
reqInterval of
      RequestedSnapshotInterval DiffTime
value -> DiffTime
value
      SnapshotInterval
DefaultSnapshotInterval           -> Integer -> DiffTime
secondsToDiffTime (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ Word64
k Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
2