{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Copyright: © 2021 IOHK
-- License: Apache-2.0
--
-- Data type that represents a collection of checkpoints.
-- Each checkpoints is associated with a 'Slot'.

module Cardano.Wallet.Checkpoints
    ( -- * Checkpoints
      Checkpoints
    , checkpoints
    , loadCheckpoints
    , fromGenesis
    , getLatest
    , findNearestPoint

    -- * Delta types
    , DeltaCheckpoints (..)
    , DeltasCheckpoints

    -- * Checkpoint hygiene
    , SparseCheckpointsConfig (..)
    , defaultSparseCheckpointsConfig
    , sparseCheckpoints
    , gapSize
    ) where

import Prelude

import Data.Delta
    ( Delta (..) )
import Data.Generics.Internal.VL.Lens
    ( over, view )
import Data.Map.Strict
    ( Map )
import Data.Maybe
    ( fromMaybe )
import Data.Quantity
    ( Quantity (..) )
import Data.Word
    ( Word32, Word8 )
import Fmt
    ( Buildable (..), listF )
import GHC.Generics
    ( Generic )

import qualified Cardano.Wallet.Primitive.Types as W
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

{- NOTE [PointSlotNo]

'SlotNo' cannot represent the genesis point.

Historical hack. The DB layer can't represent 'Origin' in the database,
instead we have mapped it to 'SlotNo 0', which is wrong.

Rolling back to SlotNo 0 instead of Origin is fine for followers starting
from genesis (which should be the majority of cases). Other, non-trivial
rollbacks to genesis cannot occur on mainnet (genesis is years within
stable part, and there were no rollbacks in byron).

Could possibly be problematic in the beginning of a testnet without a
byron era. /Perhaps/ this is what is happening in the
>>> [cardano-wallet.pools-engine:Error:1293] [2020-11-24 10:02:04.00 UTC]
>>> Couldn't store production for given block before it conflicts with
>>> another block. Conflicting block header is:
>>> 5bde7e7b<-[f1b35b98-4290#2008]
errors observed in the integration tests.

The issue has been partially fixed in that 'rollbackTo' now takes
a 'Slot' as argument, which can represent the 'Origin'.
However, the database itself mostly stores slot numbers.

FIXME LATER during ADP-1043: As we move towards in-memory data,
all slot numbers in the DB file will either be replaced by
the 'Slot' type, or handled slightly differently when it
is clear that the data cannot exist at the genesis point
(e.g. for TxHistory).

-}

{-------------------------------------------------------------------------------
    Checkpoints
-------------------------------------------------------------------------------}
-- | Collection of checkpoints indexed by 'Slot'.
newtype Checkpoints a = Checkpoints
    { Checkpoints a -> Map Slot a
checkpoints :: Map W.Slot a
    -- ^ Map of checkpoints. Always contains the genesis checkpoint.
    } deriving (Checkpoints a -> Checkpoints a -> Bool
(Checkpoints a -> Checkpoints a -> Bool)
-> (Checkpoints a -> Checkpoints a -> Bool) -> Eq (Checkpoints a)
forall a. Eq a => Checkpoints a -> Checkpoints a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Checkpoints a -> Checkpoints a -> Bool
$c/= :: forall a. Eq a => Checkpoints a -> Checkpoints a -> Bool
== :: Checkpoints a -> Checkpoints a -> Bool
$c== :: forall a. Eq a => Checkpoints a -> Checkpoints a -> Bool
Eq,Int -> Checkpoints a -> ShowS
[Checkpoints a] -> ShowS
Checkpoints a -> String
(Int -> Checkpoints a -> ShowS)
-> (Checkpoints a -> String)
-> ([Checkpoints a] -> ShowS)
-> Show (Checkpoints a)
forall a. Show a => Int -> Checkpoints a -> ShowS
forall a. Show a => [Checkpoints a] -> ShowS
forall a. Show a => Checkpoints a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Checkpoints a] -> ShowS
$cshowList :: forall a. Show a => [Checkpoints a] -> ShowS
show :: Checkpoints a -> String
$cshow :: forall a. Show a => Checkpoints a -> String
showsPrec :: Int -> Checkpoints a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Checkpoints a -> ShowS
Show,(forall x. Checkpoints a -> Rep (Checkpoints a) x)
-> (forall x. Rep (Checkpoints a) x -> Checkpoints a)
-> Generic (Checkpoints a)
forall x. Rep (Checkpoints a) x -> Checkpoints a
forall x. Checkpoints a -> Rep (Checkpoints a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Checkpoints a) x -> Checkpoints a
forall a x. Checkpoints a -> Rep (Checkpoints a) x
$cto :: forall a x. Rep (Checkpoints a) x -> Checkpoints a
$cfrom :: forall a x. Checkpoints a -> Rep (Checkpoints a) x
Generic)
-- FIXME LATER during ADP-1043:
--  Use a more sophisticated 'Checkpoints' type that stores deltas.

-- | Turn the list of checkpoints into a map of checkpoints.
--
-- FIXME LATER during ADP-1043:
--   The database actually does not store the checkpoint at genesis,
--   but the checkpoint after that.
--   Hence, this function does not check whether the genesis checkpoint
--   is in the list of checkpoints.
loadCheckpoints :: [(W.Slot, a)] -> Checkpoints a
loadCheckpoints :: [(Slot, a)] -> Checkpoints a
loadCheckpoints = Map Slot a -> Checkpoints a
forall a. Map Slot a -> Checkpoints a
Checkpoints (Map Slot a -> Checkpoints a)
-> ([(Slot, a)] -> Map Slot a) -> [(Slot, a)] -> Checkpoints a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Slot, a)] -> Map Slot a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

