{-# LANGUAGE UndecidableInstances #-}

module Hydra.Node.State where

import Hydra.Prelude

import Cardano.Binary (Decoder)
import Data.Aeson (withObject, (.:))
import Data.Map.Strict qualified as Map
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import GHC.Records (HasField (..))
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)

-- | A deposit with its L1 lifecycle slots. Deposits are L1-derived state, so a
-- rollback must rewind the view ('rollbackDeposits'): a deposit recorded after
-- the rolled-back slot vanishes (its deposit transaction was erased), and a
-- consumption after it is undone (the erased increment or recover resurfaces
-- the deposit). Forward re-observation of the new chain then converges the view
-- again. Only L1-derived state may rewind like this; L2 state (snapshots,
-- signatures) never rolls back.
data TrackedDeposit tx = TrackedDeposit
  { forall tx. TrackedDeposit tx -> Deposit tx
deposit :: Deposit tx
  , forall tx. TrackedDeposit tx -> ChainSlot
recordedAt :: ChainSlot
  -- ^ Slot at which the deposit transaction was observed.
  , forall tx. TrackedDeposit tx -> Maybe ChainSlot
consumedAt :: Maybe ChainSlot
  -- ^ Slot at which a consuming transaction (increment or recover) was
  -- observed, if any. A consumed deposit is no longer pending, but is retained
  -- for 'depositRetentionHorizon' so a rollback can resurface it.
  }
  deriving stock ((forall x. TrackedDeposit tx -> Rep (TrackedDeposit tx) x)
-> (forall x. Rep (TrackedDeposit tx) x -> TrackedDeposit tx)
-> Generic (TrackedDeposit tx)
forall x. Rep (TrackedDeposit tx) x -> TrackedDeposit tx
forall x. TrackedDeposit tx -> Rep (TrackedDeposit tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (TrackedDeposit tx) x -> TrackedDeposit tx
forall tx x. TrackedDeposit tx -> Rep (TrackedDeposit tx) x
$cfrom :: forall tx x. TrackedDeposit tx -> Rep (TrackedDeposit tx) x
from :: forall x. TrackedDeposit tx -> Rep (TrackedDeposit tx) x
$cto :: forall tx x. Rep (TrackedDeposit tx) x -> TrackedDeposit tx
to :: forall x. Rep (TrackedDeposit tx) x -> TrackedDeposit tx
Generic)

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

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

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

type TrackedDeposits tx = Map (TxIdType tx) (TrackedDeposit tx)

-- | Track the given deposits with a fresh lifecycle (recorded at slot 0,
-- unconsumed). Used to lift state serialized before lifecycle tracking
-- existed, reproducing the old (rollback unaware) behavior for those deposits.
trackedFromPending :: PendingDeposits tx -> TrackedDeposits tx
trackedFromPending :: forall tx. PendingDeposits tx -> TrackedDeposits tx
trackedFromPending = (Deposit tx -> TrackedDeposit tx)
-> Map (TxIdType tx) (Deposit tx)
-> Map (TxIdType tx) (TrackedDeposit tx)
forall a b. (a -> b) -> Map (TxIdType tx) a -> Map (TxIdType tx) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Deposit tx
deposit -> TrackedDeposit{Deposit tx
$sel:deposit:TrackedDeposit :: Deposit tx
deposit :: Deposit tx
deposit, $sel:recordedAt:TrackedDeposit :: ChainSlot
recordedAt = Natural -> ChainSlot
ChainSlot Natural
0, $sel:consumedAt:TrackedDeposit :: Maybe ChainSlot
consumedAt = Maybe ChainSlot
forall a. Maybe a
Nothing})

-- | Deposits pending as observed on chain: the tracked deposits not consumed
-- yet.
pendingDeposits :: NodeState tx -> PendingDeposits tx
pendingDeposits :: forall tx. NodeState tx -> PendingDeposits tx
pendingDeposits =
  (TrackedDeposit tx -> Maybe (Deposit tx))
-> Map (TxIdType tx) (TrackedDeposit tx)
-> Map (TxIdType tx) (Deposit tx)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (\TrackedDeposit{Deposit tx
$sel:deposit:TrackedDeposit :: forall tx. TrackedDeposit tx -> Deposit tx
deposit :: Deposit tx
deposit, Maybe ChainSlot
$sel:consumedAt:TrackedDeposit :: forall tx. TrackedDeposit tx -> Maybe ChainSlot
consumedAt :: Maybe ChainSlot
consumedAt} -> Deposit tx
deposit Deposit tx -> Maybe () -> Maybe (Deposit tx)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Maybe ChainSlot -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ChainSlot
consumedAt)) (Map (TxIdType tx) (TrackedDeposit tx)
 -> Map (TxIdType tx) (Deposit tx))
