{-# 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 (FromJSONKey, ToJSONKey, (.:), (.:?))
import Data.Aeson qualified as Aeson
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (withObject)
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.Head qualified as Head
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)
  , 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

  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

-- * Constraint synonyms

type ArbitraryIsTx tx =
  ( IsTx tx
  , Arbitrary tx
  , Arbitrary (UTxOType tx)
  , Arbitrary (TxIdType tx)
  , Arbitrary (TxOutType tx)
  )

-- * 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

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 ingore 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
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 (AlonzoTx (ConwayEra StandardCrypto))))
-> ByteString
-> Either DecoderError (AlonzoTx (ConwayEra StandardCrypto))
forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator Version
ledgerEraVersion Text
"Tx" Decoder s (Annotator (AlonzoTx (ConwayEra StandardCrypto)))
forall s.
Decoder s (Annotator (AlonzoTx (ConwayEra StandardCrypto)))
forall a s. DecCBOR a => Decoder s a
decCBOR (ByteString -> ByteString
forall l s. LazyStrict l s => s -> l
fromStrict ByteString
bs)
      Either DecoderError (AlonzoTx (ConwayEra StandardCrypto))
-> (Either DecoderError (AlonzoTx (ConwayEra StandardCrypto))
    -> Decoder s Tx)
-> Decoder s Tx
forall a b. a -> (a -> b) -> b
& (DecoderError -> Decoder s Tx)
-> (AlonzoTx (ConwayEra StandardCrypto) -> Decoder s Tx)
-> Either DecoderError (AlonzoTx (ConwayEra StandardCrypto))
-> 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)
-> (AlonzoTx (ConwayEra StandardCrypto) -> Tx)
-> AlonzoTx (ConwayEra StandardCrypto)
-> Decoder s Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (ShelleyLedgerEra ConwayEra) -> Tx
AlonzoTx (ConwayEra StandardCrypto) -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx)

instance ToCBOR UTxO where
  toCBOR :: UTxO -> Encoding
toCBOR = UTxO (ConwayEra StandardCrypto) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (UTxO (ConwayEra StandardCrypto) -> Encoding)
-> (UTxO -> UTxO (ConwayEra StandardCrypto)) -> UTxO -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> UTxO (ShelleyLedgerEra ConwayEra)
UTxO -> UTxO (ConwayEra StandardCrypto)
toLedgerUTxO
  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 StandardCrypto)) -> 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
  fromCBOR :: forall s. Decoder s UTxO
fromCBOR = UTxO (ShelleyLedgerEra ConwayEra) -> UTxO
UTxO (ConwayEra StandardCrypto) -> UTxO
fromLedgerUTxO (UTxO (ConwayEra StandardCrypto) -> UTxO)
-> Decoder s (UTxO (ConwayEra StandardCrypto)) -> Decoder s UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (UTxO (ConwayEra StandardCrypto))
forall s. Decoder s (UTxO (ConwayEra StandardCrypto))
forall a s. FromCBOR a => Decoder s a
fromCBOR
  label :: Proxy UTxO -> Text
label Proxy UTxO
_ = Proxy (UTxO (ConwayEra StandardCrypto)) -> 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 = (TxOut CtxUTxO ConwayEra -> Value) -> UTxO -> Value
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO ConwayEra -> Value
forall ctx. TxOut ctx -> Value
txOutValue

  -- NOTE: See note from `Head.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
Head.hashTxOuts ([TxOut] -> BuiltinByteString)
-> (UTxO -> [TxOut]) -> UTxO -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut CtxUTxO ConwayEra -> Maybe TxOut)
-> [TxOut CtxUTxO ConwayEra] -> [TxOut]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HasCallStack => TxOut CtxUTxO ConwayEra -> Maybe TxOut
TxOut CtxUTxO ConwayEra -> Maybe TxOut
toPlutusTxOut ([TxOut CtxUTxO ConwayEra] -> [TxOut])
-> (UTxO -> [TxOut CtxUTxO ConwayEra]) -> UTxO -> [TxOut]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> [TxOut CtxUTxO ConwayEra]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

  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 ConwayEra]
UTxOType Tx -> [TxOutType Tx]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

  withoutUTxO :: UTxOType Tx -> UTxOType Tx -> UTxOType Tx
withoutUTxO = UTxO -> UTxO -> UTxO
UTxOType Tx -> UTxOType Tx -> UTxOType Tx
forall out. UTxO' out -> UTxO' out -> UTxO' out
UTxO.difference