-- |
-- Copyright: © 2022 IOHK
-- License: Apache-2.0
--
-- Abstract data type that describes a policy for keeping and discarding
-- checkpoints. To be used with the 'Checkpoints' type.
module Cardano.Wallet.Checkpoints.Policy
    ( BlockHeight
    , CheckpointPolicy
    , nextCheckpoint
    , keepWhereTip
    , toListAtTip

    -- * Construction
    , atGenesis
    , atTip
    , trailingArithmetic
    , sparseArithmetic
    , defaultPolicy
    , gapSize

    -- * Internal invariants
    -- $invariants
    ) where

import Prelude

import Data.List
    ( unfoldr )

{-------------------------------------------------------------------------------
    CheckpointPolicy, abstract data type
-------------------------------------------------------------------------------}
type BlockHeight = Integer

{-| [CheckpointPolicy]

To save memory and time, we do not store every checkpoint.
Instead, a 'CheckpointPolicy' determines which checkpoints
to store and which ones to discard.
The 'extendAndPrune' functions consults such a policy and
drops checkpoints as it deems necessary.

A 'CheckpointPolicy' determines whether a checkpoint is worth storing
only based on its block height. The boolean

  keepWhereTip policy tip blockheight

indicates whether the checkpoint should be stored ('True') or
not ('False').
It is important that this function does not oscillate:
If @blockheight <= tip@, the function result may change from 'True'
to 'False' as the @tip@ increases, but not the other way round.
This is because we can only create checkpoints the first time we
read the corresponding block.

TODO:
The 'Checkpoints' collection currently relies on 'Slot' instead
of 'BlockHeight' to store checkpoints. We need to better integrate
this with 'BlockHeight'.

I (Heinrich) actually prefer 'Slot'. However, not every slot contains a block,
and we would lose too many checkpoints if we based the decision of
whether to keep a checkpoint or not based on the slot number alone.
In contrast, block height is "dense".
-}
newtype CheckpointPolicy = CheckpointPolicy
    { CheckpointPolicy -> BlockHeight -> BlockHeight -> Maybe BlockHeight
nextCheckpoint :: BlockHeight -> BlockHeight -> Maybe BlockHeight
        -- ^ Assuming that the tip of the chain is at block height @tip@,
        -- @nextCheckpoint policy tip height@ returns the smallest
        -- @height'@ satisfying @height' >= height#
        -- at which the next checkpoint is to be made.
    }

{-$invariants

Internal invariants of the 'CheckpointPolicy' type:

* 'prop_monotonicHeight' — 'nextCheckpoint' returns the same height
  for all heights between a given height and the height returned.
* prop_monotonicTip' — when increasing the @tip@ height, 'nextCheckpoint'
  will never return a blockheight that is smaller.
-}

-- | Assuming that the tip of the chain is at block height @tip@,
-- the value @keepWhereTip policy tip height@
-- indicates whether a checkpoint should ('True') or should not ('False')
-- be stored at @height@.
keepWhereTip
    :: CheckpointPolicy -> BlockHeight -> BlockHeight
    -> Bool
keepWhereTip :: CheckpointPolicy -> BlockHeight -> BlockHeight -> Bool
keepWhereTip CheckpointPolicy
policy BlockHeight
tip BlockHeight
height =
    CheckpointPolicy -> BlockHeight -> BlockHeight -> Maybe BlockHeight
nextCheckpoint CheckpointPolicy
policy BlockHeight
tip BlockHeight
height Maybe BlockHeight -> Maybe BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight -> Maybe BlockHeight
forall a. a -> Maybe a
Just BlockHeight
height

-- | List all checkpoints for a given tip.
toListAtTip :: CheckpointPolicy -> BlockHeight -> [BlockHeight]
toListAtTip :: CheckpointPolicy -> BlockHeight -> [BlockHeight]
toListAtTip CheckpointPolicy
policy BlockHeight
tip = (BlockHeight -> Maybe (BlockHeight, BlockHeight))
-> BlockHeight -> [BlockHeight]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr ((BlockHeight -> (BlockHeight, BlockHeight))
-> Maybe BlockHeight -> Maybe (BlockHeight, BlockHeight)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockHeight -> (BlockHeight, BlockHeight)
forall b. Num b => b -> (b, b)
next (Maybe BlockHeight -> Maybe (BlockHeight, BlockHeight))
-> (BlockHeight -> Maybe BlockHeight)
-> BlockHeight
-> Maybe (BlockHeight, BlockHeight)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckpointPolicy -> BlockHeight -> BlockHeight -> Maybe BlockHeight
nextCheckpoint CheckpointPolicy
policy BlockHeight
tip) BlockHeight
0
  where next :: b -> (b, b)
next b
x = (b
x,b
xb -> b -> b
forall a. Num a => a -> a -> a
+b
1)

