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

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

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

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry
import           Ouroboros.Consensus.Util.STM (onEachChange)

{-------------------------------------------------------------------------------
  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
-------------------------------------------------------------------------------}

-- | Spawn a thread to run an action each time the slot changes
--
-- 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 'SlotId' is).
--
-- Returns a handle to kill the thread.
onKnownSlotChange :: forall m. (IOLike m, HasCallStack)
                  => ResourceRegistry m
                  -> BlockchainTime m
                  -> String            -- ^ Label for the thread
                  -> (SlotNo -> m ())  -- ^ Action to execute
                  -> m (m ())
onKnownSlotChange :: ResourceRegistry m
-> BlockchainTime m -> String -> (SlotNo -> m ()) -> m (m ())
onKnownSlotChange ResourceRegistry m
registry BlockchainTime m
btime String
label =
      (Thread m Void -> m ()) -> m (Thread m Void) -> m (m ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Thread m Void -> m ()
forall (m :: * -> *) a. IOLike m => Thread m a -> m ()
cancelThread
    (m (Thread m Void) -> m (m ()))
-> ((SlotNo -> m ()) -> m (Thread m Void))
-> (SlotNo -> m ())
-> m (m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceRegistry m
-> String
-> (SlotNo -> SlotNo)
-> Maybe SlotNo
-> STM m SlotNo
-> (SlotNo -> m ())
-> m (Thread m Void)
forall (m :: * -> *) a b.
(IOLike m, Eq b, HasCallStack) =>
ResourceRegistry m
-> String
-> (a -> b)
-> Maybe b
-> STM m a
-> (a -> m ())
-> m (Thread m Void)
onEachChange ResourceRegistry m
registry String
label SlotNo -> SlotNo
forall a. a -> a
id Maybe SlotNo
forall a. Maybe a
Nothing 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 (stm :: * -> *) a. MonadSTMTx stm => stm a
retry
          CurrentSlot SlotNo
s      -> SlotNo -> STM m SlotNo
forall (m :: * -> *) a. Monad m => a -> m a
return SlotNo
s