{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE Rank2Types #-}

-- | Functionality for calculating @SyncProgress@ of wallets.
module Cardano.Wallet.Primitive.SyncProgress
    ( -- * Types
      SyncProgress (..)
    , SyncTolerance (..)
    , mkSyncTolerance

      -- * Implementations
    , syncProgress
    ) where

import Prelude

import Cardano.Wallet.Primitive.Slotting
    ( TimeInterpreter, interpretQuery, slotToRelTime )
import Cardano.Wallet.Primitive.Types
    ( SlotNo (..) )
import Control.DeepSeq
    ( NFData (..) )
import Data.Bifunctor
    ( bimap )
import Data.Either
    ( fromRight )
import Data.Quantity
    ( Percentage (..), Quantity (..), mkPercentage )
import Data.Ratio
    ( (%) )
import Data.Text.Class
    ( FromText (..), TextDecodingError (..), ToText (..) )
import Data.Time.Clock
    ( NominalDiffTime )
import Fmt
    ( Buildable, build )
import GHC.Generics
    ( Generic )
import GHC.Stack
    ( HasCallStack )
import NoThunks.Class
    ( NoThunks (..) )
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
    ( RelativeTime (..), diffRelTime )

data SyncProgress
    = Ready
    | Syncing !(Quantity "percent" Percentage)
    | NotResponding
    deriving ((forall x. SyncProgress -> Rep SyncProgress x)
-> (forall x. Rep SyncProgress x -> SyncProgress)
-> Generic SyncProgress
forall x. Rep SyncProgress x -> SyncProgress
forall x. SyncProgress -> Rep SyncProgress x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SyncProgress x -> SyncProgress
$cfrom :: forall x. SyncProgress -> Rep SyncProgress x
Generic, SyncProgress -> SyncProgress -> Bool
(SyncProgress -> SyncProgress -> Bool)
-> (SyncProgress -> SyncProgress -> Bool) -> Eq SyncProgress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SyncProgress -> SyncProgress -> Bool
$c/= :: SyncProgress -> SyncProgress -> Bool
== :: SyncProgress -> SyncProgress -> Bool
$c== :: SyncProgress -> SyncProgress -> Bool
Eq, Int -> SyncProgress -> ShowS
[SyncProgress] -> ShowS
SyncProgress -> String
(Int -> SyncProgress -> ShowS)
-> (SyncProgress -> String)
-> ([SyncProgress] -> ShowS)
-> Show SyncProgress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyncProgress] -> ShowS
$cshowList :: [SyncProgress] -> ShowS
show :: SyncProgress -> String
$cshow :: SyncProgress -> String
showsPrec :: Int -> SyncProgress -> ShowS
$cshowsPrec :: Int -> SyncProgress -> ShowS
Show)

instance NoThunks SyncProgress

instance NFData SyncProgress

instance Ord SyncProgress where
    SyncProgress
NotResponding <= :: SyncProgress -> SyncProgress -> Bool
<= SyncProgress
_ = Bool
True
    SyncProgress
_ <= SyncProgress
NotResponding = Bool
False
    SyncProgress
Ready <= SyncProgress
Ready = Bool
True
    SyncProgress
Ready <= Syncing Quantity "percent" Percentage
_ = Bool
False
    Syncing Quantity "percent" Percentage
_ <= SyncProgress
Ready = Bool
True
    Syncing Quantity "percent" Percentage
a <= Syncing Quantity "percent" Percentage
b = Quantity "percent" Percentage
a Quantity "percent" Percentage
-> Quantity "percent" Percentage -> Bool
forall a. Ord a => a -> a -> Bool
<= Quantity "percent" Percentage
b

instance Buildable SyncProgress where
    build :: SyncProgress -> Builder
build = \case
        SyncProgress
Ready ->
            Builder
"restored"
        Syncing (Quantity Percentage
p) ->
            Builder
"still restoring (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build (Percentage -> Text
forall a. ToText a => a -> Text
toText Percentage
p) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
        SyncProgress
NotResponding ->
            Builder
"not responding"


