More properties

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

@@ -247,7 +247,7 @@ initialDelegationState
     :: (ToRewardAccount k, SoftDerivation k)
     => k 'AccountK XPub
     -> DelegationState k
-initialDelegationState = mkDelegationState 10 0 -- FIXME: improve impl
+initialDelegationState = mkDelegationState 100 0 -- FIXME! Must not be hard-coded
     -- FIXME: We're here hard-coding number of stake keys
 
 unsafeDeserializeDelegationState

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

@@ -40,6 +40,7 @@ import Test.QuickCheck.Arbitrary.Generic
 import Test.StateMachine
 
 import qualified Data.ByteString.Char8 as B8
+import qualified Data.Set as Set
 
 spec :: Spec
 spec = do
@@ -86,7 +87,8 @@ spec = do
             isDeRegistrable s2 (StakeKey' 1) `shouldBe` True
 
     let s3 = regAndDeleg 5 s2
-    describe "for some reason, there's a gap, and key 5 is reg and delegated" $ do
+    describe "Impossible gaps in stake keys (shouldn't happen unless\
+        \ someone manually constructs txs to mess with the on-chain state)" $ do
         it "presentableKeys == [0, 1, 2, 5]" $ do
             map ix (presentableKeys s3) `shouldBe`
                 [toEnum 0, toEnum 1, toEnum 2, toEnum 5]
@@ -115,31 +117,42 @@ spec = do
                 it "presentableKeys = [0]" $ do
                     counterexample ("s0 = " <> show s0)
                         $ map ix (presentableKeys s0) === [toEnum 0]
-            it "presentableKeys s0 are consequtive" $ do
-                let keys = map (fromEnum . ix) $ presentableKeys s0
-                counterexample ("Keys: " <> show keys)
-                    $ isConsecutiveRange keys
-
         describe "s = foldl chain s0" $ do
-            it "presentableKeys s are consequtive" $ property $ \cmds -> do
+            it "(presentableKeys s) are consequtive" $ property $ \cmds -> do
                 let chain = chainFromCmds cmds
                 let s = apply chain s0
-                let keys = map (fromEnum . ix) $ presentableKeys s
+                let keys = map fromEnum $ usableKeys s
                 counterexample ("Keys: " <> show keys)
                     $ isConsecutiveRange keys
             it "adversaries can't affect usableKeys" $ property $ \cmds'' -> do
                 let cmds = dropWhile (== (CmdSetPortfolioOf $ NonNegative 0)) cmds''
-                let s0 = initialDelegationState accK
                 counterexample "\nstate /= state without adversarial cmds" $
                     usableKeys (apply (chainFromCmds cmds) s0)
                     === usableKeys (apply (chainFromCmds $ filter (not . isAdversarial) cmds) s0)
-            it "cmdsFromChain (chainFromCmds cmds) == nonAdversarial cmds" $ property $ \cmds'' -> do
-                let cmds = dropWhile (== (CmdSetPortfolioOf $ NonNegative 0)) $ nub cmds''
-                let chain = chainFromCmds cmds
-                let cmds' = cmdsFromChain chain
-                counterexample ("chainFromCmds cmds = " <> show chain) $
-                    counterexample ("states:\n" <> show (map (activeKeys . snd) cmds') ) $
-                    (map fst cmds') === (filter (not . isAdversarial) cmds)
+            it "chainFromCmds (cmdsFromChain (chainFromCmds cmds)) == chainFromCmds cmds"
+                $ property $ \cmds -> do
+                    chainFromCmds (cmdsFromChain (chainFromCmds cmds))
+                        === chainFromCmds (filter (not . isAdversarial) cmds)
+            it "activeKeys (apply (cmds <> CmdSetPortfolioOf 0) s0) === activeKeys s0"
+                $ property $ \cmds -> do
+                    let chain = chainFromCmds (cmds ++ [CmdSetPortfolioOf $ NonNegative 0])
+                    let s = apply chain s0
+                    activeKeys s === activeKeys s0
+            it "usableKeys (apply (cmds <> CmdSetPortfolioOf 0) s0) === usableKeys s0"
+                $ property $ \cmds -> do
+                    let chain = chainFromCmds (cmds ++ [CmdSetPortfolioOf $ NonNegative 0])
+                    let s = apply chain s0
+                    usableKeys s === usableKeys s0
+            it "presentableKeys (apply (cmds <> CmdSetPortfolioOf 0) s0) ⊇ presentableKeys s0"
+                $ property $ \cmds -> do
+                    let chain = chainFromCmds (cmds ++ [CmdSetPortfolioOf $ NonNegative 0])
+                    let s = apply chain s0
+                    let presentableKeys' = Set.fromList . map ix . presentableKeys
+                    if any isAdversarial cmds
+                    then label "with adversarial commands (⊇)" $
+                        (presentableKeys' s0) `Set.isSubsetOf` (presentableKeys' s)
+                    else label "no adversarial commands (=)" $
+                        (presentableKeys' s0) === (presentableKeys' s)
 
 accK :: StakeKey' 'AccountK XPub
 accK = StakeKey' 0
@@ -148,7 +161,7 @@ apply :: [Tx] -> DelegationState StakeKey' -> DelegationState StakeKey'
 apply txs s = foldl (flip applyTx) s txs
 
 applyTx :: Tx -> DelegationState StakeKey' -> DelegationState StakeKey'
-applyTx (Tx certs) = execState (mapM (\c -> modify (applyCert c)) certs)
+applyTx (Tx certs) = execState (mapM (modify . applyCert) certs)
 
 isConsecutiveRange :: (Eq a, Num a) => [a] -> Bool
 isConsecutiveRange [_] = True
@@ -228,9 +241,10 @@ instance Arbitrary Cmd where
     arbitrary = genericArbitrary
     shrink = genericShrink
 
-cmdsFromChain :: [Tx] -> ([(Cmd, DelegationState StakeKey')])
+cmdsFromChain :: [Tx] -> [Cmd] --DelegationState StakeKey')])
 cmdsFromChain =
-    normalizeOn fst (CmdSetPortfolioOf (NonNegative 0))
+    map fst
+    . normalizeOn fst (CmdSetPortfolioOf (NonNegative 0))
     . map (\x -> (CmdSetPortfolioOf . NonNegative . length . activeKeys $ x, x))
     . scanl (flip applyTx) (initialDelegationState accK)
 
@@ -256,7 +270,7 @@ normalizeOn _ _ [] = []
 
 
 chainFromCmds :: [Cmd] -> [Tx]
-chainFromCmds goals = map Tx $ reverse $ go 0 [] [] goals
+chainFromCmds goals = map Tx . filter (not . null) $ reverse $ go 0 [] [] goals
   where
     -- NOTE: For convenience we treat ix=-1 as no keys, as ix=0 means the first
     -- key (at index 0) is registered and delegating.