{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Wasm.Api.Tx
  ( UnsignedTxObject (..)
  , SignedTxObject (..)
  , ProtocolParamsJSON (..)
  , newTxImpl
  , newExperimentalEraTxImpl
  , newConwayTxImpl
  , addTxInputImpl
  , addSimpleTxOutImpl
  , appendCertificateToTxImpl
  , estimateMinFeeImpl
  , setFeeImpl
  , signWithPaymentKeyImpl
  , alsoSignWithPaymentKeyImpl
  , toCborImpl
  )
where

import Cardano.Api (FromJSON)
import Cardano.Api qualified as Api
import Cardano.Api.Experimental (obtainCommonConstraints)
import Cardano.Api.Experimental qualified as Exp
import Cardano.Api.Ledger qualified as Ledger
import Cardano.Api.Plutus qualified as Shelley
import Cardano.Api.Tx qualified as TxBody

import Cardano.Ledger.Api qualified as Ledger
import Cardano.Wasm.ExceptionHandling (justOrError, rightOrError, throwError, toMonadFail)

import Control.Monad.Catch (MonadThrow)
import Data.Aeson (ToJSON (toJSON), (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.Sequence.Strict qualified as StrictSeq
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import GHC.Stack (HasCallStack)
import Lens.Micro ((%~), (&), (.~), (<>~))

-- * @UnsignedTx@ object

-- | An object representing a transaction that is being built and has not
-- been signed yet. It abstracts over the era of the transaction.
-- It is meant to be an opaque object in the JavaScript API.
data UnsignedTxObject
  = forall era. UnsignedTxObject
  { ()
unsignedTxEra :: Exp.Era era
  , ()
unsignedTx :: Exp.UnsignedTx era
  }

deriving instance Show UnsignedTxObject

instance ToJSON UnsignedTxObject where
  toJSON :: UnsignedTxObject -> Aeson.Value
  toJSON :: UnsignedTxObject -> Value
toJSON (UnsignedTxObject Era era
era UnsignedTx era
utx) =
    Era era -> (EraCommonConstraints era => Value) -> Value
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => Value) -> Value)
-> (EraCommonConstraints era => Value) -> Value
forall a b. (a -> b) -> a -> b
$
      [Pair] -> Value
Aeson.object
        [ Key
"era" Key -> Some Era -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Era era -> Some Era
forall {k} (f :: k -> *) (a :: k).
(Typeable a, Typeable (f a)) =>
f a -> Some f
Exp.Some Era era
era
        , Key
"tx" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 (UnsignedTx era -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
Api.serialiseToRawBytesHex UnsignedTx era
utx)
        ]

instance FromJSON UnsignedTxObject where
  parseJSON :: HasCallStack => Aeson.Value -> Aeson.Parser UnsignedTxObject
  parseJSON :: HasCallStack => Value -> Parser UnsignedTxObject
parseJSON = String
-> (Object -> Parser UnsignedTxObject)
-> Value
-> Parser UnsignedTxObject
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"UnsignedTxObject" ((Object -> Parser UnsignedTxObject)
 -> Value -> Parser UnsignedTxObject)
-> (Object -> Parser UnsignedTxObject)
-> Value
-> Parser UnsignedTxObject
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Exp.Some era <- Object
o Object -> Key -> Parser (Some Era)
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"era"
    tx :: Text.Text <- o Aeson..: "tx"
    obtainCommonConstraints era $ do
      UnsignedTxObject
        era
        <$> toMonadFail (rightOrError $ Api.deserialiseFromRawBytesHex $ Text.encodeUtf8 tx)

-- | Create a new unsigned transaction object for making a transaction in the current era.
newTxImpl :: UnsignedTxObject
newTxImpl :: UnsignedTxObject
newTxImpl = UnsignedTxObject
newConwayTxImpl

-- | Create a new unsigned transaction object for making a transaction in the current experimental era.
newExperimentalEraTxImpl :: (HasCallStack, MonadThrow m) => m UnsignedTxObject
newExperimentalEraTxImpl :: forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
m UnsignedTxObject
newExperimentalEraTxImpl = String -> m UnsignedTxObject
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
throwError String
"newExperimentalEraTxImpl: No experimental era available"

-- | Create a new unsigned transaction object for making a Conway era transaction.
newConwayTxImpl :: UnsignedTxObject
newConwayTxImpl :: UnsignedTxObject
newConwayTxImpl = Era ConwayEra -> UnsignedTx ConwayEra -> UnsignedTxObject
forall era. Era era -> UnsignedTx era -> UnsignedTxObject
UnsignedTxObject Era ConwayEra
Exp.ConwayEra (Tx (LedgerEra ConwayEra) -> UnsignedTx ConwayEra
forall era.
EraTx (LedgerEra era) =>
Tx (LedgerEra era) -> UnsignedTx era
Exp.UnsignedTx (TxBody ConwayEra -> Tx ConwayEra
forall era. EraTx era => TxBody era -> Tx era
Ledger.mkBasicTx TxBody ConwayEra
forall era. EraTxBody era => TxBody era
Ledger.mkBasicTxBody))

-- | Add a simple transaction input to an unsigned transaction object.
addTxInputImpl :: UnsignedTxObject -> Api.TxId -> Api.TxIx -> UnsignedTxObject
addTxInputImpl :: UnsignedTxObject -> TxId -> TxIx -> UnsignedTxObject
addTxInputImpl (UnsignedTxObject Era era
era (Exp.UnsignedTx Tx (LedgerEra era)
tx)) TxId
txId TxIx
txIx =
  Era era
-> (EraCommonConstraints era => UnsignedTxObject)
-> UnsignedTxObject
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => UnsignedTxObject)
 -> UnsignedTxObject)
