Add metadata to transaction layer

lib/core/src/Cardano/Wallet.hs

@@ -302,6 +302,7 @@ import Cardano.Wallet.Primitive.Types
     , TransactionInfo (..)
     , Tx
     , TxMeta (..)
+    , TxMetadata
     , TxOut (..)
     , TxStatus (..)
     , UTxO (..)
@@ -1523,9 +1524,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 +1541,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)
@@ -1565,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
@@ -1579,7 +1582,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)

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

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.

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

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)

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

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"

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

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)