newtype SyncTolerance = SyncTolerance NominalDiffTime
    deriving stock ((forall x. SyncTolerance -> Rep SyncTolerance x)
-> (forall x. Rep SyncTolerance x -> SyncTolerance)
-> Generic SyncTolerance
forall x. Rep SyncTolerance x -> SyncTolerance
forall x. SyncTolerance -> Rep SyncTolerance x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SyncTolerance x -> SyncTolerance
$cfrom :: forall x. SyncTolerance -> Rep SyncTolerance x
Generic, SyncTolerance -> SyncTolerance -> Bool
(SyncTolerance -> SyncTolerance -> Bool)
-> (SyncTolerance -> SyncTolerance -> Bool) -> Eq SyncTolerance
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SyncTolerance -> SyncTolerance -> Bool
$c/= :: SyncTolerance -> SyncTolerance -> Bool
== :: SyncTolerance -> SyncTolerance -> Bool
$c== :: SyncTolerance -> SyncTolerance -> Bool
Eq, Int -> SyncTolerance -> ShowS
[SyncTolerance] -> ShowS
SyncTolerance -> String
(Int -> SyncTolerance -> ShowS)
-> (SyncTolerance -> String)
-> ([SyncTolerance] -> ShowS)
-> Show SyncTolerance
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyncTolerance] -> ShowS
$cshowList :: [SyncTolerance] -> ShowS
show :: SyncTolerance -> String
$cshow :: SyncTolerance -> String
showsPrec :: Int -> SyncTolerance -> ShowS
$cshowsPrec :: Int -> SyncTolerance -> ShowS
Show)

-- | Construct a 'SyncTolerance' from a number of __seconds__
mkSyncTolerance :: Int -> SyncTolerance
mkSyncTolerance :: Int -> SyncTolerance
mkSyncTolerance = NominalDiffTime -> SyncTolerance
SyncTolerance (NominalDiffTime -> SyncTolerance)
-> (Int -> NominalDiffTime) -> Int -> SyncTolerance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> NominalDiffTime
forall a. Enum a => Int -> a
toEnum (Int -> NominalDiffTime) -> (Int -> Int) -> Int -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pico)
  where
    pico :: Int
pico = Int
1_000_000_000_000

instance ToText SyncTolerance where
    toText :: SyncTolerance -> Text
toText (SyncTolerance NominalDiffTime
t) = NominalDiffTime -> Text
forall a. ToText a => a -> Text
toText NominalDiffTime
t

instance FromText SyncTolerance where
    fromText :: Text -> Either TextDecodingError SyncTolerance
fromText = (TextDecodingError -> TextDecodingError)
-> (NominalDiffTime -> SyncTolerance)
-> Either TextDecodingError NominalDiffTime
-> Either TextDecodingError SyncTolerance
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (TextDecodingError -> TextDecodingError -> TextDecodingError
forall a b. a -> b -> a
const TextDecodingError
errSyncTolerance) NominalDiffTime -> SyncTolerance
SyncTolerance (Either TextDecodingError NominalDiffTime
 -> Either TextDecodingError SyncTolerance)
-> (Text -> Either TextDecodingError NominalDiffTime)
-> Text
-> Either TextDecodingError SyncTolerance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either TextDecodingError NominalDiffTime
forall a. FromText a => Text -> Either TextDecodingError a
fromText
      where
        errSyncTolerance :: TextDecodingError
errSyncTolerance = String -> TextDecodingError
TextDecodingError (String -> TextDecodingError) -> String -> TextDecodingError
forall a b. (a -> b) -> a -> b
$ Context -> String
unwords
            [ String
"Cannot parse given time duration. Here are a few examples of"
            , String
"valid text representing a sync tolerance: '3s', '3600s', '42s'."
            ]

-- | Estimate restoration progress based on:
--
-- - The slot of the latest block consumed (our progress)
-- - The slot corresponding to the latest wall-clock time (our target)
--
-- The estimated progress is the quotient of these two quantities.
--
-- In the Cardano consensus protocol, only a fraction of slots contains blocks.
-- Hence, the progress percentage will often be < 100%,
-- as the slot corresponding to the current wall-clock time
-- may not be filled with a block.
-- The sync tolerance should be large enough to accommodate this issue.
syncProgress
    :: (HasCallStack, Monad m)
    => SyncTolerance
        -- ^ A time tolerance inside which we consider ourselves synced
    -> TimeInterpreter m
        -- ^ Converts slots to actual time.
    -> SlotNo
        -- ^ Slot of latest block consumed
    -> RelativeTime
        -- ^ Current wall clock time
    -> m SyncProgress
