Skip to content

Commit 3154b1b

Browse files
palaspalas
committed
Add minimal API for creating transactions
1 parent 4ee158a commit 3154b1b

File tree

5 files changed

+490
-5
lines changed

5 files changed

+490
-5
lines changed

‎cardano-wasm/app/Main.hs‎

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,4 @@
11
module Main (main) where
22

3-
import Cardano.Api.Experimental qualified as Exp
4-
53
main :: IO ()
6-
main =
7-
print Exp.ConwayEra
4+
main = pure ()

‎cardano-wasm/cardano-wasm.cabal‎

Lines changed: 22 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -37,7 +37,28 @@ executable cardano-wasm
3737
ghc-options:
3838
-no-hs-main
3939
-optl-mexec-model=reactor
40-
"-optl-Wl,--strip-all"
40+
"-optl-Wl,--strip-all,--export=newConwayTx,--export=addTxInput,--export=addSimpleTxOut,--export=setFee,--export=signWithPaymentKey,--export=alsoSignWithPaymentKey,--export=txToCbor"
41+
other-modules:
42+
Cardano.Wasm.Internal.Api.Tx
43+
Cardano.Wasm.Internal.ExceptionHandling
44+
Cardano.Wasm.Internal.JavaScript.Bridge
45+
4146
build-depends:
47+
aeson,
4248
base,
49+
base16-bytestring,
50+
bytestring,
4351
cardano-api,
52+
cardano-ledger-api,
53+
cardano-ledger-binary,
54+
cardano-strict-containers,
55+
cborg,
56+
containers,
57+
exceptions,
58+
microlens,
59+
text,
60+
61+
if arch(wasm32)
62+
build-depends:
63+
ghc-experimental,
64+
utf8-string,

‎cardano-wasm/src/Cardano/Wasm/Internal/Api/Tx.hs‎

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

‎cardano-wasm/src/Cardano/Wasm/Internal/ExceptionHandling.hs‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
module Cardano.Wasm.Internal.ExceptionHandling where
2+
3+
import Control.Exception (Exception)
4+
import Control.Monad.Catch (MonadThrow (..))
5+
import GHC.Stack (HasCallStack, withFrozenCallStack)
6+
7+
newtype ExpectedJustException = ExpectedJustException String
8+
deriving Show
9+
10+
instance Exception ExpectedJustException
11+
12+
newtype ExpectedRightException = ExpectedRightException String
13+
deriving Show
14+
15+
instance Exception ExpectedRightException
16+
17+
justOrError :: (HasCallStack, MonadThrow m) => String -> Maybe a -> m a
18+
justOrError e Nothing = withFrozenCallStack $ throwM $ ExpectedJustException e
19+
justOrError _ (Just a) = return a
20+
21+
rightOrError :: (HasCallStack, MonadThrow m, Show e) => Either e a -> m a
22+
rightOrError (Left e) = withFrozenCallStack $ throwM $ ExpectedRightException $ show e
23+
rightOrError (Right a) = return a

0 commit comments

Comments
 (0)