Merge #2079

2079: Get TxMetadata from blocks on chain r=rvl a=rvl

### Issue Number

ADP-307 / #2077

### Overview

- Initial types, etc.

### Comments

- I don't have any serialized block data to make golden tests. But the testing can be done with integration tests.


Co-authored-by: Rodney Lorrimar <rodney.lorrimar@iohk.io>

lib/core/cardano-wallet-core.cabal

@@ -38,6 +38,7 @@ library
     , binary
     , bytestring
     , cardano-addresses
+    , cardano-api
     , cardano-crypto
     , cardano-slotting
     , cborg
@@ -85,6 +86,7 @@ library
     , servant
     , servant-client
     , servant-server
+    , shelley-spec-ledger
     , split
     , statistics
     , stm
@@ -193,6 +195,7 @@ test-suite unit
     , async
     , bytestring
     , cardano-addresses
+    , cardano-api
     , cardano-crypto
     , cardano-wallet-core
     , ouroboros-consensus
@@ -235,6 +238,7 @@ test-suite unit
     , servant
     , servant-server
     , servant-swagger
+    , shelley-spec-ledger
     , stm
     , swagger2
     , temporary

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -1326,7 +1326,8 @@ mkApiTransactionFromInfo
     => TimeInterpreter m
     -> TransactionInfo
     -> m (ApiTransaction n)
-mkApiTransactionFromInfo ti (TransactionInfo txid ins outs ws meta depth txtime) = do
+mkApiTransactionFromInfo ti (TransactionInfo txid ins outs ws meta depth txtime _txmeta) = do
+    -- fixme: include _txmeta in API transaction #2074
     apiTx <- mkApiTransaction ti txid (drop2nd <$> ins) outs ws (meta, txtime) $
         case meta ^. #status of
             Pending  -> #pendingSince

lib/core/src/Cardano/Wallet/DB/Model.hs

@@ -453,6 +453,8 @@ mReadTxHistory ti wid minWithdrawal order range mstatus db@(Database wallets txs
             Quantity $ fromIntegral $ if tipH > txH then tipH - txH else 0
         , txInfoTime =
             slotStartTime' (meta ^. #slotNo)
+        , txInfoMetadata =
+            Nothing -- fixme: #2072 store in database
         }
       where
         txH  = getQuantity

lib/core/src/Cardano/Wallet/DB/Sqlite.hs

@@ -1132,6 +1132,7 @@ txHistoryFromEntity ti tip metas ins outs ws =
             , W.txInfoDepth =
                 Quantity $ fromIntegral $ if tipH > txH then tipH - txH else 0
             , W.txInfoTime = t
+            , W.txInfoMetadata = Nothing -- fixme: implement in #2072
             }
       where
         txH  = getQuantity (meta ^. #blockHeight)

lib/core/src/Cardano/Wallet/Orphans.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -11,10 +12,46 @@ module Cardano.Wallet.Orphans where
 
 import Prelude
 
+import Cardano.Api.Typed
+    ( TxMetadata (..) )
 import Cardano.Slotting.Slot
     ( SlotNo (..) )
+import Control.DeepSeq
+    ( NFData (..) )
+import Data.Ord
+    ( comparing )
 import Fmt
-    ( Buildable (..) )
+    ( Buildable (..), blockListF, hexF, nameF, unlinesF )
+import Shelley.Spec.Ledger.MetaData
+    ( MetaData (..), MetaDatum (..) )
+
+import qualified Data.Map as Map
 
 instance Buildable SlotNo where
     build (SlotNo n) = build (show n)
+
+-- Compare metadatas by their string representation.
+-- Defined here so other types which use TxMetadata can have Ord.
+instance Ord TxMetadata where
+    compare = comparing show
+
+instance Buildable TxMetadata where
+    build (TxMetadata (MetaData m)) =
+        unlinesF (map buildElem (Map.toList m))
+      where
+        buildElem (n, d) = nameF ("element " <> build n) $ buildDatum d
+        buildDatum = \case
+            Map as -> blockListF $ mconcat
+                [ [ nameF "key" (buildDatum k), nameF "val" (buildDatum v) ]
+                | (k, v) <- as ]
+            List xs -> nameF "list" $ blockListF (map buildDatum xs)
+            I i -> build i
+            B bs -> hexF bs
+            S s -> build (show s)
+
+instance NFData MetaDatum
+
+instance NFData MetaData
+
+instance NFData TxMetadata where
+    rnf (TxMetadata md) = rnf md

lib/core/src/Cardano/Wallet/Primitive/Types.hs

@@ -41,6 +41,7 @@ module Cardano.Wallet.Primitive.Types
     , TxIn(..)
     , TxOut(..)
     , TxMeta(..)
+    , TxMetadata(..)
     , Direction(..)
     , TxStatus(..)
     , SealedTx (..)
@@ -174,6 +175,8 @@ module Cardano.Wallet.Primitive.Types
 
 import Prelude
 
+import Cardano.Api.Typed
+    ( TxMetadata (..) )
 import Cardano.Slotting.Slot
     ( SlotNo (..) )
 import Cardano.Wallet.Orphans
@@ -248,6 +251,7 @@ import Fmt
     , fmt
     , indentF
     , listF'
+    , nameF
     , ordinalF
     , padRightF
     , prefixF
@@ -843,18 +847,27 @@ data Tx = Tx
         :: !(Map ChimericAccount Coin)
         -- ^ Withdrawals (of funds from a registered reward account) embedded in
         -- a transaction. The order does not matter.
+    , metadata
+        :: !(Maybe TxMetadata)
+        -- ^ Semi-structured application-specific extension data stored in the
+        -- transaction on chain.
+        --
+        -- This is not to be confused with 'TxMeta', which is information about
+        -- a transaction derived from the ledger.
+        --
+        -- See Appendix E of <https://hydra.iohk.io/job/Cardano/cardano-ledger-specs/delegationDesignSpec/latest/download-by-type/doc-pdf/delegation_design_spec Shelley Ledger: Delegation/Incentives Design Spec>.
     } deriving (Show, Generic, Ord, Eq)
 
