Merge #3099

3099: Add `WalletState`, a pure model for the entire wallet r=HeinrichApfelmus a=HeinrichApfelmus

### Issue number

ADP-1375

### Overview

Previous work in epic ADP-1043 introduced delta encodings, DBVars, and an embedding of the wallet state and its delta encodings into a database table. It's time to integrate these tools with the wallet code. To facilitate code review, the integration proceeds in a sequence of refactorings that do not change functionality and pass all unit tests.

In this step, we introduce a data type `WalletState` which represents the entire wallet state — not just the most recent checkpoint, but _all_ checkpoints.
```
data WalletState s = WalletState
    { prologue    :: Prologue s
    , checkpoints :: Checkpoints (BlockHeader, UTxO, Discoveries s)
    } 
```
The states for the different wallets currently stored in the `walletsVar` DBVar. Eventually, the data type will become the purely functional in-memory representation of all the data associated with a wallet (though perhaps with a different name). The `DBLayer` type will eventually be replaced by a `Store` for values of this type.

The introduction of this type has become possible thanks to the previous separation of the address discovery state `s` into `Prologue s` and `Discoveries s` (PRs #3056, #3068, #3073).

### Details

* As the queries in the `DBLayer` will more and more become queries on the in-memory cache `walletsVar` instead of queries on the database table, I have begun to add unit tests for the database tables. Here, I have added a property test for `loadPrologue` and `insertPrologue`. Eventually, these separate tests will become a single generic test for a `Store` of `Table`.

### Comments

* One of the next steps will be to replace `UTxO` in the above type by its delta encoding `DeltaUTxO`. This will reduce the memory footprint of the in-memory representation.
* The `Cardano.Wallet.DB.Model` module actually implements a pure model for the entire wallet state, including TxHistory etc. When extending the type, we can scavenge from there.

Co-authored-by: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>
Co-authored-by: IOHK <devops+stack-project@iohk.io>

lib/core/cardano-wallet-core.cabal

@@ -189,8 +189,10 @@ library
       Cardano.Wallet.DB.Sqlite.AddressBook
       Cardano.Wallet.DB.Sqlite.CheckpointsOld
       Cardano.Wallet.DB.Sqlite.Migration
+      Cardano.Wallet.DB.Sqlite.Stores
       Cardano.Wallet.DB.Sqlite.TH
       Cardano.Wallet.DB.Sqlite.Types
+      Cardano.Wallet.DB.WalletState
       Cardano.Wallet.Logging
       Cardano.Wallet.Network
       Cardano.Wallet.Network.Ports
@@ -354,6 +356,7 @@ test-suite unit
     , network-uri
     , nothunks
     , persistent
+    , persistent-sqlite >=2.13 && <2.14
     , plutus-ledger-api
     , pretty-simple
     , regex-pcre-builtin
@@ -422,6 +425,7 @@ test-suite unit
       Cardano.Wallet.DB.MVarSpec
       Cardano.Wallet.DB.Properties
       Cardano.Wallet.DB.SqliteSpec
+      Cardano.Wallet.DB.Sqlite.StoresSpec
       Cardano.Wallet.DB.Sqlite.TypesSpec
       Cardano.Wallet.DB.StateMachine
       Cardano.Wallet.DummyTarget.Primitive.Types

lib/core/src/Cardano/Wallet/DB.hs

@@ -332,7 +332,8 @@ data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer
 -- | Can't read the database file because it's in a bad format
 -- (corrupted, too old, …)
 data ErrBadFormat
-    = ErrBadFormatAddressState
+    = ErrBadFormatAddressPrologue
+    | ErrBadFormatCheckpoints
     deriving (Eq,Show)
 
 instance Exception ErrBadFormat

lib/core/src/Cardano/Wallet/DB/Checkpoints.hs

@@ -10,10 +10,8 @@
 -- Each checkpoints is associated with a 'Slot'.
 
 module Cardano.Wallet.DB.Checkpoints
-    ( getPoint
-
-    -- * Checkpoints  
-    , Checkpoints
+    ( -- * Checkpoints  
+      Checkpoints
     , checkpoints
     , loadCheckpoints
     , fromGenesis
@@ -22,7 +20,6 @@ module Cardano.Wallet.DB.Checkpoints
 
     -- * Delta types
     , DeltaCheckpoints (..)
-    , DeltaMap (..)
     ) where
 
 import Prelude
@@ -38,7 +35,6 @@ import Data.Maybe
 import GHC.Generics
     ( Generic )
 
-import qualified Cardano.Wallet.Primitive.Model as W
 import qualified Cardano.Wallet.Primitive.Types as W
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
@@ -75,11 +71,6 @@ is clear that the data cannot exist at the genesis point
 
 -}
 
--- | Helper function: Get the 'Point' of a wallet state.
-getPoint :: W.Wallet s -> W.Slot
-getPoint =
-    W.toSlot . W.chainPointFromBlockHeader . view #currentTip
-
 {-------------------------------------------------------------------------------
     Checkpoints
 -------------------------------------------------------------------------------}
@@ -135,18 +126,3 @@ instance Delta (DeltaCheckpoints a) where
         Map.filterWithKey (\k _ -> k <= pt)
     apply (RestrictTo pts) = over #checkpoints $ \m ->
         Map.restrictKeys m $ Set.fromList (W.Origin:pts)
-
-{-------------------------------------------------------------------------------
-    A Delta type for Maps
--------------------------------------------------------------------------------}
--- | Delta type for 'Map'.
-data DeltaMap key da
-    = Insert key (Base da)
-    | Delete key
-    | Adjust key da
-
-instance (Ord key, Delta da) => Delta (DeltaMap key da) where
-    type Base (DeltaMap key da) = Map key (Base da)
-    apply (Insert key a) = Map.insert key a
-    apply (Delete key) = Map.delete key
-    apply (Adjust key da) = Map.adjust (apply da) key

lib/core/src/Cardano/Wallet/DB/Sqlite.hs

@@ -87,18 +87,9 @@ import Cardano.Wallet.DB
     , sparseCheckpoints
     )
 import Cardano.Wallet.DB.Checkpoints
