{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Contains tools for converting between @SlotNo@, @EpochNo@, @SlotInEpoch@,
-- @UTCTime@.

module Cardano.Wallet.Primitive.Slotting
    ( -- ** Queries
      Qry
    , currentEpoch
    , epochOf
    , slotToUTCTime
    , slotToRelTime
    , toSlotId
    , slotRangeFromRelativeTimeRange
    , slotRangeFromTimeRange
    , firstSlotInEpoch
    , ongoingSlotAt
    , ceilingSlotAt
    , timeOfEpoch
    , getStartTime

      -- ** Blockchain-relative times
    , RelativeTime
    , toRelativeTime
    , toRelativeTimeRange
    , fromRelativeTime
    , addRelTime

      -- ** Blockchain-absolute times
    , SystemStart
    , getSystemStart

      -- ** What's the time?
    , currentRelativeTime
    , getCurrentTimeRelativeFromStart

      -- ** Running queries
    , TimeInterpreter
    , mkSingleEraInterpreter
    , mkTimeInterpreter
    , PastHorizonException (..)
    , interpretQuery
    , TimeInterpreterLog (..)

      -- ** EpochInfo
    , EpochInfo
    , toEpochInfo

      -- ** Combinators for running queries
    , unsafeExtendSafeZone
    , neverFails
    , snapshot
    , hoistTimeInterpreter
    , expectAndThrowFailures
    ) where

import Prelude

import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasSeverityAnnotation (..) )
import Cardano.Slotting.EpochInfo.API
    ( EpochInfo )
import Cardano.Wallet.Orphans
    ()
import Cardano.Wallet.Primitive.Types
    ( EpochLength (..)
    , EpochNo (..)
    , Range (..)
    , SlotId (..)
    , SlotInEpoch (..)
    , SlotLength (..)
    , SlotNo (..)
    , SlottingParameters (..)
    , StartTime (..)
    )
import Control.Monad
    ( ap, join, liftM, (>=>) )
import Control.Monad.IO.Class
    ( MonadIO, liftIO )
import Control.Monad.Trans.Class
    ( lift )
import Control.Monad.Trans.Except
    ( ExceptT (..), runExceptT )
import Control.Tracer
    ( Tracer, contramap, natTracer, nullTracer, traceWith )
import Data.Coerce
    ( coerce )
import Data.Functor.Identity
    ( Identity )
import Data.Generics.Internal.VL.Lens
    ( (^.) )
import Data.Kind
    ( Type )
import Data.Maybe
    ( fromMaybe )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..) )
import Data.Time.Clock
    ( NominalDiffTime, UTCTime, addUTCTime, getCurrentTime )
import Data.Word
    ( Word32, Word64 )
import Fmt
    ( blockListF', build, fmt, indentF )
import GHC.Stack
    ( CallStack, HasCallStack, getCallStack, prettySrcLoc )
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
    ( RelativeTime (..), SystemStart (SystemStart), addRelTime )
import Ouroboros.Consensus.HardFork.History.EpochInfo
    ( interpreterToEpochInfo )
import Ouroboros.Consensus.HardFork.History.Qry
    ( Expr (..)
    , Interpreter
    , PastHorizonException (..)
    , epochToSlot'
    , mkInterpreter
    , qryFromExpr
    , slotToEpoch'
    , slotToWallclock
    , wallclockToSlot
    )
import Ouroboros.Consensus.HardFork.History.Summary
    ( neverForksSummary )
import UnliftIO.Exception
    ( throwIO )

import qualified Cardano.Slotting.Slot as Cardano
import qualified Data.Text as T
import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as Cardano
import qualified Ouroboros.Consensus.HardFork.History.Qry as HF
import qualified Ouroboros.Consensus.HardFork.History.Summary as HF

{-------------------------------------------------------------------------------
                                    Queries
-------------------------------------------------------------------------------}

-- | A query for time, slot and epoch conversions. Can be interpreted using
-- @interpretQuery@.
--
-- == Differences to the underlying consensus 'Ouroboros.Consensus.HardFork.History.Qry.Qry'
--
-- @HF.Qry@ can only be interpreted in a
-- single era. If you have
--
-- @
--     q1 = epochOf someSlotInByron
--     q2 = epochOf someSlotInShelley
-- @
--
-- @HF.interpretQuery@ could interpret both individually, but
--
-- @
--    q3 = q1 >> q2
-- @
--
-- would fail.
--
-- This wrapper exists to fix this.
--
-- We also provide @QStartTime@.
--
data Qry :: Type -> Type where
    -- | A @HF.Qry@ can only be run inside a single era.
    EraContainedQry :: HF.Qry a -> Qry a
    QStartTime :: Qry StartTime
    QPure :: a -> Qry a
    QBind :: Qry a -> (a -> Qry b) -> Qry b

instance Functor Qry where
    fmap :: (a -> b) -> Qry a -> Qry b
fmap = (a -> b) -> Qry a -> Qry b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative Qry where
    pure :: a -> Qry a
pure  = a -> Qry a
forall a. a -> Qry a
QPure
    <*> :: Qry (a -> b) -> Qry a -> Qry b
(<*>) = Qry (a -> b) -> Qry a -> Qry b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Qry where
    return :: a -> Qry a
return = a -> Qry a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    >>= :: Qry a -> (a -> Qry b) -> Qry b
(>>=)  = Qry a -> (a -> Qry b) -> Qry b
forall a b. Qry a -> (a -> Qry b) -> Qry b
QBind

runQuery
     :: HasCallStack
     => StartTime
     -> Interpreter xs
     -> Qry a
     -> Either HF.PastHorizonException a
runQuery :: StartTime
-> Interpreter xs -> Qry a -> Either PastHorizonException a
runQuery StartTime
startTime Interpreter xs
int = Qry a -> Either PastHorizonException a
forall a. Qry a -> Either PastHorizonException a
go
  where
     go :: Qry a -> Either HF.PastHorizonException a
     go :: Qry a -> Either PastHorizonException a
go (EraContainedQry Qry a
q) = Interpreter xs -> Qry a -> Either PastHorizonException a
forall (xs :: [*]) a.
HasCallStack =>
Interpreter xs -> Qry a -> Either PastHorizonException a
HF.interpretQuery Interpreter xs
int Qry a
q
     go (QPure a
a) =
          a -> Either PastHorizonException a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
     go (QBind Qry a
x a -> Qry a
f) = do
          Qry a -> Either PastHorizonException a
forall a. Qry a -> Either PastHorizonException a
go Qry a
x Either PastHorizonException a
-> (a -> Either PastHorizonException a)
-> Either PastHorizonException a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Qry a -> Either PastHorizonException a
forall a. Qry a -> Either PastHorizonException a
go (Qry a -> Either PastHorizonException a)
-> (a -> Qry a) -> a -> Either PastHorizonException a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Qry a
f
     go (Qry a
QStartTime) =
        StartTime -> Either PastHorizonException StartTime
forall (m :: * -> *) a. Monad m => a -> m a
return StartTime
startTime

-- | Query the blockchain start time. This is part of the 'TimeInterpreter'
-- environment.
getStartTime :: Qry StartTime
getStartTime :: Qry StartTime
getStartTime = Qry StartTime
QStartTime

-- | Query the epoch corresponding to a flat slot number.
epochOf :: SlotNo -> Qry EpochNo
epochOf :: SlotNo -> Qry EpochNo
epochOf SlotNo
slot = SlotId -> EpochNo
epochNumber (SlotId -> EpochNo) -> Qry SlotId -> Qry EpochNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> Qry SlotId
toSlotId SlotNo
slot

-- | Query to convert a flat 'SlotNo' to a 'SlotId', which is the epoch number,
-- and the local slot index.
toSlotId :: SlotNo -> Qry SlotId
toSlotId :: SlotNo -> Qry SlotId
toSlotId SlotNo
slot = do
    (EpochNo
e, Word64
s) <- Qry (EpochNo, Word64) -> Qry (EpochNo, Word64)
forall a. Qry a -> Qry a
EraContainedQry (Qry (EpochNo, Word64) -> Qry (EpochNo, Word64))
-> Qry (EpochNo, Word64) -> Qry (EpochNo, Word64)
forall a b. (a -> b) -> a -> b
$ SlotNo -> Qry (EpochNo, Word64)
slotToEpoch' SlotNo
slot
    SlotId -> Qry SlotId
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotId -> Qry SlotId) -> SlotId -> Qry SlotId
forall a b. (a -> b) -> a -> b
$ EpochNo -> SlotInEpoch -> SlotId
SlotId
        (Word31 -> EpochNo
EpochNo (Word31 -> EpochNo) -> Word31 -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word64 -> Word31
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word31) -> Word64 -> Word31
forall a b. (a -> b) -> a -> b
$ EpochNo -> Word64
Cardano.unEpochNo EpochNo
e)
        (Word32 -> SlotInEpoch
SlotInEpoch (Word32 -> SlotInEpoch) -> Word32 -> SlotInEpoch
forall a b. (a -> b) -> a -> b
$ Word64 -> Word32
downCast Word64
s)
  where
    downCast :: Word64 -> Word32
    downCast :: Word64 -> Word32