-
 instance NFData Tx
 
 instance Buildable Tx where
-    build (Tx tid ins outs ws) = mempty
+    build (Tx tid ins outs ws md) = mempty
         <> build tid
         <> build ("\n" :: String)
         <> blockListF' "inputs" build (fst <$> ins)
         <> blockListF' "outputs" build outs
         <> blockListF' "withdrawals" tupleF (Map.toList ws)
+        <> nameF "metadata" (maybe "" build md)
 
 txIns :: Set Tx -> Set TxIn
 txIns = foldMap (Set.fromList . inputs)
@@ -989,7 +1002,9 @@ data TransactionInfo = TransactionInfo
     -- ^ Number of slots since the transaction slot.
     , txInfoTime :: UTCTime
     -- ^ Creation time of the block including this transaction.
-    } deriving (Generic, Show, Eq, Ord)
+    , txInfoMetadata :: !(Maybe TxMetadata)
+    -- ^ Application-specific extension data.
+    } deriving (Generic, Show, Eq)
 
 instance NFData TransactionInfo
 
@@ -1000,6 +1015,7 @@ fromTransactionInfo info = Tx
     , resolvedInputs = (\(a,b,_) -> (a,b)) <$> txInfoInputs info
     , outputs = txInfoOutputs info
     , withdrawals = txInfoWithdrawals info
+    , metadata = txInfoMetadata info
     }
 
 -- | Drop time-specific information

lib/core/test/bench/db/Main.hs