-> (NodeState tx -> Map (TxIdType tx) (TrackedDeposit tx))
-> NodeState tx
-> Map (TxIdType tx) (Deposit tx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeState tx -> Map (TxIdType tx) (TrackedDeposit tx)
forall tx. NodeState tx -> TrackedDeposits tx
deposits

-- | Derived view, so record-dot access keeps working across the tracked
-- representation.
instance view ~ PendingDeposits tx => HasField "pendingDeposits" (NodeState tx) view where
  getField :: NodeState tx -> view
getField = NodeState tx -> view
NodeState tx -> PendingDeposits tx
forall tx. NodeState tx -> PendingDeposits tx
pendingDeposits

-- | Record a newly observed deposit at the given slot. Re-recording an id (its
-- deposit transaction re-landed after a rollback) starts a fresh lifecycle.
recordDeposit :: IsTx tx => ChainSlot -> TxIdType tx -> Deposit tx -> NodeState tx -> NodeState tx
recordDeposit :: forall tx.
IsTx tx =>
ChainSlot
-> TxIdType tx -> Deposit tx -> NodeState tx -> NodeState tx
recordDeposit ChainSlot
slot TxIdType tx
depositTxId Deposit tx
deposit NodeState tx
nodeState =
  NodeState tx
nodeState
    { deposits =
        Map.insert depositTxId TrackedDeposit{deposit, recordedAt = slot, consumedAt = Nothing} $
          pruneConsumedDeposits slot (deposits nodeState)
    }

-- | Update a tracked deposit (e.g. on status changes); its lifecycle slots are
-- unaffected. Unknown ids are ignored.
updateDeposit :: IsTx tx => TxIdType tx -> Deposit tx -> NodeState tx -> NodeState tx
updateDeposit :: forall tx.
IsTx tx =>
TxIdType tx -> Deposit tx -> NodeState tx -> NodeState tx
updateDeposit TxIdType tx
depositTxId Deposit tx
deposit NodeState tx
nodeState =
  NodeState tx
nodeState{deposits = Map.adjust (\TrackedDeposit tx
tracked -> TrackedDeposit tx
tracked{deposit}) depositTxId (deposits nodeState)}

-- | Mark a deposit consumed at the given slot: its increment or recover was
-- observed on chain. Re-consuming (the consuming transaction re-landed after a
-- rollback) re-stamps the slot, so a rollback of the re-landed transaction
-- still resurfaces the deposit.
consumeDeposit :: IsTx tx => ChainSlot -> TxIdType tx -> NodeState tx -> NodeState tx
consumeDeposit :: forall tx.
IsTx tx =>
ChainSlot -> TxIdType tx -> NodeState tx -> NodeState tx
consumeDeposit ChainSlot
slot TxIdType tx
depositTxId NodeState tx
nodeState =
  NodeState tx
nodeState
    { deposits =
        Map.adjust (\TrackedDeposit tx
tracked -> TrackedDeposit tx
tracked{consumedAt = Just slot}) depositTxId $
          pruneConsumedDeposits slot (deposits nodeState)
    }

-- | Rewind the deposit view to the given (rolled back) slot, see
-- 'TrackedDeposit'.
rollbackDeposits :: ChainSlot -> NodeState tx -> NodeState tx
rollbackDeposits :: forall tx. ChainSlot -> NodeState tx -> NodeState tx
rollbackDeposits ChainSlot
slot NodeState tx
nodeState =
  NodeState tx
nodeState{deposits = Map.mapMaybe rollbackOne (deposits nodeState)}
 where
  rollbackOne :: TrackedDeposit tx -> Maybe (TrackedDeposit tx)
rollbackOne tracked :: TrackedDeposit tx
tracked@TrackedDeposit{ChainSlot
$sel:recordedAt:TrackedDeposit :: forall tx. TrackedDeposit tx -> ChainSlot
recordedAt :: ChainSlot
recordedAt, Maybe ChainSlot
$sel:consumedAt:TrackedDeposit :: forall tx. TrackedDeposit tx -> Maybe ChainSlot
consumedAt :: Maybe ChainSlot
consumedAt}
    | ChainSlot
recordedAt ChainSlot -> ChainSlot -> Bool
forall a. Ord a => a -> a -> Bool
> ChainSlot
slot = Maybe (TrackedDeposit tx)
forall a. Maybe a
Nothing
    | Bool
otherwise = TrackedDeposit tx -> Maybe (TrackedDeposit tx)
forall a. a -> Maybe a
Just TrackedDeposit tx
tracked{consumedAt = mfilter (<= slot) consumedAt}

-- | Drop consumed deposits beyond 'depositRetentionHorizon': no rollback can
-- resurface them anymore, so retaining them would only grow persisted state
-- with every deposit ever settled. Called on the deposit write paths, which is
-- enough because only deposit churn creates consumed entries. Unconsumed
-- deposits are never pruned — an expired deposit stays recoverable
-- indefinitely.
pruneConsumedDeposits :: ChainSlot -> TrackedDeposits tx -> TrackedDeposits tx
pruneConsumedDeposits :: forall tx. ChainSlot -> TrackedDeposits tx -> TrackedDeposits tx
pruneConsumedDeposits (ChainSlot Natural
slot) =
  (TrackedDeposit tx -> Bool)
-> Map (TxIdType tx) (TrackedDeposit tx)
-> Map (TxIdType tx) (TrackedDeposit tx)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\TrackedDeposit{Maybe ChainSlot
$sel:consumedAt:TrackedDeposit :: forall tx. TrackedDeposit tx -> Maybe ChainSlot
consumedAt :: Maybe ChainSlot
consumedAt} -> Bool -> (ChainSlot -> Bool) -> Maybe ChainSlot -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (ChainSlot -> ChainSlot -> Bool
forall a. Ord a => a -> a -> Bool
> ChainSlot
cutoff) Maybe ChainSlot
consumedAt)
 where
  cutoff :: ChainSlot