downCast = Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Query the absolute time at which a slot starts.
slotToUTCTime :: SlotNo -> Qry UTCTime
slotToUTCTime :: SlotNo -> Qry UTCTime
slotToUTCTime SlotNo
sl = SlotNo -> Qry RelativeTime
slotToRelTime SlotNo
sl Qry RelativeTime -> (RelativeTime -> Qry UTCTime) -> Qry UTCTime
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RelativeTime -> Qry UTCTime
fromRelativeTime

-- | Query the relative time at which a slot starts.
slotToRelTime :: SlotNo -> Qry RelativeTime
slotToRelTime :: SlotNo -> Qry RelativeTime
slotToRelTime = Qry RelativeTime -> Qry RelativeTime
forall a. Qry a -> Qry a
EraContainedQry (Qry RelativeTime -> Qry RelativeTime)
-> (SlotNo -> Qry RelativeTime) -> SlotNo -> Qry RelativeTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RelativeTime, SlotLength) -> RelativeTime)
-> Qry (RelativeTime, SlotLength) -> Qry RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RelativeTime, SlotLength) -> RelativeTime
forall a b. (a, b) -> a
fst (Qry (RelativeTime, SlotLength) -> Qry RelativeTime)
-> (SlotNo -> Qry (RelativeTime, SlotLength))
-> SlotNo
-> Qry RelativeTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Qry (RelativeTime, SlotLength)
slotToWallclock

-- | Query the absolute times at which an epoch starts and ends.
--
-- Querying the end time of /this/ epoch is preferable to querying the start
-- time of the /next/ epoch, because the next epoch may be outside the forecast
-- range, and result in 'PastHorizonException'.
timeOfEpoch :: EpochNo -> Qry (UTCTime, UTCTime)
timeOfEpoch :: EpochNo -> Qry (UTCTime, UTCTime)
timeOfEpoch EpochNo
epoch = do
    SlotNo
ref <- EpochNo -> Qry SlotNo
firstSlotInEpoch EpochNo
epoch
    UTCTime
refTime <- SlotNo -> Qry UTCTime
slotToUTCTime SlotNo
ref
    EpochSize
el <- Qry EpochSize -> Qry EpochSize
forall a. Qry a -> Qry a
EraContainedQry (Qry EpochSize -> Qry EpochSize) -> Qry EpochSize -> Qry EpochSize
forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *). Expr f EpochSize) -> Qry EpochSize
forall a. (forall (f :: * -> *). Expr f a) -> Qry a
qryFromExpr ((forall (f :: * -> *). Expr f EpochSize) -> Qry EpochSize)
-> (forall (f :: * -> *). Expr f EpochSize) -> Qry EpochSize
forall a b. (a -> b) -> a -> b
$ Expr f EpochNo -> Expr f EpochSize
forall (f :: * -> *). Expr f EpochNo -> Expr f EpochSize
EEpochSize (Expr f EpochNo -> Expr f EpochSize)
-> Expr f EpochNo -> Expr f EpochSize
forall a b. (a -> b) -> a -> b
$ EpochNo -> Expr f EpochNo
forall a (f :: * -> *). Show a => a -> Expr f a
ELit (EpochNo -> Expr f EpochNo) -> EpochNo -> Expr f EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochNo
toCardanoEpochNo EpochNo
epoch
    SlotLength
sl <- Qry SlotLength -> Qry SlotLength
forall a. Qry a -> Qry a
EraContainedQry (Qry SlotLength -> Qry SlotLength)
-> Qry SlotLength -> Qry SlotLength
forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *). Expr f SlotLength) -> Qry SlotLength
forall a. (forall (f :: * -> *). Expr f a) -> Qry a
qryFromExpr ((forall (f :: * -> *). Expr f SlotLength) -> Qry SlotLength)
-> (forall (f :: * -> *). Expr f SlotLength) -> Qry SlotLength
forall a b. (a -> b) -> a -> b
$ Expr f SlotNo -> Expr f SlotLength
forall (f :: * -> *). Expr f SlotNo -> Expr f SlotLength
ESlotLength (Expr f SlotNo -> Expr f SlotLength)
-> Expr f SlotNo -> Expr f SlotLength
forall a b. (a -> b) -> a -> b
$ SlotNo -> Expr f SlotNo
forall a (f :: * -> *). Show a => a -> Expr f a
ELit SlotNo
ref

    let convert :: Word64 -> NominalDiffTime
