{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilyDependencies #-}
-- NOTE: For serialiseTxLedgerCddl
{-# OPTIONS_GHC -Wno-deprecations #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Hydra.Tx.IsTx where

import Hydra.Cardano.Api
import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Binary (decCBOR, decodeFullAnnotator)
import Cardano.Ledger.Shelley.UTxO qualified as Ledger
import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Encoding qualified as CBOR
import Data.Aeson ((.:), (.:?))
import Data.Aeson qualified as Aeson
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (withObject)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text.Lazy.Builder (toLazyText)
import Formatting.Buildable (build)
import Hydra.Cardano.Api.Tx qualified as Api
import Hydra.Cardano.Api.UTxO qualified as Api
import Hydra.Contract.Util qualified as Util
import PlutusLedgerApi.V3 (fromBuiltin)

-- | Types of transactions that can be used by the Head protocol. The associated
-- types and methods of this type class represent the whole interface of what
-- the Head protocol needs from a transaction. This ensure the off-chain
-- protocol stays fairly independent of a concrete transaction type.
class
  ( Eq tx
  , Show tx
  , Typeable tx
  , FromCBOR tx
  , ToCBOR tx
  , FromJSON tx
  , ToJSON tx
  , --
    Eq (TxIdType tx)
  , Ord (TxIdType tx)
  , Show (TxIdType tx)
  , Typeable (TxIdType tx)
  , FromJSON (TxIdType tx)
  , ToJSON (TxIdType tx)
  , FromCBOR (TxIdType tx)
  , ToCBOR (TxIdType tx)
  , FromJSONKey (TxIdType tx)
  , ToJSONKey (TxIdType tx)
  , --
    Eq (TxOutType tx)
  , Ord (TxOutType tx)
  , Show (TxOutType tx)
  , ToJSON (TxOutType tx)
  , FromJSON (TxOutType tx)
  , --
    Eq (UTxOType tx)
  , Show (UTxOType tx)
  , Monoid (UTxOType tx)
  , FromJSON (UTxOType tx)
  , ToJSON (UTxOType tx)
  , FromCBOR (UTxOType tx)
  , ToCBOR (UTxOType tx)
  ) =>
  IsTx tx
  where
  -- | Type which identifies a transaction
  type TxIdType tx

  -- | Type for individual transaction outputs.
  type TxOutType tx = out | out -> tx

  -- | Type for a set of unspent transaction outputs.
  type UTxOType tx = utxo | utxo -> tx

  -- | Type representing a value on the ledger.
  type ValueType tx

  -- XXX(SN): this name easily conflicts
  txId :: tx -> TxIdType tx

  -- XXX: Is this even used?
  balance :: UTxOType tx -> ValueType tx

  -- | Hash a utxo set to be able to sign (off-chain) and verify it (on-chain).
  hashUTxO :: UTxOType tx -> ByteString

  -- | Raw bytes identifying a transaction, as bound into snapshot signatures.
  -- Must match what the on-chain code reads out of a 'TxOutRef', see
  -- 'Hydra.Tx.Snapshot.getSignableRepresentation'.
  txIdBytes :: TxIdType tx -> ByteString

  txSpendingUTxO :: UTxOType tx -> tx

  -- | Get the UTxO produced by given transaction.
  utxoFromTx :: tx -> UTxOType tx

  -- | Get only the outputs in given UTxO.
  outputsOfUTxO :: UTxOType tx -> [TxOutType tx]

  -- | Return the left-hand side without the right-hand side.
  withoutUTxO :: UTxOType tx -> UTxOType tx -> UTxOType tx

  -- | Apply a transaction to a UTxO via pure UTxO arithmetic, returning the
  -- post-tx UTxO. Removes the tx's inputs from the given UTxO and adds the
  -- tx's outputs. Performs no ledger validation; the caller must ensure the
  -- tx is valid against the given UTxO.
  applyTxTo :: tx -> UTxOType tx -> UTxOType tx

  -- | Filter a UTxO set keeping only entries whose output value is in the given set.
  filterUTxOByOutputs :: UTxOType tx -> Set (TxOutType tx) -> UTxOType tx

  removeOneOutputFromUTxO :: TxOutType tx -> UTxOType tx -> UTxOType tx

  -- | Convert a TxOut to a ByteString element for the accumulator.
  -- This serializes the TxOut in the same way as the on-chain code does.
  utxoToElement :: TxOutType tx -> ByteString

-- * Cardano Tx

instance IsShelleyBasedEra era => ToJSON (Api.Tx era) where
  toJSON :: Tx era -> Value
toJSON Tx era
tx =
    -- XXX: This is a deprecated function, but the only one that produces the
    -- right 'Tx ConwayEra' in the envelope type. Cardano-api will be
    -- fixing the 'HasTextEnvelope' instance for 'Tx era' and then we can use
    -- 'serialiseToTextEnvelope' here.
    case TextEnvelope -> Value
forall a. ToJSON a => a -> Value
toJSON (TextEnvelope -> Value) -> TextEnvelope -> Value
forall a b. (a -> b) -> a -> b
$ Maybe TextEnvelopeDescr -> Tx era -> TextEnvelope
forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> TextEnvelope
serialiseToTextEnvelope Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing Tx era
tx of
      Aeson.Object Object
km ->
        Object -> Value
Aeson.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"txId" (TxId -> Value
forall a. ToJSON a => a -> Value
toJSON (TxId -> Value) -> TxId -> Value
forall a b. (a -> b) -> a -> b
$ TxBody era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody era -> TxId) -> TxBody era -> TxId
forall a b. (a -> b) -> a -> b
$ Tx era -> TxBody era
forall era. Tx era -> TxBody era
getTxBody Tx era
tx) Object
km
      Value
v -> Value
v

-- | Orphan 'Ord' instance for 'TxOut CtxUTxO' using JSON encoding for comparison.
-- Needed to use 'TxOut CtxUTxO' in 'Set' and as 'TxOutType Tx' with the 'Ord' constraint.
--
-- XXX: This fully serialises both operands on every comparison (including any
-- reference script, as hex CBOR), so it is O(size of output) rather than O(1)
-- and allocates on each call. It is kept as-is deliberately: the ordering it
-- induces is observable through every 'Set'/'Map' keyed by an output, so a
-- cheaper key (e.g. comparing CBOR instead) would silently reorder them.
-- cardano-ledger provides no 'Ord' for 'BabbageTxOut' to delegate to, so
-- changing this needs a deliberate decision about the new ordering rather than
-- a drop-in replacement.
instance Ord (TxOut CtxUTxO) where
  compare :: TxOut CtxUTxO -> TxOut CtxUTxO -> Ordering
compare TxOut CtxUTxO
x TxOut CtxUTxO
y = ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (TxOut CtxUTxO -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode TxOut CtxUTxO
x) (TxOut CtxUTxO -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode TxOut CtxUTxO
y)

instance FromJSON Tx where
  parseJSON :: Value -> Parser Tx
parseJSON =
    String -> (Object -> Parser Tx) -> Value -> Parser Tx
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Tx" ((Object -> Parser Tx) -> Value -> Parser Tx)
-> (Object -> Parser Tx) -> Value -> Parser Tx
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      Text
hexText <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"cborHex"
      -- NOTE: We deliberately ignore the "type" to be backwards compatible
      ByteString
bytes <- Text -> Parser ByteString
forall (f :: * -> *). MonadFail f => Text -> f ByteString
decodeBase16 Text
hexText
      case AsType Tx -> ByteString -> Either DecoderError Tx
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR (Proxy Tx -> AsType Tx
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Tx)) ByteString
bytes of
        Left DecoderError