-- | Begin with the genesis checkpoint.
fromGenesis :: a -> Checkpoints a
fromGenesis :: a -> Checkpoints a
fromGenesis a
a = Map Slot a -> Checkpoints a
forall a. Map Slot a -> Checkpoints a
Checkpoints (Map Slot a -> Checkpoints a) -> Map Slot a -> Checkpoints a
forall a b. (a -> b) -> a -> b
$ Slot -> a -> Map Slot a
forall k a. k -> a -> Map k a
Map.singleton Slot
forall t. WithOrigin t
W.Origin a
a

-- | Get the checkpoint with the largest 'SlotNo'.
getLatest :: Checkpoints a -> (W.Slot, a)
getLatest :: Checkpoints a -> (Slot, a)
getLatest = Maybe (Slot, a) -> (Slot, a)
forall a. Maybe a -> a
from (Maybe (Slot, a) -> (Slot, a))
-> (Checkpoints a -> Maybe (Slot, a)) -> Checkpoints a -> (Slot, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Slot a -> Maybe (Slot, a)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax (Map Slot a -> Maybe (Slot, a))
-> (Checkpoints a -> Map Slot a)
-> Checkpoints a
-> Maybe (Slot, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Map Slot a -> Const (Map Slot a) (Map Slot a))
 -> Checkpoints a -> Const (Map Slot a) (Checkpoints a))
-> Checkpoints a -> Map Slot a
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "checkpoints"
  ((Map Slot a -> Const (Map Slot a) (Map Slot a))
   -> Checkpoints a -> Const (Map Slot a) (Checkpoints a))
(Map Slot a -> Const (Map Slot a) (Map Slot a))
-> Checkpoints a -> Const (Map Slot a) (Checkpoints a)
#checkpoints
  where
    from :: Maybe a -> a
from = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. HasCallStack => String -> a
error String
"getLatest: there should always be at least a genesis checkpoint")