convert = Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> NominalDiffTime)
-> (Word64 -> Rational) -> Word64 -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Rational
forall a. Real a => a -> Rational
toRational
    let el' :: NominalDiffTime
el' = Word64 -> NominalDiffTime
convert (Word64 -> NominalDiffTime) -> Word64 -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ EpochSize -> Word64
Cardano.unEpochSize EpochSize
el
    let sl' :: NominalDiffTime
sl' = SlotLength -> NominalDiffTime
Cardano.getSlotLength SlotLength
sl

    let timeInEpoch :: NominalDiffTime
timeInEpoch = NominalDiffTime
el' NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
sl'

    (UTCTime, UTCTime) -> Qry (UTCTime, UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
refTime, NominalDiffTime
timeInEpoch NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
refTime)
  where
    toCardanoEpochNo :: EpochNo -> EpochNo
toCardanoEpochNo (EpochNo Word31
e) = Word64 -> EpochNo
Cardano.EpochNo (Word64 -> EpochNo) -> Word64 -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word31 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word31
e

-- | Translate 'EpochNo' to the 'SlotNo' of the first slot in that epoch
firstSlotInEpoch :: EpochNo -> Qry SlotNo
firstSlotInEpoch :: EpochNo -> Qry SlotNo
firstSlotInEpoch = Qry SlotNo -> Qry SlotNo
forall a. Qry a -> Qry a
EraContainedQry (Qry SlotNo -> Qry SlotNo)
-> (EpochNo -> Qry SlotNo) -> EpochNo -> Qry SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochNo -> Qry SlotNo
epochToSlot' (EpochNo -> Qry SlotNo)
-> (EpochNo -> EpochNo) -> EpochNo -> Qry SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochNo -> EpochNo
convertEpochNo
  where
    convertEpochNo :: EpochNo -> EpochNo
convertEpochNo (EpochNo Word31
e) = Word64 -> EpochNo
Cardano.EpochNo (Word64 -> EpochNo) -> Word64 -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word31 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word31
e

-- @@
--     slot:
--     |1--------|2----------
--
--     result of onGoingSlotAt:
--     ●---------○
--          1
--               ●----------○
--                    2
-- @@
--
--
ongoingSlotAt :: RelativeTime -> Qry SlotNo
ongoingSlotAt :: RelativeTime -> Qry SlotNo
ongoingSlotAt = ((SlotNo, NominalDiffTime) -> SlotNo)
-> Qry (SlotNo, NominalDiffTime) -> Qry SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SlotNo, NominalDiffTime) -> SlotNo
forall a b. (a, b) -> a
fst (Qry (SlotNo, NominalDiffTime) -> Qry SlotNo)
-> (RelativeTime -> Qry (SlotNo, NominalDiffTime))
-> RelativeTime
-> Qry SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativeTime -> Qry (SlotNo, NominalDiffTime)
slotAtTimeDetailed

-- @@
--     slot:
--     |1--------|2----------
--
--     result of ceilingSlotAt:
--     ○---------●
--          2
--               ○----------●
--                    3
-- @@
--
ceilingSlotAt :: RelativeTime -> Qry SlotNo
ceilingSlotAt :: RelativeTime -> Qry SlotNo
ceilingSlotAt = ((SlotNo, NominalDiffTime) -> SlotNo)
-> Qry (SlotNo, NominalDiffTime) -> Qry SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SlotNo, NominalDiffTime) -> SlotNo
forall a a. (Eq a, Num a, Num a) => (a, a) -> a
ceil2 (Qry (SlotNo, NominalDiffTime) -> Qry SlotNo)
-> (RelativeTime -> Qry (SlotNo, NominalDiffTime))
-> RelativeTime
-> Qry SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativeTime -> Qry (SlotNo, NominalDiffTime)
slotAtTimeDetailed
  where
    ceil2 :: (a, a) -> a
ceil2 (a
s, a
0) = a
s
    ceil2 (a
s, a
_) = a
s a -> a -> a
forall a. Num a => a -> a -> a
+ a
1

-- | Helper that returns @(slot, elapsedTimeInSlot)@ for a
-- given @UTCTime@.
slotAtTimeDetailed :: RelativeTime -> Qry (SlotNo, NominalDiffTime)
slotAtTimeDetailed :: RelativeTime -> Qry (SlotNo, NominalDiffTime)
slotAtTimeDetailed = Qry (SlotNo, NominalDiffTime) -> Qry (SlotNo, NominalDiffTime)
forall a. Qry a -> Qry a
EraContainedQry (Qry (SlotNo, NominalDiffTime) -> Qry (SlotNo, NominalDiffTime))
-> (RelativeTime -> Qry (SlotNo, NominalDiffTime))
-> RelativeTime
-> Qry (SlotNo, NominalDiffTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SlotNo, NominalDiffTime, NominalDiffTime)
 -> (SlotNo, NominalDiffTime))
-> Qry (SlotNo, NominalDiffTime, NominalDiffTime)
-> Qry (SlotNo, NominalDiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SlotNo, NominalDiffTime, NominalDiffTime)
-> (SlotNo, NominalDiffTime)
forall a b c. (a, b, c) -> (a, b)
dropThird (Qry (SlotNo, NominalDiffTime, NominalDiffTime)
 -> Qry (SlotNo, NominalDiffTime))
-> (RelativeTime -> Qry (SlotNo, NominalDiffTime, NominalDiffTime))
-> RelativeTime
-> Qry (SlotNo, NominalDiffTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativeTime -> Qry (SlotNo, NominalDiffTime, NominalDiffTime)
wallclockToSlot
  where
    dropThird :: (a, b, c) -> (a, b)
dropThird (a
a, b
b, c
_) = (a
a, b
b)

-- | This function returns a chain-relative time range if (and only if) the
-- specified UTC time range intersects with the life of the blockchain.
--
-- If, on the other hand, the specified time range terminates before the start
-- of the blockchain, this function returns 'Nothing'.
toRelativeTimeRange :: Range UTCTime -> StartTime -> Maybe (Range RelativeTime)
toRelativeTimeRange :: Range UTCTime -> StartTime -> Maybe (Range RelativeTime)
toRelativeTimeRange Range UTCTime
range StartTime
start = case StartTime -> UTCTime -> Maybe RelativeTime
toRelativeTime StartTime
start (UTCTime -> Maybe RelativeTime)
-> Range UTCTime -> Range (Maybe RelativeTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range UTCTime
range of
    Range Maybe (Maybe RelativeTime)
_ (Just Maybe RelativeTime
Nothing) -> Maybe (Range RelativeTime)
forall a. Maybe a
Nothing
    Range Maybe (Maybe RelativeTime)
a Maybe (Maybe RelativeTime)
b -> Range RelativeTime -> Maybe (Range RelativeTime)
forall a. a -> Maybe a
Just (Maybe RelativeTime -> Maybe RelativeTime -> Range RelativeTime
forall a. Maybe a -> Maybe a -> Range a
Range (RelativeTime -> Maybe RelativeTime -> RelativeTime
forall a. a -> Maybe a -> a
fromMaybe (NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
0) (Maybe RelativeTime -> RelativeTime)
-> Maybe (Maybe RelativeTime) -> Maybe RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe RelativeTime)
a) (Maybe (Maybe RelativeTime) -> Maybe RelativeTime
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe RelativeTime)
b))

