wip: add CmdOldWalletToggleFirstKey

lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Delegation.hs

@@ -22,6 +22,10 @@ module Cardano.Wallet.Primitive.AddressDiscovery.Delegation
     , activeKeys
     , isOurStakeKey
 
+    -- * For Testing
+    , keyAtIx
+    , lastActiveIx
+
       -- * Chain following model
     , Tx (..)
     , Cert (..)
@@ -50,8 +54,6 @@ import Cardano.Wallet.Primitive.AddressDerivation
     )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..) )
-import Cardano.Wallet.Primitive.Types.Hash
-    ( Hash (..) )
 import Cardano.Wallet.Primitive.Types.RewardAccount
     ( RewardAccount )
 import Cardano.Wallet.Primitive.Types.Tx
@@ -194,9 +196,10 @@ data Cert
 setPortfolioOf
     :: (SoftDerivation k, ToRewardAccount k)
     => DelegationState k
+    -> (RewardAccount -> Bool) -- TODO: Need a Set or Map for the real implementation with LSQ
     -> Int
     -> Maybe Tx
-setPortfolioOf s n =
+setPortfolioOf s isReg n =
     let s' = s { nextKeyIx = toEnum n }
         mkTxIn (PointerUTxO i c _) = (i, c)
         pointerIn = maybe [] (\x -> [x]) (mkTxIn <$> pointer s)
@@ -205,7 +208,7 @@ setPortfolioOf s n =
     in
         case compare (toEnum n) (nextKeyIx s) of
             GT -> Just $ Tx
-                { certs = regAndDeleg [nextKeyIx s .. toEnum (n - 1)]
+                { certs = deleg [nextKeyIx s .. toEnum (n - 1)]
                 , inputs = pointerIn
                 , outputs = pointerOut
                 }
@@ -216,7 +219,11 @@ setPortfolioOf s n =
                 , outputs = pointerOut
                 }
   where
-    regAndDeleg = (>>= \ix -> [RegisterKey (acct ix), Delegate (acct ix)])
+    deleg = (>>= \ix ->
+        if isReg (acct ix)
+        then [Delegate (acct ix)]
+        else [RegisterKey (acct ix),  Delegate (acct ix)]
+        )
     dereg = map $ \ix -> DeRegisterKey (acct ix)
     acct = toRewardAccount . keyAtIx s
 

lib/core/test/unit/Cardano/Wallet/Primitive/AddressDiscovery/DelegationSpec.hs

@@ -37,6 +37,8 @@ import Crypto.Hash.Utils
     ( blake2b224 )
 import Data.Either
     ( isRight )
+import Data.Maybe
+    ( isNothing )
 import Data.Set
     ( Set )
 import GHC.Generics
@@ -123,13 +125,13 @@ spec = do
             pendingWith "think through"
 
     it "(presentableKeys s) are consequtive" $ property $ \cmds -> do
-        let (s, _chain) = applyCmds cmds
+        let ((s, _ledger), _chain) = applyCmds cmds
         let keys = map fromEnum $ usableKeys s
-        counterexample ("Keys: " <> show keys)
-            $ isConsecutiveRange keys
+        --counterexample ("Keys: " <> show keys)
+        isConsecutiveRange keys
     it "adversaries can't affect usableKeys" $ property $ \cmds -> do
         counterexample "\nstate /= state without adversarial cmds" $ do
-            let usableKeys' = usableKeys . fst . applyCmds
+            let usableKeys' = usableKeys . fst . fst . applyCmds
             usableKeys' cmds
                 === usableKeys' (filter (not . isAdversarial) cmds)
     it "chainFromCmds (cmdsFromChain (chainFromCmds cmds)) == chainFromCmds cmds"
@@ -138,7 +140,7 @@ spec = do
                 === chainFromCmds (filter (not . isAdversarial) cmds)
     it "(apply (cmds <> CmdSetPortfolioOf 0) s0) === s0"
         $ property $ \cmds -> do
-            let (s, _chain) = applyCmds (cmds ++ [CmdSetPortfolioOf 0])
+            let ((s, _ledger), _chain) = applyCmds (cmds ++ [CmdSetPortfolioOf 0])
             -- NOTE: It wouldn't be wrong to allow presentableKeys to show keys
             -- registered but not delegating. But we don't really expect such
             -- cases to happen, so there's no need.