{-------------------------------------------------------------------------------
    CheckpointPolicy, construction
-------------------------------------------------------------------------------}
-- | The combination of two 'CheckpointPolicy' makes a checkpoint
-- where at least one of the policies wants to make a checkpoint.
instance Semigroup CheckpointPolicy where
    CheckpointPolicy
p1 <> :: CheckpointPolicy -> CheckpointPolicy -> CheckpointPolicy
<> CheckpointPolicy
p2 = (BlockHeight -> BlockHeight -> Maybe BlockHeight)
-> CheckpointPolicy
CheckpointPolicy ((BlockHeight -> BlockHeight -> Maybe BlockHeight)
 -> CheckpointPolicy)
-> (BlockHeight -> BlockHeight -> Maybe BlockHeight)
-> CheckpointPolicy
forall a b. (a -> b) -> a -> b
$ \BlockHeight
t BlockHeight
h ->
        (BlockHeight -> BlockHeight -> BlockHeight)
-> Maybe BlockHeight -> Maybe BlockHeight -> Maybe BlockHeight
forall t. (t -> t -> t) -> Maybe t -> Maybe t -> Maybe t
union BlockHeight -> BlockHeight -> BlockHeight
forall a. Ord a => a -> a -> a
min (CheckpointPolicy -> BlockHeight -> BlockHeight -> Maybe BlockHeight
nextCheckpoint CheckpointPolicy
p1 BlockHeight
t BlockHeight
h) (CheckpointPolicy -> BlockHeight -> BlockHeight -> Maybe BlockHeight
nextCheckpoint CheckpointPolicy
p2 BlockHeight
t BlockHeight
h)
      where
        union :: (t -> t -> t) -> Maybe t -> Maybe t -> Maybe t
union t -> t -> t
_ Maybe t
Nothing Maybe t
mb = Maybe t
mb
        union t -> t -> t
_ Maybe t
ma Maybe t
Nothing = Maybe t
ma
        union t -> t -> t
f (Just t
a) (Just t
b) = t -> Maybe t
forall a. a -> Maybe a
Just (t -> t -> t
f t
a t
b)

instance Monoid CheckpointPolicy where
    mempty :: CheckpointPolicy
mempty = (BlockHeight -> BlockHeight -> Maybe BlockHeight)
-> CheckpointPolicy
CheckpointPolicy ((BlockHeight -> BlockHeight -> Maybe BlockHeight)
 -> CheckpointPolicy)
-> (BlockHeight -> BlockHeight -> Maybe BlockHeight)
-> CheckpointPolicy
forall a b. (a -> b) -> a -> b
$ \BlockHeight
_ BlockHeight
_ -> Maybe BlockHeight
forall a. Maybe a
Nothing

-- | The 'CheckpointPolicy' that keeps only the genesis block.
atGenesis :: CheckpointPolicy
atGenesis :: CheckpointPolicy
atGenesis = (BlockHeight -> BlockHeight -> Maybe BlockHeight)
-> CheckpointPolicy
CheckpointPolicy ((BlockHeight -> BlockHeight -> Maybe BlockHeight)
 -> CheckpointPolicy)
-> (BlockHeight -> BlockHeight -> Maybe BlockHeight)
-> CheckpointPolicy
forall a b. (a -> b) -> a -> b
$ \BlockHeight
_tip BlockHeight
height ->
    if BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockHeight
0 then BlockHeight -> Maybe BlockHeight
forall a. a -> Maybe a
Just BlockHeight
height else Maybe BlockHeight
forall a. Maybe a
Nothing

-- | The 'CheckpointPolicy' that only keeps the tip of the chain.
atTip :: CheckpointPolicy
atTip :: CheckpointPolicy
atTip = (BlockHeight -> BlockHeight -> Maybe BlockHeight)
-> CheckpointPolicy
CheckpointPolicy ((BlockHeight -> BlockHeight -> Maybe BlockHeight)
 -> CheckpointPolicy)
-> (BlockHeight -> BlockHeight -> Maybe BlockHeight)
-> CheckpointPolicy
forall a b. (a -> b) -> a -> b
$ \BlockHeight
tip BlockHeight
height ->
    if BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockHeight
tip then BlockHeight -> Maybe BlockHeight
forall a. a -> Maybe a
Just BlockHeight
tip else Maybe BlockHeight
forall a. Maybe a
Nothing

-- | @trailingArithmetic n height@ keeps @n@ checkpoints
-- at block heights that are multiples of @height@
-- and which are closest to the tip of the chain.
-- (Fewer than @n@ checkpoints are kept while the chain is too short
-- to accommodate all checkpoints.)
trailingArithmetic :: Integer -> BlockHeight -> CheckpointPolicy
trailingArithmetic :: BlockHeight -> BlockHeight -> CheckpointPolicy
trailingArithmetic BlockHeight
n BlockHeight
grid = (BlockHeight -> BlockHeight -> Maybe BlockHeight)
-> CheckpointPolicy
CheckpointPolicy ((BlockHeight -> BlockHeight -> Maybe BlockHeight)
 -> CheckpointPolicy)
