module Hydra.Chain.Direct.TimeHandleSpec where

import Hydra.Prelude hiding (label)
import Test.Hydra.Prelude

import Cardano.Ledger.Slot (SlotNo (SlotNo))
import Cardano.Slotting.Time (SystemStart (SystemStart))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Hydra.Chain.Direct.TimeHandle (TimeHandle (..), TimeHandleParams (..), mkTimeHandle, newTimeHandleCache, slotFromUTCTimeWith, slotToUTCTimeWith)
import Test.Hydra.Chain.Direct.TimeHandle (genTimeParams)
import Test.Hydra.Ledger.Cardano.Fixtures (eraHistoryWithHorizonAt, eraHistoryWithoutHorizon)
import Test.QuickCheck (Property, counterexample, forAllBlind, property, (===))

spec :: Spec
spec :: Spec
spec = do
  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"can roundtrip currentPointInTime" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    Gen TimeHandle -> (TimeHandle -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen TimeHandle
forall a. Arbitrary a => Gen a
arbitrary ((TimeHandle -> Property) -> Property)
-> (TimeHandle -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \TimeHandle{Either Text PointInTime
currentPointInTime :: Either Text PointInTime
$sel:currentPointInTime:TimeHandle :: TimeHandle -> Either Text PointInTime
currentPointInTime, SlotNo -> Either Text UTCTime
slotToUTCTime :: SlotNo -> Either Text UTCTime
$sel:slotToUTCTime:TimeHandle :: TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime, UTCTime -> Either Text SlotNo
slotFromUTCTime :: UTCTime -> Either Text SlotNo
$sel:slotFromUTCTime:TimeHandle :: TimeHandle -> UTCTime -> Either Text SlotNo
slotFromUTCTime} ->
      let onLeft :: Text -> Property
          onLeft :: Text -> Property
onLeft Text
err = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Conversion failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
err)
       in (Text -> Property)
-> (Property -> Property) -> Either Text Property -> Property
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Property
onLeft Property -> Property
forall a. a -> a
id (Either Text Property -> Property)
-> Either Text Property -> Property
forall a b. (a -> b) -> a -> b
$ do
            (SlotNo
slot, UTCTime
_) <- Either Text PointInTime
currentPointInTime
            SlotNo
res <- UTCTime -> Either Text SlotNo
slotFromUTCTime (UTCTime -> Either Text SlotNo)
-> Either Text UTCTime -> Either Text SlotNo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SlotNo -> Either Text UTCTime
slotToUTCTime SlotNo
slot
            Property -> Either Text Property
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Either Text Property)
-> Property -> Either Text Property
forall a b. (a -> b) -> a -> b
$ SlotNo
res SlotNo -> SlotNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== SlotNo
slot

  String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"should convert slot within latest/current era" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
    let currentSlotNo :: SlotNo
currentSlotNo = Word64 -> SlotNo
SlotNo Word64
13
        systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0
        eraHistory :: EraHistory
eraHistory = SlotNo -> EraHistory
eraHistoryWithHorizonAt SlotNo
15
        timeHandle :: TimeHandle
timeHandle = SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
currentSlotNo SystemStart
systemStart EraHistory
eraHistory
        slotInside :: SlotNo
slotInside = Word64 -> SlotNo
SlotNo Word64
14
        converted :: Either Text UTCTime
converted = TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime TimeHandle
timeHandle SlotNo
slotInside
        expected :: Either Text UTCTime
        expected :: Either Text UTCTime
expected = UTCTime -> Either Text UTCTime
forall a b. b -> Either a b
Right (UTCTime -> Either Text UTCTime) -> UTCTime -> Either Text UTCTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
14
    Either Text UTCTime