@@ -251,6 +253,15 @@ instance Arbitrary (StakeKey' depth key) where
 
 data Cmd
     = CmdSetPortfolioOf Int
+    | CmdOldWalletToggleFirstKey
+      -- ^ A wallet implementation without multi-stake-key support could decide
+      -- to either
+      -- 1. register stake-key 0 witout adding a pointer UTxO
+      -- 2. de-register stake-key 0 despite despite e.g. key 1 being active
+      -- depending on whether it is registered or not.
+      --
+      -- Having a "toggle"-command instead of two separate commands, makes
+      -- generating valid arbitrary values easier.
     | CmdAdversarialReg RewardAccount
       -- ^ Someone could pay 2 ada to (re-)register your stake key. Your wallet
       -- shouldn't be affected negatively from it.
@@ -259,10 +270,12 @@ data Cmd
 isAdversarial :: Cmd -> Bool
 isAdversarial (CmdSetPortfolioOf _) = False
 isAdversarial (CmdAdversarialReg _) = True
+isAdversarial CmdOldWalletToggleFirstKey = False
 
 instance Show Cmd where
     show (CmdSetPortfolioOf n) = "CmdSetPortfolioOf " <> show n
     show (CmdAdversarialReg (RewardAccount a)) = "CmdAdversarialReg " <> B8.unpack a
+    show CmdOldWalletToggleFirstKey = "CmdOldWalletToggleFirstKey"
 
 instance Arbitrary Cmd where
     -- We don't want to generate too many adversarial registrations (we don't
@@ -271,6 +284,7 @@ instance Arbitrary Cmd where
     arbitrary = frequency
         [ (98, CmdSetPortfolioOf . getNonNegative <$> arbitrary)
         , (0, CmdAdversarialReg <$> arbitrary) -- TODO: Re-enable
+        , (2, pure CmdOldWalletToggleFirstKey)
         ]
     shrink = genericShrink
 
@@ -282,15 +296,26 @@ cmdsFromChain =
 chainFromCmds :: [Cmd] -> [Tx]
 chainFromCmds = snd . applyCmds
 
-applyCmds :: [Cmd] -> (DelegationState StakeKey', [Tx])
-applyCmds = second reverse . foldl step (s0, [])
+applyCmds :: [Cmd] -> ((DelegationState StakeKey', Ledger), [Tx])
+applyCmds = second reverse . foldl step ((s0, initialLedger), [])
   where
-    step (s, accTxs) (CmdSetPortfolioOf n) = case setPortfolioOf s n of
-        Just tx -> (applyTx tx s, tx:accTxs)
-        Nothing -> (s, accTxs)
-    step (s, accTxs) (CmdAdversarialReg k) = (s, (Tx [RegisterKey k] [] []):accTxs)
+    -- TODO: Would be nice to have some abstraction to remove the boilerplate
+    -- here. Maybe StateT or some Foldable thing.
+    step ((s, l), accTxs) (CmdSetPortfolioOf n) = case setPortfolioOf s (acctIsReg l) n of
+        Just tx -> ((applyTx tx s, applyLedger' tx l), tx:accTxs)
+        Nothing -> ((s, l), accTxs)
+    step ((s,l), accTxs) (CmdAdversarialReg k) =
+        let tx = Tx [RegisterKey k] [] []
+        in ((s,applyLedger' tx l), tx:accTxs)
+    step ((s, Ledger l), accTxs) CmdOldWalletToggleFirstKey =
+            let
+                key0 = toRewardAccount (keyAtIx s minBound)
+                isReg =  key0 `Set.member` l
+                tx = Tx [if isReg then DeRegisterKey key0 else RegisterKey key0] [] []
+            in ((applyTx tx s, applyLedger' tx (Ledger l)), tx:accTxs)
 
     s0 = initialDelegationState accK
+    applyLedger' tx l = either (error . show) id $ applyLedger [tx] l
 
 --
 -- Mock ledger
@@ -301,6 +326,9 @@ newtype Ledger = Ledger (Set RewardAccount)
 initialLedger :: Ledger
 initialLedger = Ledger Set.empty
 
+acctIsReg :: Ledger -> RewardAccount -> Bool
+acctIsReg (Ledger l) a = a `Set.member` l
+
 ledgerApplyCert :: Cert -> Ledger -> Either String Ledger
 ledgerApplyCert (Delegate k) (Ledger l)
     | k `Set.member` l