cutoff =
    case ChainSlot
depositRetentionHorizon of
      ChainSlot Natural
horizon -> Natural -> ChainSlot
ChainSlot (if Natural
slot Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
horizon then Natural
slot Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
horizon else Natural
0)

-- | How long consumed deposits are retained for rollbacks: sized to cover the
-- deepest rollback Cardano can produce (the security parameter k = 2160
-- blocks, roughly 12 hours at one block per 20 slots) with a three-fold
-- margin.
depositRetentionHorizon :: ChainSlot
depositRetentionHorizon :: ChainSlot
depositRetentionHorizon = Natural -> ChainSlot
ChainSlot Natural
129600

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 -> TrackedDeposits tx
deposits :: TrackedDeposits tx
      -- ^ Deposits as observed on chain, with their L1 lifecycle (see
      -- 'TrackedDeposit'); read the pending view via 'pendingDeposits'.
      -- 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
      , deposits :: TrackedDeposits tx
      -- ^ Deposits as observed on chain, with their L1 lifecycle (see
      -- 'TrackedDeposit'); read the pending view via 'pendingDeposits'.
      -- 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)

-- | Manual instance: lifecycle-tracked 'deposits' replaced the plain pending
-- deposit map after 'NodeState' shipped. A checkpoint persisted by an older
-- version carries a "pendingDeposits" key instead, which is lifted via
-- 'trackedFromPending'.
instance (IsTx tx, FromJSON (ChainStateType tx)) => FromJSON (NodeState tx) where
  parseJSON :: Value -> Parser (NodeState tx)
parseJSON = String
-> (Object -> Parser (NodeState tx))
-> Value
-> Parser (NodeState tx)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NodeState" ((Object -> Parser (NodeState tx))
 -> Value -> Parser (NodeState tx))
-> (Object -> Parser (NodeState tx))
-> Value
-> Parser (NodeState tx)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
tag :: Text <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag"
    HeadState tx
headState <- Object
o Object -> Key -> Parser (HeadState tx)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"headState"
    Map (TxIdType tx) (TrackedDeposit tx)
deposits <- Object
o Object -> Key -> Parser (Map (TxIdType tx) (TrackedDeposit tx))
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"deposits" Parser (Map (TxIdType tx) (TrackedDeposit tx))
-> Parser (Map (TxIdType tx) (TrackedDeposit tx))
-> Parser (Map (TxIdType tx) (TrackedDeposit tx))
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Map (TxIdType tx) (Deposit tx)
-> Map (TxIdType tx) (TrackedDeposit tx)
forall tx. PendingDeposits tx -> TrackedDeposits tx
trackedFromPending (Map (TxIdType tx) (Deposit tx)
 -> Map (TxIdType tx) (TrackedDeposit tx))