-> (EraCommonConstraints era => UnsignedTxObject)
-> UnsignedTxObject
forall a b. (a -> b) -> a -> b
$
    let txIn :: TxIn
txIn = TxId -> TxIx -> TxIn
Api.TxIn TxId
txId TxIx
txIx
        tx' :: Tx (LedgerEra era)
tx' = Tx (LedgerEra era)
tx Tx (LedgerEra era)
-> (Tx (LedgerEra era) -> Tx (LedgerEra era)) -> Tx (LedgerEra era)
forall a b. a -> (a -> b) -> b
& (TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
-> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx (LedgerEra era)) (TxBody (LedgerEra era))
Ledger.bodyTxL ((TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
 -> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era)))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx (LedgerEra era)
-> Identity (Tx (LedgerEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era))
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody (LedgerEra era)) (Set TxIn)
Ledger.inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era)))
-> (Set TxIn -> Set TxIn)
-> Tx (LedgerEra era)
-> Tx (LedgerEra era)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Set TxIn -> Set TxIn -> Set TxIn
forall a. Semigroup a => a -> a -> a
<> [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [TxIn -> TxIn
TxBody.toShelleyTxIn TxIn
txIn])
     in Era era -> UnsignedTx era -> UnsignedTxObject
forall era. Era era -> UnsignedTx era -> UnsignedTxObject
UnsignedTxObject Era era
era (UnsignedTx era -> UnsignedTxObject)
-> UnsignedTx era -> UnsignedTxObject
forall a b. (a -> b) -> a -> b
$ Tx (LedgerEra era) -> UnsignedTx era
forall era.
EraTx (LedgerEra era) =>
Tx (LedgerEra era) -> UnsignedTx era
Exp.UnsignedTx Tx (LedgerEra era)
tx'

-- | Add a simple transaction output to an unsigned transaction object.
-- It takes a destination address and an amount in lovelaces.
addSimpleTxOutImpl
  :: (HasCallStack, MonadThrow m) => UnsignedTxObject -> String -> Ledger.Coin -> m UnsignedTxObject