syncProgress :: SyncTolerance
-> TimeInterpreter m -> SlotNo -> RelativeTime -> m SyncProgress
syncProgress (SyncTolerance NominalDiffTime
tolerance) TimeInterpreter m
ti SlotNo
slot RelativeTime
now = do
    RelativeTime
timeCovered <- TimeInterpreter m -> Qry RelativeTime -> m RelativeTime
forall (m :: * -> *) a.
(HasCallStack, Monad m) =>
TimeInterpreter m -> Qry a -> m a
interpretQuery TimeInterpreter m
ti (Qry RelativeTime -> m RelativeTime)
-> Qry RelativeTime -> m RelativeTime
forall a b. (a -> b) -> a -> b
$ SlotNo -> Qry RelativeTime
slotToRelTime SlotNo
slot
    let progress :: Ratio Int
progress
            | RelativeTime
now RelativeTime -> RelativeTime -> Bool
forall a. Eq a => a -> a -> Bool
== RelativeTime
start = Ratio Int
0
            | Bool
otherwise = RelativeTime -> Int
convert RelativeTime
timeCovered Int -> Int -> Ratio Int
forall a. Integral a => a -> a -> Ratio a
% RelativeTime -> Int
convert RelativeTime
now

    if RelativeTime -> RelativeTime -> Bool
withinTolerance RelativeTime
timeCovered RelativeTime
now then
        SyncProgress -> m SyncProgress
forall (m :: * -> *) a. Monad m => a -> m a
return SyncProgress
Ready
    else
        SyncProgress -> m SyncProgress
forall (m :: * -> *) a. Monad m => a -> m a
return
        (SyncProgress -> m SyncProgress)
-> (Ratio Int -> SyncProgress) -> Ratio Int -> m SyncProgress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quantity "percent" Percentage -> SyncProgress
Syncing
        (Quantity "percent" Percentage -> SyncProgress)
-> (Ratio Int -> Quantity "percent" Percentage)
-> Ratio Int
-> SyncProgress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Percentage -> Quantity "percent" Percentage
forall (unit :: Symbol) a. a -> Quantity unit a
Quantity
        (Percentage -> Quantity "percent" Percentage)
-> (Ratio Int -> Percentage)
-> Ratio Int
-> Quantity "percent" Percentage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Percentage -> Either MkPercentageError Percentage -> Percentage
forall b a. b -> Either a b -> b
fromRight (String -> Percentage
forall a. HasCallStack => String -> a
error (String -> Percentage) -> String -> Percentage
forall a b. (a -> b) -> a -> b
$ Ratio Int -> String
forall a. Show a => a -> String
errMsg Ratio Int
progress)
        (Either MkPercentageError Percentage -> Percentage)
-> (Ratio Int -> Either MkPercentageError Percentage)
-> Ratio Int
-> Percentage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Either MkPercentageError Percentage
mkPercentage
        (Rational -> Either MkPercentageError Percentage)
-> (Ratio Int -> Rational)
-> Ratio Int
-> Either MkPercentageError Percentage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Int -> Rational
forall a. Real a => a -> Rational
toRational
        (Ratio Int -> m SyncProgress) -> Ratio Int -> m SyncProgress
forall a b. (a -> b) -> a -> b
$ Ratio Int
progress
  where
    start :: RelativeTime
start = NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
0

    convert :: RelativeTime -> Int
    convert :: RelativeTime -> Int
convert = NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Int)
-> (RelativeTime -> NominalDiffTime) -> RelativeTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000) (NominalDiffTime -> NominalDiffTime)
-> (RelativeTime -> NominalDiffTime)
-> RelativeTime
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativeTime -> NominalDiffTime
getRelativeTime

    withinTolerance :: RelativeTime -> RelativeTime -> Bool
withinTolerance RelativeTime
a RelativeTime
b =  RelativeTime
b RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` RelativeTime
a NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
tolerance

    errMsg :: a -> String
errMsg a
x = String
"syncProgress: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is out of bounds"