{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DuplicateRecordFields #-}

-- | Observe hydra transactions
module Hydra.Tx.Observe (
  module Hydra.Tx.Observe,
  module Hydra.Tx.Init,
  module Hydra.Tx.Decrement,
  module Hydra.Tx.Deposit,
  module Hydra.Tx.Increment,
  module Hydra.Tx.Recover,
  module Hydra.Tx.Close,
  module Hydra.Tx.Contest,
  module Hydra.Tx.Fanout,
) where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (toList)

import Cardano.Ledger.Api (IsValid (..), isValidTxL)
import Control.Lens ((^.))
import Data.Aeson (Value (Object, String), defaultOptions, genericToJSON, withObject, (.:))
import Data.Aeson qualified as Aeson (Value)
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Lens (key, _Object, _String)
import Hydra.Contract.Head qualified as Head
import Hydra.Tx.Close (CloseObservation (..), observeCloseTx)
import Hydra.Tx.Contest (ContestObservation (..), observeContestTx)
import Hydra.Tx.Decrement (DecrementObservation (..), observeDecrementTx)
import Hydra.Tx.Deposit (DepositObservation (..), observeDepositTx)
import Hydra.Tx.Fanout (FanoutObservation (..), PartialFanoutObservation (..), observeFanoutTx, observeFinalPartialFanoutTx, observePartialFanoutTx)
import Hydra.Tx.Increment (IncrementObservation (..), observeIncrementTx)
import Hydra.Tx.Init (InitObservation (..), NotAnInitReason (..), isMalformedInit, observeInitTx)
import Hydra.Tx.Recover (RecoverObservation (..), observeRecoverTx)

-- * Observe Hydra Head transactions

-- | Generalised type for arbitrary Head observations on-chain.
data HeadObservation
  = NoHeadTx
  | Init InitObservation
  | Deposit DepositObservation
  | Recover RecoverObservation
  | Increment IncrementObservation
  | Decrement DecrementObservation
  | Close CloseObservation
  | Contest ContestObservation
  | PartialFanout PartialFanoutObservation
  | Fanout FanoutObservation
  | FinalPartialFanout FanoutObservation
  deriving stock (HeadObservation -> HeadObservation -> Bool
(HeadObservation -> HeadObservation -> Bool)
-> (HeadObservation -> HeadObservation -> Bool)
-> Eq HeadObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeadObservation -> HeadObservation -> Bool
== :: HeadObservation -> HeadObservation -> Bool
$c/= :: HeadObservation -> HeadObservation -> Bool
/= :: HeadObservation -> HeadObservation -> Bool
Eq, Int -> HeadObservation -> ShowS
[HeadObservation] -> ShowS
HeadObservation -> String
(Int -> HeadObservation -> ShowS)
-> (HeadObservation -> String)
-> ([HeadObservation] -> ShowS)
-> Show HeadObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeadObservation -> ShowS
showsPrec :: Int -> HeadObservation -> ShowS
$cshow :: HeadObservation -> String
show :: HeadObservation -> String
$cshowList :: [HeadObservation] -> ShowS
showList :: [HeadObservation] -> ShowS
Show, (forall x. HeadObservation -> Rep HeadObservation x)
-> (forall x. Rep HeadObservation x -> HeadObservation)
-> Generic HeadObservation
forall x. Rep HeadObservation x -> HeadObservation
forall x. HeadObservation -> Rep HeadObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HeadObservation -> Rep HeadObservation x
from :: forall x. HeadObservation -> Rep HeadObservation x
$cto :: forall x. Rep HeadObservation x -> HeadObservation
to :: forall x. Rep HeadObservation x -> HeadObservation
Generic)

-- NOTE: Custom To/FromJSON instances to create a "flat" encoding. The default
-- generic implementation would use 'TaggedObject' with a "contents" field, but
-- we want it flat so it resembles what we (used to) have for 'OnChainTx'
-- without removing the sub-types.

instance ToJSON HeadObservation where
  toJSON :: HeadObservation -> Value
toJSON = Value -> Value
mergeContents (Value -> Value)
-> (HeadObservation -> Value) -> HeadObservation -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> HeadObservation -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions
   where
    mergeContents :: Aeson.Value -> Aeson.Value
    mergeContents :: Value -> Value
mergeContents Value
v = do
      let tag :: Text
tag = Value
v Value -> Getting Text Value Text -> Text
forall s a. s -> Getting a s a -> a
^. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"tag" ((Value -> Const Text Value) -> Value -> Const Text Value)
-> Getting Text Value Text -> Getting Text Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String
      let km :: Object
km = Value
v Value -> Getting Object Value Object -> Object
forall s a. s -> Getting a s a -> a
^. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"contents" ((Value -> Const Object Value) -> Value -> Const Object Value)
-> Getting Object Value Object -> Getting Object Value Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Object Value Object
forall t. AsValue t => Prism' t Object
Prism' Value Object
_Object
      Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"tag" (Text -> Value
String Text
tag) Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
km

instance FromJSON HeadObservation where
  parseJSON :: Value -> Parser HeadObservation
parseJSON = String
-> (Object -> Parser HeadObservation)
-> Value
-> Parser HeadObservation
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"HeadObservation" ((Object -> Parser HeadObservation)
 -> Value -> Parser HeadObservation)
-> (Object -> Parser HeadObservation)
-> Value
-> Parser HeadObservation
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
tag <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag"
    case Text
tag :: Text of
      Text
"NoHeadTx" -> HeadObservation -> Parser HeadObservation
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadObservation
NoHeadTx
      Text
"Init" -> InitObservation -> HeadObservation
Init (InitObservation -> HeadObservation)
-> Parser InitObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser InitObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"Deposit" -> DepositObservation -> HeadObservation
Deposit (DepositObservation -> HeadObservation)
-> Parser DepositObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser DepositObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"Recover" -> RecoverObservation -> HeadObservation
Recover (RecoverObservation -> HeadObservation)
-> Parser RecoverObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser RecoverObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"Increment" -> IncrementObservation -> HeadObservation
Increment (IncrementObservation -> HeadObservation)
-> Parser IncrementObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser IncrementObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"Decrement" -> DecrementObservation -> HeadObservation
Decrement (DecrementObservation -> HeadObservation)
-> Parser DecrementObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser DecrementObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"Close" -> CloseObservation -> HeadObservation
Close (CloseObservation -> HeadObservation)
-> Parser CloseObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser CloseObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"Contest" -> ContestObservation -> HeadObservation
Contest (ContestObservation -> HeadObservation)
-> Parser ContestObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser ContestObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"PartialFanout" -> PartialFanoutObservation -> HeadObservation
PartialFanout (PartialFanoutObservation -> HeadObservation)
-> Parser PartialFanoutObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser PartialFanoutObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"Fanout" -> FanoutObservation -> HeadObservation
Fanout (FanoutObservation -> HeadObservation)
-> Parser FanoutObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser FanoutObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"FinalPartialFanout" -> FanoutObservation -> HeadObservation
FinalPartialFanout (FanoutObservation -> HeadObservation)
-> Parser FanoutObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser FanoutObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
_ -> String -> Parser HeadObservation
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser HeadObservation)
-> String -> Parser HeadObservation
forall a b. (a -> b) -> a -> b
$ String
"Unknown tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
tag