addSimpleTxOutImpl :: forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
UnsignedTxObject -> String -> Coin -> m UnsignedTxObject
addSimpleTxOutImpl (UnsignedTxObject Era era
era (Exp.UnsignedTx Tx (LedgerEra era)
tx)) String
destAddr Coin
lovelaceAmount =
  Era era
-> (EraCommonConstraints era => m UnsignedTxObject)
-> m UnsignedTxObject
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => m UnsignedTxObject)
 -> m UnsignedTxObject)
-> (EraCommonConstraints era => m UnsignedTxObject)
-> m UnsignedTxObject
forall a b. (a -> b) -> a -> b
$ do
    destAddress <- Era era -> String -> m (AddressInEra era)
forall (m :: * -> *) era.
(HasCallStack, MonadThrow m, EraCommonConstraints era) =>
Era era -> String -> m (AddressInEra era)
deserialiseAddress Era era
era String
destAddr
    let sbe = Era era -> ShelleyBasedEra era
forall era. Era era -> ShelleyBasedEra era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
Api.convert Era era
era
        txOut =
          AddressInEra era
-> TxOutValue era
-> TxOutDatum (ZonkAny 0) era
-> ReferenceScript era
-> TxOut (ZonkAny 0) era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
Api.TxOut
            AddressInEra era
destAddress
            (ShelleyBasedEra era -> Coin -> TxOutValue era
forall era. ShelleyBasedEra era -> Coin -> TxOutValue era
Api.lovelaceToTxOutValue ShelleyBasedEra era
sbe Coin
lovelaceAmount)
            TxOutDatum (ZonkAny 0) era
forall ctx era. TxOutDatum ctx era
Api.TxOutDatumNone
            ReferenceScript era
forall era. ReferenceScript era
Shelley.ReferenceScriptNone
        shelleyTxOut = ShelleyBasedEra era
-> TxOut (ZonkAny 0) era -> TxOut (LedgerEra era)
forall ctx era ledgerera.
(HasCallStack, ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut ctx era -> TxOut ledgerera
TxBody.toShelleyTxOutAny ShelleyBasedEra era
sbe TxOut (ZonkAny 0) era
txOut
        tx' = Tx (LedgerEra era)
tx Tx (LedgerEra era)
-> (Tx (LedgerEra era) -> Tx (LedgerEra era)) -> Tx (LedgerEra era)
forall a b. a -> (a -> b) -> b
& (TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
-> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx (LedgerEra era)) (TxBody (LedgerEra era))
Ledger.bodyTxL ((TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
 -> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era)))
-> ((StrictSeq (TxOut (LedgerEra era))
     -> Identity (StrictSeq (TxOut (LedgerEra era))))
    -> TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
-> (StrictSeq (TxOut (LedgerEra era))
    -> Identity (StrictSeq (TxOut (LedgerEra era))))
-> Tx (LedgerEra era)
-> Identity (Tx (LedgerEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut (LedgerEra era))
 -> Identity (StrictSeq (TxOut (LedgerEra era))))
-> TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody (LedgerEra era)) (StrictSeq (TxOut (LedgerEra era)))
Ledger.outputsTxBodyL ((StrictSeq (TxOut (LedgerEra era))
  -> Identity (StrictSeq (TxOut (LedgerEra era))))
 -> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era)))
-> (StrictSeq (TxOut (LedgerEra era))
    -> StrictSeq (TxOut (LedgerEra era)))
-> Tx (LedgerEra era)
-> Tx (LedgerEra era)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StrictSeq (TxOut (LedgerEra era))
-> StrictSeq (TxOut (LedgerEra era))
-> StrictSeq (TxOut (LedgerEra era))
forall a. Semigroup a => a -> a -> a
<> [TxOut (LedgerEra era)] -> StrictSeq (TxOut (LedgerEra era))
forall a. [a] -> StrictSeq a
StrictSeq.fromList [TxOut (LedgerEra era)
shelleyTxOut])
    return $ UnsignedTxObject era $ Exp.UnsignedTx tx'
 where
  deserialiseAddress
    :: (HasCallStack, MonadThrow m, Exp.EraCommonConstraints era)
    => Exp.Era era -> String -> m (Api.AddressInEra era)
  deserialiseAddress :: forall (m :: * -> *) era.
