Move delegation certificate declaration in a separate table

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

@@ -34,6 +34,7 @@ import Cardano.Wallet.Primitive.Model
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader
     , Hash
+    , PoolId
     , Range (..)
     , SlotId (..)
     , SortOrder (..)
@@ -126,6 +127,21 @@ data DBLayer m s k = DBLayer
         --
         -- Return 'Nothing' if there's no such wallet.
 
+    , putDelegationCertificate
+        :: PrimaryKey WalletId
+        -> PoolId
+        -> SlotId
+        -> ExceptT ErrNoSuchWallet m ()
+        -- ^ Binds a stake pool id to a wallet. This will have an influence on
+        -- the wallet metadata: the last known certificate will indicate to
+        -- which pool a wallet is currently delegating to.
+        --
+        -- This is done separately from 'putWalletMeta' because certificate
+        -- declaration are:
+        --
+        -- 1. Stored on-chain
+        -- 2. Affected by rollbacks (or said differently, tight to a 'SlotId')
+
     , putTxHistory
         :: PrimaryKey WalletId
         -> [(Tx, TxMeta)]
@@ -148,6 +164,12 @@ data DBLayer m s k = DBLayer
         --
         -- Returns an empty list if the wallet isn't found.
 
+    , removePendingTx
+        :: PrimaryKey WalletId
+        -> Hash "Tx"
+        -> ExceptT ErrRemovePendingTx m ()
+        -- ^ Remove a pending transaction.
+
     , putPrivateKey
         :: PrimaryKey WalletId
         -> (k 'RootK XPrv, Hash "encryption")
@@ -174,12 +196,6 @@ data DBLayer m s k = DBLayer
         -> ExceptT ErrNoSuchWallet m ()
         -- ^ Prune database entities and remove entities that can be discarded.
 
-    , removePendingTx
-        :: PrimaryKey WalletId
-        -> Hash "Tx"
-        -> ExceptT ErrRemovePendingTx m ()
-        -- ^ Remove a pending transaction.
-
     , withLock
         :: forall e a. ()
         => ExceptT e m a

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

@@ -33,6 +33,7 @@ import Cardano.Wallet.DB.Model
     , mListCheckpoints
     , mListWallets
     , mPutCheckpoint
+    , mPutDelegationCertificate
     , mPutPrivateKey
     , mPutTxHistory
     , mPutWalletMeta
@@ -104,6 +105,10 @@ newDBLayer = do
 
         , readWalletMeta = readDB db . mReadWalletMeta
 
+        , putDelegationCertificate = \pk pid sl -> ExceptT $ do
+            pid `deepseq` sl `deepseq`
+                alterDB errNoSuchWallet db (mPutDelegationCertificate pk pid sl)
+
         {-----------------------------------------------------------------------
                                      Tx History
         -----------------------------------------------------------------------}

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

@@ -51,6 +51,7 @@ module Cardano.Wallet.DB.Model
     , mRollbackTo
     , mPutWalletMeta
     , mReadWalletMeta
+    , mPutDelegationCertificate
     , mPutTxHistory
     , mReadTxHistory
     , mPutPrivateKey
@@ -66,13 +67,15 @@ import Cardano.Wallet.Primitive.Types
     ( BlockHeader (slotId)
     , Direction (..)
     , Hash
+    , PoolId (..)
     , Range (..)
     , SlotId (..)
     , SortOrder (..)
     , Tx (..)
     , TxMeta (..)
     , TxStatus (..)
-    , WalletMetadata
+    , WalletDelegation (..)
+    , WalletMetadata (..)
     , isWithinRange
     )
 import Control.Monad
@@ -115,6 +118,7 @@ deriving instance (Eq wid, Eq xprv, Eq s) => Eq (Database wid s xprv)
 -- | Model database record for a single wallet.
 data WalletDatabase s xprv = WalletDatabase
     { checkpoints :: !(Map SlotId (Wallet s))
+    , certificates :: !(Map SlotId PoolId)
     , metadata :: !WalletMetadata
     , txHistory :: !(Map (Hash "Tx") TxMeta)
     , xprv :: !(Maybe xprv)
@@ -173,7 +177,13 @@ mCreateWallet wid cp meta txs0 db@Database{wallets,txs}
     | wid `Map.member` wallets = (Left (WalletAlreadyExists wid), db)
     | otherwise =
         let
-            wal = WalletDatabase (Map.singleton (tip cp) cp) meta history Nothing
+            wal = WalletDatabase
+                { checkpoints = Map.singleton (tip cp) cp
+                , certificates = mempty
+                , metadata = meta
+                , txHistory = history
+                , xprv = Nothing
+                }
             txs' = Map.fromList $ (\(tx, _) -> (txId tx, tx)) <$> txs0
             history = Map.fromList $ first txId <$> txs0
         in
@@ -235,6 +245,8 @@ mRollbackTo wid point db@(Database wallets txs) = case Map.lookup wid wallets of
                     wal' = wal
                         { checkpoints =
                             Map.filter ((<= point) . tip) (checkpoints wal)
+                        , certificates =
+                            Map.filterWithKey (\k _ -> k <= point) (certificates wal)
                         , txHistory =
                             Map.mapMaybe (rescheduleOrForget nearest) (txHistory wal)
                         }
@@ -271,7 +283,24 @@ mPutWalletMeta wid meta = alterModel wid $ \wal ->
 
 mReadWalletMeta :: Ord wid => wid -> ModelOp wid s xprv (Maybe WalletMetadata)
 mReadWalletMeta wid db@(Database wallets _) =
-    (Right (metadata <$> Map.lookup wid wallets), db)
+    (Right (mkMetadata <$> Map.lookup wid wallets), db)
+  where
+    mkMetadata :: WalletDatabase s xprv -> WalletMetadata
+    mkMetadata WalletDatabase{certificates,metadata} =
+        case Map.lookupMax certificates of
+            Nothing ->
+                metadata { delegation = NotDelegating }
+            Just (_, pool) ->
+                metadata { delegation = Delegating pool }
+
+mPutDelegationCertificate
+    :: Ord wid
+    => wid
+    -> PoolId
+    -> SlotId
+    -> ModelOp wid s xprv ()
+mPutDelegationCertificate wid pool slot = alterModel wid $ \wal ->
+    ((), wal { certificates = Map.insert slot pool (certificates wal) })
 
 mPutTxHistory
     :: forall wid s xprv. Ord wid

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

@@ -55,6 +55,7 @@ import Cardano.Wallet.DB
     )
 import Cardano.Wallet.DB.Sqlite.TH
     ( Checkpoint (..)
+    , DelegationCertificate (..)
     , EntityField (..)
     , Key (..)
     , PrivateKey (..)
@@ -359,6 +360,9 @@ newDBLayer logConfig trace mDatabaseFile = do
                     deleteCheckpoints wid
                         [ CheckpointSlot >. point
                         ]
+                    deleteDelegationCertificates wid
+                        [ CertSlot >. point
+                        ]
                     updateTxMetas wid
                         [ TxMetaDirection ==. W.Outgoing
                         , TxMetaSlot >. point
@@ -391,10 +395,18 @@ newDBLayer logConfig trace mDatabaseFile = do
                       pure $ Right ()
                   Nothing -> pure $ Left $ ErrNoSuchWallet wid
 
-        , readWalletMeta = \(PrimaryKey wid) ->
-              runQuery $
-              fmap (metadataFromEntity . entityVal) <$>
-              selectFirst [WalId ==. wid] []
+        , readWalletMeta = \(PrimaryKey wid) -> runQuery $ do
+            walDelegation <- delegationFromEntity . fmap entityVal
+                <$> selectFirst [CertWalletId ==. wid] [Desc CertSlot]
+
+            fmap (metadataFromEntity walDelegation . entityVal)
+                <$> selectFirst [WalId ==. wid] []
+
+        , putDelegationCertificate = \pk pool sl -> ExceptT $ runQuery $ do
+            let (PrimaryKey wid) = pk
+            selectWallet wid >>= \case
+                Nothing -> pure $ Left $ ErrNoSuchWallet wid
+                Just _  -> pure <$> insert_ (DelegationCertificate wid sl pool)
 
         {-----------------------------------------------------------------------
                                      Tx History
@@ -466,13 +478,14 @@ newDBLayer logConfig trace mDatabaseFile = do
               ExceptT $ withMVar lock $ \() -> runExceptT action
         })
 
-delegationToPoolId :: W.WalletDelegation W.PoolId -> Maybe W.PoolId
-delegationToPoolId W.NotDelegating = Nothing
-delegationToPoolId (W.Delegating pool) = Just pool
-
-delegationFromPoolId :: Maybe W.PoolId -> W.WalletDelegation W.PoolId
-delegationFromPoolId Nothing = W.NotDelegating
-delegationFromPoolId (Just pool) = W.Delegating pool
+delegationFromEntity
+    :: Maybe DelegationCertificate
+    -> W.WalletDelegation W.PoolId
+delegationFromEntity = \case
+    Nothing ->
+        W.NotDelegating
+    Just (DelegationCertificate _ _ pool) ->
+        W.Delegating pool
 
 mkWalletEntity :: W.WalletId -> W.WalletMetadata -> Wallet
 mkWalletEntity wid meta = Wallet
@@ -481,7 +494,6 @@ mkWalletEntity wid meta = Wallet
     , walCreationTime = meta ^. #creationTime
     , walPassphraseLastUpdatedAt =
         W.lastUpdatedAt <$> meta ^. #passphraseInfo
-    , walDelegation = delegationToPoolId $ meta ^. #delegation
     }
 
 mkWalletMetadataUpdate :: W.WalletMetadata -> [Update Wallet]
@@ -490,7 +502,6 @@ mkWalletMetadataUpdate meta =
     , WalCreationTime =. meta ^. #creationTime
     , WalPassphraseLastUpdatedAt =.
         W.lastUpdatedAt <$> meta ^. #passphraseInfo
-    , WalDelegation =. delegationToPoolId (meta ^. #delegation)
     ]
 
 blockHeaderFromEntity :: Checkpoint -> W.BlockHeader
@@ -501,13 +512,13 @@ blockHeaderFromEntity cp = W.BlockHeader
     , parentHeaderHash = getBlockId (checkpointParentHash cp)
     }
 