-- | Transforms the given inclusive time range into an inclusive slot range.
slotRangeFromRelativeTimeRange :: Range RelativeTime -> Qry (Range SlotNo)
slotRangeFromRelativeTimeRange :: Range RelativeTime -> Qry (Range SlotNo)
slotRangeFromRelativeTimeRange (Range Maybe RelativeTime
a Maybe RelativeTime
b) =
    Maybe SlotNo -> Maybe SlotNo -> Range SlotNo
forall a. Maybe a -> Maybe a -> Range a
Range (Maybe SlotNo -> Maybe SlotNo -> Range SlotNo)
-> Qry (Maybe SlotNo) -> Qry (Maybe SlotNo -> Range SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RelativeTime -> Qry SlotNo)
-> Maybe RelativeTime -> Qry (Maybe SlotNo)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse RelativeTime -> Qry SlotNo
ceilingSlotAt Maybe RelativeTime
a Qry (Maybe SlotNo -> Range SlotNo)
-> Qry (Maybe SlotNo) -> Qry (Range SlotNo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RelativeTime -> Qry SlotNo)
-> Maybe RelativeTime -> Qry (Maybe SlotNo)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse RelativeTime -> Qry SlotNo
ongoingSlotAt Maybe RelativeTime
b

slotRangeFromTimeRange :: Range UTCTime -> Qry (Maybe (Range SlotNo))
slotRangeFromTimeRange :: Range UTCTime -> Qry (Maybe (Range SlotNo))
slotRangeFromTimeRange Range UTCTime
range = Qry StartTime
getStartTime Qry StartTime
-> (StartTime -> Qry (Maybe (Range SlotNo)))
-> Qry (Maybe (Range SlotNo))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (Range RelativeTime -> Qry (Range SlotNo))
-> Maybe (Range RelativeTime) -> Qry (Maybe (Range SlotNo))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Range RelativeTime -> Qry (Range SlotNo)
slotRangeFromRelativeTimeRange (Maybe (Range RelativeTime) -> Qry (Maybe (Range SlotNo)))
-> (StartTime -> Maybe (Range RelativeTime))
-> StartTime
-> Qry (Maybe (Range SlotNo))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range UTCTime -> StartTime -> Maybe (Range RelativeTime)
toRelativeTimeRange Range UTCTime
range

{-------------------------------------------------------------------------------
                            Blockchain-relative time
-------------------------------------------------------------------------------}

-- | Same as 'Cardano.toRelativeTime', but has error handling for times before
-- the system start. No other functions in this module will accept UTC times.
toRelativeTime :: StartTime -> UTCTime -> Maybe RelativeTime
toRelativeTime :: StartTime -> UTCTime -> Maybe RelativeTime
toRelativeTime (StartTime UTCTime
start) UTCTime
utc
    | UTCTime
utc UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
start = Maybe RelativeTime
forall a. Maybe a
Nothing
    | Bool
otherwise = RelativeTime -> Maybe RelativeTime
forall a. a -> Maybe a
Just (RelativeTime -> Maybe RelativeTime)
-> RelativeTime -> Maybe RelativeTime
forall a b. (a -> b) -> a -> b
$ SystemStart -> UTCTime -> RelativeTime
Cardano.toRelativeTime (UTCTime -> SystemStart
SystemStart UTCTime
start) UTCTime
utc

-- | Convert an absolute time to a relative time. If the absolute time is before
-- the system start, consider the relative time to be the system start
-- time. This function can never fail.
toRelativeTimeOrZero :: StartTime -> UTCTime -> RelativeTime
toRelativeTimeOrZero :: StartTime -> UTCTime -> RelativeTime
toRelativeTimeOrZero StartTime
start = RelativeTime -> Maybe RelativeTime -> RelativeTime
forall a. a -> Maybe a -> a
fromMaybe (NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
0) (Maybe RelativeTime -> RelativeTime)
-> (UTCTime -> Maybe RelativeTime) -> UTCTime -> RelativeTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StartTime -> UTCTime -> Maybe RelativeTime
toRelativeTime StartTime
start

-- | Query the absolute time corresponding to a blockchain-relative time.
fromRelativeTime :: RelativeTime -> Qry UTCTime
fromRelativeTime :: RelativeTime -> Qry UTCTime
fromRelativeTime RelativeTime
t = do
    StartTime
start <- Qry StartTime
getStartTime
    UTCTime -> Qry UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SystemStart -> RelativeTime -> UTCTime
Cardano.fromRelativeTime (StartTime -> SystemStart
coerce StartTime
start) RelativeTime
t)

{-------------------------------------------------------------------------------
                                What's the time?
-------------------------------------------------------------------------------}

-- | The current system time, compared to the given blockchain start time.
--
-- If the current time is before the system start (this would only happen when
-- launching testnets), let's just say we're in epoch 0.
--
-- TODO: Use io-sim-classes for easier testing.
getCurrentTimeRelativeFromStart :: StartTime -> IO RelativeTime
getCurrentTimeRelativeFromStart :: StartTime -> IO RelativeTime
getCurrentTimeRelativeFromStart StartTime
start =
    StartTime -> UTCTime -> RelativeTime
toRelativeTimeOrZero StartTime
start (UTCTime -> RelativeTime) -> IO UTCTime -> IO RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime

-- | The current system time, compared to the blockchain start time of the given
-- 'TimeInterpreter'.
--
-- If the current time is before the system start (this would only happen when
-- launching testnets), the relative time is reported as 0.
currentRelativeTime :: MonadIO m => TimeInterpreter n -> m RelativeTime
currentRelativeTime :: TimeInterpreter n -> m RelativeTime
currentRelativeTime =
    IO RelativeTime -> m RelativeTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RelativeTime -> m RelativeTime)
