Add model for delta utxos store.

lib/wallet/cardano-wallet.cabal

@@ -236,6 +236,7 @@ library
     Cardano.Wallet.DB.Sqlite.Stores
     Cardano.Wallet.DB.Sqlite.Types
     Cardano.Wallet.DB.Store.Checkpoints
+    Cardano.Wallet.DB.Store.DeltaUTxO.Model
     Cardano.Wallet.DB.Store.DeltaUTxO.Model.Internal
     Cardano.Wallet.DB.Store.Meta.Model
     Cardano.Wallet.DB.Store.Meta.Store

lib/wallet/src/Cardano/Wallet/DB/Store/DeltaUTxO/Model.hs

@@ -0,0 +1,209 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Cardano.Wallet.DB.Store.DeltaUTxO.Model
+    ( -- * Types
+      UTxOHistory
+
+      -- * Accessors
+    , getTip
+    , getFinality
+    , empty
+    , getUTxO
+
+      -- * Changes
+    , DeltaUTxOHistory (..)
+
+      -- * For testing
+    , getSpent
+    )
+where
+
+import Prelude
+
+import Cardano.Slotting.Slot
+    ( SlotNo, WithOrigin (..) )
+import Cardano.Wallet.DB.Store.DeltaUTxO.Model.Internal
+    ( UTxOHistory (..) )
+import Cardano.Wallet.Primitive.Types
+    ( Slot )
+import Cardano.Wallet.Primitive.Types.Tx.TxIn
+    ( TxIn )
+import Cardano.Wallet.Primitive.Types.UTxO
+    ( DeltaUTxO (..), UTxO, dom, excluding )
+import Data.Delta
+    ( Delta (..) )
+import Data.Foldable
+    ( fold, foldl' )
+import Data.Map.Strict
+    ( Map )
+
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
+-- | Changes to the UTxO history.
+data DeltaUTxOHistory
+    = -- | New slot tip, changes within that block.
+      AppendBlock SlotNo DeltaUTxO
+    | -- | Rollback tip.
+      Rollback Slot
+    | -- | Move finality forward.
+      Prune SlotNo
+
+-- | An empty UTxO history
+empty :: UTxO -> UTxOHistory
+empty utxo =
+    UTxOHistory
+        { history = utxo
+        , creationSlots = Map.singleton Origin $ dom utxo
+        , spentSlots = mempty
+        , spentTxIns = mempty
+        , tip = Origin
+        , finality = Nothing
+        }
+
+-- | Returns the UTxO.
+getUTxO :: UTxOHistory -> UTxO
+getUTxO UTxOHistory {history, spentSlots} = history `excluding` fold spentSlots
+
+-- | Returns the tip slot.
+getTip :: UTxOHistory -> Slot
+getTip UTxOHistory {tip} = tip
+
+-- | Returns the finality slot.
+getFinality :: UTxOHistory -> Maybe SlotNo
+getFinality UTxOHistory {finality} = finality
+
+-- | Returns the spent TxIns that can be rolled back.
+getSpent :: UTxOHistory -> Map TxIn SlotNo
+getSpent UTxOHistory {spentTxIns} = spentTxIns
+
+onNotNull :: Foldable t1 => t1 a -> t2 -> (t1 a -> t2 -> t2) -> t2
+onNotNull x d f =
+    if null x
+        then d
+        else f x d
+
+-- how to apply a DeltaUTxOHistory to a UTxOHistory
+instance Delta DeltaUTxOHistory where
+    type Base DeltaUTxOHistory = UTxOHistory
+    apply
+        (AppendBlock slot delta)
+        noop@UTxOHistory
+            { history
+            , spentSlots
+            , creationSlots
+            , spentTxIns
+            , tip
+            , finality
+            }
+            | At slot <= tip = noop
+            | otherwise =
+                UTxOHistory
+                    { history = history <> received delta
+                    , creationSlots = onNotNull
+                        (dom $ received delta)
+                        creationSlots
+                        $ \received' ->
+                            Map.insert
+                                (At slot)
+                                (received' `Set.difference` dom history)
+                    , spentSlots = onNotNull
+                        ( (excluded delta `Set.intersection` dom history)
+                            `Set.difference` fold spentSlots
+                        )
+                        spentSlots
+                        $ \excluded' -> Map.insert slot excluded'
+                    , spentTxIns =
+                        foldl'
+                            (\m txIn -> Map.insert txIn slot m)
+                            spentTxIns
+                            (excluded delta)
+                    , tip = At slot
+                    , finality = finality
+                    }
+    apply
+        (Rollback slot)
+        noop@UTxOHistory
+            { history
+            , spentSlots
+            , creationSlots
+            , spentTxIns
+            , tip
+            , finality
+            }
+            | slot >= tip = noop
+            | otherwise =
+                let slot' = maybe slot (max slot) $ At <$> finality
+                    (leftCreationSlots, rolledCreatedSlots) =
+                        Map.spanAntitone (<= slot') creationSlots
+                    rolledSpentTxIns = fold $ case slot' of
+                        Origin -> spentSlots
+                        At slot'' ->
+                            Map.dropWhileAntitone
+                                (<= slot'')
+                                spentSlots
+                    rolledCreatedTxIns = fold rolledCreatedSlots
+                 in UTxOHistory
+                        { history = history `excluding` rolledCreatedTxIns
+                        , spentSlots = case slot' of
+                            Origin -> mempty
+                            At slot'' ->
+                                Map.takeWhileAntitone
+                                    (<= slot'')
+                                    spentSlots
+                        , creationSlots = leftCreationSlots
+                        , spentTxIns =
+                            Map.withoutKeys
+                                spentTxIns
+                                rolledSpentTxIns
+                        , tip = slot'
+                        , finality = finality
+                        }
+    apply
+        (Prune newFinality)
+        noop@UTxOHistory
+            { history
+            , spentSlots
+            , creationSlots
+            , spentTxIns
+            , tip
+            , finality
+            }
+            | finalityIsOlder finality = noop
+            | otherwise = constraintFinality tip $ \newFinality' ->
+                let (prunedSlots, leftSlots) =
+                        Map.spanAntitone
+                            (<= newFinality')
+                            spentSlots
+                    prunedTxIns = fold prunedSlots
+                    fixCreationSlot
+                        (txIn, slotNo) = Map.alter f (At slotNo)
+                          where
+                            f Nothing = Nothing
+                            f (Just txIns) =
+                                let txIns' = Set.delete txIn txIns
+                                 in if null txIns'
+                                        then Nothing
+                                        else Just txIns'
+                 in UTxOHistory
+                        { history = history `excluding` prunedTxIns
+                        , spentSlots = leftSlots
+                        , creationSlots =
+                            foldl'
+                                (flip fixCreationSlot)
+                                creationSlots
+                                $ Map.assocs
+                                $ Map.restrictKeys spentTxIns prunedTxIns
+                        , spentTxIns =
+                            Map.withoutKeys
+                                spentTxIns
+                                prunedTxIns
+                        , tip = tip
+                        , finality = Just newFinality'
+                        }
+          where
+            finalityIsOlder Nothing = False
+            finalityIsOlder (Just oldFinality) = newFinality <= oldFinality
+            constraintFinality Origin _ = noop
+            constraintFinality (At slotNo) f = f $ min slotNo newFinality