converted Either Text UTCTime -> Either Text UTCTime -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Either Text UTCTime
expected

  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"slotToUTCTimeWith/slotFromUTCTimeWith roundtrip within the horizon" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    Gen TimeHandleParams -> (TimeHandleParams -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen TimeHandleParams
genTimeParams ((TimeHandleParams -> Property) -> Property)
-> (TimeHandleParams -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \TimeHandleParams{SystemStart
systemStart :: SystemStart
$sel:systemStart:TimeHandleParams :: TimeHandleParams -> SystemStart
systemStart, EraHistory
eraHistory :: EraHistory
$sel:eraHistory:TimeHandleParams :: TimeHandleParams -> EraHistory
eraHistory, SlotNo
currentSlot :: SlotNo
$sel:currentSlot:TimeHandleParams :: TimeHandleParams -> SlotNo
currentSlot} ->
      (SystemStart -> EraHistory -> UTCTime -> Either Text SlotNo
slotFromUTCTimeWith SystemStart
systemStart EraHistory
eraHistory (UTCTime -> Either Text SlotNo)
-> Either Text UTCTime -> Either Text SlotNo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SystemStart -> EraHistory -> SlotNo -> Either Text UTCTime
slotToUTCTimeWith SystemStart
systemStart EraHistory
eraHistory SlotNo
currentSlot)
        Either Text SlotNo -> Either Text SlotNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== SlotNo -> Either Text SlotNo
forall a b. b -> Either a b
Right SlotNo
currentSlot

  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"slotToUTCTimeWith fails past the horizon" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    Gen TimeHandleParams -> (TimeHandleParams -> Bool) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen TimeHandleParams
genTimeParams ((TimeHandleParams -> Bool) -> Property)
-> (TimeHandleParams -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \TimeHandleParams{SystemStart
$sel:systemStart:TimeHandleParams :: TimeHandleParams -> SystemStart
systemStart :: SystemStart
systemStart, EraHistory
$sel:eraHistory:TimeHandleParams :: TimeHandleParams -> EraHistory
eraHistory :: EraHistory
eraHistory, SlotNo
horizonSlot :: SlotNo
$sel:horizonSlot:TimeHandleParams :: TimeHandleParams -> SlotNo
horizonSlot} ->
      Either Text UTCTime -> Bool
forall a b. Either a b -> Bool
isLeft (SystemStart -> EraHistory -> SlotNo -> Either Text UTCTime
slotToUTCTimeWith SystemStart
systemStart EraHistory
eraHistory (SlotNo
horizonSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1))

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"newTimeHandleCache" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"queries system start and era history only once" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
systemStartQueries <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      IORef Int
eraHistoryQueries <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      SlotNo -> IO TimeHandle
getTimeHandle <-
        IO SystemStart -> IO EraHistory -> IO (SlotNo -> IO TimeHandle)
forall (m :: * -> *).
MonadLabelledSTM m =>
m SystemStart -> m EraHistory -> m (SlotNo -> m TimeHandle)
newTimeHandleCache
          (IORef Int -> (Int -> Int) -> Expectation
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef Int
systemStartQueries (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Expectation -> SystemStart -> IO SystemStart
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> UTCTime -> SystemStart
SystemStart (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0))
          (IORef Int -> (Int -> Int) -> Expectation
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef Int
eraHistoryQueries (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Expectation -> EraHistory -> IO EraHistory
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> EraHistory
eraHistoryWithoutHorizon)
      [Word64] -> (Word64 -> IO TimeHandle) -> Expectation
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Word64
0 .. Word64
4] (SlotNo -> IO TimeHandle
getTimeHandle (SlotNo -> IO TimeHandle)
-> (Word64 -> SlotNo) -> Word64 -> IO TimeHandle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo)
      IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
systemStartQueries IO Int -> Int -> Expectation
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Int
1
      IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
eraHistoryQueries IO Int -> Int -> Expectation
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Int
1

    String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"refreshes era history when the demanded slot is past the horizon" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
eraHistoryQueries <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      SlotNo -> IO TimeHandle
getTimeHandle <-
        IO SystemStart -> IO EraHistory -> IO (SlotNo -> IO TimeHandle)
forall (m :: * -> *).
MonadLabelledSTM m =>
m SystemStart -> m EraHistory -> m (SlotNo -> m TimeHandle)
newTimeHandleCache
          (SystemStart -> IO SystemStart
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SystemStart -> IO SystemStart)
-> (UTCTime -> SystemStart) -> UTCTime -> IO SystemStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> SystemStart
SystemStart (UTCTime -> IO SystemStart) -> UTCTime -> IO SystemStart
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0)
          ( do
              Int
n <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
eraHistoryQueries
              IORef Int -> (Int -> Int) -> Expectation
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef Int
eraHistoryQueries (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
              EraHistory -> IO EraHistory
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EraHistory -> IO EraHistory) -> EraHistory -> IO EraHistory
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then SlotNo -> EraHistory
eraHistoryWithHorizonAt SlotNo
1 else EraHistory
eraHistoryWithoutHorizon
          )
      TimeHandle{SlotNo -> Either Text UTCTime
$sel:slotToUTCTime:TimeHandle :: TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime :: SlotNo -> Either Text UTCTime
slotToUTCTime} <- SlotNo -> IO TimeHandle
getTimeHandle SlotNo
5
      IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
eraHistoryQueries IO Int -> Int -> Expectation
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Int
2
      SlotNo -> Either Text UTCTime
slotToUTCTime SlotNo
5 Either Text UTCTime -> Either Text UTCTime -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` UTCTime -> Either Text UTCTime
forall a b. b -> Either a b
Right (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
5)

    String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"degrades gracefully when refreshing does not extend the horizon" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
eraHistoryQueries <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      SlotNo -> IO TimeHandle
getTimeHandle <-
        IO SystemStart -> IO EraHistory -> IO (SlotNo -> IO TimeHandle)
forall (m :: * -> *).
MonadLabelledSTM m =>
m SystemStart -> m EraHistory -> m (SlotNo -> m TimeHandle)
newTimeHandleCache
          (SystemStart -> IO SystemStart
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SystemStart -> IO SystemStart)
-> (UTCTime -> SystemStart) -> UTCTime -> IO SystemStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> SystemStart
SystemStart (UTCTime -> IO SystemStart) -> UTCTime -> IO SystemStart
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0)
          (IORef Int -> (Int -> Int) -> Expectation
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef Int
eraHistoryQueries (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Expectation -> EraHistory -> IO EraHistory
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SlotNo -> EraHistory
eraHistoryWithHorizonAt SlotNo
1)
      TimeHandle{Either Text PointInTime
$sel:currentPointInTime:TimeHandle :: TimeHandle -> Either Text PointInTime
currentPointInTime :: Either Text PointInTime
currentPointInTime, SlotNo -> Either Text UTCTime
$sel:slotToUTCTime:TimeHandle :: TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime :: SlotNo -> Either Text UTCTime
slotToUTCTime} <- SlotNo -> IO TimeHandle
getTimeHandle SlotNo
5
      IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
eraHistoryQueries IO Int -> Int -> Expectation
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Int
2
      Either Text PointInTime
currentPointInTime Either Text PointInTime
-> (Either Text PointInTime -> Bool) -> Expectation
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` Either Text PointInTime -> Bool
forall a b. Either a b -> Bool
isLeft
      SlotNo -> Either Text UTCTime
slotToUTCTime SlotNo
0 Either Text UTCTime -> Either Text UTCTime -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` UTCTime -> Either Text UTCTime
forall a b. b -> Either a b
Right (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0)