(HasCallStack, MonadThrow m, EraCommonConstraints era) =>
Era era -> String -> m (AddressInEra era)
deserialiseAddress Era era
_eon String
destAddrStr =
    String -> Maybe (AddressInEra era) -> m (AddressInEra era)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> Maybe a -> m a
justOrError
      (String
"Couldn't deserialise destination address: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
destAddrStr)
      (Maybe (AddressInEra era) -> m (AddressInEra era))
-> Maybe (AddressInEra era) -> m (AddressInEra era)
forall a b. (a -> b) -> a -> b
$ AsType (AddressInEra era) -> Text -> Maybe (AddressInEra era)
forall addr.
SerialiseAddress addr =>
AsType addr -> Text -> Maybe addr
Api.deserialiseAddress
        (AsType era -> AsType (AddressInEra era)
forall era. AsType era -> AsType (AddressInEra era)
Api.AsAddressInEra AsType era
forall t. HasTypeProxy t => AsType t
Api.asType)
        (String -> Text
Text.pack String
destAddrStr)

-- | Append a certificate (in CBOR hex string format) to an unsigned transaction object.
appendCertificateToTxImpl
  :: (HasCallStack, MonadThrow m) => UnsignedTxObject -> String -> m UnsignedTxObject
appendCertificateToTxImpl :: forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
UnsignedTxObject -> String -> m UnsignedTxObject
appendCertificateToTxImpl (UnsignedTxObject Era era
era (Exp.UnsignedTx Tx (LedgerEra era)
tx)) String
certCbor = do
  Exp.Certificate cert <- Era era -> String -> m (Certificate (LedgerEra era))
forall (m :: * -> *) era.
(HasCallStack, MonadThrow m) =>
Era era -> String -> m (Certificate (LedgerEra era))
deserialiseCertificate Era era
era String
certCbor
  let tx' = Tx (LedgerEra era)
tx Tx (LedgerEra era)
-> (Tx (LedgerEra era) -> Tx (LedgerEra era)) -> Tx (LedgerEra era)
forall a b. a -> (a -> b) -> b
& (TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
-> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx (LedgerEra era)) (TxBody (LedgerEra era))
Ledger.bodyTxL ((TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
 -> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era)))
-> ((StrictSeq (TxCert (LedgerEra era))
     -> Identity (StrictSeq (TxCert (LedgerEra era))))
    -> TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
-> (StrictSeq (TxCert (LedgerEra era))
    -> Identity (StrictSeq (TxCert (LedgerEra era))))
-> Tx (LedgerEra era)
-> Identity (Tx (LedgerEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert (LedgerEra era))
 -> Identity (StrictSeq (TxCert (LedgerEra era))))
-> TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody (LedgerEra era)) (StrictSeq (TxCert (LedgerEra era)))
Ledger.certsTxBodyL ((StrictSeq (TxCert (LedgerEra era))
  -> Identity (StrictSeq (TxCert (LedgerEra era))))
 -> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era)))
-> (StrictSeq (TxCert (LedgerEra era))
    -> StrictSeq (TxCert (LedgerEra era)))
-> Tx (LedgerEra era)
-> Tx (LedgerEra era)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StrictSeq (TxCert (LedgerEra era))
-> StrictSeq (TxCert (LedgerEra era))
-> StrictSeq (TxCert (LedgerEra era))
forall a. Semigroup a => a -> a -> a
<> [TxCert (LedgerEra era)] -> StrictSeq (TxCert (LedgerEra era))
forall a. [a] -> StrictSeq a
StrictSeq.fromList [TxCert (LedgerEra era)
cert])
  return $ UnsignedTxObject era $ Exp.UnsignedTx tx'
 where
  deserialiseCertificate
    :: (HasCallStack, MonadThrow m) => Exp.Era era -> String -> m (Exp.Certificate (Exp.LedgerEra era))
  deserialiseCertificate :: forall (m :: * -> *) era.