e -> String -> Parser Tx
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Tx) -> String -> Parser Tx
forall a b. (a -> b) -> a -> b
$ DecoderError -> String
forall b a. (Show a, IsString b) => a -> b
show DecoderError
e
        Right Tx
tx -> do
          -- NOTE: Check txId equivalence only if present.
          (Object
o Object -> Key -> Parser (Maybe TxId)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"txId") Parser (Maybe TxId) -> (Maybe TxId -> Parser Tx) -> Parser Tx
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just TxId
txid'
              | TxId
txid' TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
/= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
Hydra.Tx.IsTx.txId Tx
tx -> String -> Parser Tx
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"txId not matching"
            Maybe TxId
_ -> Tx -> Parser Tx
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
tx

-- XXX: Double CBOR encoding?
instance IsShelleyBasedEra era => ToCBOR (Api.Tx era) where
  toCBOR :: Tx era -> Encoding
toCBOR = ByteString -> Encoding
CBOR.encodeBytes (ByteString -> Encoding)
-> (Tx era -> ByteString) -> Tx era -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx era -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR

-- XXX: Double CBOR encoding?
instance FromCBOR Tx where
  fromCBOR :: forall s. Decoder s Tx
fromCBOR = do
    ByteString
bs <- Decoder s ByteString
forall s. Decoder s ByteString
CBOR.decodeBytes
    Version
-> Text
-> (forall s. Decoder s (Annotator (Tx TopTx ConwayEra)))
-> ByteString
-> Either DecoderError (Tx TopTx ConwayEra)
forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator Version
ledgerEraVersion Text
"Tx" Decoder s (Annotator (Tx TopTx ConwayEra))
forall s. Decoder s (Annotator (Tx TopTx ConwayEra))
forall a s. DecCBOR a => Decoder s a
decCBOR (ByteString -> ByteString
forall l s. LazyStrict l s => s -> l
fromStrict ByteString
bs)
      Either DecoderError (Tx TopTx ConwayEra)
