Update Exchanges scenarios to use the new TxHistory

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs

@@ -27,6 +27,8 @@ module Cardano.Wallet.Deposit.IO
     , availableBalance
     , getTxHistoryByCustomer
     , getTxHistoryByTime
+    , getCustomerDeposits
+    , getAllDeposits
 
       -- ** Writing to the blockchain
     , createPayment
@@ -46,6 +48,7 @@ import Cardano.Wallet.Address.BIP32
     )
 import Cardano.Wallet.Deposit.Pure
     ( Customer
+    , ValueTransfer
     , WalletPublicIdentity (..)
     , WalletState
     , Word31
@@ -56,6 +59,8 @@ import Cardano.Wallet.Deposit.Pure.API.TxHistory
     )
 import Cardano.Wallet.Deposit.Read
     ( Address
+    , TxId
+    , WithOrigin
     )
 import Cardano.Wallet.Network.Checkpoints.Policy
     ( defaultPolicy
@@ -70,6 +75,12 @@ import Data.Bifunctor
 import Data.List.NonEmpty
     ( NonEmpty
     )
+import Data.Map.Strict
+    ( Map
+    )
+import Data.Time
+    ( UTCTime
+    )
 
 import qualified Cardano.Wallet.Deposit.IO.Network.Type as Network
 import qualified Cardano.Wallet.Deposit.Pure as Wallet
@@ -239,19 +250,33 @@ getTxHistoryByCustomer :: WalletInstance -> IO ByCustomer
 getTxHistoryByCustomer w =
     Wallet.getTxHistoryByCustomer <$> readWalletState w
 
-getTxHistoryByTime
-    :: WalletInstance
-    -> IO ByTime
+getTxHistoryByTime :: WalletInstance -> IO ByTime
 getTxHistoryByTime w = Wallet.getTxHistoryByTime <$> readWalletState w
 
+getCustomerDeposits
+    :: WalletInstance
+    -> Customer
+    -> Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
+    -> IO (Map TxId ValueTransfer)
+getCustomerDeposits w c i =
+    Wallet.getCustomerDeposits c i <$> readWalletState w
+
+getAllDeposits
+    :: WalletInstance
+    -> Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
+    -> IO (Map Customer ValueTransfer)
+getAllDeposits w i =
+    Wallet.getAllDeposits i <$> readWalletState w
+
 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
@@ -280,4 +305,4 @@ signTxBody txbody w = Wallet.signTxBody txbody <$> readWalletState w
 ------------------------------------------------------------------------------}
 data WalletLog
     = WalletLogDummy
-    deriving Show
+    deriving (Show)

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs

@@ -1,4 +1,8 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Cardano.Wallet.Deposit.Pure
     ( -- * Types
@@ -44,9 +48,13 @@ module Cardano.Wallet.Deposit.Pure
 
       -- * Internal, for testing
     , availableUTxO
+    , getCustomerDeposits
+    , getAllDeposits
     ) where
 
-import Prelude
+import Prelude hiding
+    ( lookup
+    )
 
 import Cardano.Crypto.Wallet
     ( XPrv
@@ -56,9 +64,17 @@ import Cardano.Wallet.Address.BIP32
     ( BIP32Path (..)
     , DerivationType (..)
     )
+import Cardano.Wallet.Deposit.Map
+    ( Map
+    , W
+    , forgetPatch
+    , lookup
+    , openMap
+    )
 import Cardano.Wallet.Deposit.Pure.API.TxHistory
     ( ByCustomer
     , ByTime
+    , DownTime
     , TxHistory (..)
     )
 import Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory
@@ -69,19 +85,31 @@ import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer
     )
 import Cardano.Wallet.Deposit.Read
     ( Address
+    , TxId
+    , WithOrigin
     )
 import Data.Foldable