-metadataFromEntity :: Wallet -> W.WalletMetadata
-metadataFromEntity wal = W.WalletMetadata
+metadataFromEntity :: W.WalletDelegation W.PoolId -> Wallet -> W.WalletMetadata
+metadataFromEntity walDelegation wal = W.WalletMetadata
     { name = W.WalletName (walName wal)
     , creationTime = walCreationTime wal
     , passphraseInfo = W.WalletPassphraseInfo <$>
         walPassphraseLastUpdatedAt wal
-    , delegation = delegationFromPoolId (walDelegation wal)
+    , delegation = walDelegation
     }
 
 mkPrivateKeyEntity
@@ -781,6 +792,14 @@ deleteLooseTransactions = do
             "LEFT OUTER JOIN tx_meta ON tx_meta.tx_id = "<> t <>".tx_id " <>
             "WHERE (tx_meta.tx_id IS NULL))"
 
+-- | Delete all delegation certificates matching the given filter
+deleteDelegationCertificates
+    :: W.WalletId
+    -> [Filter DelegationCertificate]
+    -> SqlPersistT IO ()
+deleteDelegationCertificates wid filters = do
+    deleteCascadeWhere ((CertWalletId ==. wid) : filters)
+
 selectLatestCheckpoint
     :: W.WalletId
     -> SqlPersistT IO (Maybe Checkpoint)

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