-> (Either DecoderError (Tx TopTx ConwayEra) -> Decoder s Tx)
-> Decoder s Tx
forall a b. a -> (a -> b) -> b
& (DecoderError -> Decoder s Tx)
-> (Tx TopTx ConwayEra -> Decoder s Tx)
-> Either DecoderError (Tx TopTx ConwayEra)
-> Decoder s Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        (String -> Decoder s Tx
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s Tx)
-> (DecoderError -> String) -> DecoderError -> Decoder s Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> String)
-> (DecoderError -> Text) -> DecoderError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text)
-> (DecoderError -> Builder) -> DecoderError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoderError -> Builder
forall p. Buildable p => p -> Builder
build)
        (Tx -> Decoder s Tx
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Decoder s Tx)
-> (Tx TopTx ConwayEra -> Tx) -> Tx TopTx ConwayEra -> Decoder s Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx TopTx (ShelleyLedgerEra ConwayEra) -> Tx
Tx TopTx ConwayEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx)

instance ToCBOR UTxO where
  toCBOR :: UTxO -> Encoding
toCBOR = UTxO ConwayEra -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (UTxO ConwayEra -> Encoding)
-> (UTxO -> UTxO ConwayEra) -> UTxO -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra ConwayEra
-> UTxO -> UTxO (ShelleyLedgerEra ConwayEra)
forall era.
HasCallStack =>
ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
UTxO.toShelleyUTxO ShelleyBasedEra ConwayEra
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy UTxO -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
sz Proxy UTxO
_ = (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (UTxO ConwayEra) -> Size
forall a.
ToCBOR a =>
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr Proxy t -> Size
forall t. ToCBOR t => Proxy t -> Size
sz (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Ledger.UTxO LedgerEra))

instance FromCBOR UTxO where
  -- NOTE: Use the forcing conversion to uphold the invariant that any 'UTxO'
  -- entering the head logic is thunk-free.
  fromCBOR :: forall s. Decoder s UTxO
fromCBOR = UTxO (ShelleyLedgerEra ConwayEra) -> UTxO
UTxO ConwayEra -> UTxO
Api.fromLedgerUTxO (UTxO ConwayEra -> UTxO)
-> Decoder s (UTxO ConwayEra) -> Decoder s UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (UTxO ConwayEra)
forall s. Decoder s (UTxO ConwayEra)
forall a s. FromCBOR a => Decoder s a
fromCBOR
  label :: Proxy UTxO -> Text
label Proxy UTxO
_ = Proxy (UTxO ConwayEra) -> Text
forall a. FromCBOR a => Proxy a -> Text
label (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Ledger.UTxO LedgerEra))

instance IsTx Tx where
  type TxIdType Tx = TxId
  type TxOutType Tx = TxOut CtxUTxO
  type UTxOType Tx = UTxO
  type ValueType Tx = Value

  txId :: Tx -> TxIdType Tx
txId = TxBody ConwayEra -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody ConwayEra -> TxId)
-> (Tx -> TxBody ConwayEra) -> Tx -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> TxBody ConwayEra
forall era. Tx era -> TxBody era
getTxBody
  balance :: UTxOType Tx -> ValueType Tx
balance = UTxO -> Value
UTxOType Tx -> ValueType Tx
forall era. UTxO era -> Value
UTxO.totalValue

  -- NOTE: See note from `Util.hashTxOuts`.
  hashUTxO :: UTxOType Tx -> ByteString
hashUTxO = BuiltinByteString -> ByteString
BuiltinByteString -> FromBuiltin BuiltinByteString
forall arep. HasFromBuiltin arep => arep -> FromBuiltin arep
fromBuiltin (BuiltinByteString -> ByteString)
-> (UTxO -> BuiltinByteString) -> UTxO -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOut] -> BuiltinByteString
Util.hashTxOuts ([TxOut] -> BuiltinByteString)
-> (UTxO -> [TxOut]) -> UTxO -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut CtxUTxO -> Maybe TxOut) -> [TxOut CtxUTxO] -> [TxOut]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HasCallStack => TxOut CtxUTxO -> Maybe TxOut
TxOut CtxUTxO -> Maybe TxOut
toPlutusTxOut ([TxOut CtxUTxO] -> [TxOut])
-> (UTxO -> [TxOut CtxUTxO]) -> UTxO -> [TxOut]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs

  -- NOTE: Same 32 bytes as the on-chain 'getTxId' of a 'TxOutRef'.
  txIdBytes :: TxIdType Tx -> ByteString
