Add roll forward support in TxHistory

Author: paolino

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

@@ -1,5 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
 
 module Cardano.Wallet.Deposit.Pure.API.TxHistory
     ( ByCustomer
@@ -10,6 +12,9 @@ module Cardano.Wallet.Deposit.Pure.API.TxHistory
     , TxHistory (..)
     , firstJust
     , transfers
+    , ResolveValueTransfer
+    , rollForward
+    , getEraSlotOfBlock
     )
 where
 
@@ -19,8 +24,9 @@ import Cardano.Wallet.Deposit.Map
     ( F
     , Map (..)
     , W
+    , singletonFinger
+    , singletonMap
     )
-
 import Cardano.Wallet.Deposit.Pure.Address
     ( Customer
     )
@@ -29,15 +35,27 @@ import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer
     )
 import Cardano.Wallet.Deposit.Read
     ( Address
+    , WithOrigin (..)
+    , getEraBHeader
+    , getEraSlotNo
+    , getEraTransactions
     )
 import Cardano.Wallet.Read
-    ( Slot
+    ( Block
+    , EraValue (..)
+    , IsEra
+    , Slot
+    , Tx
     , TxId
-    , WithOrigin
+    , applyEraFun
+    , getTxId
     )
 import Data.Foldable
     ( Foldable (..)
     )
+import Data.Maybe
+    ( maybeToList
+    )
 import Data.Monoid
     ( First (..)
     )
@@ -48,10 +66,13 @@ import Data.Time
     ( UTCTime
     )
 
+import qualified Data.Map.Strict as Map
+
 firstJust :: a -> First a
 firstJust = First . Just
 
-transfers :: Foldable (Map xs) => Map xs ValueTransfer -> ValueTransfer
+transfers
+    :: Foldable (Map xs) => Map xs ValueTransfer -> ValueTransfer
 transfers = fold
 
 type DownTime = Down (WithOrigin UTCTime)
@@ -85,3 +106,49 @@ instance Monoid TxHistory where
 
 type ResolveAddress = Address -> Maybe Customer
 type ResolveSlot = Slot -> Maybe DownTime
+type ResolveValueTransfer =
+    forall era. IsEra era => Tx era -> Map.Map Address ValueTransfer
+
+getEraSlotOfBlock :: IsEra era => Block era -> Slot
+getEraSlotOfBlock = At . getEraSlotNo . getEraBHeader
+
+rollForward
+    :: ResolveValueTransfer
+    -> ResolveAddress
+    -> ResolveSlot
+    -> EraValue Block
+    -> TxHistory
+    -> TxHistory
+rollForward resolveValueTransfer resolveAddress resolveSlot block =
+    (<> txHistory')
+  where
+    txHistory' =
+        applyEraFun
+            (blockToTxHistory resolveValueTransfer resolveAddress resolveSlot)
+            block
+
+blockToTxHistory
+    :: IsEra era
+    => ResolveValueTransfer
+    -> ResolveAddress
+    -> ResolveSlot
+    -> Block era
+    -> TxHistory
+blockToTxHistory resolveValueTransfer resolveAddress resolveSlot block =
+    fold $ do
+        tx <- getEraTransactions block
+        let slot = getEraSlotOfBlock block
+        time <- maybeToList $ resolveSlot slot
+        (address, valueTransfer) <- Map.toAscList $ resolveValueTransfer tx
+        customer <- maybeToList $ resolveAddress address
+        let byTime =
+                singletonFinger () time
+                    $ singletonMap (First $ Just slot) customer
+                    $ singletonMap (First $ Just address) (getTxId tx)
+                    $ Value valueTransfer
+        let byCustomer =
+                singletonMap () customer
+                    $ singletonFinger (First $ Just address) time
+                    $ singletonMap (First $ Just slot) (getTxId tx)
+                    $ Value valueTransfer
+        pure $ TxHistory{byCustomer, byTime}