-- | Observe any Hydra head transaction.
observeHeadTx :: NetworkId -> UTxO -> Tx -> HeadObservation
observeHeadTx :: NetworkId -> UTxO -> Tx -> HeadObservation
observeHeadTx NetworkId
networkId UTxO
utxo =
  (HeadObservation, Maybe NotAnInitReason) -> HeadObservation
forall a b. (a, b) -> a
fst ((HeadObservation, Maybe NotAnInitReason) -> HeadObservation)
-> (Tx -> (HeadObservation, Maybe NotAnInitReason))
-> Tx
-> HeadObservation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkId -> UTxO -> Tx -> (HeadObservation, Maybe NotAnInitReason)
observeHeadTxWithReason NetworkId
networkId UTxO
utxo

-- | Like 'observeHeadTx', but also reports why a transaction that really did
-- mint a head's tokens was rejected as an init (see 'isMalformedInit'). There is
-- nothing to act on in that case - hence the 'HeadObservation' is unaffected -
-- but it is worth logging, as the minting policy constrains none of the datum
-- fields involved.
observeHeadTxWithReason :: NetworkId -> UTxO -> Tx -> (HeadObservation, Maybe NotAnInitReason)
observeHeadTxWithReason :: NetworkId -> UTxO -> Tx -> (HeadObservation, Maybe NotAnInitReason)
observeHeadTxWithReason NetworkId
networkId UTxO
utxo Tx
tx
  -- NOTE: Never make an observation on invalid transactions.
  | Bool -> Bool