(HasCallStack, MonadThrow m) =>
Era era -> String -> m (Certificate (LedgerEra era))
deserialiseCertificate Era era
era' String
certCbor' =
    Era era
-> (EraCommonConstraints era => m (Certificate (LedgerEra era)))
-> m (Certificate (LedgerEra era))
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era' ((EraCommonConstraints era => m (Certificate (LedgerEra era)))
 -> m (Certificate (LedgerEra era)))
-> (EraCommonConstraints era => m (Certificate (LedgerEra era)))
-> m (Certificate (LedgerEra era))
forall a b. (a -> b) -> a -> b
$
      Either DecoderError (Certificate (LedgerEra era))
-> m (Certificate (LedgerEra era))
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Show e) =>
Either e a -> m a
rightOrError (Either DecoderError (Certificate (LedgerEra era))
 -> m (Certificate (LedgerEra era)))
-> Either DecoderError (Certificate (LedgerEra era))
-> m (Certificate (LedgerEra era))
forall a b. (a -> b) -> a -> b
$
        AsType (Certificate (LedgerEra era))
-> ByteString -> Either DecoderError (Certificate (LedgerEra era))
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
Api.deserialiseFromCBOR AsType (Certificate (LedgerEra era))
forall era. AsType (Certificate era)
Exp.AsCertificate (Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
certCbor')

-- | Set the fee for an unsigned transaction object.
setFeeImpl :: UnsignedTxObject -> Ledger.Coin -> UnsignedTxObject
setFeeImpl :: UnsignedTxObject -> Coin -> UnsignedTxObject
setFeeImpl (UnsignedTxObject Era era
era (Exp.UnsignedTx Tx (LedgerEra era)
tx)) Coin
fee =
  Era era
-> (EraCommonConstraints era => UnsignedTxObject)
-> UnsignedTxObject
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => UnsignedTxObject)
 -> UnsignedTxObject)
-> (EraCommonConstraints era => UnsignedTxObject)
-> UnsignedTxObject
forall a b. (a -> b) -> a -> b
$
    let tx' :: Tx (LedgerEra era)
tx' = Tx (LedgerEra era)
tx Tx (LedgerEra era)
-> (Tx (LedgerEra era) -> Tx (LedgerEra era)) -> Tx (LedgerEra era)
forall a b. a -> (a -> b) -> b
& (TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
-> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx (LedgerEra era)) (TxBody (LedgerEra era))
Ledger.bodyTxL ((TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
 -> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era)))
-> ((Coin -> Identity Coin)
    -> TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era)))
-> (Coin -> Identity Coin)
-> Tx (LedgerEra era)
-> Identity (Tx (LedgerEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> TxBody (LedgerEra era) -> Identity (TxBody (LedgerEra era))
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody (LedgerEra era)) Coin
Ledger.feeTxBodyL ((Coin -> Identity Coin)
 -> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era)))
-> Coin -> Tx (LedgerEra era) -> Tx (LedgerEra era)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
     in Era era -> UnsignedTx era -> UnsignedTxObject
forall era. Era era -> UnsignedTx era -> UnsignedTxObject
UnsignedTxObject Era era
era (UnsignedTx era -> UnsignedTxObject)
-> UnsignedTx era -> UnsignedTxObject
forall a b. (a -> b) -> a -> b
$ Tx (LedgerEra era) -> UnsignedTx era
forall era.
EraTx (LedgerEra era) =>
Tx (LedgerEra era) -> UnsignedTx era
Exp.UnsignedTx Tx (LedgerEra era)
tx'

-- | Sign an unsigned transaction using a payment key.
signWithPaymentKeyImpl
  :: UnsignedTxObject -> Api.SigningKey Api.PaymentKey -> SignedTxObject
