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

@@ -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

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

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
         -----------------------------------------------------------------------}

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]

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

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.

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