not Bool
txIsValid = (HeadObservation
NoHeadTx, Maybe NotAnInitReason
forall a. Maybe a
Nothing)
  | Bool
otherwise =
      case Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
tx of
        Right InitObservation
observation -> (InitObservation -> HeadObservation
Init InitObservation
observation, Maybe NotAnInitReason
forall a. Maybe a
Nothing)
        Left NotAnInitReason
reason ->
          ( HeadObservation -> Maybe HeadObservation -> HeadObservation
forall a. a -> Maybe a -> a
fromMaybe HeadObservation
NoHeadTx Maybe HeadObservation
observeAnythingElse
          , if NotAnInitReason -> Bool
isMalformedInit NotAnInitReason
reason then NotAnInitReason -> Maybe NotAnInitReason
forall a. a -> Maybe a
Just NotAnInitReason
reason else Maybe NotAnInitReason
forall a. Maybe a
Nothing
          )
 where
  -- XXX: This is throwing away valuable information! We should be collecting
  -- all "not an XX" reasons here in case we fall through and want that
  -- diagnostic information in the call site of this function. Collecting errors
  -- could be done with 'validation' or a similar package.
  --
  -- Every observer but the deposit one identifies its transaction by the
  -- redeemer spending a head or deposit output. The deposit observer matches on
  -- shape alone (a deposit output at index 0 with a consistent datum, in a
  -- transaction with an upper validity bound), which a head transaction can
  -- reproduce: a fanout distributes L2 outputs from index 0, and anyone can
  -- create a deposit-shaped output on L2. So it is tried last, and never for a
  -- transaction spending a head output, which no deposit does.
  observeAnythingElse :: Maybe HeadObservation
observeAnythingElse =
    IncrementObservation -> HeadObservation
Increment (IncrementObservation -> HeadObservation)
-> Maybe IncrementObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId -> UTxO -> Tx -> Maybe IncrementObservation
observeIncrementTx NetworkId
networkId UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RecoverObservation -> HeadObservation
Recover (RecoverObservation -> HeadObservation)
-> Maybe RecoverObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId -> UTxO -> Tx -> Maybe RecoverObservation
observeRecoverTx NetworkId
networkId UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DecrementObservation -> HeadObservation
Decrement (DecrementObservation -> HeadObservation)
-> Maybe DecrementObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe DecrementObservation
observeDecrementTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CloseObservation -> HeadObservation
Close (CloseObservation -> HeadObservation)
-> Maybe CloseObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe CloseObservation
observeCloseTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ContestObservation -> HeadObservation
Contest (ContestObservation -> HeadObservation)
-> Maybe ContestObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe ContestObservation
observeContestTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PartialFanoutObservation -> HeadObservation
PartialFanout (PartialFanoutObservation -> HeadObservation)
-> Maybe PartialFanoutObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe PartialFanoutObservation
observePartialFanoutTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FanoutObservation -> HeadObservation
Fanout (FanoutObservation -> HeadObservation)
-> Maybe FanoutObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe FanoutObservation
observeFanoutTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FanoutObservation -> HeadObservation
FinalPartialFanout (FanoutObservation -> HeadObservation)
-> Maybe FanoutObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe FanoutObservation
observeFinalPartialFanoutTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DepositObservation -> HeadObservation
Deposit (DepositObservation -> HeadObservation)
-> Maybe DepositObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
spendsHeadOutput) Maybe () -> Maybe DepositObservation -> Maybe DepositObservation
forall a b. Maybe a -> Maybe b -> Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
networkId Tx
tx)

  spendsHeadOutput :: Bool
spendsHeadOutput = Maybe (TxIn, TxOut CtxUTxO Era) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (TxIn, TxOut CtxUTxO Era) -> Bool)
-> Maybe (TxIn, TxOut CtxUTxO Era) -> Bool
forall a b. (a -> b) -> a -> b
$ UTxO
-> PlutusScript PlutusScriptV3 -> Maybe (TxIn, TxOut CtxUTxO Era)
forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO Era)
findTxOutByScript (UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx) PlutusScript PlutusScriptV3
Head.validatorScript

  txIsValid :: Bool
txIsValid = Tx -> Tx TopTx (ShelleyLedgerEra Era)
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx Tx TopTx ConwayEra
-> Getting IsValid (Tx TopTx ConwayEra) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx ConwayEra) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx ConwayEra) IsValid
isValidTxL IsValid -> IsValid -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> IsValid
IsValid Bool
True