{-# LANGUAGE UndecidableInstances #-}

module Hydra.Node.State where

import Hydra.Prelude

import Data.Map.Strict qualified as Map
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Hydra.Chain.ChainState (ChainSlot, IsChainState (..), chainStateSlot)
import Hydra.HeadLogic.State (HeadState (Idle), IdleState (..))
import Hydra.Tx (
  HeadId,
  IsTx (..),
 )

type PendingDeposits tx = Map (TxIdType tx) (Deposit tx)

data ChainPointTime = ChainPointTime
  { ChainPointTime -> ChainSlot
currentSlot :: ChainSlot
  -- ^ Latest chain slot as observed on chain.
  , ChainPointTime -> UTCTime
currentChainTime :: UTCTime
  -- ^ Time corresponding to `currentSlot`.
  , ChainPointTime -> POSIXTime
drift :: NominalDiffTime
  -- ^ Time difference with current system wall-clock measured in seconds
  }
  deriving stock (ChainPointTime -> ChainPointTime -> Bool
(ChainPointTime -> ChainPointTime -> Bool)
-> (ChainPointTime -> ChainPointTime -> Bool) -> Eq ChainPointTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainPointTime -> ChainPointTime -> Bool
== :: ChainPointTime -> ChainPointTime -> Bool
$c/= :: ChainPointTime -> ChainPointTime -> Bool
/= :: ChainPointTime -> ChainPointTime -> Bool
Eq, Int -> ChainPointTime -> ShowS
[ChainPointTime] -> ShowS
ChainPointTime -> String
(Int -> ChainPointTime -> ShowS)
-> (ChainPointTime -> String)
-> ([ChainPointTime] -> ShowS)
-> Show ChainPointTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainPointTime -> ShowS
showsPrec :: Int -> ChainPointTime -> ShowS
$cshow :: ChainPointTime -> String
show :: ChainPointTime -> String
$cshowList :: [ChainPointTime] -> ShowS
showList :: [ChainPointTime] -> ShowS
Show, (forall x. ChainPointTime -> Rep ChainPointTime x)
-> (forall x. Rep ChainPointTime x -> ChainPointTime)
-> Generic ChainPointTime
forall x. Rep ChainPointTime x -> ChainPointTime
forall x. ChainPointTime -> Rep ChainPointTime x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainPointTime -> Rep ChainPointTime x
from :: forall x. ChainPointTime -> Rep ChainPointTime x
$cto :: forall x. Rep ChainPointTime x -> ChainPointTime
to :: forall x. Rep ChainPointTime x -> ChainPointTime
Generic)
  deriving anyclass ([ChainPointTime] -> Value
[ChainPointTime] -> Encoding
ChainPointTime -> Bool
ChainPointTime -> Value
ChainPointTime -> Encoding
(ChainPointTime -> Value)
-> (ChainPointTime -> Encoding)
-> ([ChainPointTime] -> Value)
-> ([ChainPointTime] -> Encoding)
-> (ChainPointTime -> Bool)
-> ToJSON ChainPointTime
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ChainPointTime -> Value
toJSON :: ChainPointTime -> Value
$ctoEncoding :: ChainPointTime -> Encoding
toEncoding :: ChainPointTime -> Encoding
$ctoJSONList :: [ChainPointTime] -> Value
toJSONList :: [ChainPointTime] -> Value
$ctoEncodingList :: [ChainPointTime] -> Encoding
toEncodingList :: [ChainPointTime] -> Encoding
$comitField :: ChainPointTime -> Bool
omitField :: ChainPointTime -> Bool
ToJSON, Maybe ChainPointTime
Value -> Parser [ChainPointTime]
Value -> Parser ChainPointTime
(Value -> Parser ChainPointTime)
-> (Value -> Parser [ChainPointTime])
-> Maybe ChainPointTime
-> FromJSON ChainPointTime
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ChainPointTime
parseJSON :: Value -> Parser ChainPointTime
$cparseJSONList :: Value -> Parser [ChainPointTime]
parseJSONList :: Value -> Parser [ChainPointTime]
$comittedField :: Maybe ChainPointTime
omittedField :: Maybe ChainPointTime
FromJSON)

instance ToCBOR ChainPointTime where
  toCBOR :: ChainPointTime -> Encoding
toCBOR = ChainPointTime -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR ChainPointTime where
  fromCBOR :: forall s. Decoder s ChainPointTime
fromCBOR = Decoder s ChainPointTime
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

data NodeState tx
  = -- | Normal operation of the node where it is connected and has a recent
    -- view of the chain.
    NodeInSync
      { forall tx. NodeState tx -> HeadState tx
headState :: HeadState tx
      , forall tx. NodeState tx -> PendingDeposits tx
pendingDeposits :: PendingDeposits tx
      -- ^ Pending deposits as observed on chain.
      -- TODO: could even move the chain state here (also see todo below)
      -- , chainState :: ChainStateType tx
      , forall tx. NodeState tx -> ChainPointTime
chainPointTime :: ChainPointTime
      }
  | -- | Node is catching up on its view of the chain and should behave
    -- differently.
    NodeCatchingUp
      { headState :: HeadState tx
      , pendingDeposits :: PendingDeposits tx
      -- ^ Pending deposits as observed on chain.
      -- TODO: could even move the chain state here (also see todo below)
      -- , chainState :: ChainStateType tx
      , chainPointTime :: ChainPointTime
      }
  deriving stock ((forall x. NodeState tx -> Rep (NodeState tx) x)
-> (forall x. Rep (NodeState tx) x -> NodeState tx)
-> Generic (NodeState tx)
forall x. Rep (NodeState tx) x -> NodeState tx
forall x. NodeState tx -> Rep (NodeState tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (NodeState tx) x -> NodeState tx
forall tx x. NodeState tx -> Rep (NodeState tx) x
$cfrom :: forall tx x. NodeState tx -> Rep (NodeState tx) x
from :: forall x. NodeState tx -> Rep (NodeState tx) x
$cto :: forall tx x. Rep (NodeState tx) x -> NodeState tx
to :: forall x. Rep (NodeState tx) x -> NodeState tx
Generic)

deriving stock instance (IsTx tx, Eq (ChainStateType tx)) => Eq (NodeState tx)
deriving stock instance (IsTx tx, Show (ChainStateType tx)) => Show (NodeState tx)
deriving anyclass instance (IsTx tx, ToJSON (ChainStateType tx)) => ToJSON (NodeState tx)
deriving anyclass instance (IsTx tx, FromJSON (ChainStateType tx)) => FromJSON (NodeState tx)

instance IsChainState tx => ToCBOR (NodeState tx) where
  toCBOR :: NodeState tx -> Encoding
toCBOR = NodeState tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance IsChainState tx => FromCBOR (NodeState tx) where
  fromCBOR :: forall s. Decoder s (NodeState tx)
fromCBOR = Decoder s (NodeState tx)
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

initNodeState :: IsChainState tx => ChainStateType tx -> NodeState tx
initNodeState :: forall tx. IsChainState tx => ChainStateType tx -> NodeState tx
initNodeState ChainStateType tx
chainState =
  NodeCatchingUp
    { $sel:headState:NodeInSync :: HeadState tx
headState = IdleState tx -> HeadState tx
forall tx. IdleState tx -> HeadState tx
Idle IdleState{ChainStateType tx
chainState :: ChainStateType tx
$sel:chainState:IdleState :: ChainStateType tx
chainState}
    , $sel:pendingDeposits:NodeInSync :: Map (TxIdType tx) (Deposit tx)
pendingDeposits = Map (TxIdType tx) (Deposit tx)
forall a. Monoid a => a
mempty
    , $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime = ChainStateType tx -> ChainPointTime
forall tx. IsChainState tx => ChainStateType tx -> ChainPointTime
initialChainPointTime ChainStateType tx
chainState
    }

initialChainPointTime :: IsChainState tx => ChainStateType tx -> ChainPointTime
initialChainPointTime :: forall tx. IsChainState tx => ChainStateType tx -> ChainPointTime
initialChainPointTime ChainStateType tx
chainState =
  ChainPointTime
    { $sel:currentSlot:ChainPointTime :: ChainSlot
currentSlot = ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
chainState
    , $sel:currentChainTime:ChainPointTime :: UTCTime
currentChainTime = UTCTime
initialChainTime
    , $sel:drift:ChainPointTime :: POSIXTime
drift = POSIXTime
0
    }

initialChainTime :: UTCTime
initialChainTime :: UTCTime
initialChainTime = POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0

data SyncedStatus = InSync | CatchingUp
  deriving stock ((forall x. SyncedStatus -> Rep SyncedStatus x)
-> (forall x. Rep SyncedStatus x -> SyncedStatus)
-> Generic SyncedStatus
forall x. Rep SyncedStatus x -> SyncedStatus
forall x. SyncedStatus -> Rep SyncedStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SyncedStatus -> Rep SyncedStatus x
from :: forall x. SyncedStatus -> Rep SyncedStatus x
$cto :: forall x. Rep SyncedStatus x -> SyncedStatus
to :: forall x. Rep SyncedStatus x -> SyncedStatus
Generic, SyncedStatus -> SyncedStatus -> Bool
(SyncedStatus -> SyncedStatus -> Bool)
-> (SyncedStatus -> SyncedStatus -> Bool) -> Eq SyncedStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SyncedStatus -> SyncedStatus -> Bool
== :: SyncedStatus -> SyncedStatus -> Bool
$c/= :: SyncedStatus -> SyncedStatus -> Bool
/= :: SyncedStatus -> SyncedStatus -> Bool
Eq, Int -> SyncedStatus -> ShowS
[SyncedStatus] -> ShowS
SyncedStatus -> String
(Int -> SyncedStatus -> ShowS)
-> (SyncedStatus -> String)
-> ([SyncedStatus] -> ShowS)
-> Show SyncedStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SyncedStatus -> ShowS
showsPrec :: Int -> SyncedStatus -> ShowS
$cshow :: SyncedStatus -> String
show :: SyncedStatus -> String
$cshowList :: [SyncedStatus] -> ShowS
showList :: [SyncedStatus] -> ShowS
Show)
  deriving anyclass ([SyncedStatus] -> Value
[SyncedStatus] -> Encoding
SyncedStatus -> Bool
SyncedStatus -> Value
SyncedStatus -> Encoding
(SyncedStatus -> Value)
-> (SyncedStatus -> Encoding)
-> ([SyncedStatus] -> Value)
-> ([SyncedStatus] -> Encoding)
-> (SyncedStatus -> Bool)
-> ToJSON SyncedStatus
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: SyncedStatus -> Value
toJSON :: SyncedStatus -> Value
$ctoEncoding :: SyncedStatus -> Encoding
toEncoding :: SyncedStatus -> Encoding
$ctoJSONList :: [SyncedStatus] -> Value
toJSONList :: [SyncedStatus] -> Value
$ctoEncodingList :: [SyncedStatus] -> Encoding
toEncodingList :: [SyncedStatus] -> Encoding
$comitField :: SyncedStatus -> Bool
omitField :: SyncedStatus -> Bool
ToJSON, Maybe SyncedStatus
Value -> Parser [SyncedStatus]
Value -> Parser SyncedStatus
(Value -> Parser SyncedStatus)
-> (Value -> Parser [SyncedStatus])
-> Maybe SyncedStatus
-> FromJSON SyncedStatus
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser SyncedStatus
parseJSON :: Value -> Parser SyncedStatus
$cparseJSONList :: Value -> Parser [SyncedStatus]
parseJSONList :: Value -> Parser [SyncedStatus]
$comittedField :: Maybe SyncedStatus
omittedField :: Maybe SyncedStatus
FromJSON)

instance ToCBOR SyncedStatus where
  toCBOR :: SyncedStatus -> Encoding
toCBOR = SyncedStatus -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR SyncedStatus where
  fromCBOR :: forall s. Decoder s SyncedStatus
fromCBOR = Decoder s SyncedStatus
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

syncedStatus :: NodeState tx -> SyncedStatus
syncedStatus :: forall tx. NodeState tx -> SyncedStatus
syncedStatus NodeInSync{} = SyncedStatus
InSync
syncedStatus NodeCatchingUp{} = SyncedStatus
CatchingUp

-- | A deposit tracked by the protocol. The 'DepositStatus' determines whether
-- it may be used for an incremental commit or not.
data Deposit tx = Deposit
  { forall tx. Deposit tx -> HeadId
headId :: HeadId
  , forall tx. Deposit tx -> UTxOType tx
deposited :: UTxOType tx
  , forall tx. Deposit tx -> UTCTime
created :: UTCTime
  , forall tx. Deposit tx -> UTCTime
deadline :: UTCTime
  , forall tx. Deposit tx -> DepositStatus
status :: DepositStatus
  }
  deriving stock ((forall x. Deposit tx -> Rep (Deposit tx) x)
-> (forall x. Rep (Deposit tx) x -> Deposit tx)
-> Generic (Deposit tx)
forall x. Rep (Deposit tx) x -> Deposit tx
forall x. Deposit tx -> Rep (Deposit tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (Deposit tx) x -> Deposit tx
forall tx x. Deposit tx -> Rep (Deposit tx) x
$cfrom :: forall tx x. Deposit tx -> Rep (Deposit tx) x
from :: forall x. Deposit tx -> Rep (Deposit tx) x
$cto :: forall tx x. Rep (Deposit tx) x -> Deposit tx
to :: forall x. Rep (Deposit tx) x -> Deposit tx
Generic)

deriving stock instance IsTx tx => Eq (Deposit tx)
deriving stock instance IsTx tx => Show (Deposit tx)
deriving anyclass instance IsTx tx => ToJSON (Deposit tx)
deriving anyclass instance IsTx tx => FromJSON (Deposit tx)

instance IsTx tx => ToCBOR (Deposit tx) where
  toCBOR :: Deposit tx -> Encoding
toCBOR = Deposit tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance IsTx tx => FromCBOR (Deposit tx) where
  fromCBOR :: forall s. Decoder s (Deposit tx)
fromCBOR = Decoder s (Deposit tx)
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

data DepositStatus = Inactive | Active | Expired
  deriving stock ((forall x. DepositStatus -> Rep DepositStatus x)
-> (forall x. Rep DepositStatus x -> DepositStatus)
-> Generic DepositStatus
forall x. Rep DepositStatus x -> DepositStatus
forall x. DepositStatus -> Rep DepositStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DepositStatus -> Rep DepositStatus x
from :: forall x. DepositStatus -> Rep DepositStatus x
$cto :: forall x. Rep DepositStatus x -> DepositStatus
to :: forall x. Rep DepositStatus x -> DepositStatus
Generic, DepositStatus -> DepositStatus -> Bool
(DepositStatus -> DepositStatus -> Bool)
-> (DepositStatus -> DepositStatus -> Bool) -> Eq DepositStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DepositStatus -> DepositStatus -> Bool
== :: DepositStatus -> DepositStatus -> Bool
$c/= :: DepositStatus -> DepositStatus -> Bool
/= :: DepositStatus -> DepositStatus -> Bool
Eq, Int -> DepositStatus -> ShowS
[DepositStatus] -> ShowS
DepositStatus -> String
(Int -> DepositStatus -> ShowS)
-> (DepositStatus -> String)
-> ([DepositStatus] -> ShowS)
-> Show DepositStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DepositStatus -> ShowS
showsPrec :: Int -> DepositStatus -> ShowS
$cshow :: DepositStatus -> String
show :: DepositStatus -> String
$cshowList :: [DepositStatus] -> ShowS
showList :: [DepositStatus] -> ShowS
Show)
  deriving anyclass ([DepositStatus] -> Value
[DepositStatus] -> Encoding
DepositStatus -> Bool
DepositStatus -> Value
DepositStatus -> Encoding
(DepositStatus -> Value)
-> (DepositStatus -> Encoding)
-> ([DepositStatus] -> Value)
-> ([DepositStatus] -> Encoding)
-> (DepositStatus -> Bool)
-> ToJSON DepositStatus
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: DepositStatus -> Value
toJSON :: DepositStatus -> Value
$ctoEncoding :: DepositStatus -> Encoding
toEncoding :: DepositStatus -> Encoding
$ctoJSONList :: [DepositStatus] -> Value
toJSONList :: [DepositStatus] -> Value
$ctoEncodingList :: [DepositStatus] -> Encoding
toEncodingList :: [DepositStatus] -> Encoding
$comitField :: DepositStatus -> Bool
omitField :: DepositStatus -> Bool
ToJSON, Maybe DepositStatus
Value -> Parser [DepositStatus]
Value -> Parser DepositStatus
(Value -> Parser DepositStatus)
-> (Value -> Parser [DepositStatus])
-> Maybe DepositStatus
-> FromJSON DepositStatus
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser DepositStatus
parseJSON :: Value -> Parser DepositStatus
$cparseJSONList :: Value -> Parser [DepositStatus]
parseJSONList :: Value -> Parser [DepositStatus]
$comittedField :: Maybe DepositStatus
omittedField :: Maybe DepositStatus
FromJSON)

instance ToCBOR DepositStatus where
  toCBOR :: DepositStatus -> Encoding
toCBOR = DepositStatus -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR DepositStatus where
  fromCBOR :: forall s. Decoder s DepositStatus
fromCBOR = Decoder s DepositStatus
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

depositsForHead :: HeadId -> PendingDeposits tx -> PendingDeposits tx
depositsForHead :: forall tx. HeadId -> PendingDeposits tx -> PendingDeposits tx
depositsForHead HeadId
targetHeadId =
  (Deposit tx -> Bool)
-> Map (TxIdType tx) (Deposit tx) -> Map (TxIdType tx) (Deposit tx)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Deposit{HeadId
$sel:headId:Deposit :: forall tx. Deposit tx -> HeadId
headId :: HeadId
headId} -> HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
targetHeadId)