-> (TimeInterpreter n -> IO RelativeTime)
-> TimeInterpreter n
-> m RelativeTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StartTime -> IO RelativeTime
getCurrentTimeRelativeFromStart (StartTime -> IO RelativeTime)
-> (TimeInterpreter n -> StartTime)
-> TimeInterpreter n
-> IO RelativeTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeInterpreter n -> StartTime
forall (m :: * -> *). TimeInterpreter m -> StartTime
blockchainStartTime

-- | Note: This fails when the node is far enough behind that we in the present
-- are beyond its safe zone.
currentEpoch :: MonadIO m => TimeInterpreter m -> m EpochNo
currentEpoch :: TimeInterpreter m -> m EpochNo
currentEpoch TimeInterpreter m
ti = do
    RelativeTime
now <- TimeInterpreter m -> m RelativeTime
forall (m :: * -> *) (n :: * -> *).
MonadIO m =>
TimeInterpreter n -> m RelativeTime
currentRelativeTime TimeInterpreter m
ti
    TimeInterpreter m -> Qry EpochNo -> m EpochNo
forall (m :: * -> *) a.
(HasCallStack, Monad m) =>
TimeInterpreter m -> Qry a -> m a
interpretQuery TimeInterpreter m
ti (RelativeTime -> Qry SlotNo
ongoingSlotAt RelativeTime
now Qry SlotNo -> (SlotNo -> Qry EpochNo) -> Qry EpochNo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SlotNo -> Qry EpochNo
epochOf)

{-------------------------------------------------------------------------------
                                Time Interpreter
-------------------------------------------------------------------------------}

-- | A @TimeInterpreter@ is a way for the wallet to run things of type @Qry a@,
-- with a system start time as context.
data TimeInterpreter m = forall eras. TimeInterpreter
    { ()
interpreter :: m (Interpreter eras)
    , TimeInterpreter m -> StartTime
blockchainStartTime :: StartTime
    , TimeInterpreter m -> Tracer m TimeInterpreterLog
tracer :: Tracer m TimeInterpreterLog
    , TimeInterpreter m -> forall a. Either PastHorizonException a -> m a
handleResult :: forall a. Either PastHorizonException a -> m a
    }

toEpochInfo
    :: forall m. (Applicative m)
    => TimeInterpreter m
    -> m (EpochInfo (ExceptT PastHorizonException Identity))
toEpochInfo :: TimeInterpreter m
-> m (EpochInfo (ExceptT PastHorizonException Identity))
toEpochInfo TimeInterpreter{m (Interpreter eras)
interpreter :: m (Interpreter eras)
interpreter :: ()
interpreter} =
    Interpreter eras
-> EpochInfo (ExceptT PastHorizonException Identity)
forall (xs :: [*]).
Interpreter xs -> EpochInfo (ExceptT PastHorizonException Identity)
interpreterToEpochInfo (Interpreter eras
 -> EpochInfo (ExceptT PastHorizonException Identity))
-> m (Interpreter eras)
-> m (EpochInfo (ExceptT PastHorizonException Identity))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Interpreter eras)
interpreter

getSystemStart :: TimeInterpreter m -> SystemStart
getSystemStart :: TimeInterpreter m -> SystemStart
getSystemStart TimeInterpreter{StartTime
blockchainStartTime :: StartTime
blockchainStartTime :: forall (m :: * -> *). TimeInterpreter m -> StartTime
blockchainStartTime} =
    let (StartTime UTCTime
t) = StartTime
blockchainStartTime in UTCTime -> SystemStart
SystemStart UTCTime
t

data TimeInterpreterLog
    = MsgInterpreterPastHorizon
        (Maybe String) -- ^ Reason for why the failure should be impossible
        StartTime
        PastHorizonException
    deriving (TimeInterpreterLog -> TimeInterpreterLog -> Bool
(TimeInterpreterLog -> TimeInterpreterLog -> Bool)
-> (TimeInterpreterLog -> TimeInterpreterLog -> Bool)
-> Eq TimeInterpreterLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeInterpreterLog -> TimeInterpreterLog -> Bool
$c/= :: TimeInterpreterLog -> TimeInterpreterLog -> Bool
== :: TimeInterpreterLog -> TimeInterpreterLog -> Bool
$c== :: TimeInterpreterLog -> TimeInterpreterLog -> Bool
Eq, Int -> TimeInterpreterLog -> ShowS
[TimeInterpreterLog] -> ShowS
TimeInterpreterLog -> String
(Int -> TimeInterpreterLog -> ShowS)
-> (TimeInterpreterLog -> String)
-> ([TimeInterpreterLog] -> ShowS)
-> Show TimeInterpreterLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeInterpreterLog] -> ShowS
$cshowList :: [TimeInterpreterLog] -> ShowS
show :: TimeInterpreterLog -> String
$cshow :: TimeInterpreterLog -> String
showsPrec :: Int -> TimeInterpreterLog -> ShowS
$cshowsPrec :: Int -> TimeInterpreterLog -> ShowS
Show)

instance HasSeverityAnnotation TimeInterpreterLog where
    getSeverityAnnotation :: TimeInterpreterLog -> Severity
getSeverityAnnotation = \case
        MsgInterpreterPastHorizon Maybe String
Nothing StartTime
_ PastHorizonException
_ -> Severity
Notice
        MsgInterpreterPastHorizon{} -> Severity
Error

instance ToText TimeInterpreterLog where
    toText :: TimeInterpreterLog -> Text
toText = \case
        MsgInterpreterPastHorizon Maybe String
Nothing StartTime
t0 PastHorizonException
e -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Time interpreter queried past the horizon. "
            , PastHorizonException -> StartTime -> Text
forall a. Show a => PastHorizonException -> a -> Text
renderPastHorizonException PastHorizonException
e StartTime
t0
            ]
        MsgInterpreterPastHorizon (Just String
reason) StartTime
t0 PastHorizonException
e -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Time interpreter queried past the horizon. "
            , Text
"This should not happen because "
            , String -> Text
T.pack String
reason
            , PastHorizonException -> StartTime -> Text
forall a. Show a => PastHorizonException -> a -> Text
renderPastHorizonException PastHorizonException
e StartTime
t0
            ]
      where
        renderPastHorizonException :: PastHorizonException -> a -> Text
renderPastHorizonException (PastHorizon CallStack
callStack Some ClosedExpr
expr [EraSummary]
eras) a
t0 = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"\nCalled from:\n"
            , CallStack -> Text
prettyCallStackTop CallStack
callStack
            , Text
"\nConverting expression:\n"
            , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Some ClosedExpr -> String