-- | Find the nearest 'Checkpoint' that is either at the given point or before.
findNearestPoint :: Checkpoints a -> W.Slot -> Maybe W.Slot
findNearestPoint :: Checkpoints a -> Slot -> Maybe Slot
findNearestPoint Checkpoints a
m Slot
key = (Slot, a) -> Slot
forall a b. (a, b) -> a
fst ((Slot, a) -> Slot) -> Maybe (Slot, a) -> Maybe Slot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Slot -> Map Slot a -> Maybe (Slot, a)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupLE Slot
key (((Map Slot a -> Const (Map Slot a) (Map Slot a))
 -> Checkpoints a -> Const (Map Slot a) (Checkpoints a))
-> Checkpoints a -> Map Slot a
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "checkpoints"
  ((Map Slot a -> Const (Map Slot a) (Map Slot a))
   -> Checkpoints a -> Const (Map Slot a) (Checkpoints a))
(Map Slot a -> Const (Map Slot a) (Map Slot a))
-> Checkpoints a -> Const (Map Slot a) (Checkpoints a)
#checkpoints Checkpoints a
m)

{-------------------------------------------------------------------------------
    Delta type for Checkpoints
-------------------------------------------------------------------------------}
type DeltasCheckpoints a = [DeltaCheckpoints a]

data DeltaCheckpoints a
    = PutCheckpoint W.Slot a
    | RollbackTo W.Slot
        -- Rolls back to the latest checkpoint at or before this slot.
    | RestrictTo [W.Slot]
        -- ^ Restrict to the intersection of this list with
        -- the checkpoints that are already present.
        -- The genesis checkpoint will always be present.

instance Delta (DeltaCheckpoints a) where
    type Base (DeltaCheckpoints a) = Checkpoints a
    apply :: DeltaCheckpoints a
-> Base (DeltaCheckpoints a) -> Base (DeltaCheckpoints a)
apply (PutCheckpoint Slot
pt a
a) = ((Map Slot a -> Identity (Map Slot a))
 -> Checkpoints a -> Identity (Checkpoints a))
-> (Map Slot a -> Map Slot a) -> Checkpoints a -> Checkpoints a
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
over IsLabel
  "checkpoints"
  ((Map Slot a -> Identity (Map Slot a))
   -> Checkpoints a -> Identity (Checkpoints a))
(Map Slot a -> Identity (Map Slot a))
-> Checkpoints a -> Identity (Checkpoints a)
#checkpoints ((Map Slot a -> Map Slot a) -> Checkpoints a -> Checkpoints a)
-> (Map Slot a -> Map Slot a) -> Checkpoints a -> Checkpoints a
forall a b. (a -> b) -> a -> b
$ Slot -> a -> Map Slot a -> Map Slot a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Slot
pt a
a
    apply (RollbackTo Slot
pt) = ((Map Slot a -> Identity (Map Slot a))
 -> Checkpoints a -> Identity (Checkpoints a))
-> (Map Slot a -> Map Slot a) -> Checkpoints a -> Checkpoints a
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
over IsLabel
  "checkpoints"
  ((Map Slot a -> Identity (Map Slot a))
   -> Checkpoints a -> Identity (Checkpoints a))
(Map Slot a -> Identity (Map Slot a))
-> Checkpoints a -> Identity (Checkpoints a)
#checkpoints ((Map Slot a -> Map Slot a) -> Checkpoints a -> Checkpoints a)
-> (Map Slot a -> Map Slot a) -> Checkpoints a -> Checkpoints a
forall a b. (a -> b) -> a -> b
$
        (Slot -> a -> Bool) -> Map Slot a -> Map Slot a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Slot
k a
_ -> Slot
k Slot -> Slot -> Bool
forall a. Ord a => a -> a -> Bool
<= Slot
pt)
    apply (RestrictTo [Slot]
pts) = ((Map Slot a -> Identity (Map Slot a))
 -> Checkpoints a -> Identity (Checkpoints a))
-> (Map Slot a -> Map Slot a) -> Checkpoints a -> Checkpoints a
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
over IsLabel
  "checkpoints"
  ((Map Slot a -> Identity (Map Slot a))
   -> Checkpoints a -> Identity (Checkpoints a))
