Add roll backward support in TxHistory

cardano-foundation · Nov 1, 2024 · e1450b6 · e1450b6
1 parent 1dcc6bf
commit e1450b6
Show file tree

Hide file tree

Showing 2 changed files with 43 additions and 11 deletions.
diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -15,6 +16,7 @@ module Cardano.Wallet.Deposit.Pure.API.TxHistory
     , ResolveValueTransfer
     , rollForward
     , getEraSlotOfBlock
+    , rollBackward
     )
 where
 
@@ -24,9 +26,15 @@ import Cardano.Wallet.Deposit.Map
     ( F
     , Map (..)
     , W
+    , onFinger
+    , onMap
     , singletonFinger
     , singletonMap
     )
+import Cardano.Wallet.Deposit.Map.Timed
+    ( TimedSeq
+    , before
+    )
 import Cardano.Wallet.Deposit.Pure.Address
     ( Customer
     )
@@ -112,6 +120,9 @@ type ResolveValueTransfer =
 getEraSlotOfBlock :: IsEra era => Block era -> Slot
 getEraSlotOfBlock = At . getEraSlotNo . getEraBHeader
 
+-- | Roll forward a block into the transaction history. This function
+-- relies on the TxHistory to be sorted by time both on the time and
+-- customer views.
 rollForward
     :: ResolveValueTransfer
     -> ResolveAddress
@@ -143,12 +154,35 @@ blockToTxHistory resolveValueTransfer resolveAddress resolveSlot block =
         customer <- maybeToList $ resolveAddress address
         let byTime =
                 singletonFinger () time
-                    $ singletonMap (First $ Just slot) customer
-                    $ singletonMap (First $ Just address) (getTxId tx)
+                    $ singletonMap (firstJust slot) customer
+                    $ singletonMap (firstJust address) (getTxId tx)
                     $ Value valueTransfer
         let byCustomer =
                 singletonMap () customer
-                    $ singletonFinger (First $ Just address) time
-                    $ singletonMap (First $ Just slot) (getTxId tx)
+                    $ singletonFinger (firstJust address) time
+                    $ singletonMap (firstJust slot) (getTxId tx)
                     $ Value valueTransfer
         pure $ TxHistory{byCustomer, byTime}
+
+-- | Roll backward the transaction history to a given slot. This function
+-- relies on the TxHistory to be sorted by time both on the time and
+-- customer views.
+rollBackward
+    :: ResolveSlot
+    -> Slot
+    -> TxHistory
+    -> TxHistory
+rollBackward
+    resolveSlot
+    slot
+    TxHistory
+        { byCustomer
+        , byTime
+        } =
+        TxHistory
+            { byCustomer = onMap byCustomer $ fmap (`onFinger` takeToSlot)
+            , byTime = onFinger byTime takeToSlot
+            }
+        where
+            takeToSlot :: Monoid a => TimedSeq DownTime a -> TimedSeq DownTime a
+            takeToSlot x = maybe x (`before` x) (resolveSlot slot)
diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory/Mock.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory/Mock.hs
@@ -22,6 +22,7 @@ import Cardano.Wallet.Deposit.Pure.API.TxHistory
     ( ResolveAddress
     , ResolveSlot
     , TxHistory (..)
+    , firstJust
     )
 import Cardano.Wallet.Deposit.Read
     ( Address
@@ -43,9 +44,6 @@ import Control.Monad
 import Data.Maybe
     ( fromJust
     )
-import Data.Monoid
-    ( First (..)
-    )
 import Data.Time
     ( UTCTime (..)
     )
@@ -107,13 +105,13 @@ mockTxHistory now solveAddress solveSlot addresses ns =
                             Nothing -> error "fakeDepositsCreate: slot not found"
                         singletonByTime =
                             singletonMap () time
-                                $ singletonMap (First $ Just slot) customer
-                                $ singletonMap (First $ Just address) txId
+                                $ singletonMap (firstJust slot) customer
+                                $ singletonMap (firstJust address) txId
                                 $ Value value
                         singletonByCustomer =
                             singletonMap () customer
-                                $ singletonMap (First $ Just address) time
-                                $ singletonMap (First $ Just slot) txId
+                                $ singletonMap (firstJust address) time
+                                $ singletonMap (firstJust slot) txId
                                 $ Value value
                     pure (singletonByCustomer, singletonByTime)
         byCustomer' = Map w $ fmap toFinger f