forall a. Show a => a -> String
show Some ClosedExpr
expr
            , Text
"\n\nWith knowledge about the following eras:\n"
            , Builder -> Text
forall b. FromBuilder b => Builder -> b
fmt (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Builder -> Builder
indentF Int
4 (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> (EraSummary -> Builder) -> [EraSummary] -> Builder
forall (f :: * -> *) a.
Foldable f =>
Text -> (a -> Builder) -> f a -> Builder
blockListF' Text
"-" EraSummary -> Builder
eraSummaryF [EraSummary]
eras
            , Text
"\nt0 = "
            , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
t0
            ]

        prettyCallStackTop :: CallStack -> Text
        prettyCallStackTop :: CallStack -> Text
prettyCallStackTop CallStack
callStack =
            case [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
callStack) of
                ((String
_, SrcLoc
srcLoc):[(String, SrcLoc)]
_rest) -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String
prettySrcLoc SrcLoc
srcLoc
                [(String, SrcLoc)]
_ -> Text
"Unknown"

        eraSummaryF :: EraSummary -> Builder
eraSummaryF (HF.EraSummary Bound
start EraEnd
end EraParams
_params) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Bound -> Builder
boundF Bound
start
            , Builder
" to "
            , EraEnd -> Builder
endF EraEnd
end
            ]

        endF :: EraEnd -> Builder
endF (HF.EraEnd Bound
b) = Bound -> Builder
boundF Bound
b
        endF (EraEnd
HF.EraUnbounded) = Builder
"<unbounded>"

        boundF :: Bound -> Builder
boundF (HF.Bound RelativeTime
_time SlotNo
_slot EpochNo
epoch) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ String -> Builder
forall p. Buildable p => p -> Builder
build (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ EpochNo -> String
forall a. Show a => a -> String
show EpochNo
epoch
            ]


-- | Run a query.
interpretQuery
    :: HasCallStack
    => Monad m
    => TimeInterpreter m
    -> Qry a
    -> m a
interpretQuery :: TimeInterpreter m -> Qry a -> m a
interpretQuery (TimeInterpreter m (Interpreter eras)
getI StartTime
start Tracer m TimeInterpreterLog
tr forall a. Either PastHorizonException a -> m a
handleRes) Qry a
qry = do
    Interpreter eras
i <- m (Interpreter eras)
getI
    let res :: Either PastHorizonException a
res = StartTime
-> Interpreter eras -> Qry a -> Either PastHorizonException a
forall (xs :: [*]) a.
HasCallStack =>
StartTime
-> Interpreter xs -> Qry a -> Either PastHorizonException a
runQuery StartTime
start Interpreter eras
i Qry a
qry
    case Either PastHorizonException a
res of
        Left PastHorizonException
e -> do
            Tracer m TimeInterpreterLog -> TimeInterpreterLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TimeInterpreterLog
tr (TimeInterpreterLog -> m ()) -> TimeInterpreterLog -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe String
-> StartTime -> PastHorizonException -> TimeInterpreterLog
MsgInterpreterPastHorizon Maybe String
forall a. Maybe a
Nothing StartTime
start PastHorizonException
e
        Right a
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Either PastHorizonException a -> m a
forall a. Either PastHorizonException a -> m a
handleRes Either PastHorizonException a
res

-- | An 'Interpreter' for a single era, where the @SlottingParameters@ cannot
-- change.
--
-- Queries will never fail with @mkSingleEraInterpreter@.
mkSingleEraInterpreter
    :: HasCallStack
    => StartTime
    -> SlottingParameters
    -> TimeInterpreter Identity
mkSingleEraInterpreter :: StartTime -> SlottingParameters -> TimeInterpreter Identity
mkSingleEraInterpreter StartTime
start SlottingParameters
sp = TimeInterpreter :: forall (m :: * -> *) (eras :: [*]).
m (Interpreter eras)
-> StartTime
-> Tracer m TimeInterpreterLog
-> (forall a. Either PastHorizonException a -> m a)
-> TimeInterpreter m
TimeInterpreter
    { interpreter :: Identity (Interpreter '[Any])
interpreter = Interpreter '[Any] -> Identity (Interpreter '[Any])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Interpreter '[Any]
int
    , blockchainStartTime :: StartTime
blockchainStartTime = StartTime
start
    , tracer :: Tracer Identity TimeInterpreterLog
tracer = Tracer Identity TimeInterpreterLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , handleResult :: forall a. Either PastHorizonException a -> Identity a
handleResult = (PastHorizonException -> Identity a)
-> (a -> Identity a) -> Either PastHorizonException a -> Identity a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PastHorizonException -> Identity a
forall a a. Show a => a -> a
bomb a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    }
  where
    int :: Interpreter '[Any]
int = Summary '[Any] -> Interpreter '[Any]
forall (xs :: [*]). Summary xs -> Interpreter xs
mkInterpreter Summary '[Any]
summary
    summary :: Summary '[Any]
summary = EpochSize -> SlotLength -> Summary '[Any]
forall x. EpochSize -> SlotLength -> Summary '[x]
neverForksSummary EpochSize
sz SlotLength
len
    sz :: EpochSize
sz = Word64 -> EpochSize
Cardano.EpochSize (Word64 -> EpochSize) -> Word64 -> EpochSize
forall a b. (a -> b) -> a -> b
$ Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> Word32 -> Word64
forall a b. (a -> b) -> a -> b
$ EpochLength -> Word32
unEpochLength (EpochLength -> Word32) -> EpochLength -> Word32
forall a b. (a -> b) -> a -> b
$ SlottingParameters
sp SlottingParameters
-> ((EpochLength -> Const EpochLength EpochLength)
    -> SlottingParameters -> Const EpochLength SlottingParameters)
-> EpochLength
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "getEpochLength"
  ((EpochLength -> Const EpochLength EpochLength)
   -> SlottingParameters -> Const EpochLength SlottingParameters)
(EpochLength -> Const EpochLength EpochLength)
-> SlottingParameters -> Const EpochLength SlottingParameters
#getEpochLength
    len :: SlotLength
len = NominalDiffTime -> SlotLength
Cardano.mkSlotLength (NominalDiffTime -> SlotLength) -> NominalDiffTime -> SlotLength
forall a b. (a -> b) -> a -> b
$ SlotLength -> NominalDiffTime
unSlotLength (SlotLength -> NominalDiffTime) -> SlotLength -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ SlottingParameters
sp SlottingParameters
-> ((SlotLength -> Const SlotLength SlotLength)
    -> SlottingParameters -> Const SlotLength SlottingParameters)
-> SlotLength
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "getSlotLength"
  ((SlotLength -> Const SlotLength SlotLength)
   -> SlottingParameters -> Const SlotLength SlottingParameters)