-    ( DeltaCheckpoints (..)
-    , DeltaMap (..)
-    , findNearestPoint
-    , fromGenesis
-    , getLatest
-    , getPoint
-    )
+    ( DeltaCheckpoints (..) )
 import Cardano.Wallet.DB.Sqlite.CheckpointsOld
-    ( PersistAddressBook (..)
-    , blockHeaderFromEntity
-    , mkStoreWalletsCheckpoints
-    )
+    ( PersistAddressBook (..), blockHeaderFromEntity, mkStoreWallets )
 import Cardano.Wallet.DB.Sqlite.Migration
     ( DefaultFieldValues (..), migrateManually )
 import Cardano.Wallet.DB.Sqlite.TH
@@ -121,6 +112,16 @@ import Cardano.Wallet.DB.Sqlite.TH
     )
 import Cardano.Wallet.DB.Sqlite.Types
     ( BlockId (..), TxId (..) )
+import Cardano.Wallet.DB.WalletState
+    ( DeltaMap (..)
+    , DeltaWalletState1 (..)
+    , findNearestPoint
+    , fromGenesis
+    , fromWallet
+    , getBlockHeight
+    , getLatest
+    , getSlot
+    )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( Depth (..), PersistPrivateKey (..), WalletKey (..) )
 import Cardano.Wallet.Primitive.Slotting
@@ -531,7 +532,7 @@ newDBLayerWith _cacheBehavior tr ti SqliteContext{runQuery} = do
 
     -- FIXME LATER during ADP-1043:
     --   Handle the case where loading the database fails.
-    checkpointsVar <- runQuery $ loadDBVar mkStoreWalletsCheckpoints
+    walletsVar <- runQuery $ loadDBVar mkStoreWallets
 
     -- NOTE
     -- The cache will not work properly unless 'atomically' is protected by a
@@ -542,19 +543,25 @@ newDBLayerWith _cacheBehavior tr ti SqliteContext{runQuery} = do
     -- assuming that the wallet already exists.
     let insertCheckpointCached wid cp = do
             liftIO $ traceWith tr $ MsgCheckpointCache wid MsgPutCheckpoint
-            modifyDBMaybe checkpointsVar $ \ws ->
-                let point = getPoint cp
-                in  case Map.lookup wid ws of
-                    Nothing  -> (Nothing, ())
-                    Just _   -> (Just $ Adjust wid $ PutCheckpoint point cp, ())
+            modifyDBMaybe walletsVar $ \ws ->
+                case Map.lookup wid ws of
+                    Nothing -> (Nothing, ())
+                    Just _  ->
+                        let (prologue, wcp) = fromWallet cp
+                            slot = getSlot wcp
+                            delta = Just $ Adjust wid
+                                [ UpdateCheckpoints $ PutCheckpoint slot wcp
+                                , ReplacePrologue prologue
+                                ]
+                        in  (delta, ())
 
     -- Insert genesis checkpoint into the DBVar.
     -- Throws an internal error if the checkpoint is not actually at genesis.