signWithPaymentKeyImpl :: UnsignedTxObject -> SigningKey PaymentKey -> SignedTxObject
signWithPaymentKeyImpl (UnsignedTxObject Era era
era fullUnsignedTx :: UnsignedTx era
fullUnsignedTx@(Exp.UnsignedTx Tx (LedgerEra era)
tx)) SigningKey PaymentKey
signingKey =
  Era era
-> (EraCommonConstraints era => SignedTxObject) -> SignedTxObject
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => SignedTxObject) -> SignedTxObject)
-> (EraCommonConstraints era => SignedTxObject) -> SignedTxObject
forall a b. (a -> b) -> a -> b
$
    let witness :: WitVKey 'Witness
witness = Era era
-> UnsignedTx era -> ShelleyWitnessSigningKey -> WitVKey 'Witness
forall era.
Era era
-> UnsignedTx era -> ShelleyWitnessSigningKey -> WitVKey 'Witness
Exp.makeKeyWitness Era era
era UnsignedTx era
fullUnsignedTx (ShelleyWitnessSigningKey -> WitVKey 'Witness)
-> (SigningKey PaymentKey -> ShelleyWitnessSigningKey)
-> SigningKey PaymentKey
-> WitVKey 'Witness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> ShelleyWitnessSigningKey
Api.WitnessPaymentKey (SigningKey PaymentKey -> WitVKey 'Witness)
-> SigningKey PaymentKey -> WitVKey 'Witness
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey
signingKey
        txWits :: TxWits (LedgerEra era)
txWits =
          TxWits (LedgerEra era)
forall era. EraTxWits era => TxWits era
Ledger.mkBasicTxWits
            TxWits (LedgerEra era)
-> (TxWits (LedgerEra era) -> TxWits (LedgerEra era))
-> TxWits (LedgerEra era)
forall a b. a -> (a -> b) -> b
& (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era))
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits (LedgerEra era)) (Set (WitVKey 'Witness))
Ledger.addrTxWitsL
              ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
 -> TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era)))
-> Set (WitVKey 'Witness)
-> TxWits (LedgerEra era)
-> TxWits (LedgerEra era)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [WitVKey 'Witness] -> Set (WitVKey 'Witness)
forall a. Ord a => [a] -> Set a
Set.fromList [WitVKey 'Witness
witness]
        txWithWits :: Tx (LedgerEra era)
txWithWits =
          Era era
-> (EraCommonConstraints era => Tx (LedgerEra era))
-> Tx (LedgerEra era)
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints
            Era era
era
            (Tx (LedgerEra era)
tx Tx (LedgerEra era)
-> (Tx (LedgerEra era) -> Tx (LedgerEra era)) -> Tx (LedgerEra era)
forall a b. a -> (a -> b) -> b
& (TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era)))
-> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era))
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx (LedgerEra era)) (TxWits (LedgerEra era))
Ledger.witsTxL ((TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era)))
 -> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era)))
-> TxWits (LedgerEra era)
-> Tx (LedgerEra era)
-> Tx (LedgerEra era)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits (LedgerEra era)
txWits)
     in Era era -> SignedTx era -> SignedTxObject
forall era. Era era -> SignedTx era -> SignedTxObject
SignedTxObject
          Era era
era
          (Tx (LedgerEra era) -> SignedTx era
forall era.
EraTx (LedgerEra era) =>
Tx (LedgerEra era) -> SignedTx era
Exp.SignedTx Tx (LedgerEra era)
txWithWits)

newtype ProtocolParamsJSON = ProtocolParamsJSON String

-- | Estimate min fees for an unsigned transaction object.
estimateMinFeeImpl
  :: (HasCallStack, MonadThrow m)
  => UnsignedTxObject
  -- ^ The unsigned transaction object to estimate fees for.
  -> ProtocolParamsJSON
  -- ^ The JSON for the protocol parameters of the correct era and network.
  -> Int
  -- ^ The number of key witnesses still to be added to the transaction.
  -> Int
  -- ^ The number of Byron key witnesses still to be added to the transaction.
  -> Int
  -- ^ The total size in bytes of reference scripts
  -> m Ledger.Coin