-> Parser (Map (TxIdType tx) (Deposit tx))
-> Parser (Map (TxIdType tx) (TrackedDeposit tx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Map (TxIdType tx) (Deposit tx))
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pendingDeposits")
    ChainPointTime
chainPointTime <- Object
o Object -> Key -> Parser ChainPointTime
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"chainPointTime"
    case Text
tag of
      Text
"NodeInSync" -> NodeState tx -> Parser (NodeState tx)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeInSync{HeadState tx
$sel:headState:NodeInSync :: HeadState tx
headState :: HeadState tx
headState, Map (TxIdType tx) (TrackedDeposit tx)
$sel:deposits:NodeInSync :: Map (TxIdType tx) (TrackedDeposit tx)
deposits :: Map (TxIdType tx) (TrackedDeposit tx)
deposits, ChainPointTime
$sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime :: ChainPointTime
chainPointTime}
      Text
"NodeCatchingUp" -> NodeState tx -> Parser (NodeState tx)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeCatchingUp{HeadState tx
$sel:headState:NodeInSync :: HeadState tx
headState :: HeadState tx
headState, Map (TxIdType tx) (TrackedDeposit tx)
$sel:deposits:NodeInSync :: Map (TxIdType tx) (TrackedDeposit tx)
deposits :: Map (TxIdType tx) (TrackedDeposit tx)
deposits, ChainPointTime
$sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime :: ChainPointTime
chainPointTime}
      Text
_ -> String -> Parser (NodeState tx)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (NodeState tx))
-> String -> Parser (NodeState tx)
forall a b. (a -> b) -> a -> b
$ String
"unknown NodeState tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
tag

-- | Tags of the current on-disk\/wire layout, which tracks deposit lifecycles
-- ('TrackedDeposits'). The fields are a bare concatenation with no length
-- prefix, so a layout change is only decodable when the tag distinguishes it:
-- the V1 tags name the layout with a plain pending deposit map written before
-- lifecycle tracking existed and are still accepted, lifted via
-- 'trackedFromPending' like the 'FromJSON' instance above.
nodeInSyncCBORTag, nodeCatchingUpCBORTag :: Text
nodeInSyncCBORTag :: Text
nodeInSyncCBORTag = Text
"NodeInSync2"
nodeCatchingUpCBORTag :: Text
nodeCatchingUpCBORTag = Text
"NodeCatchingUp2"

-- | Tags of the layout without deposit lifecycles. Decoded, never written.
nodeInSyncCBORTagV1, nodeCatchingUpCBORTagV1 :: Text
nodeInSyncCBORTagV1 :: Text
nodeInSyncCBORTagV1 = Text
"NodeInSync"
nodeCatchingUpCBORTagV1 :: Text
nodeCatchingUpCBORTagV1 = Text
"NodeCatchingUp"

instance IsChainState tx => ToCBOR (NodeState tx) where
  toCBOR :: NodeState tx -> Encoding
toCBOR NodeState tx
nodeState =
    Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Text
tag
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> HeadState tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (NodeState tx -> HeadState tx
forall tx. NodeState tx -> HeadState tx
headState NodeState tx
nodeState)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (TxIdType tx) (TrackedDeposit tx) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (NodeState tx -> Map (TxIdType tx) (TrackedDeposit tx)
forall tx. NodeState tx -> TrackedDeposits tx
deposits NodeState tx
nodeState)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ChainPointTime -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (NodeState tx -> ChainPointTime
forall tx. NodeState tx -> ChainPointTime
chainPointTime NodeState tx
nodeState)
   where
    tag :: Text
tag = case NodeState tx
nodeState of
      NodeInSync{} -> Text
nodeInSyncCBORTag
      NodeCatchingUp{} -> Text
nodeCatchingUpCBORTag

instance IsChainState tx => FromCBOR (NodeState tx) where
  fromCBOR :: forall s. Decoder s (NodeState tx)
fromCBOR =
    Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s Text
