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

module Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (
    DiskPolicy (..)
  , SnapshotInterval (..)
  , TimeSinceLast (..)
  , defaultDiskPolicy
  ) where

import           Data.Time.Clock (secondsToDiffTime)
import           Data.Word
import           GHC.Generics
import           NoThunks.Class (NoThunks, OnlyCheckWhnf (..))

import           Control.Monad.Class.MonadTime

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 `defaultDiskPolicy` 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
/= :: SnapshotInterval -> SnapshotInterval -> Bool
$c/= :: SnapshotInterval -> SnapshotInterval -> Bool
== :: SnapshotInterval -> SnapshotInterval -> Bool
$c== :: 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
$cto :: forall x. Rep SnapshotInterval x -> SnapshotInterval
$cfrom :: forall x. SnapshotInterval -> Rep SnapshotInterval x
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
showList :: [SnapshotInterval] -> ShowS
$cshowList :: [SnapshotInterval] -> ShowS
show :: SnapshotInterval -> String
$cshow :: SnapshotInterval -> String
showsPrec :: Int -> SnapshotInterval -> ShowS
$cshowsPrec :: Int -> SnapshotInterval -> ShowS
Show)

-- | 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 'defaultDiskPolicy'
    , 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
showTypeOf :: Proxy DiskPolicy -> String
$cshowTypeOf :: Proxy DiskPolicy -> String
wNoThunks :: Context -> DiskPolicy -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> DiskPolicy -> IO (Maybe ThunkInfo)
noThunks :: Context -> DiskPolicy -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> DiskPolicy -> IO (Maybe ThunkInfo)
NoThunks via OnlyCheckWhnf DiskPolicy

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

-- | Default on-disk policy suitable to use with cardano-node
--
defaultDiskPolicy :: SecurityParam -> SnapshotInterval -> DiskPolicy
defaultDiskPolicy :: SecurityParam -> SnapshotInterval -> DiskPolicy
defaultDiskPolicy (SecurityParam Word64
k) SnapshotInterval
requestedInterval = DiskPolicy :: Word -> (TimeSinceLast DiffTime -> Word64 -> Bool) -> DiskPolicy
DiskPolicy {Word
TimeSinceLast DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool
onDiskNumSnapshots :: Word
onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool
onDiskNumSnapshots :: Word
..}
  where
    onDiskNumSnapshots :: Word
    onDiskNumSnapshots :: Word
onDiskNumSnapshots = Word
2

    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
requestedInterval 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