(SlotLength -> Const SlotLength SlotLength)
-> SlottingParameters -> Const SlotLength SlottingParameters
#getSlotLength

    bomb :: a -> a
bomb a
x = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"mkSingleEraInterpreter: the impossible happened: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x

-- | Set up a 'TimeInterpreter' for a given start time, and an 'Interpreter'
-- queried from the ledger layer.
mkTimeInterpreter
    :: Monad m
    => Tracer m TimeInterpreterLog
    -> StartTime
    -> m (Interpreter eras)
    -> TimeInterpreter (ExceptT PastHorizonException m)
mkTimeInterpreter :: Tracer m TimeInterpreterLog
-> StartTime
-> m (Interpreter eras)
-> TimeInterpreter (ExceptT PastHorizonException m)
mkTimeInterpreter Tracer m TimeInterpreterLog
tr StartTime
start m (Interpreter eras)
int = TimeInterpreter :: forall (m :: * -> *) (eras :: [*]).
m (Interpreter eras)
-> StartTime
-> Tracer m TimeInterpreterLog
-> (forall a. Either PastHorizonException a -> m a)
-> TimeInterpreter m
TimeInterpreter
    { interpreter :: ExceptT PastHorizonException m (Interpreter eras)
interpreter = m (Interpreter eras)
-> ExceptT PastHorizonException m (Interpreter eras)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Interpreter eras)
int
    , blockchainStartTime :: StartTime
blockchainStartTime = StartTime
start
    , tracer :: Tracer (ExceptT PastHorizonException m) TimeInterpreterLog
tracer = (forall x. m x -> ExceptT PastHorizonException m x)
-> Tracer m TimeInterpreterLog
-> Tracer (ExceptT PastHorizonException m) TimeInterpreterLog
forall (m :: * -> *) (n :: * -> *) s.
(forall x. m x -> n x) -> Tracer m s -> Tracer n s
natTracer forall x. m x -> ExceptT PastHorizonException m x
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Tracer m TimeInterpreterLog
tr
    , handleResult :: forall a.
Either PastHorizonException a -> ExceptT PastHorizonException m a
handleResult = m (Either PastHorizonException a)
-> ExceptT PastHorizonException m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either PastHorizonException a)
 -> ExceptT PastHorizonException m a)
-> (Either PastHorizonException a
    -> m (Either PastHorizonException a))
-> Either PastHorizonException a
-> ExceptT PastHorizonException m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either PastHorizonException a -> m (Either PastHorizonException a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    }

{-------------------------------------------------------------------------------
                        Time Interpreter combinators
-------------------------------------------------------------------------------}

-- | Takes a motivation of why @TimeInterpreter@ shouldn't fail interpreting
-- queries.
--
-- Unexpected @PastHorizonException@s will be thrown in IO, and traced with
-- Error severity along with the provided motivation.
neverFails
    :: String
    -> TimeInterpreter (ExceptT PastHorizonException IO)
    -> TimeInterpreter IO
neverFails :: String
-> TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
neverFails String
reason =
    TimeInterpreter IO -> TimeInterpreter IO
f (TimeInterpreter IO -> TimeInterpreter IO)
-> (TimeInterpreter (ExceptT PastHorizonException IO)
    -> TimeInterpreter IO)
-> TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ExceptT PastHorizonException IO a -> IO a)
-> TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> TimeInterpreter m -> TimeInterpreter n
hoistTimeInterpreter (ExceptT PastHorizonException IO a
-> IO (Either PastHorizonException a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PastHorizonException IO a
 -> IO (Either PastHorizonException a))
-> (Either PastHorizonException a -> IO a)
-> ExceptT PastHorizonException IO a
-> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (PastHorizonException -> IO a)
-> (a -> IO a) -> Either PastHorizonException a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PastHorizonException -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
  where
    f :: TimeInterpreter IO -> TimeInterpreter IO
f (TimeInterpreter IO (Interpreter eras)
getI StartTime
ss Tracer IO TimeInterpreterLog
tr forall a. Either PastHorizonException a -> IO a
h) = TimeInterpreter :: forall (m :: * -> *) (eras :: [*]).
m (Interpreter eras)
-> StartTime
-> Tracer m TimeInterpreterLog
-> (forall a. Either PastHorizonException a -> m a)
-> TimeInterpreter m
TimeInterpreter
        { interpreter :: IO (Interpreter eras)
interpreter = IO (Interpreter eras)
getI
        , blockchainStartTime :: StartTime
blockchainStartTime = StartTime
ss
        , tracer :: Tracer IO TimeInterpreterLog
tracer = (TimeInterpreterLog -> TimeInterpreterLog)
-> Tracer IO TimeInterpreterLog -> Tracer IO TimeInterpreterLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (String -> TimeInterpreterLog -> TimeInterpreterLog
setReason String
reason) Tracer IO TimeInterpreterLog
tr
        , handleResult :: forall a. Either PastHorizonException a -> IO a
handleResult = forall a. Either PastHorizonException a -> IO a
h
        }
    setReason :: String -> TimeInterpreterLog -> TimeInterpreterLog
setReason String
r (MsgInterpreterPastHorizon Maybe String
_ StartTime
t0 PastHorizonException
e)
        = Maybe String
-> StartTime -> PastHorizonException -> TimeInterpreterLog
MsgInterpreterPastHorizon (String -> Maybe String
forall a. a -> Maybe a
Just String
r) StartTime
t0 PastHorizonException
e

-- | Makes @PastHorizonException@ be thrown in @IO@.
--
-- Will /not/ cause @PastHorizonException@ to be tracer with Error severity,
-- unlike @neverFails@.
expectAndThrowFailures
    :: TimeInterpreter (ExceptT PastHorizonException IO)
    -> TimeInterpreter IO
expectAndThrowFailures :: TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
expectAndThrowFailures = (forall a. ExceptT PastHorizonException IO a -> IO a)
-> TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> TimeInterpreter m -> TimeInterpreter n
hoistTimeInterpreter (ExceptT PastHorizonException IO a
-> IO (Either PastHorizonException a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PastHorizonException IO a
 -> IO (Either PastHorizonException a))
-> (Either PastHorizonException a -> IO a)
-> ExceptT PastHorizonException IO a
-> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Either PastHorizonException a -> IO a
forall (f :: * -> *) e a.
(MonadIO f, Exception e) =>
Either e a -> f a
eitherToIO)
  where
    eitherToIO :: Either e a -> f a
eitherToIO (Right a
x) = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    eitherToIO (Left e
e) = e -> f a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO e
e

-- | Pre-fetches a snapshot of the epoch history from the node, such that the
-- resulting 'TimeInterpreter' doesn't require 'IO'.
--
-- Please consider /not/ using this function, as it disables all logging.
snapshot
    :: TimeInterpreter (ExceptT PastHorizonException IO)
    -> IO (TimeInterpreter (Either PastHorizonException))
snapshot :: TimeInterpreter (ExceptT PastHorizonException IO)
-> IO (TimeInterpreter (Either PastHorizonException))
snapshot (TimeInterpreter ExceptT PastHorizonException IO (Interpreter eras)
getI StartTime
ss Tracer (ExceptT PastHorizonException IO) TimeInterpreterLog
_tr forall a.
Either PastHorizonException a -> ExceptT PastHorizonException IO a
_h) = do
    Either PastHorizonException (Interpreter eras)
i <- ExceptT PastHorizonException IO (Interpreter eras)
-> IO (Either PastHorizonException (Interpreter eras))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT PastHorizonException IO (Interpreter eras)
getI
    TimeInterpreter (Either PastHorizonException)
-> IO (TimeInterpreter (Either PastHorizonException))
forall (m :: * -> *) a. Monad m => a -> m a
return TimeInterpreter :: forall (m :: * -> *) (eras :: [*]).
m (Interpreter eras)
-> StartTime
-> Tracer m TimeInterpreterLog
-> (forall a. Either PastHorizonException a -> m a)
-> TimeInterpreter m
TimeInterpreter
        { interpreter :: Either PastHorizonException (Interpreter eras)
interpreter = Either PastHorizonException (Interpreter eras)
i
        , blockchainStartTime :: StartTime
blockchainStartTime = StartTime
ss
        , tracer :: Tracer (Either PastHorizonException) TimeInterpreterLog
tracer = Tracer (Either PastHorizonException) TimeInterpreterLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        , handleResult :: forall a.
Either PastHorizonException a -> Either PastHorizonException a
handleResult = forall a. a -> a
forall a.
Either PastHorizonException a -> Either PastHorizonException a
id
        }

-- | Change the underlying monad of the TimeInterpreter with a natural
-- transformation.
hoistTimeInterpreter
    :: (forall a. m a -> n a)
    -> TimeInterpreter m
    -> TimeInterpreter n
hoistTimeInterpreter :: (forall a. m a -> n a) -> TimeInterpreter m -> TimeInterpreter n
hoistTimeInterpreter forall a. m a -> n a
f (TimeInterpreter m (Interpreter eras)
getI StartTime
ss Tracer m TimeInterpreterLog
tr forall a. Either PastHorizonException a -> m a
h) = TimeInterpreter :: forall (m :: * -> *) (eras :: [*]).
m (Interpreter eras)
-> StartTime
-> Tracer m TimeInterpreterLog
-> (forall a. Either PastHorizonException a -> m a)
-> TimeInterpreter m
TimeInterpreter
    { interpreter :: n (Interpreter eras)
interpreter = m (Interpreter eras) -> n (Interpreter eras)
forall a. m a -> n a
f m (Interpreter eras)
getI
     -- NOTE: interpreter ti cannot throw PastHorizonException, but
     -- this way we don't have to carry around yet another type parameter.
    , blockchainStartTime :: StartTime
blockchainStartTime = StartTime
ss
    , tracer :: Tracer n TimeInterpreterLog
tracer = (forall a. m a -> n a)
-> Tracer m TimeInterpreterLog -> Tracer n TimeInterpreterLog
forall (m :: * -> *) (n :: * -> *) s.
(forall x. m x -> n x) -> Tracer m s -> Tracer n s
natTracer forall a. m a -> n a
f Tracer m TimeInterpreterLog
tr
    , handleResult :: forall a. Either PastHorizonException a -> n a
handleResult = m a -> n a
forall a. m a -> n a
f (m a -> n a)
-> (Either PastHorizonException a -> m a)
-> Either PastHorizonException a
-> n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either PastHorizonException a -> m a
forall a. Either PastHorizonException a -> m a
h
    }

-- | Extend the safe zone to make the TimeInterpreter return predictions where
-- it otherwise would have failed with @PastHorizonException@. This should be
-- used with great caution, and if we can get away from it, that would also be
-- great. Also ADP-575.
--
-- From the underlying ouroboros-consensus function:
--
-- UNSAFE: extend the safe zone of the current era of the given 'Interpreter'
-- to be /unbounded/, ignoring any future hard forks.
--
-- This only has effect when the 'Interpreter' was obtained in an era that was
-- /not the final one/ (in the final era, this is a no-op). The 'Interpreter'
-- will be made to believe that the current era is the final era, making its
-- horizon unbounded, and thus never returning a 'PastHorizonException'.
--
-- Use of this function is /strongly discouraged/, as it will ignore any future
-- hard forks, and the results produced by the 'Interpreter' can thus be
-- incorrect.
unsafeExtendSafeZone
    :: TimeInterpreter (ExceptT PastHorizonException IO)
    -> TimeInterpreter IO
unsafeExtendSafeZone :: TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
unsafeExtendSafeZone = TimeInterpreter IO -> TimeInterpreter IO
forall (m :: * -> *).
Functor m =>
TimeInterpreter m -> TimeInterpreter m
f (TimeInterpreter IO -> TimeInterpreter IO)
-> (TimeInterpreter (ExceptT PastHorizonException IO)
    -> TimeInterpreter IO)
-> TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
neverFails String
r
  where
    f :: TimeInterpreter m -> TimeInterpreter m
f (TimeInterpreter m (Interpreter eras)
getI StartTime
ss Tracer m TimeInterpreterLog
tr forall a. Either PastHorizonException a -> m a
h) = TimeInterpreter :: forall (m :: * -> *) (eras :: [*]).
m (Interpreter eras)
-> StartTime
-> Tracer m TimeInterpreterLog
-> (forall a. Either PastHorizonException a -> m a)
-> TimeInterpreter m
TimeInterpreter
        { interpreter :: m (Interpreter eras)
interpreter = Interpreter eras -> Interpreter eras
forall (xs :: [*]). Interpreter xs -> Interpreter xs
HF.unsafeExtendSafeZone (Interpreter eras -> Interpreter eras)
-> m (Interpreter eras) -> m (Interpreter eras)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Interpreter eras)
getI
        , blockchainStartTime :: StartTime
blockchainStartTime = StartTime
ss
        , tracer :: Tracer m TimeInterpreterLog
tracer = Tracer m TimeInterpreterLog
tr
        , handleResult :: forall a. Either PastHorizonException a -> m a
handleResult = forall a. Either PastHorizonException a -> m a
h
        }
    r :: String
r = String
"unsafeExtendSafeZone should make PastHorizonExceptions impossible."