From 19a1064df834ff420e45a9cd36bc665a9bd482ec Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Fri, 3 Jul 2020 20:11:51 +0200 Subject: [PATCH] Track stake key registrations independently from delegation To delegate in shelley we need to know whether we need to register the stake key, or if it already exists. Trying to register the same key twice will cause the delegation to fail. In shelley there are three delegation certs: - reg - dereg - delegate We need to keep track of two things: - Delegation status - Is the stake key registered or not? (new in this commit) Also new in this commit: - Stake key de-registration inserts an uptdate to the delegation status table that says that it is not delegating. --- lib/core/src/Cardano/Wallet.hs | 38 ++++++++++------- lib/core/src/Cardano/Wallet/DB.hs | 4 ++ lib/core/src/Cardano/Wallet/DB/MVar.hs | 2 + lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 42 +++++++++++++++++-- lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs | 10 +++++ .../src/Cardano/Wallet/Primitive/Types.hs | 4 ++ .../Cardano/Wallet/Shelley/Compatibility.hs | 3 +- 7 files changed, 83 insertions(+), 20 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 67787da297a..c81743069d3 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -1245,11 +1245,11 @@ estimateFeeForDelegation ctx wid = db & \DBLayer{..} -> do (utxo, txp) <- withExceptT ErrSelectForDelegationNoSuchWallet $ selectCoinsSetup @ctx @s @k ctx wid - walMeta <- mapExceptT atomically + isKeyReg <- mapExceptT atomically $ withExceptT ErrSelectForDelegationNoSuchWallet - $ withNoSuchWallet wid $ readWalletMeta (PrimaryKey wid) + $ readIsStakeKeyRegistered (PrimaryKey wid) - let action = nextJoinAction pid walMeta + let action = if isKeyReg then Join pid else RegisterKeyAndJoin pid let selectCoins = selectCoinsForDelegationFromUTxO @_ @t @k ctx utxo txp action estimateFeeForCoinSelection $ Fee . feeBalance <$> selectCoins where @@ -1712,13 +1712,17 @@ joinStakePool -> Passphrase "raw" -> ExceptT ErrJoinStakePool IO (Tx, TxMeta, UTCTime) joinStakePool ctx wid (pid, pools) argGenChange pwd = db & \DBLayer{..} -> do - walMeta <- mapExceptT atomically $ withExceptT ErrJoinStakePoolNoSuchWallet $ - withNoSuchWallet wid $ readWalletMeta (PrimaryKey wid) + (isKeyReg, walMeta) <- mapExceptT atomically $ withExceptT ErrJoinStakePoolNoSuchWallet $ + (,) + <$> readIsStakeKeyRegistered (PrimaryKey wid) + <*> withNoSuchWallet wid (readWalletMeta (PrimaryKey wid)) withExceptT ErrJoinStakePoolCannotJoin $ except $ guardJoin pools (walMeta ^. #delegation) pid - let action = nextJoinAction pid walMeta + let action = if isKeyReg then Join pid else RegisterKeyAndJoin pid + liftIO $ traceWith tr $ MsgIsStakeKeyRegistered isKeyReg + selection <- withExceptT ErrJoinStakePoolSelectCoin $ selectCoinsForDelegation @ctx @s @t @k ctx wid action @@ -1731,6 +1735,7 @@ joinStakePool ctx wid (pid, pools) argGenChange pwd = db & \DBLayer{..} -> do pure (tx, txMeta, txTime) where db = ctx ^. dbLayer @s @k + tr = ctx ^. logger -- | Helper function to factor necessary logic for quitting a stake pool. quitStakePool @@ -1772,16 +1777,6 @@ quitStakePool ctx wid argGenChange pwd = db & \DBLayer{..} -> do where db = ctx ^. dbLayer @s @k -nextJoinAction - :: PoolId - -> WalletMetadata - -> DelegationAction -nextJoinAction pid meta = case (delegation meta) of - (WalletDelegation NotDelegating []) -> - RegisterKeyAndJoin pid - _ -> - Join pid - {------------------------------------------------------------------------------- Fee Estimation @@ -2163,6 +2158,7 @@ data WalletLog | MsgTip BlockHeader | MsgBlocks (NonEmpty Block) | MsgDelegationCoinSelection CoinSelection + | MsgIsStakeKeyRegistered Bool | MsgPaymentCoinSelectionStart W.UTxO W.TxParameters (NonEmpty TxOut) | MsgPaymentCoinSelection CoinSelection | MsgPaymentCoinSelectionAdjusted CoinSelection @@ -2191,6 +2187,11 @@ instance ToText WalletLog where , " within slot " , pretty slotId ] + CertRegisterKey {} -> mconcat + [ "Discovered stake key registration " + , " within slot " + , pretty slotId + ] MsgCheckpoint checkpointTip -> "Creating checkpoint at " <> pretty checkpointTip MsgWalletMetadata meta -> @@ -2207,6 +2208,10 @@ instance ToText WalletLog where "blocks: " <> pretty (NE.toList blocks) MsgDelegationCoinSelection sel -> "Coins selected for delegation: \n" <> pretty sel + MsgIsStakeKeyRegistered True -> + "Wallet stake key is registered. Will not register it again." + MsgIsStakeKeyRegistered False -> + "Wallet stake key is not registered. Will register..." MsgPaymentCoinSelectionStart utxo _txp recipients -> "Starting coin selection " <> "|utxo| = "+|Map.size (getUTxO utxo)|+" " <> @@ -2246,6 +2251,7 @@ instance HasSeverityAnnotation WalletLog where MsgPaymentCoinSelectionStart{} -> Debug MsgPaymentCoinSelection _ -> Debug MsgPaymentCoinSelectionAdjusted _ -> Debug + MsgIsStakeKeyRegistered _ -> Info MsgRewardBalanceQuery _ -> Debug MsgRewardBalanceResult (Right _) -> Debug MsgRewardBalanceResult (Left _) -> Notice diff --git a/lib/core/src/Cardano/Wallet/DB.hs b/lib/core/src/Cardano/Wallet/DB.hs index c1b88515ef3..b790c995954 100644 --- a/lib/core/src/Cardano/Wallet/DB.hs +++ b/lib/core/src/Cardano/Wallet/DB.hs @@ -169,6 +169,10 @@ data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer -- -- Return 'Nothing' if there's no such wallet. + , readIsStakeKeyRegistered + :: PrimaryKey WalletId + -> ExceptT ErrNoSuchWallet stm Bool + , putDelegationCertificate :: PrimaryKey WalletId -> DelegationCertificate diff --git a/lib/core/src/Cardano/Wallet/DB/MVar.hs b/lib/core/src/Cardano/Wallet/DB/MVar.hs index b9aad9b7868..863a1102d79 100644 --- a/lib/core/src/Cardano/Wallet/DB/MVar.hs +++ b/lib/core/src/Cardano/Wallet/DB/MVar.hs @@ -118,6 +118,8 @@ newDBLayer = do cert `deepseq` sl `deepseq` alterDB errNoSuchWallet db (mPutDelegationCertificate pk cert sl) + , readIsStakeKeyRegistered = error "todo" + {----------------------------------------------------------------------- Tx History -----------------------------------------------------------------------} diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 5fabf737e1d..f8f13bae74c 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -77,6 +77,7 @@ import Cardano.Wallet.DB.Sqlite.TH , SeqState (..) , SeqStateAddress (..) , SeqStatePendingIx (..) + , StakeKeyCertificate (..) , TxIn (..) , TxMeta (..) , TxOut (..) @@ -573,6 +574,9 @@ newDBLayer trace defaultFieldValues mDatabaseFile = do [ TxMetaDirection ==. W.Incoming , TxMetaSlot >. nearestPoint ] + deleteStakeKeyCerts wid + [ StakeKeyCertSlot >. nearestPoint + ] pure (Right nearestPoint) , prune = \(PrimaryKey wid) -> ExceptT $ do @@ -604,9 +608,32 @@ newDBLayer trace defaultFieldValues mDatabaseFile = do , putDelegationCertificate = \(PrimaryKey wid) cert sl -> ExceptT $ do selectWallet wid >>= \case Nothing -> pure $ Left $ ErrNoSuchWallet wid - Just _ -> pure <$> repsert - (DelegationCertificateKey wid sl) - (DelegationCertificate wid sl (W.dlgCertPoolId cert)) + Just _ -> case cert of + W.CertDelegateNone _ -> do + repsert + (DelegationCertificateKey wid sl) + (DelegationCertificate wid sl Nothing) + pure <$> repsert + (StakeKeyCertificateKey wid sl) + (StakeKeyCertificate wid sl False) + W.CertDelegateFull _ pool -> + pure <$> repsert + (DelegationCertificateKey wid sl) + (DelegationCertificate wid sl (Just pool)) + W.CertRegisterKey _ -> + pure <$> repsert + (StakeKeyCertificateKey wid sl) + (StakeKeyCertificate wid sl True) + + , readIsStakeKeyRegistered = \(PrimaryKey wid) -> ExceptT $ do + val <- fmap entityVal <$> selectFirst + [StakeKeyCertWalletId ==. wid] + [Desc StakeKeyCertSlot] + + return $ case val of + Nothing -> Left $ ErrNoSuchWallet wid + Just (StakeKeyCertificate _ _ isReg) -> Right isReg + {----------------------------------------------------------------------- Tx History @@ -1068,6 +1095,15 @@ deleteTxMetas deleteTxMetas wid filters = deleteWhere ((TxMetaWalletId ==. wid) : filters) + +-- | Delete stake key certificates for a wallet. +deleteStakeKeyCerts + :: W.WalletId + -> [Filter StakeKeyCertificate] + -> SqlPersistT IO () +deleteStakeKeyCerts wid filters = + deleteWhere ((StakeKeyCertWalletId ==. wid) : filters) + updateTxMetas :: W.WalletId -> [Filter TxMeta] diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs index a2dea9d3834..641a698317b 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs @@ -156,6 +156,16 @@ ProtocolParameters Foreign Wallet fk_wallet_protocol_parameters protocolParametersWalletId ! ON DELETE CASCADE deriving Show Generic +-- Track whether the wallet's stake key is registered or not. +StakeKeyCertificate + stakeKeyCertWalletId W.WalletId sql=wallet_id + stakeKeyCertSlot W.SlotId sql=slot + stakeKeyCertIsReg Bool sql=is_reg + + Primary stakeKeyCertWalletId stakeKeyCertSlot + Foreign Wallet stakeKeyRegistration stakeKeyCertWalletId ! ON DELETE CASCADE + deriving Show Generic + -- Store known delegation certificates for a particular wallet DelegationCertificate certWalletId W.WalletId sql=wallet_id diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index 4cb3c503b31..14063df920c 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -1844,6 +1844,7 @@ instance NFData ChimericAccount data DelegationCertificate = CertDelegateNone ChimericAccount | CertDelegateFull ChimericAccount PoolId + | CertRegisterKey ChimericAccount deriving (Generic, Show, Eq, Ord) instance NFData DelegationCertificate @@ -1852,11 +1853,14 @@ dlgCertAccount :: DelegationCertificate -> ChimericAccount dlgCertAccount = \case CertDelegateNone acc -> acc CertDelegateFull acc _ -> acc + CertRegisterKey acc -> acc dlgCertPoolId :: DelegationCertificate -> Maybe PoolId dlgCertPoolId = \case CertDelegateNone{} -> Nothing CertDelegateFull _ poolId -> Just poolId + CertRegisterKey _ -> Nothing + -- | Sum-type of pool registration- and retirement- certificates. Mirrors the -- @PoolCert@ type in cardano-ledger-specs. diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 3f7e25895d2..ed982823ff9 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -676,7 +676,8 @@ fromShelleyDelegationCert = \case SL.DCertDeleg (SL.DeRegKey credentials) -> Just $ W.CertDelegateNone (fromStakeCredential credentials) - SL.DCertDeleg SL.RegKey{} -> Nothing + SL.DCertDeleg (SL.RegKey cred) -> + Just $ W.CertRegisterKey $ fromStakeCredential cred SL.DCertPool{} -> Nothing SL.DCertGenesis{} -> Nothing SL.DCertMir{} -> Nothing