[ADP-3443] Add roll forward and backward of TxHistory to deposit wallet

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

@@ -46,16 +46,21 @@ import Cardano.Crypto.Wallet
 import Cardano.Wallet.Address.BIP32
     ( BIP32Path
     )
+import Cardano.Wallet.Deposit.IO.Network.Type
+    ( NetworkEnv (slotsToUTCTimes)
+    )
 import Cardano.Wallet.Deposit.Pure
     ( Customer
     , ValueTransfer
     , WalletPublicIdentity (..)
     , WalletState
     , Word31
+    , getEraSlotOfBlock
     )
 import Cardano.Wallet.Deposit.Pure.API.TxHistory
     ( ByCustomer
     , ByTime
+    , LookupTimeFromSlot
     )
 import Cardano.Wallet.Deposit.Read
     ( Address
@@ -65,13 +70,20 @@ import Cardano.Wallet.Deposit.Read
 import Cardano.Wallet.Network.Checkpoints.Policy
     ( defaultPolicy
     )
+import Cardano.Wallet.Read
+    ( Slot
+    , applyEraFun
+    )
 import Control.Tracer
     ( Tracer
     , contramap
     )
 import Data.Bifunctor
     ( first
     )
+import Data.Foldable
+    ( Foldable (..)
+    )
 import Data.List.NonEmpty
     ( NonEmpty
     )
@@ -92,6 +104,7 @@ import qualified Data.Delta as Delta
     ( Replace (..)
     )
 import qualified Data.Delta.Update as Delta
+import qualified Data.Set as Set
 import qualified Data.Store as Store
 
 {-----------------------------------------------------------------------------
@@ -113,8 +126,7 @@ data WalletBootEnv m = WalletBootEnv
 type WalletStore = Store.UpdateStore IO Wallet.DeltaWalletState
 
 -- | The full environment needed to run a wallet.
-data WalletEnv m
-    = WalletEnv
+data WalletEnv m = WalletEnv
     { bootEnv :: WalletBootEnv m
     -- ^ The boot environment.
     , store :: WalletStore
@@ -269,18 +281,41 @@ getAllDeposits w i =
     Wallet.getAllDeposits i <$> readWalletState w
 
 rollForward
-    :: WalletInstance -> NonEmpty (Read.EraValue Read.Block) -> tip -> IO ()
-rollForward w blocks _nodeTip =
+    :: WalletInstance
+    -> NonEmpty (Read.EraValue Read.Block)
+    -> tip
+    -> IO ()
+rollForward w blocks _nodeTip = do
+    let blockSlots =
+            applyEraFun getEraSlotOfBlock
+                <$> toList blocks
+    timeFromSlot <- slotResolver w blockSlots
     onWalletState w
         $ Delta.update
-        $ Delta.Replace . Wallet.rollForwardMany blocks
+        $ Delta.Replace
+            . Wallet.rollForwardMany
+                timeFromSlot
+                blocks
 
 rollBackward
     :: WalletInstance -> Read.ChainPoint -> IO Read.ChainPoint
-rollBackward w point =
+rollBackward w point = do
+    timeFromSlot <- slotResolver w [Read.slotFromChainPoint point]
     onWalletState w
         $ Delta.updateWithResult
-        $ first Delta.Replace . Wallet.rollBackward point
+        $ first Delta.Replace . Wallet.rollBackward timeFromSlot point
+
+-- | Compute a slot resolver for the given slots.
+slotResolver
+    :: WalletInstance
+    -> [Slot]
+    -> IO LookupTimeFromSlot
+slotResolver w slots = do
+    let slotSet = Set.fromList slots
+    flip slotsToUTCTimes slotSet
+        $ networkEnv
+        $ bootEnv
+        $ env w
 
 {-----------------------------------------------------------------------------
     Operations

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

@@ -11,7 +11,9 @@ import Prelude
 
 import Cardano.Wallet.Deposit.Read
     ( Slot
-    , WithOrigin
+    )
+import Cardano.Wallet.Deposit.Time
+    ( LookupTimeFromSlot
     )
 import Cardano.Wallet.Network
     ( ChainFollower (..)
@@ -26,9 +28,6 @@ import Control.Tracer
 import Data.List.NonEmpty
     ( NonEmpty
     )
-import Data.Map.Strict
-    ( Map
-    )
 import Data.Set
     ( Set
     )
@@ -65,7 +64,7 @@ data NetworkEnv m block = NetworkEnv
         -- ^ Get the current 'TimeInterpreter' from the Cardano node.
     , slotsToUTCTimes
         :: Set Slot
-        -> m (Map Slot (WithOrigin UTCTime))
+        -> m LookupTimeFromSlot
     -- ^ Try to convert a set of slots to their UTCTimes counterparts
     , utcTimeToSlot
         :: UTCTime

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

@@ -39,7 +39,13 @@ module Cardano.Wallet.Deposit.Map
       -- * Construction
     , singletonMap
     , singletonFinger
+
+      -- * Conversion
     , toFinger
+
+      -- * Modification
+    , onMap
+    , onFinger
     )
 where
 
@@ -82,12 +88,20 @@ data F (w :: Type) (k :: Type)
 
 -- | A nested monoidal map. Every nesting can also be patched with a monoid 'w'.
 data Map :: [Type] -> Type -> Type where
-    Value :: v -> Map '[] v
-    -- ^ A leaf node with a value.
-    Map :: w -> k ^^^ Map ks v -> Map (W w k ': ks) v
-    -- ^ A node with a patch 'w' and a nested monoidal map.
-    Finger :: w -> TimedSeq k (Map ks v) -> Map (F w k ': ks) v
-    -- ^ A node with a patch 'w' and a nested finger tree of maps.
+    Value
+        :: v
+        -> Map '[] v
+        -- ^ A leaf node with a value.
+    Map
+        :: w
+        -> k ^^^ Map ks v
+        -> Map (W w k ': ks) v
+        -- ^ A node with a patch 'w' and a nested monoidal map.
+    Finger
+        :: w
+        -> TimedSeq k (Map ks v)
+        -> Map (F w k ': ks) v
+        -- ^ A node with a patch 'w' and a nested finger tree of maps.
 
 deriving instance Show v => Show (Map '[] v)
 
@@ -241,7 +255,8 @@ singletonFinger
 singletonFinger w k m =
     Finger w $ FingerTree.singleton (Timed (Last (Just k)) m)
 
-toFinger :: Monoid (Map ks a) => Map (W w k : ks) a -> Map (F w k : ks) a
+toFinger
+    :: Monoid (Map ks a) => Map (W w k : ks) a -> Map (F w k : ks) a
 toFinger (Map w m) = Finger w $ FingerTree.fromList $ do
     (k, v) <- MonoidalMap.toList m
     pure $ Timed (Last (Just k)) v
@@ -262,3 +277,17 @@ lookupFinger k1 k2 (Finger w m) = do
     case extractInterval k1 k2 m of
         Timed (Last Nothing) _ -> Nothing
         Timed _ m' -> Just (w, m')
+
+-- | Apply a function to the nested monoidal map keeping the patch.
+onMap
+    :: Map (W w k : ks) a
+    -> (MonoidalMap k (Map ks a) -> MonoidalMap k (Map ks a))
+    -> Map (W w k : ks) a
+onMap (Map w m) f = Map w $ f m
+
+-- | Apply a function to the nested finger tree keeping the patch.
+onFinger
+    :: Map (F w k : ks) a
+    -> (TimedSeq k (Map ks a) -> TimedSeq k (Map ks a))
+    -> Map (F w k : ks) a
+onFinger (Finger w m) f = Finger w $ f m

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

@@ -11,6 +11,7 @@ module Cardano.Wallet.Deposit.Map.Timed
     , extractInterval
     , minKey
     , maxKey
+    , dropAfter
     )
 where
 
@@ -183,3 +184,7 @@ extractInterval t0 t1 tseq =
     measure
         $ takeUntil (\q -> time q > Last (Just t1))
         $ dropUntil (\q -> time q >= Last (Just t0)) tseq
+
+-- | Extract all elements from a tseq that are before the given time.
+dropAfter :: (Ord t, Monoid a) => t -> TimedSeq t a -> TimedSeq t a
+dropAfter t = takeUntil (\q -> time q > Last (Just t))

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

@@ -36,6 +36,7 @@ module Cardano.Wallet.Deposit.Pure
     , ValueTransfer (..)
     , getTxHistoryByCustomer
     , getTxHistoryByTime
+    , getEraSlotOfBlock
 
       -- ** Writing to the blockchain
     , createPayment
@@ -82,6 +83,9 @@ import Cardano.Wallet.Deposit.Pure.API.TxHistory
     , DownTime
     , TxHistory (..)
     )
+import Cardano.Wallet.Deposit.Pure.Balance
+    ( ValueTransferMap
+    )
 import Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory
     ( UTxOHistory
     )
@@ -90,8 +94,14 @@ import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer
     )
 import Cardano.Wallet.Deposit.Read
     ( Address
+    , Slot
     , TxId
-    , WithOrigin
+    , WithOrigin (..)
+    , getEraBHeader
+    , getEraSlotNo
+    )
+import Cardano.Wallet.Deposit.Time
+    ( LookupTimeFromSlot
     )
 import Data.Foldable
     ( fold
@@ -120,6 +130,7 @@ import Data.Word.Odd
     )
 
 import qualified Cardano.Wallet.Deposit.Pure.Address as Address
+import qualified Cardano.Wallet.Deposit.Pure.API.TxHistory as TxHistory
 import qualified Cardano.Wallet.Deposit.Pure.Balance as Balance
 import qualified Cardano.Wallet.Deposit.Pure.RollbackWindow as Rollback
 import qualified Cardano.Wallet.Deposit.Pure.Submissions as Sbm
@@ -230,44 +241,70 @@ getWalletTip :: WalletState -> Read.ChainPoint
 getWalletTip = walletTip
 
 rollForwardMany
-    :: NonEmpty (Read.EraValue Read.Block) -> WalletState -> WalletState
-rollForwardMany blocks w = foldl' (flip rollForwardOne) w blocks
+    :: LookupTimeFromSlot
+    -> NonEmpty (Read.EraValue Read.Block)
+    -> WalletState
+    -> WalletState
+rollForwardMany timeFromSlot blocks w =
+    foldl' (flip $ rollForwardOne timeFromSlot) w blocks
 
 rollForwardOne
-    :: Read.EraValue Read.Block -> WalletState -> WalletState
-rollForwardOne (Read.EraValue block) w =
+    :: LookupTimeFromSlot
+    -> Read.EraValue Read.Block
+    -> WalletState
+    -> WalletState
+rollForwardOne timeFromSlot (Read.EraValue block) w =
     w
         { walletTip = Read.getChainPoint block
-        , utxoHistory = rollForwardUTxO isOurs block (utxoHistory w)
+        , utxoHistory = utxoHistory'
         , submissions = Delta.apply (Sbm.rollForward block) (submissions w)
+        , txHistory =
+            TxHistory.rollForward
+                valueTransfers
+                (`addressToCustomer` w)
+                timeFromSlot
+                (getEraSlotOfBlock block)
+                (txHistory w)
         }
   where
+    (utxoHistory', valueTransfers) =
+        rollForwardUTxO isOurs block (utxoHistory w)
     isOurs :: Address -> Bool
     isOurs = Address.isOurs (addresses w)
 
+getEraSlotOfBlock :: Read.IsEra era => Read.Block era -> Slot
+getEraSlotOfBlock = At . getEraSlotNo . getEraBHeader
+
 rollForwardUTxO
     :: Read.IsEra era
     => (Address -> Bool)
     -> Read.Block era
     -> UTxOHistory
-    -> UTxOHistory
+    -> (UTxOHistory, ValueTransferMap)
 rollForwardUTxO isOurs block u =
-    UTxOHistory.rollForward slot deltaUTxO u
+    (UTxOHistory.rollForward slot deltaUTxO u, valueTransfers)
   where
-    (deltaUTxO, _) = Balance.applyBlock isOurs block (UTxOHistory.getUTxO u)
+    (deltaUTxO, _, valueTransfers) =
+            Balance.applyBlock isOurs block (UTxOHistory.getUTxO u)
     slot = Read.getEraSlotNo $ Read.getEraBHeader block
 
 rollBackward
-    :: Read.ChainPoint
+    :: LookupTimeFromSlot
+    -> Read.ChainPoint
     -> WalletState
     -> (WalletState, Read.ChainPoint)
-rollBackward targetPoint w =
+rollBackward timeFromSlot targetPoint w =
     ( w
         { walletTip = actualPoint
         , utxoHistory =
             UTxOHistory.rollBackward actualSlot (utxoHistory w)
         , submissions =
             Delta.apply (Sbm.rollBackward actualSlot) (submissions w)
+        , txHistory =
+            TxHistory.rollBackward
+                timeFromSlot
+                (Read.slotFromChainPoint targetPoint)
+                (txHistory w)
         }
     , actualPoint
     )
@@ -282,8 +319,8 @@ rollBackward targetPoint w =
     -- any other point than the target point (or genesis).
     actualPoint =
         if (targetSlot `Rollback.member` UTxOHistory.getRollbackWindow h)
-            -- FIXME: Add test for rollback window of `submissions`
-            then targetPoint
+            then -- FIXME: Add test for rollback window of `submissions`
+                targetPoint
             else Read.GenesisPoint
 
 availableBalance :: WalletState -> Read.Value