@@ -57,11 +57,10 @@ share
 
 -- Wallet IDs, address discovery state, and metadata.
 Wallet
-    walId                 W.WalletId     sql=wallet_id
-    walCreationTime       UTCTime        sql=creation_time
-    walName               Text           sql=name
+    walId                       W.WalletId     sql=wallet_id
+    walCreationTime             UTCTime        sql=creation_time
+    walName                     Text           sql=name
     walPassphraseLastUpdatedAt  UTCTime Maybe  sql=passphrase_last_updated_at
-    walDelegation         W.PoolId Maybe sql=delegation
 
     Primary walId
     deriving Show Generic
@@ -143,6 +142,16 @@ Checkpoint
     Foreign Wallet checkpoint checkpointWalletId ! ON DELETE CASCADE
     deriving Show Generic
 
+-- Store known delegation certificates for a particular wallet
+DelegationCertificate
+    certWalletId             W.WalletId   sql=wallet_id
+    certSlot                 W.SlotId     sql=slot
+    certPoolId               W.PoolId     sql=delegation
+
+    Primary certWalletId certSlot certPoolId
+    Foreign Wallet delegationCertificate certWalletId ! ON DELETE CASCADE
+    deriving Show Generic
+
 -- The UTxO for a given wallet checkpoint is a one-to-one mapping from TxIn ->
 -- TxOut. This table does not need to refer to the TxIn or TxOut tables. All
 -- necessary information for the UTxO is in this table.

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

@@ -394,6 +394,12 @@ instance PathPiece PoolId where
     fromPathPiece = fromTextMaybe
     toPathPiece = toText
 
+instance ToJSON PoolId where
+    toJSON = String . toText
+
+instance FromJSON PoolId where
+    parseJSON = aesonFromText "PoolId"
+
 ----------------------------------------------------------------------------
 -- HDPassphrase
 

lib/core/test/unit/Cardano/Wallet/DB/Arbitrary.hs

@@ -73,6 +73,7 @@ import Cardano.Wallet.Primitive.Types
     , EpochLength (..)
     , EpochNo (..)
     , Hash (..)
+    , PoolId (..)
     , ShowFmt (..)
     , SlotId (..)
     , SlotNo (..)
@@ -506,7 +507,11 @@ instance Eq XPrv where
 
 instance Arbitrary (Hash purpose) where
     arbitrary = do
-        Hash . convertToBase Base16 . BS.pack <$> vectorOf 32 arbitrary
+        Hash . convertToBase Base16 . BS.pack <$> vectorOf 16 arbitrary
+
+instance Arbitrary PoolId where
+    arbitrary = do
+        PoolId . convertToBase Base16 . BS.pack <$> vectorOf 16 arbitrary
 
 {-------------------------------------------------------------------------------
                                    Buildable