{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Network.Protocol.ChainSync.Codec.TimeLimits (timeLimitsChainSync) where

import Control.Monad.Class.MonadTime.SI

import Network.TypedProtocol.Codec.CBOR hiding (decode, encode)

import Ouroboros.Network.Protocol.ChainSync.Codec
import Ouroboros.Network.Protocol.ChainSync.Type
import Ouroboros.Network.Protocol.Limits

import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..))

import Data.Bifunctor (first)
import Data.Kind (Type)
import System.Random (StdGen, randomR)

-- | Time Limits
--
-- +----------------+----------------------------+-------------------------------------------------------------+
-- | Trustable peer | ChainSync State            | timeout (s)                                                 |
-- +================+============================+=============================================================+
-- |                | @'StIdle'@                 | corresponds to 'ChainSyncIdleTimeout'                       |
-- +----------------+----------------------------+-------------------------------------------------------------+
-- |                | @'StNext' 'StCanAwait'@    | 'shortWait'                                                 |
-- +----------------+----------------------------+-------------------------------------------------------------+
-- | IsNotTrustable | @'StNext' 'StMustReply'@   | randomly picked using uniform distribution from             |
-- |                |                            | the range @('minChainSyncTimeout', 'maxChainSyncTimeout')@, |
-- |                |                            | which corresponds to a chance of an empty streak of slots   |
-- |                |                            | between `0.0001%` and `1%` probability.                     |
-- +----------------+----------------------------+-------------------------------------------------------------+
-- | IsTrustable    | @'StNext' 'StMustReply'@   | 'waitForever' (i.e. never times out)                        |
-- +----------------+----------------------------+-------------------------------------------------------------+
-- |                | @'StIntersect'@            | 'shortWait'                                                 |
-- +----------------+----------------------------+-------------------------------------------------------------+
--
timeLimitsChainSync :: forall (header :: Type) (point :: Type) (tip :: Type).
                       ChainSyncIdleTimeout
                    -- ^ idle timeout, the default value
                    -- `Configuration.defaultChainSyncIdleTimeout`.
                    -> PeerTrustable
                    -> ProtocolTimeLimitsWithRnd (ChainSync header point tip)
timeLimitsChainSync :: forall header point tip.
ChainSyncIdleTimeout
-> PeerTrustable
-> ProtocolTimeLimitsWithRnd (ChainSync header point tip)
timeLimitsChainSync ChainSyncIdleTimeout
idleTimeout PeerTrustable
peerTrustable = (forall (st :: ChainSync header point tip).
 ActiveState st =>
 StateToken st -> StdGen -> (Maybe DiffTime, StdGen))
-> ProtocolTimeLimitsWithRnd (ChainSync header point tip)
forall ps.
(forall (st :: ps).
 ActiveState st =>
 StateToken st -> StdGen -> (Maybe DiffTime, StdGen))
-> ProtocolTimeLimitsWithRnd ps
ProtocolTimeLimitsWithRnd StateToken st -> StdGen -> (Maybe DiffTime, StdGen)
forall (st :: ChainSync header point tip).
ActiveState st =>
StateToken st -> StdGen -> (Maybe DiffTime, StdGen)
stateToLimit
  where
    stateToLimit :: forall (st :: ChainSync header point tip).
                    ActiveState st
                 => StateToken st -> StdGen -> (Maybe DiffTime, StdGen)
    stateToLimit :: forall (st :: ChainSync header point tip).
ActiveState st =>
StateToken st -> StdGen -> (Maybe DiffTime, StdGen)
stateToLimit StateToken st
SingChainSync st
SingIdle                 StdGen
rnd | ChainSyncIdleTimeout DiffTime
timeout <- ChainSyncIdleTimeout
idleTimeout
                                              = (DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just DiffTime
timeout, StdGen
rnd)
                                              | Bool
otherwise
                                              = (Maybe DiffTime
forall a. Maybe a
Nothing, StdGen
rnd)
    stateToLimit StateToken st
SingChainSync st
SingIntersect            StdGen
rnd = (Maybe DiffTime
shortWait, StdGen
rnd)
    stateToLimit (SingNext SingNextKind k1
SingCanAwait)  StdGen
rnd = (Maybe DiffTime
shortWait, StdGen
rnd)
    stateToLimit (SingNext SingNextKind k1
SingMustReply) StdGen
rnd =
      case PeerTrustable
peerTrustable of
        PeerTrustable
IsTrustable    -> (Maybe DiffTime
forall a. Maybe a
Nothing, StdGen
rnd)
        PeerTrustable
IsNotTrustable ->
          -- We draw from a range for which streaks of empty slots ranges
          -- from 0.0001% up to 1% probability.
          -- t = T_s [log (1-Y) / log (1-f)]
          -- Y = [0.99, 0.999...]
          -- T_s = slot length of 1s.
          -- f = 0.05
          -- The timeout is randomly picked per state to avoid all peers go down at
          -- the same time in case of a long streak of empty slots, and thus to
          -- avoid global synchronisation.  The timeout is picked uniformly from
          -- the interval 135 - 269, which corresponds to 99.9% to
          -- 99.9999% thresholds.
          let timeout :: DiffTime
              (DiffTime
timeout, StdGen
rnd') = (Double -> DiffTime) -> (Double, StdGen) -> (DiffTime, StdGen)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Double -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac
                              ((Double, StdGen) -> (DiffTime, StdGen))
-> (StdGen -> (Double, StdGen)) -> StdGen -> (DiffTime, StdGen)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double) -> StdGen -> (Double, StdGen)
forall g. RandomGen g => (Double, Double) -> g -> (Double, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR ( DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
minChainSyncTimeout :: Double
                                        , DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
maxChainSyncTimeout :: Double
                                        )
                              (StdGen -> (DiffTime, StdGen)) -> StdGen -> (DiffTime, StdGen)
forall a b. (a -> b) -> a -> b
$ StdGen
rnd
          in (DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just DiffTime
timeout, StdGen
rnd')
    stateToLimit a :: StateToken st
a@StateToken st
SingChainSync st
SingDone StdGen
rnd = (StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
a, StdGen
rnd)