From db06c596d7e08c62aeda43c3906d3b4e7c557e56 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Fri, 28 Aug 2020 21:58:26 +1000 Subject: [PATCH 1/2] Add metadata to transaction layer --- lib/core/src/Cardano/Wallet.hs | 8 ++-- lib/core/src/Cardano/Wallet/Transaction.hs | 4 +- lib/core/test/unit/Cardano/WalletSpec.hs | 6 +-- .../Cardano/Wallet/Jormungandr/Transaction.hs | 2 +- .../Jormungandr/Scenario/API/Transactions.hs | 2 +- .../Wallet/Jormungandr/TransactionSpec.hs | 4 +- .../src/Cardano/Wallet/Shelley/Transaction.hs | 40 ++++++++++++------- .../Cardano/Wallet/Shelley/TransactionSpec.hs | 27 ++++++++++--- 8 files changed, 63 insertions(+), 30 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index eaff67baf02..876c9bd7361 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -1523,9 +1523,10 @@ signPayment -> ((k 'RootK XPrv, Passphrase "encryption") -> (XPrv, Passphrase "encryption")) -- ^ Reward account derived from the root key (or somewhere else). -> Passphrase "raw" + -> Maybe W.TxMetadata -> CoinSelection -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx) -signPayment ctx wid argGenChange mkRewardAccount pwd cs = db & \DBLayer{..} -> do +signPayment ctx wid argGenChange mkRewardAccount pwd md cs = db & \DBLayer{..} -> do withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do let pwdP = preparePassphrase scheme pwd nodeTip <- withExceptT ErrSignPaymentNetwork $ currentNodeTip nl @@ -1539,7 +1540,7 @@ signPayment ctx wid argGenChange mkRewardAccount pwd cs = db & \DBLayer{..} -> d let keyFrom = isOwned (getState cp) (xprv, pwdP) let rewardAcnt = mkRewardAccount (xprv, pwdP) (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $ - mkStdTx tl rewardAcnt keyFrom (nodeTip ^. #slotNo) cs' + mkStdTx tl rewardAcnt keyFrom (nodeTip ^. #slotNo) md cs' (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) s' tx cs' return (tx, meta, time, sealedTx) @@ -1579,7 +1580,7 @@ signTx ctx wid pwd (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do let keyFrom = isOwned (getState cp) (xprv, pwdP) let rewardAcnt = getRawKey $ deriveRewardAccount @k pwdP xprv (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $ - mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotNo) cs + mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotNo) md cs (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) (getState cp) tx cs return (tx, meta, time, sealedTx) @@ -1591,6 +1592,7 @@ signTx ctx wid pwd (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do nl = ctx ^. networkLayer @t inps = NE.toList inpsNE outs = NE.toList outsNE + md = Nothing -- no metadata -- | Makes a fully-resolved coin selection for the given set of payments. selectCoinsExternal diff --git a/lib/core/src/Cardano/Wallet/Transaction.hs b/lib/core/src/Cardano/Wallet/Transaction.hs index 4fbd9eecc97..5ff89a54806 100644 --- a/lib/core/src/Cardano/Wallet/Transaction.hs +++ b/lib/core/src/Cardano/Wallet/Transaction.hs @@ -36,7 +36,7 @@ import Cardano.Wallet.Primitive.CoinSelection import Cardano.Wallet.Primitive.Fee ( Fee, FeePolicy ) import Cardano.Wallet.Primitive.Types - ( Address (..), PoolId, SealedTx (..), SlotNo (..), Tx (..) ) + ( Address (..), PoolId, SealedTx (..), SlotNo (..), Tx (..), TxMetadata ) import Data.ByteString ( ByteString ) import Data.Quantity @@ -54,6 +54,8 @@ data TransactionLayer t k = TransactionLayer -- Key store -> SlotNo -- Tip of the chain, for TTL + -> Maybe TxMetadata + -- User or application-defined metadata to embed in the transaction. -> CoinSelection -- A balanced coin selection where all change addresses have been -- assigned. diff --git a/lib/core/test/unit/Cardano/WalletSpec.hs b/lib/core/test/unit/Cardano/WalletSpec.hs index a153366ed43..386345ef322 100644 --- a/lib/core/test/unit/Cardano/WalletSpec.hs +++ b/lib/core/test/unit/Cardano/WalletSpec.hs @@ -527,10 +527,10 @@ walletKeyIsReencrypted (wid, wname) (xprv, pwd) newPwd = let credentials (rootK, pwdP) = (getRawKey $ deriveRewardAccount pwdP rootK, pwdP) (_,_,_,txOld) <- unsafeRunExceptT $ - W.signPayment @_ @_ @DummyTarget wl wid () credentials (coerce pwd) selection + W.signPayment @_ @_ @DummyTarget wl wid () credentials (coerce pwd) Nothing selection unsafeRunExceptT $ W.updateWalletPassphrase wl wid (coerce pwd, newPwd) (_,_,_,txNew) <- unsafeRunExceptT $ - W.signPayment @_ @_ @DummyTarget wl wid () credentials newPwd selection + W.signPayment @_ @_ @DummyTarget wl wid () credentials newPwd Nothing selection txOld `shouldBe` txNew where selection = mempty @@ -704,7 +704,7 @@ setupFixture (wid, wname, wstate) = do -- implements a fake signer that still produces sort of witnesses dummyTransactionLayer :: TransactionLayer DummyTarget JormungandrKey dummyTransactionLayer = TransactionLayer - { mkStdTx = \_ keyFrom _slot cs -> do + { mkStdTx = \_ keyFrom _slot _md cs -> do let inps' = map (second coin) (CS.inputs cs) let tid = mkTxId inps' (CS.outputs cs) mempty Nothing let tx = Tx tid inps' (CS.outputs cs) mempty Nothing diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Transaction.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Transaction.hs index 1a5399c4942..48fb9f68826 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Transaction.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Transaction.hs @@ -83,7 +83,7 @@ newTransactionLayer => Hash "Genesis" -> TransactionLayer t k newTransactionLayer block0H = TransactionLayer - { mkStdTx = \_rewardAcnt keyFrom _ cs -> + { mkStdTx = \_rewardAcnt keyFrom _ _ cs -> mkFragment ( MkFragmentSimpleTransaction (txWitnessTagFor @k) ) keyFrom (CS.inputs cs) (CS.outputs cs) diff --git a/lib/jormungandr/test/integration/Test/Integration/Jormungandr/Scenario/API/Transactions.hs b/lib/jormungandr/test/integration/Test/Integration/Jormungandr/Scenario/API/Transactions.hs index 34c0c4b7572..6fedb65c259 100644 --- a/lib/jormungandr/test/integration/Test/Integration/Jormungandr/Scenario/API/Transactions.hs +++ b/lib/jormungandr/test/integration/Test/Integration/Jormungandr/Scenario/API/Transactions.hs @@ -529,7 +529,7 @@ fixtureExternalTx ctx toSend = do tl <- newTransactionLayer <$> getBlock0H let rewardAcnt = error "rewardAcnt unused" let curSlot = error "current slot not needed in jormungandr mkStdTx" - let (Right (tx, bin)) = mkStdTx tl rewardAcnt keystore curSlot cs + let (Right (tx, bin)) = mkStdTx tl rewardAcnt keystore curSlot Nothing cs return ExternalTxFixture { srcWallet = wSrc diff --git a/lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/TransactionSpec.hs b/lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/TransactionSpec.hs index 3511a9df83e..b796d22adfa 100644 --- a/lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/TransactionSpec.hs +++ b/lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/TransactionSpec.hs @@ -506,7 +506,7 @@ goldenTestStdTx goldenTestStdTx tl keystore inps outs bytes' = it title $ do let cs = mempty { inputs = inps, outputs = outs } let rewardAcnt = error "unused" - let tx = mkStdTx tl rewardAcnt keystore (SlotNo 0) cs + let tx = mkStdTx tl rewardAcnt keystore (SlotNo 0) Nothing cs let bytes = hex . getSealedTx . snd <$> tx bytes `shouldBe` Right bytes' where @@ -575,7 +575,7 @@ unknownInputTest unknownInputTest _ block0 = it title $ do let addr = paymentAddress @n $ publicKey $ fst $ xprvSeqFromSeed "address-number-0" - let res = mkStdTx tl rewardAcnt keyFrom (SlotNo 0) cs + let res = mkStdTx tl rewardAcnt keyFrom (SlotNo 0) Nothing cs where tl = newTransactionLayer @JormungandrKey block0 rewardAcnt = error "unused" diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs index 1d7da1f23fb..18382675d56 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs @@ -66,6 +66,7 @@ import Cardano.Wallet.Primitive.Types , SealedTx (..) , Tx (..) , TxIn (..) + , TxMetadata , TxOut (..) ) import Cardano.Wallet.Shelley.Compatibility @@ -127,7 +128,11 @@ import qualified Shelley.Spec.Ledger.Tx as SL -- Designed to allow us to have /one/ @mkTx@ which doesn't care whether we -- include certificates or not. data TxPayload era = TxPayload - { _certificates :: [Cardano.Certificate] + { _metadata :: Maybe Cardano.TxMetadata + -- ^ User or application-defined metadata to be included in the + -- transaction. + + , _certificates :: [Cardano.Certificate] -- ^ Certificates to be included in the transactions. , _extraWitnesses :: Cardano.TxBody era -> [Cardano.Witness era] @@ -138,7 +143,10 @@ data TxPayload era = TxPayload } emptyTxPayload :: TxPayload c -emptyTxPayload = TxPayload mempty mempty +emptyTxPayload = TxPayload Nothing mempty mempty + +stdTxPayload :: Maybe TxMetadata -> TxPayload c +stdTxPayload md = TxPayload md mempty mempty data TxWitnessTag = TxWitnessByronUTxO WalletStyle @@ -176,13 +184,13 @@ mkTx -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption")) -> CoinSelection -> Either ErrMkTx (Tx, SealedTx) -mkTx networkId (TxPayload certs mkExtraWits) timeToLive (rewardAcnt, pwdAcnt) keyFrom cs = do +mkTx networkId (TxPayload md certs mkExtraWits) timeToLive (rewardAcnt, pwdAcnt) keyFrom cs = do let wdrls = mkWithdrawals networkId (toChimericAccountRaw . toXPub $ rewardAcnt) (withdrawal cs) - let unsigned = mkUnsignedTx timeToLive cs wdrls certs + let unsigned = mkUnsignedTx timeToLive cs md wdrls certs wits <- case (txWitnessTagFor @k) of TxWitnessShelleyUTxO -> do @@ -215,8 +223,8 @@ newTransactionLayer => NetworkId -> TransactionLayer t k newTransactionLayer networkId = TransactionLayer - { mkStdTx = \acc ks tip -> - mkTx networkId emptyTxPayload (defaultTTL tip) acc ks + { mkStdTx = \acc ks tip md -> + mkTx networkId (stdTxPayload md) (defaultTTL tip) acc ks , initDelegationSelection = _initDelegationSelection , mkDelegationJoinTx = _mkDelegationJoinTx , mkDelegationQuitTx = _mkDelegationQuitTx @@ -267,7 +275,7 @@ newTransactionLayer networkId = TransactionLayer [ mkShelleyWitness unsigned (accXPrv, pwd') ] - let payload = TxPayload certs mkWits + let payload = TxPayload Nothing certs mkWits let ttl = defaultTTL tip mkTx networkId payload ttl acc keyFrom cs @@ -289,7 +297,7 @@ newTransactionLayer networkId = TransactionLayer [ mkShelleyWitness unsigned (accXPrv, pwd') ] - let payload = TxPayload certs mkWits + let payload = TxPayload Nothing certs mkWits let ttl = defaultTTL tip mkTx networkId payload ttl acc keyFrom cs @@ -322,7 +330,7 @@ _estimateMaxNumberOfInputs networkId (Quantity maxSize) nOuts = isTooBig nInps = size > fromIntegral maxSize where - size = computeTxSize networkId (txWitnessTagFor @k) Nothing sel + size = computeTxSize networkId (txWitnessTagFor @k) Nothing Nothing sel sel = dummyCoinSel nInps (fromIntegral nOuts) dummyCoinSel :: Int -> Int -> CoinSelection @@ -354,8 +362,10 @@ _minimumFee -> CoinSelection -> Fee _minimumFee networkId policy action cs = - computeFee $ computeTxSize networkId (txWitnessTagFor @k) action cs + computeFee $ computeTxSize networkId (txWitnessTagFor @k) md action cs where + md = Nothing -- fixme: #2075 include metadata in fee calculations + computeFee :: Integer -> Fee computeFee size = Fee $ ceiling (a + b*fromIntegral size) @@ -367,10 +377,11 @@ _minimumFee networkId policy action cs = computeTxSize :: Cardano.NetworkId -> TxWitnessTag + -> Maybe Cardano.TxMetadata -> Maybe DelegationAction -> CoinSelection -> Integer -computeTxSize networkId witTag action cs = +computeTxSize networkId witTag md action cs = withUnderlyingShelleyTx SL.txsize signed + outputCorrection where withUnderlyingShelleyTx @@ -410,7 +421,7 @@ computeTxSize networkId witTag action cs = maxSizeOfIcarusMainAddr = 43 maxSizeOfIcarusTestAddr = 50 - unsigned = mkUnsignedTx maxBound cs' wdrls certs + unsigned = mkUnsignedTx maxBound cs' md wdrls certs where cs' :: CoinSelection cs' = cs @@ -544,13 +555,14 @@ lookupPrivateKey keyFrom addr = mkUnsignedTx :: Cardano.SlotNo -> CoinSelection + -> Maybe Cardano.TxMetadata -> [(Cardano.StakeAddress, Cardano.Lovelace)] -> [Cardano.Certificate] -> Cardano.TxBody Cardano.Shelley -mkUnsignedTx ttl cs wdrls certs = +mkUnsignedTx ttl cs md wdrls certs = Cardano.makeShelleyTransaction TxExtraContent - { txMetadata = Nothing + { txMetadata = md , txWithdrawals = wdrls , txCertificates = certs , txUpdateProposal = Nothing diff --git a/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs b/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs index 8d0a4297d80..b6ad2a06dca 100644 --- a/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs +++ b/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs @@ -39,7 +39,14 @@ import Cardano.Wallet.Primitive.CoinSelection import Cardano.Wallet.Primitive.Fee ( Fee (..), FeeOptions (..), FeePolicy (..), adjustForFee ) import Cardano.Wallet.Primitive.Types - ( Address (..), Coin (..), Hash (..), TxIn (..), TxOut (..), UTxO (..) ) + ( Address (..) + , Coin (..) + , Hash (..) + , TxIn (..) + , TxMetadata (..) + , TxOut (..) + , UTxO (..) + ) import Cardano.Wallet.Shelley.Compatibility ( Shelley, sealShelleyTx ) import Cardano.Wallet.Shelley.Transaction @@ -97,6 +104,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Shelley.Spec.Ledger.MetaData as MD spec :: Spec spec = do @@ -172,10 +180,10 @@ estimateMaxInputsTests net = prop_decodeSignedShelleyTxRoundtrip :: DecodeShelleySetup -> Property -prop_decodeSignedShelleyTxRoundtrip (DecodeShelleySetup utxo outs slotNo pairs) = do +prop_decodeSignedShelleyTxRoundtrip (DecodeShelleySetup utxo outs md slotNo pairs) = do let inps = Map.toList $ getUTxO utxo let cs = mempty { CS.inputs = inps, CS.outputs = outs } - let unsigned = mkUnsignedTx slotNo cs mempty [] + let unsigned = mkUnsignedTx slotNo cs md mempty [] let addrWits = map (mkShelleyWitness unsigned) pairs let wits = addrWits let ledgerTx = Cardano.makeSignedTransaction wits unsigned @@ -188,7 +196,7 @@ prop_decodeSignedByronTxRoundtrip prop_decodeSignedByronTxRoundtrip (DecodeByronSetup utxo outs slotNo network pairs) = do let inps = Map.toList $ getUTxO utxo let cs = mempty { CS.inputs = inps, CS.outputs = outs } - let unsigned = mkUnsignedTx slotNo cs mempty [] + let unsigned = mkUnsignedTx slotNo cs Nothing mempty [] let byronWits = zipWith (mkByronWitness' unsigned) inps pairs let ledgerTx = Cardano.makeSignedTransaction byronWits unsigned @@ -248,6 +256,7 @@ testTxLayer = newTransactionLayer @ShelleyKey Cardano.Mainnet data DecodeShelleySetup = DecodeShelleySetup { inputs :: UTxO , outputs :: [TxOut] + , metadata :: Maybe TxMetadata , ttl :: SlotNo , keyPasswd :: [(XPrv, Passphrase "encryption")] } deriving Show @@ -265,10 +274,11 @@ instance Arbitrary DecodeShelleySetup where utxo <- arbitrary n <- choose (1,10) outs <- vectorOf n arbitrary + md <- arbitrary slot <- arbitrary let numInps = Map.size $ getUTxO utxo pairs <- vectorOf numInps arbitrary - pure $ DecodeShelleySetup utxo outs slot pairs + pure $ DecodeShelleySetup utxo outs md slot pairs instance Arbitrary Cardano.NetworkId where arbitrary = elements @@ -310,6 +320,13 @@ instance Arbitrary TxOut where let addr = Address $ BS.pack (1:replicate 64 0) TxOut addr <$> arbitrary +instance Arbitrary TxMetadata where + arbitrary = TxMetadata . MD.MetaData <$> arbitrary + shrink (TxMetadata (MD.MetaData md)) = TxMetadata . MD.MetaData <$> shrink md + +instance Arbitrary MD.MetaDatum where + arbitrary = MD.I <$> arbitrary + instance Arbitrary UTxO where arbitrary = do n <- choose (1,10) From 30d70f6b6ea0bec2052ccb794c83a66b80736cec Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Mon, 31 Aug 2020 21:36:42 +1000 Subject: [PATCH 2/2] Add TxMetadata arg to signTx --- lib/core/src/Cardano/Wallet.hs | 5 +++-- lib/core/src/Cardano/Wallet/Api/Server.hs | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 876c9bd7361..69161ca9242 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -302,6 +302,7 @@ import Cardano.Wallet.Primitive.Types , TransactionInfo (..) , Tx , TxMeta (..) + , TxMetadata , TxOut (..) , TxStatus (..) , UTxO (..) @@ -1566,9 +1567,10 @@ signTx => ctx -> WalletId -> Passphrase "raw" + -> Maybe TxMetadata -> UnsignedTx -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx) -signTx ctx wid pwd (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do +signTx ctx wid pwd md (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do let pwdP = preparePassphrase scheme pwd nodeTip <- withExceptT ErrSignPaymentNetwork $ currentNodeTip nl @@ -1592,7 +1594,6 @@ signTx ctx wid pwd (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do nl = ctx ^. networkLayer @t inps = NE.toList inpsNE outs = NE.toList outsNE - md = Nothing -- no metadata -- | Makes a fully-resolved coin selection for the given set of payments. selectCoinsExternal diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index d3a3208003a..ad2433391ce 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -1224,6 +1224,7 @@ postTransaction postTransaction ctx genChange (ApiT wid) body = do let pwd = coerce $ getApiT $ body ^. #passphrase let outs = coerceCoin <$> (body ^. #payments) + let md = Nothing -- fixme: implement in #2073 let selfRewardCredentials (rootK, pwdP) = (getRawKey $ deriveRewardAccount @k pwdP rootK, pwdP) @@ -1251,7 +1252,7 @@ postTransaction ctx genChange (ApiT wid) body = do pure (selection, credentials) (tx, meta, time, wit) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ - W.signPayment @_ @s @t @k wrk wid genChange credentials pwd selection + W.signPayment @_ @s @t @k wrk wid genChange credentials pwd md selection withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ W.submitTx @_ @s @t @k wrk wid (tx, meta, wit) @@ -1528,7 +1529,7 @@ migrateWallet ctx (ApiT wid) migrateData = do forM migration $ \cs -> do (tx, meta, time, wit) <- withWorkerCtx ctx wid liftE liftE - $ \wrk -> liftHandler $ W.signTx @_ @s @t @k wrk wid pwd cs + $ \wrk -> liftHandler $ W.signTx @_ @s @t @k wrk wid pwd Nothing cs withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ W.submitTx @_ @_ @t wrk wid (tx, meta, wit) liftIO $ mkApiTransaction