txIdBytes = TxId -> ByteString
TxIdType Tx -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes

  txSpendingUTxO :: UTxOType Tx -> Tx
txSpendingUTxO = UTxO -> Tx
UTxOType Tx -> Tx
Api.txSpendingUTxO

  utxoFromTx :: Tx -> UTxOType Tx
utxoFromTx = Tx -> UTxO
Tx -> UTxOType Tx
Api.utxoFromTx

  outputsOfUTxO :: UTxOType Tx -> [TxOutType Tx]
outputsOfUTxO = UTxO -> [TxOut CtxUTxO]
UTxOType Tx -> [TxOutType Tx]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs

  withoutUTxO :: UTxOType Tx -> UTxOType Tx -> UTxOType Tx
withoutUTxO = UTxO -> UTxO -> UTxO
UTxOType Tx -> UTxOType Tx -> UTxOType Tx
forall era. UTxO era -> UTxO era -> UTxO era
UTxO.difference

  applyTxTo :: Tx -> UTxOType Tx -> UTxOType Tx
applyTxTo Tx
tx UTxOType Tx
utxo = (UTxO
UTxOType Tx
utxo UTxO -> UTxO -> UTxO
forall era. UTxO era -> UTxO era -> UTxO era
`UTxO.difference` UTxO -> Tx -> UTxO
Api.resolveInputsUTxO UTxO
UTxOType Tx
utxo Tx
tx) UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> Tx -> UTxO
Api.utxoFromTx Tx
tx

  filterUTxOByOutputs :: UTxOType Tx -> Set (TxOutType Tx) -> UTxOType Tx
filterUTxOByOutputs UTxOType Tx
utxo Set (TxOutType Tx)
outputs = (TxOut CtxUTxO -> Bool) -> UTxO -> UTxO
forall era. (TxOut CtxUTxO era -> Bool) -> UTxO era -> UTxO era
UTxO.filter (TxOutType Tx -> Set (TxOutType Tx) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (TxOutType Tx)
outputs) UTxO
UTxOType Tx
utxo

  removeOneOutputFromUTxO :: TxOutType Tx -> UTxOType Tx -> UTxOType Tx
removeOneOutputFromUTxO TxOutType Tx
out (UTxO Map TxIn (TxOut CtxUTxO)
m) =
    case Map TxIn (TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
forall k a. Map k a -> [(k, a)]
Map.toAscList ((TxOut CtxUTxO -> Bool)
-> Map TxIn (TxOut CtxUTxO) -> Map TxIn (TxOut CtxUTxO)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (TxOutType Tx -> TxOutType Tx -> Bool
forall a. Eq a => a -> a -> Bool
== TxOutType Tx
out) Map TxIn (TxOut CtxUTxO)
m) of
      [] -> Map TxIn (TxOut CtxUTxO) -> UTxO
UTxO Map TxIn (TxOut CtxUTxO)
m
      (TxIn
txin, TxOut CtxUTxO
_) : [(TxIn, TxOut CtxUTxO)]
_ -> Map TxIn (TxOut CtxUTxO) -> UTxO
UTxO (TxIn -> Map TxIn (TxOut CtxUTxO) -> Map TxIn (TxOut CtxUTxO)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TxIn
txin Map TxIn (TxOut CtxUTxO)
m)

  -- \| Convert a Cardano UTxO pair to a ByteString element using Plutus serialization.
  -- Uses sha2_256 (via hashTxOuts) because the haskell-accumulator library
  -- internally applies Blake2b_224 on each element (see Accumulator.addElement).
  -- The on-chain scalar is then blake2b_224(sha2_256(serialised)), matching exactly.
  utxoToElement :: TxOutType Tx -> ByteString
utxoToElement TxOutType Tx
txOut =
    case HasCallStack => TxOut CtxUTxO -> Maybe TxOut
TxOut CtxUTxO -> Maybe TxOut
toPlutusTxOut TxOut CtxUTxO
TxOutType Tx
txOut of
      Just TxOut
plutusTxOut -> BuiltinByteString -> FromBuiltin BuiltinByteString
forall arep. HasFromBuiltin arep => arep -> FromBuiltin arep
fromBuiltin ([TxOut] -> BuiltinByteString
Util.hashTxOuts [TxOut
plutusTxOut])
      Maybe TxOut
Nothing -> ByteString
forall a. Monoid a => a
mempty -- Should not happen for valid UTxO

instance {-# OVERLAPPING #-} FromJSON UTxO where
  parseJSON :: Value -> Parser UTxO
parseJSON = Value -> Parser UTxO
parseUTxOFromJSON