-    ( foldl'
+    ( fold
+    , foldl'
     )
 import Data.List.NonEmpty
     ( NonEmpty
     )
+import Data.Map.Monoidal.Strict
+    ( MonoidalMap (..)
+    )
 import Data.Maybe
     ( mapMaybe
     )
+import Data.Ord
+    ( Down (..)
+    )
 import Data.Set
     ( Set
     )
+import Data.Time
+    ( UTCTime
+    )
 import Data.Word.Odd
     ( Word31
     )
@@ -95,6 +123,8 @@ import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory as UTxOHistory
 import qualified Cardano.Wallet.Deposit.Read as Read
 import qualified Cardano.Wallet.Deposit.Write as Write
 import qualified Data.Delta as Delta
+import qualified Data.List as L
+import qualified Data.Map.Monoidal.Strict as MonoidalMap
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 
@@ -131,7 +161,7 @@ listCustomers =
     Address.listCustomers . addresses
 
 customerAddress :: Customer -> WalletState -> Maybe Address
-customerAddress c = lookup c . listCustomers
+customerAddress c = L.lookup c . listCustomers
 
 addressToCustomer :: Address -> WalletState -> Maybe Customer
 addressToCustomer address =
@@ -268,18 +298,65 @@ getTxHistoryByCustomer state = byCustomer $ txHistory state
 getTxHistoryByTime :: WalletState -> ByTime
 getTxHistoryByTime state = byTime $ txHistory state
 
+getCustomerDeposits
+    :: Customer
+    -> Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
+    -> WalletState
+    -> Map.Map TxId ValueTransfer
+getCustomerDeposits c interval s = fold $ do
+    m <-
+        fmap (openMap . forgetPatch)
+            $ lookup c
+            $ getTxHistoryByCustomer s
+    pure
+        $ wonders interval
+        $ selectTimeInterval interval m
+
+selectTimeInterval
+    :: Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
+    -> MonoidalMap DownTime a
+    -> MonoidalMap DownTime a
+selectTimeInterval Nothing = id
+selectTimeInterval (Just (from, to)) =
+    MonoidalMap.dropWhileAntitone (< Down to)
+        . MonoidalMap.takeWhileAntitone (>= Down from)
+
+getAllDeposits
+    :: Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
+    -> WalletState
+    -> Map.Map Customer ValueTransfer
+getAllDeposits interval s =
+    wonders interval
+        $ openMap
+        $ getTxHistoryByTime s
+
+wonders
+    :: (Ord k, Monoid w, Foldable (Map xs), Monoid (Map xs ValueTransfer))
+    => Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
+    -> MonoidalMap DownTime (Map (W w k : xs) ValueTransfer)
+    -> Map.Map k ValueTransfer
+wonders interval =
+    getMonoidalMap
+        . fmap fold
+        . openMap
+        . forgetPatch
+        . fold
+        . selectTimeInterval interval
+
 {-----------------------------------------------------------------------------
     Operations
     Writing to blockchain
 ------------------------------------------------------------------------------}
 
-createPayment :: [(Address, Write.Value)] -> WalletState -> Maybe Write.TxBody
+createPayment
+    :: [(Address, Write.Value)] -> WalletState -> Maybe Write.TxBody
 createPayment = undefined
 
 -- needs balanceTx
 -- needs to sign the transaction
 
-getBIP32PathsForOwnedInputs :: Write.TxBody -> WalletState -> [BIP32Path]
+getBIP32PathsForOwnedInputs
+    :: Write.TxBody -> WalletState -> [BIP32Path]
 getBIP32PathsForOwnedInputs txbody w =
     getBIP32Paths w
         . resolveInputAddresses

lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md

@@ -33,12 +33,12 @@ import Cardano.Wallet.Deposit.IO
     )
 import Cardano.Wallet.Deposit.Pure
     ( Customer
-    , TxSummary (..)
     , ValueTransfer (..)
     )
 import Cardano.Wallet.Deposit.Read
     ( Address
     , Value
+    , TxId
     )
 import Test.Scenario.Blockchain
     ( ScenarioEnv
@@ -48,10 +48,6 @@ import Test.Scenario.Blockchain
     , signTx
     , submitTx
     )
