{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE UndecidableInstances #-}

module Hydra.HeadLogic.Outcome where

import Hydra.Prelude

import Data.Aeson (Value (..), defaultOptions, genericParseJSON)
import Data.Aeson.KeyMap qualified as KeyMap
import Hydra.API.ServerOutput (ClientMessage, DecommitInvalidReason)
import Hydra.Chain (PostChainTx)
import Hydra.Chain.ChainState (ChainPointType, ChainSlot, ChainStateType, IsChainState)
import Hydra.HeadLogic.Error (LogicError)
import Hydra.HeadLogic.State (FanoutMode (..))
import Hydra.Ledger (ValidationError)
import Hydra.Network (Host, ProtocolVersion)
import Hydra.Network.Message (Message)
import Hydra.Node.State (Deposit, NodeState)
import Hydra.Tx (
  HeadId,
  HeadParameters,
  HeadSeed,
  IsTx,
  Party,
  Snapshot,
  SnapshotNumber,
  SnapshotVersion,
  TxIdType,
  UTxOType,
 )
import Hydra.Tx.ContestationPeriod (ContestationPeriod)
import Hydra.Tx.Crypto (MultiSignature, Signature)
import Hydra.Tx.OnChainId (OnChainId)

-- | Analogous to inputs, the pure head logic "core" can have effects emitted to
-- the "shell" layers and we distinguish the same: effects onto the client, the
-- network and the chain.
data Effect tx
  = -- | Effect to be handled by the "Hydra.API", results in sending this 'ClientMessage'.
    ClientEffect {forall tx. Effect tx -> ClientMessage tx
clientMessage :: ClientMessage tx}
  | -- | Effect to be handled by a "Hydra.Network", results in a 'Hydra.Network.broadcast'.
    NetworkEffect {forall tx. Effect tx -> Message tx
message :: Message tx}
  | -- | Effect to be handled by a "Hydra.Chain", results in a 'Hydra.Chain.postTx'.
    OnChainEffect {forall tx. Effect tx -> PostChainTx tx
postChainTx :: PostChainTx tx}
  deriving stock ((forall x. Effect tx -> Rep (Effect tx) x)
-> (forall x. Rep (Effect tx) x -> Effect tx)
-> Generic (Effect tx)
forall x. Rep (Effect tx) x -> Effect tx
forall x. Effect tx -> Rep (Effect tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (Effect tx) x -> Effect tx
forall tx x. Effect tx -> Rep (Effect tx) x
$cfrom :: forall tx x. Effect tx -> Rep (Effect tx) x
from :: forall x. Effect tx -> Rep (Effect tx) x
$cto :: forall tx x. Rep (Effect tx) x -> Effect tx
to :: forall x. Rep (Effect tx) x -> Effect tx
Generic)

deriving stock instance IsChainState tx => Eq (Effect tx)
deriving stock instance IsChainState tx => Show (Effect tx)
deriving anyclass instance IsChainState tx => ToJSON (Effect tx)

-- | Head state changed event. These events represent all the internal state
-- changes, get persisted and processed in an event sourcing manner.
data StateChanged tx
  = NetworkConnected
  | NetworkDisconnected
  | PeerConnected {forall tx. StateChanged tx -> Host
peer :: Host}
  | PeerDisconnected {peer :: Host}
  | NetworkVersionMismatch
      { forall tx. StateChanged tx -> ProtocolVersion
ourVersion :: ProtocolVersion
      , forall tx. StateChanged tx -> Maybe ProtocolVersion
theirVersion :: Maybe ProtocolVersion
      }
  | NetworkClusterIDMismatch
      { forall tx. StateChanged tx -> Text
clusterPeers :: Text
      , forall tx. StateChanged tx -> Text
misconfiguredPeers :: Text
      }
  | HeadOpened
      { forall tx. StateChanged tx -> HeadParameters
parameters :: HeadParameters
      , forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
      , forall tx. StateChanged tx -> HeadId
headId :: HeadId
      , forall tx. StateChanged tx -> HeadSeed
headSeed :: HeadSeed
      , forall tx. StateChanged tx -> [Party]
parties :: [Party]
      }
  | TransactionReceived {forall tx. StateChanged tx -> tx
tx :: tx}
  | TransactionAppliedToLocalUTxO
      { headId :: HeadId
      , tx :: tx
      }
  | SnapshotRequestDecided {forall tx. StateChanged tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber}
  | SnapshotRequested
      { forall tx. StateChanged tx -> Snapshot tx
requestedSnapshot :: Snapshot tx
      , forall tx. StateChanged tx -> Seq tx
newLocalTxs :: Seq tx
      , forall tx. StateChanged tx -> Maybe (TxIdType tx)
newCurrentDepositTxId :: Maybe (TxIdType tx)
      }
  | PartySignedSnapshot {snapshotNumber :: SnapshotNumber, forall tx. StateChanged tx -> Party
party :: Party, forall tx. StateChanged tx -> Signature (Snapshot tx)
signature :: Signature (Snapshot tx)}
  | SnapshotConfirmed
      { headId :: HeadId
      , forall tx. StateChanged tx -> Maybe (Snapshot tx)
snapshot :: Maybe (Snapshot tx)
      -- ^ 'Nothing' on the normal signing path (snapshot already in 'seenSnapshot');
      -- 'Just' only for the side-load path where no preceding 'SnapshotRequested' exists.
      , forall tx. StateChanged tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
      }
  | DepositRecorded
      { chainState :: ChainStateType tx
      , headId :: HeadId
      , forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
      , forall tx. StateChanged tx -> UTxOType tx
deposited :: UTxOType tx
      , forall tx. StateChanged tx -> UTCTime
created :: UTCTime
      , forall tx. StateChanged tx -> UTCTime
deadline :: UTCTime
      }
  | DepositActivated {depositTxId :: TxIdType tx, forall tx. StateChanged tx -> UTCTime
chainTime :: UTCTime, forall tx. StateChanged tx -> Deposit tx
deposit :: Deposit tx}
  | DepositExpired {depositTxId :: TxIdType tx, chainTime :: UTCTime, deposit :: Deposit tx}
  | DepositRecovered
      { chainState :: ChainStateType tx
      , headId :: HeadId
      , depositTxId :: TxIdType tx
      , forall tx. StateChanged tx -> UTxOType tx
recovered :: UTxOType tx
      }
  | -- TODO: Rename to DepositApproved
    CommitApproved {headId :: HeadId, forall tx. StateChanged tx -> UTxOType tx
utxoToCommit :: UTxOType tx}
  | -- TODO: Rename to DepositFinalized
    CommitFinalized
      { chainState :: ChainStateType tx
      , headId :: HeadId
      , forall tx. StateChanged tx -> SnapshotVersion
newVersion :: SnapshotVersion
      , depositTxId :: TxIdType tx
      }
  | DecommitRecorded {headId :: HeadId, forall tx. StateChanged tx -> tx
decommitTx :: tx}
  | DecommitApproved {headId :: HeadId, forall tx. StateChanged tx -> TxIdType tx
decommitTxId :: TxIdType tx, forall tx. StateChanged tx -> UTxOType tx
utxoToDecommit :: UTxOType tx}
  | DecommitInvalid {headId :: HeadId, decommitTx :: tx, forall tx. StateChanged tx -> DecommitInvalidReason tx
decommitInvalidReason :: DecommitInvalidReason tx}
  | DecommitFinalized
      { chainState :: ChainStateType tx
      , headId :: HeadId
      , forall tx. StateChanged tx -> UTxOType tx
distributedUTxO :: UTxOType tx
      , newVersion :: SnapshotVersion
      }
  | HeadClosed {headId :: HeadId, snapshotNumber :: SnapshotNumber, chainState :: ChainStateType tx, forall tx. StateChanged tx -> UTCTime
contestationDeadline :: UTCTime}
  | HeadContested {headId :: HeadId, chainState :: ChainStateType tx, contestationDeadline :: UTCTime, snapshotNumber :: SnapshotNumber}
  | HeadIsReadyToFanout {headId :: HeadId}
  | -- | This node initiated a full automatic fanout ('Fanout' command). It
    -- transitions 'Closed' → 'PartialFanout' in 'AutoDrain' mode so that this
    -- node (the driver) auto-continues draining as chunks are observed. Other
    -- parties that merely observe the resulting partial fanout do NOT auto-drive
    -- (they go to 'AwaitingSelection'). No chain state change (client command).
    HeadFanoutInitiated
      { headId :: HeadId
      , forall tx. StateChanged tx -> UTxOType tx
remainingOutputs :: UTxOType tx
      }
  | -- | A user initiated or updated a selective partial fanout. From 'Closed'
    -- this transitions into the 'PartialFanout' state (using 'remainingOutputs'
    -- as the initial remaining set); from 'PartialFanout' it just updates the
    -- active selection. No chain state change (driven by a client command).
    HeadPartialFanoutSelected
      { headId :: HeadId
      , remainingOutputs :: UTxOType tx
      , forall tx. StateChanged tx -> UTxOType tx
selection :: UTxOType tx
      }
  | -- | Revert an optimistic 'Closed' → 'PartialFanout' transition back to
    -- 'Closed'. Emitted when posting the initiating fanout transaction fails
    -- terminally /before/ any partial fanout has landed on chain (i.e. while the
    -- off-chain state is 'PartialFanout' but the on-chain datum is still
    -- 'Closed'). Without this the head would wedge in 'PartialFanout' with
    -- 'Fanout' rejected. No chain state change.
    HeadFanoutReverted {headId :: HeadId}
  | HeadFannedOut {headId :: HeadId, forall tx. StateChanged tx -> UTxOType tx
finalizedOutputs :: UTxOType tx, chainState :: ChainStateType tx}
  | HeadPartialFannedOut
      { headId :: HeadId
      , forall tx. StateChanged tx -> UTxOType tx
distributedOutputs :: UTxOType tx
      , remainingOutputs :: UTxOType tx
      , chainState :: ChainStateType tx
      , forall tx. StateChanged tx -> FanoutMode tx
mode :: FanoutMode tx
      -- ^ The fanout mode to continue with after this step (drives whether the
      --   node auto-resumes draining or waits for the next 'PartialFanout').
      }
  | ChainRolledBack {chainState :: ChainStateType tx}
  | TickObserved {forall tx. StateChanged tx -> ChainPointType tx
chainPoint :: ChainPointType tx, chainTime :: UTCTime}
  | IgnoredHeadInitializing
      { headId :: HeadId
      , forall tx. StateChanged tx -> ContestationPeriod
contestationPeriod :: ContestationPeriod
      , parties :: [Party]
      , forall tx. StateChanged tx -> [OnChainId]
participants :: [OnChainId]
      }
  | TxInvalid {headId :: HeadId, forall tx. StateChanged tx -> UTxOType tx
utxo :: UTxOType tx, forall tx. StateChanged tx -> tx
transaction :: tx, forall tx. StateChanged tx -> ValidationError
validationError :: ValidationError}
  | LocalStateCleared {headId :: HeadId, snapshotNumber :: SnapshotNumber}
  | Checkpoint {forall tx. StateChanged tx -> NodeState tx
state :: NodeState tx}
  | NodeUnsynced {forall tx. StateChanged tx -> ChainSlot
chainSlot :: ChainSlot, chainTime :: UTCTime, forall tx. StateChanged tx -> NominalDiffTime
drift :: NominalDiffTime}
  | NodeSynced {chainSlot :: ChainSlot, chainTime :: UTCTime, drift :: NominalDiffTime}
  deriving stock ((forall x. StateChanged tx -> Rep (StateChanged tx) x)
-> (forall x. Rep (StateChanged tx) x -> StateChanged tx)
-> Generic (StateChanged tx)
forall x. Rep (StateChanged tx) x -> StateChanged tx
forall x. StateChanged tx -> Rep (StateChanged tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (StateChanged tx) x -> StateChanged tx
forall tx x. StateChanged tx -> Rep (StateChanged tx) x
$cfrom :: forall tx x. StateChanged tx -> Rep (StateChanged tx) x
from :: forall x. StateChanged tx -> Rep (StateChanged tx) x
$cto :: forall tx x. Rep (StateChanged tx) x -> StateChanged tx
to :: forall x. Rep (StateChanged tx) x -> StateChanged tx
Generic)

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

-- | Decoded generically, except that a 'HeadPartialFannedOut' persisted before
-- the 'mode' field existed (event logs from an earlier node) is decoded with
-- 'mode' defaulting to 'AwaitingSelection'. That is the safe default: the node
-- waits for the next 'PartialFanout' rather than assuming an auto-drain, so a
-- node mid-fanout can still restart. All other constructors decode as before.
instance forall tx. (IsChainState tx, IsTx tx, FromJSON (NodeState tx), FromJSON (ChainStateType tx)) => FromJSON (StateChanged tx) where
  parseJSON :: Value -> Parser (StateChanged tx)
parseJSON = Options -> Value -> Parser (StateChanged tx)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions (Value -> Parser (StateChanged tx))
-> (Value -> Value) -> Value -> Parser (StateChanged tx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
withDefaultFanoutMode
   where
    withDefaultFanoutMode :: Value -> Value
withDefaultFanoutMode = \case
      Object Object
o
        | Just (String Text
"HeadPartialFannedOut") <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"tag" Object
o
        , Bool -> Bool
not (Key -> Object -> Bool
forall a. Key -> KeyMap a -> Bool
KeyMap.member Key
"mode" Object
o) ->
            Object -> Value
Object (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"mode" (FanoutMode tx -> Value
forall a. ToJSON a => a -> Value
toJSON (FanoutMode tx
forall tx. FanoutMode tx
AwaitingSelection :: FanoutMode tx)) Object
o)
      Value
v -> Value
v

-- NOTE: This codec defines the event format persisted in the hydra.db events
-- table (see "Hydra.Events.SQLiteBased"). Changing an encoding here breaks
-- decoding of existing databases and requires a schema migration.
instance IsChainState tx => ToCBOR (StateChanged tx) where
  toCBOR :: StateChanged tx -> Encoding
toCBOR = StateChanged tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

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

data Outcome tx
  = -- | Continue with the given state updates and side effects.
    Continue {forall tx. Outcome tx -> [StateChanged tx]
stateChanges :: [StateChanged tx], forall tx. Outcome tx -> [Effect tx]
effects :: [Effect tx]}
  | -- | Wait for some condition to be met with optional state updates.
    Wait {forall tx. Outcome tx -> WaitReason tx
reason :: WaitReason tx, stateChanges :: [StateChanged tx]}
  | -- | Processing resulted in an error.
    Error {forall tx. Outcome tx -> LogicError tx
error :: LogicError tx}
  deriving stock ((forall x. Outcome tx -> Rep (Outcome tx) x)
-> (forall x. Rep (Outcome tx) x -> Outcome tx)
-> Generic (Outcome tx)
forall x. Rep (Outcome tx) x -> Outcome tx
forall x. Outcome tx -> Rep (Outcome tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (Outcome tx) x -> Outcome tx
forall tx x. Outcome tx -> Rep (Outcome tx) x
$cfrom :: forall tx x. Outcome tx -> Rep (Outcome tx) x
from :: forall x. Outcome tx -> Rep (Outcome tx) x
$cto :: forall tx x. Rep (Outcome tx) x -> Outcome tx
to :: forall x. Rep (Outcome tx) x -> Outcome tx
Generic)

instance Semigroup (Outcome tx) where
  e :: Outcome tx
e@Error{} <> :: Outcome tx -> Outcome tx -> Outcome tx
<> Outcome tx
_ = Outcome tx
e
  Outcome tx
_ <> e :: Outcome tx
e@Error{} = Outcome tx
e
  Continue [StateChanged tx]
scA [Effect tx]
_ <> Wait WaitReason tx
r [StateChanged tx]
scB = WaitReason tx -> [StateChanged tx] -> Outcome tx
forall tx. WaitReason tx -> [StateChanged tx] -> Outcome tx
Wait WaitReason tx
r ([StateChanged tx]
scA [StateChanged tx] -> [StateChanged tx] -> [StateChanged tx]
forall a. Semigroup a => a -> a -> a
<> [StateChanged tx]
scB)
  Wait WaitReason tx
r [StateChanged tx]
scA <> Outcome tx
_ = WaitReason tx -> [StateChanged tx] -> Outcome tx
forall tx. WaitReason tx -> [StateChanged tx] -> Outcome tx
Wait WaitReason tx
r [StateChanged tx]
scA
  Continue [StateChanged tx]
scA [Effect tx]
efA <> Continue [StateChanged tx]
scB [Effect tx]
efB = [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue ([StateChanged tx]
scA [StateChanged tx] -> [StateChanged tx] -> [StateChanged tx]
forall a. Semigroup a => a -> a -> a
<> [StateChanged tx]
scB) ([Effect tx]
efA [Effect tx] -> [Effect tx] -> [Effect tx]
forall a. Semigroup a => a -> a -> a
<> [Effect tx]
efB)

deriving stock instance IsChainState tx => Eq (Outcome tx)
deriving stock instance IsChainState tx => Show (Outcome tx)
deriving anyclass instance IsChainState tx => ToJSON (Outcome tx)

noop :: Outcome tx
noop :: forall tx. Outcome tx
noop = [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [] []

wait :: WaitReason tx -> Outcome tx
wait :: forall tx. WaitReason tx -> Outcome tx
wait WaitReason tx
reason = WaitReason tx -> [StateChanged tx] -> Outcome tx
forall tx. WaitReason tx -> [StateChanged tx] -> Outcome tx
Wait WaitReason tx
reason []

newState :: StateChanged tx -> Outcome tx
newState :: forall tx. StateChanged tx -> Outcome tx
newState StateChanged tx
change = [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [StateChanged tx
change] []

cause :: Effect tx -> Outcome tx
cause :: forall tx. Effect tx -> Outcome tx
cause Effect tx
e = [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [] [Effect tx
e]

causes :: [Effect tx] -> Outcome tx
causes :: forall tx. [Effect tx] -> Outcome tx
causes = [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue []

changes :: [StateChanged tx] -> Outcome tx
changes :: forall tx. [StateChanged tx] -> Outcome tx
changes [StateChanged tx]
stateChanges = [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [StateChanged tx]
stateChanges []

data WaitReason tx
  = WaitOnNotApplicableTx {forall tx. WaitReason tx -> ValidationError
validationError :: ValidationError}
  | WaitOnSnapshotNumber {forall tx. WaitReason tx -> SnapshotNumber
waitingForNumber :: SnapshotNumber}
  | WaitOnSnapshotVersion {forall tx. WaitReason tx -> SnapshotVersion
waitingForVersion :: SnapshotVersion}
  | WaitOnSeenSnapshot
  | WaitOnTxs {forall tx. WaitReason tx -> [TxIdType tx]
waitingForTxIds :: [TxIdType tx]}
  | WaitOnContestationDeadline
  | WaitOnNotApplicableDecommitTx {forall tx. WaitReason tx -> DecommitInvalidReason tx
notApplicableReason :: DecommitInvalidReason tx}
  | WaitOnUnresolvedCommit {forall tx. WaitReason tx -> UTxOType tx
commitUTxO :: UTxOType tx}
  | WaitOnUnresolvedDecommit {forall tx. WaitReason tx -> tx
decommitTx :: tx}
  | WaitOnDepositObserved {forall tx. WaitReason tx -> TxIdType tx
depositTxId :: TxIdType tx}
  | WaitOnDepositActivation {depositTxId :: TxIdType tx}
  | WaitOnNodeInSync {forall tx. WaitReason tx -> ChainSlot
currentSlot :: ChainSlot}
  deriving stock ((forall x. WaitReason tx -> Rep (WaitReason tx) x)
-> (forall x. Rep (WaitReason tx) x -> WaitReason tx)
-> Generic (WaitReason tx)
forall x. Rep (WaitReason tx) x -> WaitReason tx
forall x. WaitReason tx -> Rep (WaitReason tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (WaitReason tx) x -> WaitReason tx
forall tx x. WaitReason tx -> Rep (WaitReason tx) x
$cfrom :: forall tx x. WaitReason tx -> Rep (WaitReason tx) x
from :: forall x. WaitReason tx -> Rep (WaitReason tx) x
$cto :: forall tx x. Rep (WaitReason tx) x -> WaitReason tx
to :: forall x. Rep (WaitReason tx) x -> WaitReason tx
Generic)

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