Merge #1851

1851: Track stake key registrations independently from delegation r=KtorZ a=Anviking

# Issue Number

#1835 


# Overview


- [x] Keep track of stake key registrations such that we don't try to register a key twice
- [ ] TODO: model impl
- There was a integration test, which I saw passing at some point, but I've not rebased it to this PR
- Some DB model-like tests would have been nice, but no time now

# Comments

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.

<!-- 
Don't forget to:

 ✓ Self-review your changes to make sure nothing unexpected slipped through
 ✓ Assign yourself to the PR
 ✓ Assign one or several reviewer(s)
 ✓ Once created, link this PR to its corresponding ticket
 ✓ Assign the PR to a corresponding milestone
 ✓ Acknowledge any changes required to the Wiki
-->


Co-authored-by: Johannes Lund <johannes.lund@iohk.io>
Co-authored-by: KtorZ <matthias.benkort@gmail.com>

lib/byron/cardano-wallet-byron.cabal

@@ -133,18 +133,14 @@ test-suite unit
     , cardano-crypto-wrapper
     , cardano-wallet-byron
     , cardano-wallet-core
-    , cardano-wallet-test-utils
     , cborg
     , containers
     , fmt
-    , generic-lens
     , hspec
-    , iohk-monitoring
     , memory
     , ouroboros-consensus-byron
     , ouroboros-network
     , QuickCheck
-    , retry
     , text
     , transformers
   build-tools:
@@ -157,7 +153,6 @@ test-suite unit
       Main.hs
   other-modules:
       Cardano.Wallet.Byron.CompatibilitySpec
-      Cardano.Wallet.Byron.NetworkSpec
       Cardano.Wallet.Byron.TransactionSpec
 
 test-suite integration

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs

@@ -53,6 +53,8 @@ import Data.Quantity
     ( Quantity (..) )
 import Data.Set
     ( Set )
+import Data.Text
+    ( Text )
 import Data.Text.Class
     ( toText )
 import Numeric.Natural
@@ -369,6 +371,29 @@ spec = do
             , expectErrorMessage errMsg403NonNullReward
             ]
 
+    it "STAKE_POOLS_JOIN_05 - Can join when stake key already exists" $ \ctx -> do
+        let walletWithPreRegKey =
+                [ "over", "decorate", "flock", "badge", "beauty"
+                , "stamp" , "chest", "owner", "excess", "omit"
+                , "bid", "raccoon", "spin" , "reduce", "rival"
+                ] :: [Text]
+        let payload = Json [json| {
+                "name": "Wallet with pre-registered stake key",
+                "mnemonic_sentence": #{walletWithPreRegKey},
+                "passphrase": "Secure Passphrase"
+                } |]
+
+        (_, w) <- unsafeRequest @ApiWallet ctx (Link.postWallet @'Shelley) payload
+        pool:_ <- map (view #id) . snd
+            <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools arbitraryStake) Empty
+
+        eventually "wallet join a pool" $ do
+            joinStakePool @n ctx pool (w, passwd) >>= flip verify
+                [ expectResponseCode HTTP.status202
+                , expectField (#status . #getApiT) (`shouldBe` Pending)
+                , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
+                ]
+
     describe "STAKE_POOLS_JOIN_01x - Fee boundary values" $ do
         it "STAKE_POOLS_JOIN_01x - \
             \I can join if I have just the right amount" $ \ctx -> do

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)
+        $ isStakeKeyRegistered (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
+        $ (,) <$> isStakeKeyRegistered (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

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.
 
+    , isStakeKeyRegistered
+        :: PrimaryKey WalletId
+        -> ExceptT ErrNoSuchWallet stm Bool
+
     , putDelegationCertificate
         :: PrimaryKey WalletId
         -> DelegationCertificate

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

@@ -35,6 +35,7 @@ import Cardano.Wallet.DB.Model
     , emptyDatabase
     , mCheckWallet
     , mInitializeWallet
+    , mIsStakeKeyRegistered
     , mListCheckpoints
     , mListWallets
     , mPutCheckpoint
@@ -118,6 +119,9 @@ newDBLayer = do
             cert `deepseq` sl `deepseq`
                 alterDB errNoSuchWallet db (mPutDelegationCertificate pk cert sl)
 
+        , isStakeKeyRegistered =
+            ExceptT . alterDB errNoSuchWallet db . mIsStakeKeyRegistered
+
         {-----------------------------------------------------------------------
                                      Tx History
         -----------------------------------------------------------------------}

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

@@ -50,6 +50,7 @@ module Cardano.Wallet.DB.Model
     , mPutWalletMeta
     , mReadWalletMeta
     , mPutDelegationCertificate
+    , mIsStakeKeyRegistered
     , mPutTxHistory
     , mReadTxHistory
     , mRemovePendingTx
@@ -78,6 +79,7 @@ import Cardano.Wallet.Primitive.Types
     , Range (..)
     , SlotId (..)
     , SortOrder (..)
+    , StakeKeyCertificate (..)
     , TransactionInfo (..)
     , Tx (..)
     , TxMeta (..)
@@ -139,6 +141,7 @@ deriving instance (Eq wid, Eq xprv, Eq s) => Eq (Database wid s xprv)
 data WalletDatabase s xprv = WalletDatabase
     { checkpoints :: !(Map SlotId (Wallet s))
     , certificates :: !(Map SlotId (Maybe PoolId))
+    , stakeKeys :: !(Map SlotId StakeKeyCertificate)
     , metadata :: !WalletMetadata
     , txHistory :: !(Map (Hash "Tx") TxMeta)
     , xprv :: !(Maybe xprv)
@@ -202,6 +205,7 @@ mInitializeWallet wid cp meta txs0 pp db@Database{wallets,txs}
         let
             wal = WalletDatabase
                 { checkpoints = Map.singleton (tip cp) cp
+                , stakeKeys = mempty
                 , certificates = mempty
                 , metadata = meta
                 , txHistory = history
@@ -353,11 +357,25 @@ mPutDelegationCertificate
     -> DelegationCertificate
     -> SlotId
     -> ModelOp wid s xprv ()
-mPutDelegationCertificate wid cert slot = alterModel wid $ \wal ->
-    ( ()
+mPutDelegationCertificate wid cert slot = alterModel wid
+    $ \wal@WalletDatabase{certificates,stakeKeys} ->
+        ( ()
+        , wal
+            { certificates = Map.insert slot (dlgCertPoolId cert) certificates
+            , stakeKeys = case cert of
+                CertDelegateNone{} -> Map.insert slot StakeKeyDeregistration stakeKeys
+                CertDelegateFull{} -> stakeKeys
+                CertRegisterKey{}  -> Map.insert slot StakeKeyRegistration stakeKeys
+            }
+        )
+
+mIsStakeKeyRegistered
+    :: Ord wid
+    => wid
+    -> ModelOp wid s xprv Bool
+mIsStakeKeyRegistered wid = alterModel wid $ \wal@WalletDatabase{stakeKeys} ->
+    ( maybe False ((== StakeKeyRegistration) . snd) (Map.lookupMax stakeKeys)
     , wal
-        { certificates = Map.insert slot (dlgCertPoolId cert) (certificates wal)
-        }
     )
 
 mPutTxHistory