-import Data.Foldable
-    ( toList
-    , fold
-    )
 
 import qualified Cardano.Wallet.Deposit.IO as Wallet
 import qualified Data.Map as Map
@@ -66,8 +62,9 @@ depositFundsAt env address value = payFromFaucet env [(address, value)]
 
 We ignore the mapping from TxId when retrieving the customer history
 ```haskell
-getCustomerHistory :: Customer -> WalletInstance -> IO [TxSummary]
-getCustomerHistory customer w = toList <$> Wallet.getCustomerHistory customer w
+getCustomerDeposits :: Customer -> WalletInstance -> IO [(TxId, ValueTransfer)]
+getCustomerDeposits customer w =
+    Map.toList <$> Wallet.getCustomerDeposits w customer Nothing
 ```
 
 ## 0. Start a Wallet
@@ -123,11 +120,11 @@ scenarioCreateAddressList w = do
 
 As soon as an association between customer and address has been added to the wallet state using `customerAddress`, the wallet will track deposits sent to this address.
 
-The function `getCustomerHistory` returns a `TxSummary` for each transaction that is related to this customer. For every `TxSummary`, the `received` field records the total deposit made by the customer at this address in this transaction.
+The function `getCustomerDeposits` returns a `TxSummary` for each transaction that is related to this customer. For every `TxSummary`, the `received` field records the total deposit made by the customer at this address in this transaction.
 
 (The `spent` field has informative purpose only, and records whether the wallet has moved any funds out of this address.)
 
-The following scenario illustrates how `getCustomerHistory` records deposits:
+The following scenario illustrates how `getCustomerDeposits` records deposits:
 
 ```haskell
 scenarioTrackDepositOne
@@ -136,18 +133,18 @@ scenarioTrackDepositOne env w = do
     Just address <- Wallet.customerAddress customer w
 
     -- no deposits
-    txsummaries0 <- getCustomerHistory customer w
+    txsummaries0 <- getCustomerDeposits customer w
     assert $ null txsummaries0
 
     -- first deposit
     depositFundsAt env address coin
-    txsummaries1 <- getCustomerHistory customer w
-    assert $ map (received . txTransfer) txsummaries1 == [coin]
+    txsummaries1 <- getCustomerDeposits customer w
+    assert $ map (received . snd) txsummaries1 == [coin]
 
     -- second deposit
     depositFundsAt env address coin
-    txsummaries2 <- getCustomerHistory customer w
-    assert $ map (received . txTransfer) txsummaries2 == [coin, coin]
+    txsummaries2 <- getCustomerDeposits customer w
+    assert $ map (received . snd) txsummaries2 == [coin, coin]
   where
     customer = 7 :: Customer
     coin = ada 12
@@ -175,13 +172,13 @@ scenarioTrackDepositAll env w = do
     depositFundsAt env address2 coin
     depositFundsAt env address1 (coin <> coin)
 
-    history <- fold <$> Wallet.getValueTransfers w
+    history <- Wallet.getAllDeposits w Nothing
     assert $
         Map.map received history
       ==
         Map.fromList
-            [ (address1, coin <> coin <> coin)
-            , (address2, coin)
+            [ (customer1, coin <> coin <> coin)
+            , (customer2, coin)
             ]
   where
     customer1, customer2 :: Customer
@@ -217,8 +214,8 @@ scenarioCreatePayment xprv env destination w = do
     assert $ value2 <> coin == value1
 
     -- but the original deposit amount is still recorded
-    txsummaries <- getCustomerHistory customer w
-    assert $ value1 `elem` map (received . txTransfer) txsummaries
+    txsummaries <- getCustomerDeposits customer w
+    assert $ value1 `elem` map (received . snd) txsummaries
   where
     customer :: Customer
     customer = 17