-> (Text -> Decoder s (NodeState tx)) -> Decoder s (NodeState tx)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Text
tag :: Text)
        | Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nodeInSyncCBORTag -> (HeadState tx
 -> Map (TxIdType tx) (TrackedDeposit tx)
 -> ChainPointTime
 -> NodeState tx)
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (NodeState tx)
forall s.
(HeadState tx
 -> Map (TxIdType tx) (TrackedDeposit tx)
 -> ChainPointTime
 -> NodeState tx)
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (NodeState tx)
decode HeadState tx
-> Map (TxIdType tx) (TrackedDeposit tx)
-> ChainPointTime
-> NodeState tx
forall tx.
HeadState tx
-> TrackedDeposits tx -> ChainPointTime -> NodeState tx
NodeInSync Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
forall s. Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        | Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nodeCatchingUpCBORTag -> (HeadState tx
 -> Map (TxIdType tx) (TrackedDeposit tx)
 -> ChainPointTime
 -> NodeState tx)
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (NodeState tx)
forall s.
(HeadState tx
 -> Map (TxIdType tx) (TrackedDeposit tx)
 -> ChainPointTime
 -> NodeState tx)
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (NodeState tx)
decode HeadState tx
-> Map (TxIdType tx) (TrackedDeposit tx)
-> ChainPointTime
-> NodeState tx
forall tx.
HeadState tx
-> TrackedDeposits tx -> ChainPointTime -> NodeState tx
NodeCatchingUp Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
forall s. Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        | Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nodeInSyncCBORTagV1 -> (HeadState tx
 -> Map (TxIdType tx) (TrackedDeposit tx)
 -> ChainPointTime
 -> NodeState tx)
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (NodeState tx)
forall s.
(HeadState tx
 -> Map (TxIdType tx) (TrackedDeposit tx)
 -> ChainPointTime
 -> NodeState tx)
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (NodeState tx)
decode HeadState tx
-> Map (TxIdType tx) (TrackedDeposit tx)
-> ChainPointTime
-> NodeState tx
forall tx.
HeadState tx
-> TrackedDeposits tx -> ChainPointTime -> NodeState tx
NodeInSync (Map (TxIdType tx) (Deposit tx)
-> Map (TxIdType tx) (TrackedDeposit tx)
forall tx. PendingDeposits tx -> TrackedDeposits tx
trackedFromPending (Map (TxIdType tx) (Deposit tx)
 -> Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (Map (TxIdType tx) (Deposit tx))
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Map (TxIdType tx) (Deposit tx))
forall s. Decoder s (Map (TxIdType tx) (Deposit tx))
forall a s. FromCBOR a => Decoder s a
fromCBOR)
        | Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nodeCatchingUpCBORTagV1 -> (HeadState tx
 -> Map (TxIdType tx) (TrackedDeposit tx)
 -> ChainPointTime
 -> NodeState tx)
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (NodeState tx)
forall s.
(HeadState tx
 -> Map (TxIdType tx) (TrackedDeposit tx)
 -> ChainPointTime
 -> NodeState tx)
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (NodeState tx)
decode HeadState tx
-> Map (TxIdType tx) (TrackedDeposit tx)
-> ChainPointTime
-> NodeState tx
forall tx.
HeadState tx
-> TrackedDeposits tx -> ChainPointTime -> NodeState tx
NodeCatchingUp (Map (TxIdType tx) (Deposit tx)
-> Map (TxIdType tx) (TrackedDeposit tx)
forall tx. PendingDeposits tx -> TrackedDeposits tx
trackedFromPending (Map (TxIdType tx) (Deposit tx)
 -> Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (Map (TxIdType tx) (Deposit tx))
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Map (TxIdType tx) (Deposit tx))
forall s. Decoder s (Map (TxIdType tx) (Deposit tx))
forall a s. FromCBOR a => Decoder s a
fromCBOR)
        | Bool
otherwise -> String -> Decoder s (NodeState tx)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (NodeState tx))
-> String -> Decoder s (NodeState tx)
forall a b. (a -> b) -> a -> b
$ Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
tag String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a proper CBOR-encoded NodeState"
   where
    decode ::
      (HeadState tx -> TrackedDeposits tx -> ChainPointTime -> NodeState tx) ->
      Decoder s (TrackedDeposits tx) ->
      Decoder s (NodeState tx)
    decode :: forall s.
(HeadState tx
 -> Map (TxIdType tx) (TrackedDeposit tx)
 -> ChainPointTime
 -> NodeState tx)
-> Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
-> Decoder s (NodeState tx)
decode HeadState tx
-> Map (TxIdType tx) (TrackedDeposit tx)
-> ChainPointTime
-> NodeState tx
mkNodeState Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
decodeDeposits = do
      HeadState tx
headState <- Decoder s (HeadState tx)
forall s. Decoder s (HeadState tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Map (TxIdType tx) (TrackedDeposit tx)
deposits <- Decoder s (Map (TxIdType tx) (TrackedDeposit tx))
decodeDeposits
      HeadState tx
-> Map (TxIdType tx) (TrackedDeposit tx)
-> ChainPointTime
-> NodeState tx
mkNodeState HeadState tx
headState Map (TxIdType tx) (TrackedDeposit tx)
deposits (ChainPointTime -> NodeState tx)
-> Decoder s ChainPointTime -> Decoder s (NodeState tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ChainPointTime
forall s. Decoder s ChainPointTime
forall a s. FromCBOR a => Decoder s a
fromCBOR

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:deposits:NodeInSync :: Map (TxIdType tx) (TrackedDeposit tx)
deposits = Map (TxIdType tx) (TrackedDeposit 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)