{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Consensus.BlockchainTime.API (
    BlockchainTime (..)
  , CurrentSlot (..)
  , knownSlotWatcher
  ) where

import           GHC.Generics (Generic)
import           NoThunks.Class (OnlyCheckWhnfNamed (..))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.STM (Watcher (..))

{-------------------------------------------------------------------------------
  API
-------------------------------------------------------------------------------}

-- | Blockchain time
--
-- When we run the blockchain, there is a single, global time. We abstract over
-- this here to allow to query this time (in terms of the current slot), and
-- execute an action each time we advance a slot.
data BlockchainTime m = BlockchainTime {
      -- | Get current slot
      BlockchainTime m -> STM m CurrentSlot
getCurrentSlot :: STM m CurrentSlot
    }
  deriving Context -> BlockchainTime m -> IO (Maybe ThunkInfo)
Proxy (BlockchainTime m) -> String
(Context -> BlockchainTime m -> IO (Maybe ThunkInfo))
-> (Context -> BlockchainTime m -> IO (Maybe ThunkInfo))
-> (Proxy (BlockchainTime m) -> String)
-> NoThunks (BlockchainTime m)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *).
Context -> BlockchainTime m -> IO (Maybe ThunkInfo)
forall (m :: * -> *). Proxy (BlockchainTime m) -> String
showTypeOf :: Proxy (BlockchainTime m) -> String
$cshowTypeOf :: forall (m :: * -> *). Proxy (BlockchainTime m) -> String
wNoThunks :: Context -> BlockchainTime m -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *).
Context -> BlockchainTime m -> IO (Maybe ThunkInfo)
noThunks :: Context -> BlockchainTime m -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (m :: * -> *).
Context -> BlockchainTime m -> IO (Maybe ThunkInfo)
NoThunks
       via OnlyCheckWhnfNamed "BlockchainTime" (BlockchainTime m)

data CurrentSlot =
    -- | The current slot is known
    CurrentSlot !SlotNo

    -- | The current slot is not yet known
    --
    -- This only happens when the tip of the ledger is so far behind that we
    -- lack the information necessary to translate the current 'UTCTime' into a
    -- 'SlotNo'. This should only be the case during syncing.
  | CurrentSlotUnknown
  deriving stock    ((forall x. CurrentSlot -> Rep CurrentSlot x)
-> (forall x. Rep CurrentSlot x -> CurrentSlot)
-> Generic CurrentSlot
forall x. Rep CurrentSlot x -> CurrentSlot
forall x. CurrentSlot -> Rep CurrentSlot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CurrentSlot x -> CurrentSlot
$cfrom :: forall x. CurrentSlot -> Rep CurrentSlot x
Generic, Int -> CurrentSlot -> ShowS
[CurrentSlot] -> ShowS
CurrentSlot -> String
(Int -> CurrentSlot -> ShowS)
-> (CurrentSlot -> String)
-> ([CurrentSlot] -> ShowS)
-> Show CurrentSlot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CurrentSlot] -> ShowS
$cshowList :: [CurrentSlot] -> ShowS
show :: CurrentSlot -> String
$cshow :: CurrentSlot -> String
showsPrec :: Int -> CurrentSlot -> ShowS
$cshowsPrec :: Int -> CurrentSlot -> ShowS
Show)
  deriving anyclass (Context -> CurrentSlot -> IO (Maybe ThunkInfo)
Proxy CurrentSlot -> String
(Context -> CurrentSlot -> IO (Maybe ThunkInfo))
-> (Context -> CurrentSlot -> IO (Maybe ThunkInfo))
-> (Proxy CurrentSlot -> String)
-> NoThunks CurrentSlot
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy CurrentSlot -> String
$cshowTypeOf :: Proxy CurrentSlot -> String
wNoThunks :: Context -> CurrentSlot -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> CurrentSlot -> IO (Maybe ThunkInfo)
noThunks :: Context -> CurrentSlot -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> CurrentSlot -> IO (Maybe ThunkInfo)
NoThunks)

{-------------------------------------------------------------------------------
  Derived functionality
-------------------------------------------------------------------------------}

-- | Watches for changes in the current slot
--
-- The action will not be called until the current slot becomes known
-- (if the tip of our ledger is too far away from the current wallclock time,
-- we may not know what the current 'SlotNo' is).
knownSlotWatcher :: forall m. IOLike m
                 => BlockchainTime m
                 -> (SlotNo -> m ())  -- ^ Action to execute
                 -> Watcher m SlotNo SlotNo
knownSlotWatcher :: BlockchainTime m -> (SlotNo -> m ()) -> Watcher m SlotNo SlotNo
knownSlotWatcher BlockchainTime m
btime SlotNo -> m ()
notify =
    Watcher :: forall (m :: * -> *) a fp.
(a -> fp) -> Maybe fp -> (a -> m ()) -> STM m a -> Watcher m a fp
Watcher {
        wFingerprint :: SlotNo -> SlotNo
wFingerprint = SlotNo -> SlotNo
forall a. a -> a
id
      , wInitial :: Maybe SlotNo
wInitial     = Maybe SlotNo
forall a. Maybe a
Nothing
      , wNotify :: SlotNo -> m ()
wNotify      = SlotNo -> m ()
notify
      , wReader :: STM m SlotNo
wReader      = STM m SlotNo
getCurrentSlot'
      }
  where
    getCurrentSlot' :: STM m SlotNo
    getCurrentSlot' :: STM m SlotNo
getCurrentSlot' = do
        CurrentSlot
mSlot <- BlockchainTime m -> STM m CurrentSlot
forall (m :: * -> *). BlockchainTime m -> STM m CurrentSlot
getCurrentSlot BlockchainTime m
btime
        case CurrentSlot
mSlot of
          CurrentSlot
CurrentSlotUnknown -> STM m SlotNo
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
          CurrentSlot SlotNo
s      -> SlotNo -> STM m SlotNo
forall (m :: * -> *) a. Monad m => a -> m a
return SlotNo
s