estimateMinFeeImpl :: forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
UnsignedTxObject
-> ProtocolParamsJSON -> Int -> Int -> Int -> m Coin
estimateMinFeeImpl
  (UnsignedTxObject Era era
era (Exp.UnsignedTx Tx (LedgerEra era)
ledgerTx))
  (ProtocolParamsJSON String
protocolParamsJson)
  Int
numKeyWitnesses
  Int
numByronKeyWitnesses
  Int
totalRefScriptSize =
    Era era -> (EraCommonConstraints era => m Coin) -> m Coin
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => m Coin) -> m Coin)
-> (EraCommonConstraints era => m Coin) -> m Coin
forall a b. (a -> b) -> a -> b
$ do
      protocolParams <- Either String (PParams (LedgerEra era))
-> m (PParams (LedgerEra era))
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Show e) =>
Either e a -> m a
rightOrError (Either String (PParams (LedgerEra era))
 -> m (PParams (LedgerEra era)))
-> Either String (PParams (LedgerEra era))
-> m (PParams (LedgerEra era))
forall a b. (a -> b) -> a -> b
$ Text -> Either String (PParams (LedgerEra era))
forall a. FromJSON a => Text -> Either String a
Aeson.eitherDecodeStrictText (String -> Text
Text.pack String
protocolParamsJson)
      return $
        Ledger.estimateMinFeeTx
          protocolParams
          ledgerTx
          numKeyWitnesses
          numByronKeyWitnesses
          totalRefScriptSize

-- * @SignedTx@ object

-- | An object representing a signed transaction.
data SignedTxObject
  = forall era. SignedTxObject (Exp.Era era) (Exp.SignedTx era)

deriving instance Show SignedTxObject

instance ToJSON SignedTxObject where
  toJSON :: SignedTxObject -> Aeson.Value
  toJSON :: SignedTxObject -> Value
toJSON (SignedTxObject Era era
era SignedTx era
tx) =
    Era era -> (EraCommonConstraints era => Value) -> Value
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => Value) -> Value)
-> (EraCommonConstraints era => Value) -> Value
forall a b. (a -> b) -> a -> b
$
      [Pair] -> Value
Aeson.object
        [ Key
"era" Key -> Some Era -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Era era -> Some Era
forall {k} (f :: k -> *) (a :: k).
(Typeable a, Typeable (f a)) =>
f a -> Some f
Exp.Some Era era
era
        , Key
"tx" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 (SignedTx era -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
Api.serialiseToRawBytesHex SignedTx era
tx)
        ]

instance FromJSON SignedTxObject where
  parseJSON :: HasCallStack => Aeson.Value -> Aeson.Parser SignedTxObject
  parseJSON :: HasCallStack => Value -> Parser SignedTxObject
parseJSON = String
-> (Object -> Parser SignedTxObject)
-> Value
-> Parser SignedTxObject
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"SignedTxObject" ((Object -> Parser SignedTxObject)
 -> Value -> Parser SignedTxObject)
-> (Object -> Parser SignedTxObject)
-> Value
-> Parser SignedTxObject
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Exp.Some era <- Object
o Object -> Key -> Parser (Some Era)
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"era"
    tx :: Text.Text <- o Aeson..: "tx"
    obtainCommonConstraints era $ do
      decodedTx <- toMonadFail (rightOrError $ Api.deserialiseFromRawBytesHex $ Text.encodeUtf8 tx)
      return $
        SignedTxObject era decodedTx

-- | Add an extra signature to an already signed transaction using a payment key.
alsoSignWithPaymentKeyImpl
  :: SignedTxObject -> Api.SigningKey Api.PaymentKey -> SignedTxObject
alsoSignWithPaymentKeyImpl :: SignedTxObject -> SigningKey PaymentKey -> SignedTxObject
alsoSignWithPaymentKeyImpl (SignedTxObject Era era
era (Exp.SignedTx Tx (LedgerEra era)
tx)) SigningKey PaymentKey
signingKey =
  Era era