-    let insertCheckpointGenesis wid cp
-            | W.isGenesisBlockHeader header =
-                updateDBVar checkpointsVar $ Insert wid $ fromGenesis cp
-            | otherwise =
-                throwIO $ ErrInitializeNotGenesis wid header
+    let insertCheckpointGenesis wid cp =
+            case fromGenesis cp of
+                Nothing -> throwIO $ ErrInitializeGenesisAbsent wid header
+                Just wallet ->
+                    updateDBVar walletsVar $ Insert wid wallet
           where
             header = cp ^. #currentTip
 
@@ -563,8 +570,8 @@ newDBLayerWith _cacheBehavior tr ti SqliteContext{runQuery} = do
             :: W.WalletId
             -> SqlPersistT IO (Maybe (W.Wallet s))
         selectLatestCheckpointCached wid = do
-            let get = fmap (snd . getLatest) . Map.lookup wid
-            cp <- get <$> readDBVar checkpointsVar
+            let get = fmap getLatest . Map.lookup wid
+            cp <- get <$> readDBVar walletsVar
             liftIO $ traceWith tr $ MsgCheckpointCache wid $ MsgGetCheckpoint $ isJust cp
             pure cp
 
@@ -576,21 +583,21 @@ newDBLayerWith _cacheBehavior tr ti SqliteContext{runQuery} = do
             let heights = Set.fromList $ sparseCheckpoints
                     (defaultSparseCheckpointsConfig epochStability)
                     (tip ^. #blockHeight)
-            modifyDBMaybe checkpointsVar $ \ws ->
+            modifyDBMaybe walletsVar $ \ws ->
                 case Map.lookup wid ws of
                     Nothing  -> (Nothing, ())
-                    Just cps ->
-                        let willKeep cp =
-                                (cp ^. #currentTip ^. #blockHeight ^. #getQuantity)
-                                `Set.member` heights
-                            slots = Map.filter willKeep (cps ^. #checkpoints)
-                        in  (Just $ Adjust wid $ RestrictTo $ Map.keys slots, ())
+                    Just wal ->
+                        let willKeep cp = getBlockHeight cp `Set.member` heights
+                            slots = Map.filter willKeep (wal ^. #checkpoints ^. #checkpoints)
+                            delta = Adjust wid
+                                [ UpdateCheckpoints $ RestrictTo $ Map.keys slots ]
+                        in  (Just delta, ())
 
     -- Delete the a wallet from the checkpoint DBVar
     let deleteCheckpoints :: W.WalletId -> SqlPersistT IO ()
         deleteCheckpoints wid = do
             liftIO $ traceWith tr $ MsgCheckpointCache wid MsgDrop
-            updateDBVar checkpointsVar $ Delete wid
+            updateDBVar walletsVar $ Delete wid
 
     return DBLayer
 
@@ -639,24 +646,26 @@ newDBLayerWith _cacheBehavior tr ti SqliteContext{runQuery} = do
                 [ Asc CheckpointSlot ]
 
         , rollbackTo = \wid requestedPoint -> ExceptT $ do
-            iomNearestCheckpoint <- modifyDBMaybe checkpointsVar $ \ws ->
+            iomNearestCheckpoint <- modifyDBMaybe walletsVar $ \ws ->
                 case Map.lookup wid ws of
                     Nothing  -> (Nothing, pure Nothing)
-                    Just cps -> case findNearestPoint cps requestedPoint of
+                    Just wal -> case findNearestPoint wal requestedPoint of
                         Nothing ->
                             ( Nothing
                             , throwIO $ ErrNoOlderCheckpoint wid requestedPoint
                             )
                         Just nearestPoint ->
-                            ( Just $ Adjust wid $ RollbackTo nearestPoint
-                            , pure $ Map.lookup nearestPoint $ cps ^. #checkpoints
+                            ( Just $ Adjust wid
+                                [ UpdateCheckpoints $ RollbackTo nearestPoint ]
+                            , pure $ Map.lookup nearestPoint $
+                                wal ^. #checkpoints ^. #checkpoints
                             )
             mNearestCheckpoint <- liftIO iomNearestCheckpoint
 
             case mNearestCheckpoint of
-                Nothing -> pure $ Left $ ErrNoSuchWallet wid
-                Just cp -> do
-                    let nearestPoint = cp ^. #currentTip ^. #slotNo
+                Nothing  -> pure $ Left $ ErrNoSuchWallet wid
+                Just wcp -> do
+                    let nearestPoint = wcp ^. #currentTip ^. #slotNo
                     deleteDelegationCertificates wid
                         [ CertSlot >. nearestPoint
                         ]
@@ -676,7 +685,7 @@ newDBLayerWith _cacheBehavior tr ti SqliteContext{runQuery} = do
                         ]
                     pure $ Right
                         $ W.chainPointFromBlockHeader
-                        $ view #currentTip cp
+                        $ view #currentTip wcp
 
         , prune = \wid epochStability -> ExceptT $ do
             selectLatestCheckpointCached wid >>= \case
@@ -1566,7 +1575,7 @@ data ErrRollbackTo = ErrNoOlderCheckpoint W.WalletId W.Slot deriving (Show)
 instance Exception ErrRollbackTo
 
 -- | Can't initialize a wallet because the given 'BlockHeader' is not genesis.
-data ErrInitializeNotGenesis
-    = ErrInitializeNotGenesis W.WalletId W.BlockHeader deriving (Eq, Show)
+data ErrInitializeGenesisAbsent
+    = ErrInitializeGenesisAbsent W.WalletId W.BlockHeader deriving (Eq, Show)
 
-instance Exception ErrInitializeNotGenesis
+instance Exception ErrInitializeGenesisAbsent

lib/core/src/Cardano/Wallet/DB/Sqlite/AddressBook.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}
@@ -30,6 +31,8 @@ import Cardano.Wallet.Primitive.AddressDerivation
     , KeyFingerprint (..)
     , Role (..)
     )
+import Cardano.Wallet.Primitive.AddressDerivation.Shared
+    ()
 import Cardano.Wallet.Primitive.AddressDerivation.SharedKey
     ( SharedKey (..) )
 import Cardano.Wallet.Primitive.Types.Address
@@ -42,6 +45,8 @@ import Data.Map.Strict
     ( Map )
 import Data.Type.Equality
     ( type (==) )
+import Fmt
+    ( Buildable (..) )
 
 import qualified Cardano.Wallet.Address.Pool as AddressPool
 import qualified Cardano.Wallet.Primitive.AddressDiscovery.Random as Rnd
@@ -123,6 +128,12 @@ loadUnsafe
 loadUnsafe (Seq.SeqAddressPool pool0) (SeqAddressMap addrs) =
     Seq.SeqAddressPool $ AddressPool.loadUnsafe pool0 addrs
 
+instance Buildable (Prologue (Seq.SeqState n k)) where
+    build (SeqPrologue st) = "Prologue of " <> build st
+
+instance Eq (Seq.SeqState n k) => Eq (Prologue (Seq.SeqState n k)) where
+    SeqPrologue a == SeqPrologue b = a == b
+
 {-------------------------------------------------------------------------------
     Shared key address book
 -------------------------------------------------------------------------------}
@@ -155,6 +166,14 @@ instance ( key ~ SharedKey ) => AddressBookIso (Shared.SharedState n key)
                 let pool = AddressPool.loadUnsafe pool0 addrs
                 in  st{ Shared.ready = Shared.Active pool }
 
+instance ( key ~ SharedKey )
+    => Buildable (Prologue (Shared.SharedState n key))
+  where
+    build (SharedPrologue st) = "Prologue of " <> build st
+
+instance ( key ~ SharedKey ) => Eq (Prologue (Shared.SharedState n key)) where
+    SharedPrologue a == SharedPrologue b = a == b
+
 {-------------------------------------------------------------------------------
     HD Random address book
 -------------------------------------------------------------------------------}
@@ -183,3 +202,9 @@ instance AddressBookIso (Rnd.RndState n) where
             = (RndPrologue (Rnd.RndState a b Map.empty c d), RndDiscoveries addrs)
         to (RndPrologue (Rnd.RndState a b _ c d), RndDiscoveries addrs)
             = Rnd.RndState a b addrs c d
+
+instance Buildable (Prologue (Rnd.RndState n)) where
+    build (RndPrologue st) = "Prologue of " <> build st
+
+instance Eq (Prologue (Rnd.RndState n)) where
+    RndPrologue a == RndPrologue b = a == b