@@ -511,7 +511,7 @@ benchReadTxHistory sortOrder (inf, sup) mstatus DBLayer{..} =
 mkTxHistory :: Int -> Int -> Int -> [Word64] -> [(Tx, TxMeta)]
 mkTxHistory numTx numInputs numOutputs range =
     [ force
-        ( (Tx (mkTxId inps outs mempty) inps outs mempty)
+        ( (Tx (mkTxId inps outs mempty Nothing) inps outs mempty) Nothing
         , TxMeta
             { status = [InLedger, Pending] !! (i `mod` 2)
             , direction = Incoming

lib/core/test/shared/Cardano/Wallet/DummyTarget/Primitive/Types.hs

@@ -37,6 +37,7 @@ import Cardano.Wallet.Primitive.Types
     , StartTime (..)
     , Tx (..)
     , TxIn (..)
+    , TxMetadata (..)
     , TxOut (..)
     , TxParameters (..)
     )
@@ -117,12 +118,12 @@ dummyProtocolParameters = ProtocolParameters
     }
 
 -- | Construct a @Tx@, computing its hash using the dummy @mkTxId@.
-mkTx :: [(TxIn, Coin)] -> [TxOut] -> Map ChimericAccount Coin -> Tx
-mkTx ins outs wdrls = Tx (mkTxId ins outs wdrls) ins outs wdrls
+mkTx :: [(TxIn, Coin)] -> [TxOut] -> Map ChimericAccount Coin -> Maybe TxMetadata -> Tx
+mkTx ins outs wdrls md = Tx (mkTxId ins outs wdrls md) ins outs wdrls md
 
 -- | txId calculation for testing purposes.
-mkTxId :: [(TxIn, Coin)] -> [TxOut] -> Map ChimericAccount Coin -> Hash "Tx"
-mkTxId ins outs wdrls = mockHash (ins, outs, wdrls)
+mkTxId :: [(TxIn, Coin)] -> [TxOut] -> Map ChimericAccount Coin -> Maybe TxMetadata -> Hash "Tx"
+mkTxId ins outs wdrls md = mockHash (ins, outs, wdrls, md)
 
 -- | Construct a good-enough hash for testing
 mockHash :: Show a => a -> Hash whatever

lib/core/test/unit/Cardano/Wallet/DB/Arbitrary.hs

@@ -365,18 +365,20 @@ arbitraryChainLength = 10
 -------------------------------------------------------------------------------}
 
 instance Arbitrary Tx where
-    shrink (Tx _tid ins outs wdrls) = mconcat
-        [ [ mkTx ins' outs  wdrls
+    shrink (Tx _tid ins outs wdrls md) = mconcat
+        [ [ mkTx ins' outs  wdrls md
           | ins' <- shrinkList' ins
           ]
 
-        , [ mkTx ins  outs' wdrls
+        , [ mkTx ins  outs' wdrls md
           | outs' <- shrinkList' outs
           ]
 
-        , [ mkTx ins outs (Map.fromList wdrls')
+        , [ mkTx ins outs (Map.fromList wdrls') md
           | wdrls' <- shrinkList' (Map.toList wdrls)
           ]
+
+        -- fixme: #2072 shrink md
         ]
       where
         shrinkList' xs  = filter (not . null)
@@ -386,7 +388,9 @@ instance Arbitrary Tx where
         ins <- fmap (L.nub . L.take 5 . getNonEmpty) arbitrary
         outs <- fmap (L.take 5 . getNonEmpty) arbitrary
         wdrls <- fmap (Map.fromList . L.take 5) arbitrary
-        return $ mkTx ins outs wdrls
+        -- fixme: #2072 generate md
+        let md = Nothing
+        return $ mkTx ins outs wdrls md
 
 instance Arbitrary TxIn where
     arbitrary = TxIn

lib/core/test/unit/Cardano/Wallet/DB/Properties.hs

@@ -516,8 +516,8 @@ prop_getTxAfterPutValidTxId db@DBLayer{..} wid txGen =
     prop = do
         let txs = unGenTxHistory txGen
         run $ unsafeRunExceptT $ mapExceptT atomically $ putTxHistory wid txs
-        forM_ txs $ \((Tx txId _ _ _), txMeta) -> do
-            (Just (TransactionInfo txId' _ _ _ txMeta' _ _)) <-
+        forM_ txs $ \((Tx txId _ _ _ _), txMeta) -> do
+            (Just (TransactionInfo txId' _ _ _ txMeta' _ _ _)) <-
                 run $ atomically $ unsafeRunExceptT $ getTx wid txId
 
             monitor $ counterexample $
@@ -567,7 +567,7 @@ prop_getTxAfterPutInvalidWalletId db@DBLayer{..} (key, cp, meta) txGen key'@(Pri
     prop = liftIO $ do
         let txs = unGenTxHistory txGen
         atomically (runExceptT $ putTxHistory key txs) `shouldReturn` Right ()
-        forM_ txs $ \((Tx txId _ _ _), _) -> do
+        forM_ txs $ \((Tx txId _ _ _ _), _) -> do
             let err = ErrNoSuchWallet wid'
             atomically (runExceptT $ getTx key' txId) `shouldReturn` Left err
 

lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs

@@ -603,6 +603,7 @@ fileModeSpec =  do
                                 [(TxIn (dummyHash "faucet") 0, Coin 4)]
                                 [ TxOut (fst $ head ourAddrs) (Coin 4) ]
                                 mempty
+                                Nothing
                             ]
 
                 -- Slot 1 0
@@ -618,6 +619,7 @@ fileModeSpec =  do
                                 , TxOut (fst $ ourAddrs !! 1) (Coin 2)
                                 ]
                                 mempty
+                                Nothing
                             ]
 
                 -- Slot 300
@@ -856,6 +858,7 @@ testTxs =
         [ (TxIn (mockHash @String "tx1") 0, Coin 1)]
         [ TxOut (Address "addr") (Coin 1) ]
         mempty
+        Nothing
       , TxMeta InLedger Incoming (SlotNo 140) (Quantity 0) (Quantity 1337144)
       )
     ]

lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs

@@ -132,6 +132,7 @@ import Cardano.Wallet.Primitive.Types
     , Tx (..)
     , TxIn (..)
     , TxMeta (..)
+    , TxMetadata
     , TxOut (..)
     , TxParameters (..)
     , TxStatus
@@ -841,6 +842,9 @@ instance ToExpr Tx where
 instance ToExpr TxIn where
     toExpr = genericToExpr
 
+instance ToExpr TxMetadata where
+    toExpr = defaultExprViaShow
+
 instance ToExpr Coin where
     toExpr = genericToExpr