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

-- | Observe hydra transactions
module Hydra.Tx.Observe (
  module Hydra.Tx.Observe,
  module Hydra.Tx.Init,
  module Hydra.Tx.Abort,
  module Hydra.Tx.Commit,
  module Hydra.Tx.CollectCom,
  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.KeyMap qualified as KeyMap
import Data.Aeson.Lens (key, _Object, _String)
import Hydra.Tx.Abort (AbortObservation (..), observeAbortTx)
import Hydra.Tx.Close (CloseObservation (..), observeCloseTx)
import Hydra.Tx.CollectCom (CollectComObservation (..), observeCollectComTx)
import Hydra.Tx.Commit (CommitObservation (..), observeCommitTx)
import Hydra.Tx.Contest (ContestObservation (..), observeContestTx)
import Hydra.Tx.Decrement (DecrementObservation (..), observeDecrementTx)
import Hydra.Tx.Deposit (DepositObservation (..), observeDepositTx)
import Hydra.Tx.Fanout (FanoutObservation (..), observeFanoutTx)
import Hydra.Tx.Increment (IncrementObservation (..), observeIncrementTx)
import Hydra.Tx.Init (InitObservation (..), NotAnInitReason (..), observeInitTx)
import Hydra.Tx.Recover (RecoverObservation (..), observeRecoverTx)

-- * Observe Hydra Head transactions

-- | Generalised type for arbitrary Head observations on-chain.
data HeadObservation
  = NoHeadTx
  | Init InitObservation
  | Abort AbortObservation
  | Commit CommitObservation
  | CollectCom CollectComObservation
  | Deposit DepositObservation
  | Recover RecoverObservation
  | Increment IncrementObservation
  | Decrement DecrementObservation
  | Close CloseObservation
  | Contest ContestObservation
  | Fanout 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
forall {s}. AsValue s => s -> 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 :: s -> Value
mergeContents s
v = do
      let tag :: Text
tag = s
v s -> Getting Text s Text -> Text
forall s a. s -> Getting a s a -> a
^. Key -> Traversal' s Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"tag" ((Value -> Const Text Value) -> s -> Const Text s)
-> ((Text -> Const Text Text) -> Value -> Const Text Value)
-> Getting Text s Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> Value -> Const Text Value
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String
      let km :: Object
km = s
v s -> Getting Object s Object -> Object
forall s a. s -> Getting a s a -> a
^. Key -> Traversal' s Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"contents" ((Value -> Const Object Value) -> s -> Const Object s)
-> ((Object -> Const Object Object) -> Value -> Const Object Value)
-> Getting Object s Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Object -> Const Object Object) -> Value -> Const Object Value
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
"Abort" -> AbortObservation -> HeadObservation
Abort (AbortObservation -> HeadObservation)
-> Parser AbortObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser AbortObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"Commit" -> CommitObservation -> HeadObservation
Commit (CommitObservation -> HeadObservation)
-> Parser CommitObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser CommitObservation
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
      Text
"CollectCom" -> CollectComObservation -> HeadObservation
CollectCom (CollectComObservation -> HeadObservation)
-> Parser CollectComObservation -> Parser HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser CollectComObservation
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
"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
_ -> 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 Tx
tx =
  -- 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.
  HeadObservation -> Maybe HeadObservation -> HeadObservation
forall a. a -> Maybe a -> a
fromMaybe HeadObservation
NoHeadTx (Maybe HeadObservation -> HeadObservation)
-> Maybe HeadObservation -> HeadObservation
forall a b. (a -> b) -> a -> b
$ do
    -- NOTE: Never make an observation on invalid transactions.
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
txIsValid
    (NotAnInitReason -> Maybe HeadObservation)
-> (InitObservation -> Maybe HeadObservation)
-> Either NotAnInitReason InitObservation
-> Maybe HeadObservation
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe HeadObservation -> NotAnInitReason -> Maybe HeadObservation
forall a b. a -> b -> a
const Maybe HeadObservation
forall a. Maybe a
Nothing) (HeadObservation -> Maybe HeadObservation
forall a. a -> Maybe a
Just (HeadObservation -> Maybe HeadObservation)
-> (InitObservation -> HeadObservation)
-> InitObservation
-> Maybe HeadObservation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitObservation -> HeadObservation
Init) (Tx -> Either NotAnInitReason InitObservation
observeInitTx 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
<|> AbortObservation -> HeadObservation
Abort (AbortObservation -> HeadObservation)
-> Maybe AbortObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe AbortObservation
observeAbortTx 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
<|> CommitObservation -> HeadObservation
Commit (CommitObservation -> HeadObservation)
-> Maybe CommitObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId -> UTxO -> Tx -> Maybe CommitObservation
observeCommitTx 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
<|> CollectComObservation -> HeadObservation
CollectCom (CollectComObservation -> HeadObservation)
-> Maybe CollectComObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe CollectComObservation
observeCollectComTx 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
<$> NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
networkId 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
<|> IncrementObservation -> HeadObservation
Increment (IncrementObservation -> HeadObservation)
-> Maybe IncrementObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe IncrementObservation
observeIncrementTx 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
<|> 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
 where
  txIsValid :: Bool
txIsValid = Tx -> Tx (ShelleyLedgerEra Era)
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx AlonzoTx ConwayEra
-> Getting IsValid (AlonzoTx ConwayEra) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. (IsValid -> Const IsValid IsValid)
-> Tx ConwayEra -> Const IsValid (Tx ConwayEra)
Getting IsValid (AlonzoTx ConwayEra) IsValid
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx ConwayEra) IsValid
isValidTxL IsValid -> IsValid -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> IsValid
IsValid Bool
True