(Map Slot a -> Identity (Map Slot a))
-> Checkpoints a -> Identity (Checkpoints a)
#checkpoints ((Map Slot a -> Map Slot a) -> Checkpoints a -> Checkpoints a)
-> (Map Slot a -> Map Slot a) -> Checkpoints a -> Checkpoints a
forall a b. (a -> b) -> a -> b
$ \Map Slot a
m ->
        Map Slot a -> Set Slot -> Map Slot a
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map Slot a
m (Set Slot -> Map Slot a) -> Set Slot -> Map Slot a
forall a b. (a -> b) -> a -> b
$ [Slot] -> Set Slot
forall a. Ord a => [a] -> Set a
Set.fromList (Slot
forall t. WithOrigin t
W.OriginSlot -> [Slot] -> [Slot]
forall a. a -> [a] -> [a]
:[Slot]
pts)

instance Buildable (DeltaCheckpoints a) where
    build :: DeltaCheckpoints a -> Builder
build (PutCheckpoint Slot
slot a
_) = Builder
"PutCheckpoint " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Slot -> Builder
forall p. Buildable p => p -> Builder
build Slot
slot
    build (RollbackTo Slot
slot) = Builder
"RollbackTo " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Slot -> Builder
forall p. Buildable p => p -> Builder
build Slot
slot
    build (RestrictTo [Slot]
slots) = Builder
"RestrictTo " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Slot] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
listF [Slot]
slots

{-------------------------------------------------------------------------------
    Checkpoint hygiene
-------------------------------------------------------------------------------}
-- | Storing EVERY checkpoints in the database is quite expensive and useless.
-- We make the following assumptions:
--
-- - 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 may occur more often than deep ones
--
-- So, as we insert checkpoints, we make sure to:
--
-- - Prune any checkpoint that more than `k` blocks in the past
-- - Keep only one checkpoint every 100 blocks
-- - But still keep ~10 most recent checkpoints to cope with small rollbacks
--
-- __Example 1__: Inserting `cp153`
--
--  ℹ: `cp142` is discarded and `cp153` inserted.
--
--  @
--  Currently in DB:
-- ┌───┬───┬───┬─  ──┬───┐
-- │cp000 │cp100 │cp142 │..    ..│cp152 │
-- └───┴───┴───┴─  ──┴───┘
--  Want in DB:
-- ┌───┬───┬───┬─  ──┬───┐
-- │cp000 │cp100 │cp143 │..    ..│cp153 │
-- └───┴───┴───┴─  ──┴───┘
--  @
--
--
--  __Example 2__: Inserting `cp111`
--
--  ℹ: `cp100` is kept and `cp111` inserted.
--
--  @
--  Currently in DB:
-- ┌───┬───┬───┬─  ──┬───┐
-- │cp000 │cp100 │cp101 │..    ..│cp110 │
-- └───┴───┴───┴─  ──┴───┘
--  Want in DB:
-- ┌───┬───┬───┬─  ──┬───┐
-- │cp000 │cp100 │cp101 │..    ..│cp111 │
-- └───┴───┴───┴─  ──┴───┘
--  @
--
-- NOTE: There might be cases where the chain following "fails" (because, for
-- example, the node has switched to a different chain, different by more than k),
-- and in such cases, we have no choice but rolling back from genesis.
-- Therefore, we need to keep the very first checkpoint in the database, no
-- matter what.
sparseCheckpoints
    :: SparseCheckpointsConfig
        -- ^ Parameters for the function.
    -> Quantity "block" Word32
        -- ^ A given block height
    -> [Word32]
        -- ^ The list of checkpoint heights that should be kept in DB.
sparseCheckpoints :: SparseCheckpointsConfig -> Quantity "block" Word32 -> [Word32]
sparseCheckpoints SparseCheckpointsConfig
cfg Quantity "block" Word32
blkH  =
    let
        SparseCheckpointsConfig{Word8
edgeSize :: SparseCheckpointsConfig -> Word8
edgeSize :: Word8
edgeSize,Word32
epochStability :: SparseCheckpointsConfig -> Word32
epochStability :: Word32
epochStability} = SparseCheckpointsConfig
cfg
        g :: Word32
