Update Exchanges scenarios to use the new TxHistory

cardano-foundation · Oct 25, 2024 · c44fc7f · c44fc7f
1 parent d09fc74
commit c44fc7f
Show file tree

Hide file tree

Showing 2 changed files with 83 additions and 5 deletions.
diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -32,28 +34,45 @@ module Cardano.Wallet.Deposit.IO
     , signTxBody
     , WalletStore
     , walletPublicIdentity
+    , getCustomerTxSummaries
+    , getValueTransfers
     ) where
 
-import Prelude
+import Prelude hiding
+    ( lookup
+    )
 
 import Cardano.Crypto.Wallet
     ( XPub
     )
 import Cardano.Wallet.Address.BIP32
     ( BIP32Path
     )
+import Cardano.Wallet.Deposit.Map
+    ( Map (Value)
+    , W
+    , forgetPatch
+    , lookup
+    , openMap
+    , openPatched
+    , unPatch
+    )
 import Cardano.Wallet.Deposit.Pure
     ( Customer
+    , ValueTransfer
     , WalletPublicIdentity (..)
     , WalletState
     , Word31
     )
 import Cardano.Wallet.Deposit.Pure.API.TxHistory
     ( ByCustomer
     , ByTime
+    , DownTime
     )
 import Cardano.Wallet.Deposit.Read
     ( Address
+    , Slot
+    , TxId
     )
 import Cardano.Wallet.Network.Checkpoints.Policy
     ( defaultPolicy
@@ -65,9 +84,15 @@ import Control.Tracer
 import Data.Bifunctor
     ( first
     )
+import Data.Foldable
+    ( Foldable (..)
+    )
 import Data.List.NonEmpty
     ( NonEmpty
     )
+import Data.Monoid
+    ( First (..)
+    )
 
 import qualified Cardano.Wallet.Deposit.IO.Network.Type as Network
 import qualified Cardano.Wallet.Deposit.Pure as Wallet
@@ -79,7 +104,11 @@ import qualified Data.Delta as Delta
     ( Replace (..)
     )
 import qualified Data.Delta.Update as Delta
+import Data.Map.Monoidal.Strict (MonoidalMap (..))
+import qualified Data.Map.Monoidal.Strict as MonoidalMap
+import qualified Data.Map.Strict as Map
 import qualified Data.Store as Store
+import qualified GHC.Float as MonoidalMap
 
 {-----------------------------------------------------------------------------
     Types
@@ -230,19 +259,57 @@ getTxHistoryByCustomer :: WalletInstance -> IO ByCustomer
 getTxHistoryByCustomer w =
     Wallet.getTxHistoryByCustomer <$> readWalletState w
 
+getCustomerTxSummaries
+    :: Customer
+    -> WalletInstance
+    -> IO [(Slot, TxId, ValueTransfer)]
+getCustomerTxSummaries c w = do
+    h <- getTxHistoryByCustomer w
+    pure $ convert $ lookup c h
+  where
+    convert
+        :: Maybe
+            (Map '[W (First Address) DownTime, W (First Slot) TxId] ValueTransfer)
+        -> [(Slot, TxId, ValueTransfer)]
+    convert = concatMap f . toList . openMap . forgetPatch . fold
+      where
+        f
+            :: (Map '[W (First Slot) TxId] ValueTransfer)
+            -> [(Slot, TxId, ValueTransfer)]
+        f txs = do
+            (txId, Value (First (Just slot), value)) <-
+                MonoidalMap.assocs . openMap . unPatch $ txs
+            pure (slot, txId, value)
+
 getTxHistoryByTime
     :: WalletInstance
     -> IO ByTime
 getTxHistoryByTime w = Wallet.getTxHistoryByTime <$> readWalletState w
 
+getValueTransfers
+    :: WalletInstance -> IO (Map.Map Slot (Map.Map Address ValueTransfer))
+getValueTransfers w = do
+    h <- getTxHistoryByTime w
+    pure $ getMonoidalMap $ (fmap getMonoidalMap) $ fold $ f h
+  where
+    f
+        :: ByTime -> [(MonoidalMap Slot (MonoidalMap Address ValueTransfer))]
+    f x = do
+        (_, slots) <- MonoidalMap.assocs $ openMap x
+        (First (Just slot), addrs) <- pure $ openPatched slots
+        (_, txs') <- MonoidalMap.assocs addrs
+        (First (Just addr), value) <- pure $ fold $ unPatch txs'
+        pure $ MonoidalMap.singleton slot $ MonoidalMap.singleton addr value
+
 rollForward
     :: WalletInstance -> NonEmpty (Read.EraValue Read.Block) -> tip -> IO ()
 rollForward w blocks _nodeTip =
     onWalletState w
         $ Delta.update
         $ Delta.Replace . Wallet.rollForwardMany blocks
 
-rollBackward :: WalletInstance -> Read.ChainPoint -> IO Read.ChainPoint
+rollBackward
+    :: WalletInstance -> Read.ChainPoint -> IO Read.ChainPoint
 rollBackward w point =
     onWalletState w
         $ Delta.updateWithResult
@@ -271,4 +338,4 @@ signTxBody txbody w = Wallet.signTxBody txbody <$> readWalletState w
 ------------------------------------------------------------------------------}
 data WalletLog
     = WalletLogDummy
-    deriving Show
+    deriving (Show)
diff --git a/...omer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md b/...omer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md
@@ -33,12 +33,13 @@ import Cardano.Wallet.Deposit.IO
     )
 import Cardano.Wallet.Deposit.Pure
     ( Customer
-    , TxSummary (..)
     , ValueTransfer (..)
     )
 import Cardano.Wallet.Deposit.Read
     ( Address
     , Value
+    , Slot
+    , TxId
     )
 import Test.Scenario.Blockchain
     ( ScenarioEnv
@@ -66,8 +67,18 @@ depositFundsAt env address value = payFromFaucet env [(address, value)]
 
 We ignore the mapping from TxId when retrieving the customer history
 ```haskell
+
+data TxSummary = TxSummary
+    { _txSlot :: Slot
+    , _txId :: TxId
+    , txTransfer :: ValueTransfer
+    }
+
 getCustomerHistory :: Customer -> WalletInstance -> IO [TxSummary]
-getCustomerHistory customer w = toList <$> Wallet.getCustomerHistory customer w
+getCustomerHistory customer w = do
+    rs <- toList <$> Wallet.getCustomerTxSummaries customer w
+    pure $ map (\(slot, txid, transfer) -> TxSummary slot txid transfer) rs
+
 ```
 
 ## 0. Start a Wallet