-> (EraCommonConstraints era => SignedTxObject) -> SignedTxObject
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => SignedTxObject) -> SignedTxObject)
-> (EraCommonConstraints era => SignedTxObject) -> SignedTxObject
forall a b. (a -> b) -> a -> b
$
    let witness :: WitVKey 'Witness
witness = Era era
-> UnsignedTx era -> ShelleyWitnessSigningKey -> WitVKey 'Witness
forall era.
Era era
-> UnsignedTx era -> ShelleyWitnessSigningKey -> WitVKey 'Witness
Exp.makeKeyWitness Era era
era (Tx (LedgerEra era) -> UnsignedTx era
forall era.
EraTx (LedgerEra era) =>
Tx (LedgerEra era) -> UnsignedTx era
Exp.UnsignedTx Tx (LedgerEra era)
tx) (ShelleyWitnessSigningKey -> WitVKey 'Witness)
-> (SigningKey PaymentKey -> ShelleyWitnessSigningKey)
-> SigningKey PaymentKey
-> WitVKey 'Witness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> ShelleyWitnessSigningKey
Api.WitnessPaymentKey (SigningKey PaymentKey -> WitVKey 'Witness)
-> SigningKey PaymentKey -> WitVKey 'Witness
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey
signingKey
        txWits :: TxWits (LedgerEra era)
txWits =
          TxWits (LedgerEra era)
forall era. EraTxWits era => TxWits era
Ledger.mkBasicTxWits
            TxWits (LedgerEra era)
-> (TxWits (LedgerEra era) -> TxWits (LedgerEra era))
-> TxWits (LedgerEra era)
forall a b. a -> (a -> b) -> b
& (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era))
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits (LedgerEra era)) (Set (WitVKey 'Witness))
Ledger.addrTxWitsL
              ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
 -> TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era)))
-> Set (WitVKey 'Witness)
-> TxWits (LedgerEra era)
-> TxWits (LedgerEra era)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [WitVKey 'Witness] -> Set (WitVKey 'Witness)
forall a. Ord a => [a] -> Set a
Set.fromList [WitVKey 'Witness
witness]
        txWithWits :: Tx (LedgerEra era)
txWithWits =
          Era era
-> (EraCommonConstraints era => Tx (LedgerEra era))
-> Tx (LedgerEra era)
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints
            Era era
era
            (Tx (LedgerEra era)
tx Tx (LedgerEra era)
-> (Tx (LedgerEra era) -> Tx (LedgerEra era)) -> Tx (LedgerEra era)
forall a b. a -> (a -> b) -> b
& (TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era)))
-> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era))
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx (LedgerEra era)) (TxWits (LedgerEra era))
Ledger.witsTxL ((TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era)))
 -> Tx (LedgerEra era) -> Identity (Tx (LedgerEra era)))
-> TxWits (LedgerEra era)
-> Tx (LedgerEra era)
-> Tx (LedgerEra era)
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ TxWits (LedgerEra era)
txWits)
     in Era era -> SignedTx era -> SignedTxObject
forall era. Era era -> SignedTx era -> SignedTxObject
SignedTxObject
          Era era
era
          (Tx (LedgerEra era) -> SignedTx era
forall era.
EraTx (LedgerEra era) =>
Tx (LedgerEra era) -> SignedTx era
Exp.SignedTx Tx (LedgerEra era)
txWithWits)

-- | Convert a signed transaction object to a base16 encoded string of its CBOR representation.
toCborImpl :: SignedTxObject -> String
toCborImpl :: SignedTxObject -> String
toCborImpl (SignedTxObject Era era
era SignedTx era
signedTx) =
  Era era -> (EraCommonConstraints era => String) -> String
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => String) -> String)
-> (EraCommonConstraints era => String) -> String
forall a b. (a -> b) -> a -> b
$
    Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
      ByteString -> Text
Text.decodeUtf8 (SignedTx era -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
Api.serialiseToRawBytesHex SignedTx era
signedTx)