|
| 1 | +{-# LANGUAGE DataKinds #-} |
| 2 | +{-# LANGUAGE ExistentialQuantification #-} |
| 3 | +{-# LANGUAGE FlexibleContexts #-} |
| 4 | +{-# LANGUAGE InstanceSigs #-} |
| 5 | +{-# LANGUAGE OverloadedStrings #-} |
| 6 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 7 | +{-# LANGUAGE StandaloneDeriving #-} |
| 8 | +{-# LANGUAGE TypeFamilies #-} |
| 9 | + |
| 10 | +module Cardano.Wasm.Internal.Api.Tx |
| 11 | + ( newConwayTxImpl |
| 12 | + , addTxInputImpl |
| 13 | + , addSimpleTxOutImpl |
| 14 | + , setFeeImpl |
| 15 | + , signWithPaymentKeyImpl |
| 16 | + , alsoSignWithPaymentKeyImpl |
| 17 | + , toCborImpl |
| 18 | + ) |
| 19 | +where |
| 20 | + |
| 21 | +import Cardano.Api (FromJSON) |
| 22 | +import Cardano.Api qualified as Api |
| 23 | +import Cardano.Api.Experimental (obtainCommonConstraints) |
| 24 | +import Cardano.Api.Experimental qualified as Exp |
| 25 | +import Cardano.Api.Ledger qualified as Ledger |
| 26 | +import Cardano.Api.Plutus qualified as Shelley |
| 27 | +import Cardano.Api.Tx qualified as TxBody |
| 28 | + |
| 29 | +import Cardano.Ledger.Api qualified as Ledger |
| 30 | +import Cardano.Wasm.Internal.ExceptionHandling (justOrError, rightOrError) |
| 31 | + |
| 32 | +import Control.Monad.Catch (Exception (displayException), MonadThrow) |
| 33 | +import Data.Aeson (ToJSON (toJSON), (.=)) |
| 34 | +import Data.Aeson qualified as Aeson |
| 35 | +import Data.Aeson.Types qualified as Aeson |
| 36 | +import Data.Sequence.Strict qualified as StrictSeq |
| 37 | +import Data.Set qualified as Set |
| 38 | +import Data.Text qualified as Text |
| 39 | +import Data.Text.Encoding qualified as Text |
| 40 | +import GHC.Stack (HasCallStack) |
| 41 | +import Lens.Micro ((%~), (&), (.~), (<>~)) |
| 42 | + |
| 43 | +-- * @UnsignedTx@ object |
| 44 | + |
| 45 | +-- | An object representing a transaction that is being built and hasn't |
| 46 | +-- been signed yet. It abstracts over the era of the transaction. |
| 47 | +-- It is meant to be an opaque object in JavaScript API. |
| 48 | +data UnsignedTxObject |
| 49 | + = forall era. UnsignedTxObject (Exp.Era era) (Exp.UnsignedTx era) |
| 50 | + |
| 51 | +deriving instance Show UnsignedTxObject |
| 52 | + |
| 53 | +instance ToJSON UnsignedTxObject where |
| 54 | + toJSON :: UnsignedTxObject -> Aeson.Value |
| 55 | + toJSON (UnsignedTxObject era utx) = |
| 56 | + obtainCommonConstraints era $ |
| 57 | + Aeson.object |
| 58 | + [ "era" .= Exp.Some era |
| 59 | + , "tx" .= Text.decodeUtf8 (Api.serialiseToRawBytesHex utx) |
| 60 | + ] |
| 61 | + |
| 62 | +instance FromJSON UnsignedTxObject where |
| 63 | + parseJSON :: HasCallStack => Aeson.Value -> Aeson.Parser UnsignedTxObject |
| 64 | + parseJSON = Aeson.withObject "UnsignedTxObject" $ \o -> do |
| 65 | + Exp.Some era <- o Aeson..: "era" |
| 66 | + tx :: Text.Text <- o Aeson..: "tx" |
| 67 | + obtainCommonConstraints era $ do |
| 68 | + UnsignedTxObject |
| 69 | + era |
| 70 | + <$> toMonadFail (rightOrError $ Api.deserialiseFromRawBytesHex $ Text.encodeUtf8 tx) |
| 71 | + |
| 72 | +-- | Create a new unsigned transaction object for making a Conway era transaction. |
| 73 | +newConwayTxImpl :: UnsignedTxObject |
| 74 | +newConwayTxImpl = UnsignedTxObject Exp.ConwayEra (Exp.UnsignedTx (Ledger.mkBasicTx Ledger.mkBasicTxBody)) |
| 75 | + |
| 76 | +-- | Add a simple transaction input to an unsigned transaction object. |
| 77 | +addTxInputImpl :: UnsignedTxObject -> Api.TxId -> Api.TxIx -> UnsignedTxObject |
| 78 | +addTxInputImpl (UnsignedTxObject era (Exp.UnsignedTx tx)) txId txIx = |
| 79 | + obtainCommonConstraints era $ |
| 80 | + let txIn = Api.TxIn txId txIx |
| 81 | + tx' = tx & Ledger.bodyTxL . Ledger.inputsTxBodyL %~ (<> Set.fromList [TxBody.toShelleyTxIn txIn]) |
| 82 | + in UnsignedTxObject era $ Exp.UnsignedTx tx' |
| 83 | + |
| 84 | +-- | Add a simple transaction output to an unsigned transaction object. |
| 85 | +-- It takes a destination address and an amount in lovelace. |
| 86 | +addSimpleTxOutImpl |
| 87 | + :: (HasCallStack, MonadThrow m) => UnsignedTxObject -> String -> Ledger.Coin -> m UnsignedTxObject |
| 88 | +addSimpleTxOutImpl (UnsignedTxObject era (Exp.UnsignedTx tx)) destAddr lovelaceAmount = |
| 89 | + obtainCommonConstraints era $ do |
| 90 | + destAddress <- deserialiseAddress era destAddr |
| 91 | + let sbe = Api.convert era |
| 92 | + txOut = |
| 93 | + Api.TxOut |
| 94 | + destAddress |
| 95 | + (Api.lovelaceToTxOutValue sbe lovelaceAmount) |
| 96 | + Api.TxOutDatumNone |
| 97 | + Shelley.ReferenceScriptNone |
| 98 | + shelleyTxOut = TxBody.toShelleyTxOutAny sbe txOut |
| 99 | + tx' = tx & Ledger.bodyTxL . Ledger.outputsTxBodyL %~ (<> StrictSeq.fromList [shelleyTxOut]) |
| 100 | + return $ UnsignedTxObject era $ Exp.UnsignedTx tx' |
| 101 | + where |
| 102 | + deserialiseAddress |
| 103 | + :: (HasCallStack, MonadThrow m, Exp.EraCommonConstraints era) |
| 104 | + => Exp.Era era -> String -> m (Api.AddressInEra era) |
| 105 | + deserialiseAddress _eon destAddrStr = |
| 106 | + justOrError |
| 107 | + ("Couldn't deserialise destination address: " ++ show destAddrStr) |
| 108 | + $ Api.deserialiseAddress |
| 109 | + (Api.AsAddressInEra Api.asType) |
| 110 | + (Text.pack destAddrStr) |
| 111 | + |
| 112 | +-- | Set the fee for an unsigned transaction object. |
| 113 | +setFeeImpl :: UnsignedTxObject -> Ledger.Coin -> UnsignedTxObject |
| 114 | +setFeeImpl (UnsignedTxObject era (Exp.UnsignedTx tx)) fee = |
| 115 | + obtainCommonConstraints era $ |
| 116 | + let tx' = tx & Ledger.bodyTxL . Ledger.feeTxBodyL .~ fee |
| 117 | + in UnsignedTxObject era $ Exp.UnsignedTx tx' |
| 118 | + |
| 119 | +-- | Sign an unsigned transaction using a payment key. |
| 120 | +signWithPaymentKeyImpl |
| 121 | + :: UnsignedTxObject -> Api.SigningKey Api.PaymentKey -> SignedTxObject |
| 122 | +signWithPaymentKeyImpl (UnsignedTxObject era unsignedTx@(Exp.UnsignedTx tx)) signingKey = |
| 123 | + obtainCommonConstraints era $ |
| 124 | + let witness = Exp.makeKeyWitness era unsignedTx . Api.WitnessPaymentKey $ signingKey |
| 125 | + txWits = |
| 126 | + Ledger.mkBasicTxWits |
| 127 | + & Ledger.addrTxWitsL |
| 128 | + .~ Set.fromList [witness] |
| 129 | + txWithWits = |
| 130 | + obtainCommonConstraints |
| 131 | + era |
| 132 | + (tx & Ledger.witsTxL .~ txWits) |
| 133 | + in SignedTxObject |
| 134 | + era |
| 135 | + (Exp.SignedTx txWithWits) |
| 136 | + |
| 137 | +-- * @SignedTx@ object |
| 138 | + |
| 139 | +-- | An object representing a signed transaction. |
| 140 | +data SignedTxObject |
| 141 | + = forall era. SignedTxObject (Exp.Era era) (Exp.SignedTx era) |
| 142 | + |
| 143 | +deriving instance Show SignedTxObject |
| 144 | + |
| 145 | +instance ToJSON SignedTxObject where |
| 146 | + toJSON :: SignedTxObject -> Aeson.Value |
| 147 | + toJSON (SignedTxObject era tx) = |
| 148 | + obtainCommonConstraints era $ |
| 149 | + Aeson.object |
| 150 | + [ "era" .= Exp.Some era |
| 151 | + , "tx" .= Text.decodeUtf8 (Api.serialiseToRawBytesHex tx) |
| 152 | + ] |
| 153 | + |
| 154 | +instance FromJSON SignedTxObject where |
| 155 | + parseJSON :: HasCallStack => Aeson.Value -> Aeson.Parser SignedTxObject |
| 156 | + parseJSON = Aeson.withObject "SignedTxObject" $ \o -> do |
| 157 | + Exp.Some era <- o Aeson..: "era" |
| 158 | + tx :: Text.Text <- o Aeson..: "tx" |
| 159 | + obtainCommonConstraints era $ do |
| 160 | + decodedTx <- toMonadFail (rightOrError $ Api.deserialiseFromRawBytesHex $ Text.encodeUtf8 tx) |
| 161 | + return $ |
| 162 | + SignedTxObject era decodedTx |
| 163 | + |
| 164 | +-- | Add an extra signature to an already signed transaction using a payment key. |
| 165 | +alsoSignWithPaymentKeyImpl |
| 166 | + :: SignedTxObject -> Api.SigningKey Api.PaymentKey -> SignedTxObject |
| 167 | +alsoSignWithPaymentKeyImpl (SignedTxObject era (Exp.SignedTx tx)) signingKey = |
| 168 | + obtainCommonConstraints era $ |
| 169 | + let witness = Exp.makeKeyWitness era (Exp.UnsignedTx tx) . Api.WitnessPaymentKey $ signingKey |
| 170 | + txWits = |
| 171 | + Ledger.mkBasicTxWits |
| 172 | + & Ledger.addrTxWitsL |
| 173 | + .~ Set.fromList [witness] |
| 174 | + txWithWits = |
| 175 | + obtainCommonConstraints |
| 176 | + era |
| 177 | + (tx & Ledger.witsTxL <>~ txWits) |
| 178 | + in SignedTxObject |
| 179 | + era |
| 180 | + (Exp.SignedTx txWithWits) |
| 181 | + |
| 182 | +-- | Convert an 'Either' value to a 'MonadFail' monad. This can be useful for converting |
| 183 | +-- MonadThrow monads into Aeson Parser monads, but it loses the stack trace information. |
| 184 | +toMonadFail :: (Exception e, MonadFail m) => Either e a -> m a |
| 185 | +toMonadFail (Left e) = fail $ displayException e |
| 186 | +toMonadFail (Right a) = return a |
| 187 | + |
| 188 | +-- | Convert a signed transaction object to a base16 encoded string of its CBOR representation. |
| 189 | +toCborImpl :: SignedTxObject -> String |
| 190 | +toCborImpl (SignedTxObject era signedTx) = |
| 191 | + obtainCommonConstraints era $ |
| 192 | + Text.unpack $ |
| 193 | + Text.decodeUtf8 (Api.serialiseToRawBytesHex signedTx) |
0 commit comments