-> (BlockHeight -> BlockHeight -> Maybe BlockHeight)
-> CheckpointPolicy
forall a b. (a -> b) -> a -> b
$ \BlockHeight
tip BlockHeight
height ->
    case [BlockHeight
h | BlockHeight
h <- BlockHeight -> [BlockHeight]
window BlockHeight
tip, BlockHeight
h BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
height] of
        [] -> Maybe BlockHeight
forall a. Maybe a
Nothing
        (BlockHeight
x:[BlockHeight]
_) -> BlockHeight -> Maybe BlockHeight
forall a. a -> Maybe a
Just BlockHeight
x
  where
    window :: BlockHeight -> [BlockHeight]
window BlockHeight
tip = [BlockHeight
a, BlockHeight
a BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
grid .. BlockHeight
tip]
      where
        m :: BlockHeight
m = BlockHeight
n BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
1
        a :: BlockHeight
a = if BlockHeight
tip BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> BlockHeight
m BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
grid then BlockHeight -> BlockHeight
toGrid (BlockHeight
tip BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
m BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
grid) else BlockHeight
0
    toGrid :: BlockHeight -> BlockHeight
toGrid BlockHeight
x = (BlockHeight
x BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`div` BlockHeight
grid) BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
grid

{- | Note [sparseArithmeticPolicy]

The 'sparseArithmetic' checkpoint policy contains essentially two
sets of checkpoints: One fairly dense set near the tip of the chain
in order to handle frequent potential rollbacks, and one sparse
set that spans the entire epoch stability window. These two sets
are arranged as arithmetic sequences.

This policy is motivated by the following observations:

  - We can't rollback for more than `k = epochStability` blocks in the past
  - It is pretty fast to re-sync a few hundred blocks
  - Small rollbacks near the tip may occur more often than long ones

Hence, we should strive to

- Prune any checkpoint that are more than `k` blocks in the past
- Keep only one checkpoint every `largeGap` ~100 blocks
- But still keep ~10 most recent checkpoints to cope with small rollbacks.

Roughly, the 'sparseArithmetic'

0 ..... N*largeGap .... (N+1)*largeGap .. .. M*smallGap (M+1)*smallGap tip
        |_______________________________________________________________|
                 epochStability

Note: In the event where chain following "fails completely" (because, for
example, the node has switch to a different chain, different by more than `k`),
we have no choice but rolling back from genesis.
Therefore, we need to keep the very first checkpoint in the database, no
matter what.
-}
sparseArithmetic :: BlockHeight -> CheckpointPolicy
sparseArithmetic :: BlockHeight -> CheckpointPolicy
sparseArithmetic BlockHeight
epochStability =
    CheckpointPolicy
atGenesis
    CheckpointPolicy -> CheckpointPolicy -> CheckpointPolicy
forall a. Semigroup a => a -> a -> a
<> CheckpointPolicy
atTip
    CheckpointPolicy -> CheckpointPolicy -> CheckpointPolicy
forall a. Semigroup a => a -> a -> a
<> BlockHeight -> BlockHeight -> CheckpointPolicy
trailingArithmetic BlockHeight
10 BlockHeight
1
    CheckpointPolicy -> CheckpointPolicy -> CheckpointPolicy
forall a. Semigroup a => a -> a -> a
<> BlockHeight -> BlockHeight -> CheckpointPolicy
trailingArithmetic BlockHeight
n BlockHeight
largeGap
  where
    largeGap :: BlockHeight
largeGap = BlockHeight -> BlockHeight
gapSize BlockHeight
epochStability
    n :: BlockHeight
n = BlockHeight
epochStability BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`div` BlockHeight
largeGap

-- | A sensible default checkpoint policy; currently 'sparseArithmetic'.
defaultPolicy :: BlockHeight -> CheckpointPolicy
defaultPolicy :: BlockHeight -> CheckpointPolicy
defaultPolicy = BlockHeight -> CheckpointPolicy
sparseArithmetic

{- | A reasonable gap size used internally in 'sparseArithmeticPolicy'.

'Reasonable' means that it's not _too frequent_ and it's not too large. A
value that is too small in front of k would require generating much more
checkpoints than necessary.

A value that is larger than `k` may have dramatic consequences in case of
deep rollbacks.

As a middle ground, we current choose `k / 3`, which is justified by:

- The current bandwidth of the network layer (several thousands blocks per seconds)
- The current value of k = 2160

So, `k / 3` = 720, which corresponds to around a second of time needed to catch
up in case of large rollbacks (if our local node has caught up already).
-}
gapSize :: BlockHeight -> Integer
gapSize :: BlockHeight -> BlockHeight
gapSize BlockHeight
epochStability = BlockHeight -> BlockHeight -> BlockHeight
forall a. Ord a => a -> a -> a
max BlockHeight
1 (BlockHeight
epochStability  BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`div` BlockHeight
3)