g = SparseCheckpointsConfig -> Word32
gapSize SparseCheckpointsConfig
cfg
        h :: Word32
h = Quantity "block" Word32 -> Word32
forall (unit :: Symbol) a. Quantity unit a -> a
getQuantity Quantity "block" Word32
blkH
        e :: Word32
e = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
edgeSize

        minH :: Word32
minH =
            let x :: Word32
x = if Word32
h Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
epochStability Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
g then Word32
0 else Word32
h Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
epochStability Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
g
            in Word32
g Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* (Word32
x Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
g)

        initial :: Word32
initial   = Word32
0
        longTerm :: [Word32]
longTerm  = [Word32
minH,Word32
minHWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
g..Word32
h]
        shortTerm :: [Word32]
shortTerm = if Word32
h Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
e
            then [Word32
0..Word32
h]
            else [Word32
hWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
e,Word32
hWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
eWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1..Word32
h]
    in
        [Word32] -> [Word32]
forall a. Ord a => [a] -> [a]
L.sort ([Word32] -> [Word32]
forall a. Eq a => [a] -> [a]
L.nub ([Word32] -> [Word32]) -> [Word32] -> [Word32]
forall a b. (a -> b) -> a -> b
$ Word32
initial Word32 -> [Word32] -> [Word32]
forall a. a -> [a] -> [a]
: ([Word32]
longTerm [Word32] -> [Word32] -> [Word32]
forall a. [a] -> [a] -> [a]
++ [Word32]
shortTerm))

-- | Captures the configuration for the `sparseCheckpoints` function.
--
-- NOTE: large values of 'edgeSize' aren't recommended as they would mean
-- storing many unnecessary checkpoints. In Ouroboros Praos, there's a
-- reasonable probability for small forks each a few blocks deep so it makes sense to
-- maintain a small part that is denser near the edge.
data SparseCheckpointsConfig = SparseCheckpointsConfig
    { SparseCheckpointsConfig -> Word8
edgeSize :: Word8
    , SparseCheckpointsConfig -> Word32
epochStability :: Word32
    } deriving Int -> SparseCheckpointsConfig -> ShowS
[SparseCheckpointsConfig] -> ShowS
SparseCheckpointsConfig -> String
(Int -> SparseCheckpointsConfig -> ShowS)
-> (SparseCheckpointsConfig -> String)
-> ([SparseCheckpointsConfig] -> ShowS)
-> Show SparseCheckpointsConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SparseCheckpointsConfig] -> ShowS
$cshowList :: [SparseCheckpointsConfig] -> ShowS
show :: SparseCheckpointsConfig -> String
$cshow :: SparseCheckpointsConfig -> String
showsPrec :: Int -> SparseCheckpointsConfig -> ShowS
$cshowsPrec :: Int -> SparseCheckpointsConfig -> ShowS
Show

-- | A sensible default to use in production. See also 'SparseCheckpointsConfig'
defaultSparseCheckpointsConfig :: Quantity "block" Word32 -> SparseCheckpointsConfig
defaultSparseCheckpointsConfig :: Quantity "block" Word32 -> SparseCheckpointsConfig
defaultSparseCheckpointsConfig (Quantity Word32
epochStability) =
    SparseCheckpointsConfig :: Word8 -> Word32 -> SparseCheckpointsConfig
SparseCheckpointsConfig
        { edgeSize :: Word8
edgeSize = Word8
5
        , Word32
epochStability :: Word32
epochStability :: Word32
epochStability
        }

-- | A reasonable gap size used internally in 'sparseCheckpoints'.
--
-- '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 speed of the network layer (several thousands blocks per seconds)
-- - The current value of k = 2160
--
-- So, `k / 3` = 720, which should remain around a second of time needed to catch
-- up in case of large rollbacks.
gapSize :: SparseCheckpointsConfig -> Word32
gapSize :: SparseCheckpointsConfig -> Word32
gapSize SparseCheckpointsConfig{Word32
epochStability :: Word32
epochStability :: SparseCheckpointsConfig -> Word32
epochStability} =
    Word32
epochStability Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
3