From a3ca9f870995f9587892ab82d86d6c84714e535c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Mon, 21 Feb 2022 21:51:49 +0100 Subject: [PATCH] Revise globalstate Instances test to use V0 and V1 instances. --- concordium-consensus/smart-contracts | 2 +- .../Concordium/GlobalState/ContractStateV1.hs | 20 +- .../src/Concordium/Skov/Update.hs | 1 - .../globalstate/GlobalStateTests/Instances.hs | 751 ++++++++++-------- 4 files changed, 420 insertions(+), 354 deletions(-) diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 33f081ffaa..5f1ce2d580 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 33f081ffaa12ce10f5273731ee3830087694f04e +Subproject commit 5f1ce2d58058b92e1c9981960c3010988165e425 diff --git a/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs b/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs index 9aa7cdee1c..58d69c6518 100644 --- a/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs +++ b/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs @@ -15,7 +15,8 @@ module Concordium.GlobalState.ContractStateV1 thawInMemoryPersistent, toByteString, -- * Testing - lookupKey + lookupKey, + generatePersistentTree ) where @@ -74,6 +75,9 @@ foreign import ccall "load_persistent_tree_v1" loadPersistentTree :: LoadCallbac foreign import ccall unsafe "&free_persistent_state_v1" freePersistentState :: FunPtr (Ptr PersistentState -> IO ()) foreign import ccall unsafe "&free_mutable_state_v1" freeMutableState :: FunPtr (Ptr MutableStateInner -> IO ()) +{-# WARNING generatePersistentTreeFFI "Only for testing. DO NOT USE IN PRODUCTION." #-} +foreign import ccall "generate_persistent_state_from_seed" generatePersistentTreeFFI :: Word64 -> Word64 -> IO (Ptr PersistentState) + -- |Write out the tree using the provided callback, and return a BlobRef to the root. foreign import ccall "store_persistent_tree_v1" storePersistentTree :: StoreCallback -> Ptr PersistentState -> IO (BlobRef PersistentState) @@ -212,3 +216,17 @@ instance Serialize InMemoryPersistentState where bytePtr <- serializePersistentState errorLoadCallBack psPtr sizePtr len <- peek sizePtr putByteStringLen <$> unsafePackCStringFinalizer (castPtr bytePtr) (fromIntegral len) (rs_free_array_len bytePtr (fromIntegral len)) + + +{-# WARNING generatePersistentTree "Only for testing. DO NOT USE IN PRODUCTION." #-} +{-# NOINLINE generatePersistentTree #-} +generatePersistentTree :: + Word64 -- ^Seed. + -> Word64 -- ^Number of values. + -> InMemoryPersistentState +generatePersistentTree seed len = unsafePerformIO $ do + res <- generatePersistentTreeFFI seed len + if res == nullPtr then + error "Could not generate tree." + else + InMemoryPersistentState . PersistentState <$> newForeignPtr freePersistentState res diff --git a/concordium-consensus/src/Concordium/Skov/Update.hs b/concordium-consensus/src/Concordium/Skov/Update.hs index 329d207e4c..126d40a7d1 100644 --- a/concordium-consensus/src/Concordium/Skov/Update.hs +++ b/concordium-consensus/src/Concordium/Skov/Update.hs @@ -39,7 +39,6 @@ import Concordium.Skov.Statistics import qualified Concordium.TransactionVerification as TV import Concordium.Types.Updates (uiHeader, updateType, uiPayload) import Concordium.Scheduler.Types (updateSeqNumber) -import Concordium.GlobalState.TransactionTable (pttDeployCredential) -- |Determine if one block is an ancestor of another. -- A block is considered to be an ancestor of itself. diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs index 16842c2f02..e3b427f3ac 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs @@ -1,355 +1,404 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module GlobalStateTests.Instances where --- import Data.Word --- import Data.Maybe --- import qualified Data.Text as Text --- import qualified Data.Set as Set --- import Control.Monad --- import Data.Serialize --- import qualified Data.Map.Strict as Map --- import Lens.Micro.Platform --- import Data.FileEmbed - --- import qualified Concordium.Crypto.SHA256 as H --- import Concordium.Types --- import qualified Concordium.Wasm as Wasm --- import qualified Concordium.Scheduler.WasmIntegration as WasmV0 --- import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 --- import qualified Concordium.GlobalState.Wasm as GSWasm --- import Concordium.Types.HashableTo --- import Concordium.GlobalState.Basic.BlockState.InstanceTable --- import Concordium.GlobalState.Basic.BlockState.Instances --- import Concordium.GlobalState.Instance - --- import qualified Data.FixedByteString as FBS --- import qualified Data.ByteString as BS - --- import Test.QuickCheck --- import Test.Hspec - --- contractSourcesV0 :: [(FilePath, BS.ByteString)] --- contractSourcesV0 = $(makeRelativeToProject "testdata/contracts/" >>= embedDir) - --- -- Read all the files in testdata/contracts and get any valid contract interfaces. --- -- This assumes there is at least one, otherwise the tests will fail. --- validContractArtifactsV0 :: [(Wasm.ModuleSource GSWasm.V0, GSWasm.ModuleInterfaceV GSWasm.V0)] --- validContractArtifactsV0 = mapMaybe packModule contractSourcesV0 --- where packModule (_, sourceBytes) = --- let source = Wasm.ModuleSource sourceBytes --- in (source,) <$> WasmV0.processModule (Wasm.WasmModuleV source) - --- contractSourcesV1 :: [(FilePath, BS.ByteString)] --- contractSourcesV1 = $(makeRelativeToProject "testdata/contracts/v1" >>= embedDir) - --- -- Read all the files in testdata/contracts/v1 and get any valid contract interfaces. --- -- This assumes there is at least one, otherwise the tests will fail. --- validContractArtifactsV1 :: [(Wasm.ModuleSource GSWasm.V1, GSWasm.ModuleInterfaceV GSWasm.V1)] --- validContractArtifactsV1 = mapMaybe packModule contractSourcesV1 --- where packModule (_, sourceBytes) = --- let source = Wasm.ModuleSource sourceBytes --- in (source,) <$> WasmV1.processModule (Wasm.WasmModuleV source) - --- checkBinary :: Show a => (a -> a -> Bool) -> a -> a -> String -> String -> String -> Either String () --- checkBinary bop x y sbop sx sy = unless (bop x y) $ Left $ "Not satisfied: " ++ sx ++ " (" ++ show x ++ ") " ++ sbop ++ " " ++ sy ++ " (" ++ show y ++ ")" - --- invariantIT :: ContractIndex -> IT -> Either String (Word8, Bool, Bool, ContractIndex, H.Hash, Word64) --- invariantIT offset (Leaf inst) = do --- checkBinary (==) (contractIndex $ instanceAddress inst) offset "==" "account index" "expected value" --- return (0, True, False, succ offset, getHash inst, 1) --- invariantIT offset (VacantLeaf si) = return (0, True, True, succ offset, H.hash $ runPut $ put si, 0) --- invariantIT offset (Branch h f v hsh l r) = do --- (hl, fl, vl, offset', hshl, cl) <- invariantIT offset l --- checkBinary (==) hl h "==" "sucessor level of left child" "node level" --- unless fl $ Left "tree is not left-full" --- (hr, fr, vr, offset'', hshr, cr) <- invariantIT offset' r --- checkBinary (==) hsh (H.hash $ runPut $ put hshl <> put hshr) "==" "branch hash" "hash(leftHash <> rightHash)" --- checkBinary (<=) hr h "<=" "successor level of right child" "node level" --- checkBinary (==) f (fr && hr == h) "<->" "branch marked full" "right child is full at next lower level" --- checkBinary (==) v (vl || vr) "<->" "branch has vacancies" "at least one child has vacancies" --- return (succ h, f, v, offset'', hsh, cl + cr) - --- invariantInstanceTable :: InstanceTable -> Either String () --- invariantInstanceTable Empty = Right () --- invariantInstanceTable (Tree c0 t) = do --- (_, _, _, _, _, c) <- invariantIT 0 t --- checkBinary (==) c0 c "==" "reported number of instances" "actual number" - --- invariantInstances :: Instances -> Either String () --- invariantInstances = invariantInstanceTable . _instances - --- -- These generators name contracts as numbers to make sure the names are valid. --- genInitName :: Gen Wasm.InitName --- genInitName = --- Wasm.InitName . Text.pack . ("init_" ++) . show <$> (arbitrary :: Gen Word) - --- genReceiveName :: Gen Wasm.ReceiveName --- genReceiveName = do --- contract <- show <$> (arbitrary :: Gen Word) --- receive <- show <$> (arbitrary :: Gen Word) --- return . Wasm.ReceiveName . Text.pack $ receive ++ "." ++ contract - - --- genReceiveNames :: Gen (Map.Map Wasm.InitName (Set.Set Wasm.ReceiveName)) --- genReceiveNames = do --- n <- choose (1,10) --- ns <- replicateM n $ do --- i <- genInitName --- m <- choose (0,10) --- receives <- replicateM m genReceiveName --- return (i, Set.fromList receives) --- return $ Map.fromList ns - --- genContractState :: Gen Wasm.ContractState --- genContractState = do --- n <- choose (1,1000) --- Wasm.ContractState . BS.pack <$> vector n - --- makeDummyInstance :: InstanceData -> Gen (ContractAddress -> Instance) --- makeDummyInstance (InstanceData model amount) = oneof [mkV0, mkV1] --- where mkV0 = do --- (_, mInterface@GSWasm.ModuleInterface{..}) <- elements validContractArtifactsV0 --- initName <- if Set.null miExposedInit then return (Wasm.InitName "init_") else elements (Set.toList miExposedInit) --- let receiveNames = fromMaybe Set.empty $ Map.lookup initName miExposedReceive --- return $ makeInstance initName receiveNames mInterface model amount owner - --- mkV1 = do --- (_, mInterface@GSWasm.ModuleInterface{..}) <- elements validContractArtifactsV1 --- initName <- if Set.null miExposedInit then return (Wasm.InitName "init_") else elements (Set.toList miExposedInit) --- let receiveNames = fromMaybe Set.empty $ Map.lookup initName miExposedReceive --- return $ makeInstance initName receiveNames mInterface model amount owner --- owner = AccountAddress . FBS.pack . replicate 32 $ 0 - --- data InstanceData = InstanceData Wasm.ContractState Amount --- deriving (Eq, Show) - --- instance Arbitrary InstanceData where --- arbitrary = do --- model <- genContractState --- amount <- Amount <$> arbitrary --- return $ InstanceData model amount - --- instanceData :: Instance -> InstanceData --- instanceData inst = InstanceData (instanceModel inst) (instanceAmount inst) - --- data Model = Model { --- -- Data of instances --- modelInstances :: Map.Map ContractIndex (ContractSubindex, InstanceData), --- -- The next free subindex for free indexes --- modelFree :: Map.Map ContractIndex ContractSubindex, --- -- The lowest index that has never been assigned --- modelBound :: ContractIndex --- } deriving (Eq, Show) - --- emptyModel :: Model --- emptyModel = Model Map.empty Map.empty 0 - --- modelGetInstanceData :: ContractAddress -> Model -> Maybe InstanceData --- modelGetInstanceData (ContractAddress ci csi) m = do --- (csi', idata) <- Map.lookup ci (modelInstances m) --- guard $ csi == csi' --- return idata - --- modelUpdateInstanceAt :: ContractAddress -> Amount -> Wasm.ContractState -> Model -> Model --- modelUpdateInstanceAt (ContractAddress ci csi) amt val m = m {modelInstances = Map.adjust upd ci (modelInstances m)} --- where --- upd o@(csi', _) --- | csi == csi' = (csi, InstanceData val amt) --- | otherwise = o - --- modelCreateInstance :: (ContractAddress -> Instance) -> Model -> (ContractAddress, Model) --- modelCreateInstance mk m --- | null (modelFree m) = --- let ca = ContractAddress (modelBound m) 0 in --- (ca, m { --- modelInstances = Map.insert (modelBound m) (0, instanceData (mk ca)) (modelInstances m), --- modelBound = succ $ modelBound m --- }) --- | otherwise = --- let --- ((ci, csi), free') = Map.deleteFindMin (modelFree m) --- ca = ContractAddress ci csi --- in --- (ca, m { --- modelInstances = Map.insert ci (csi, instanceData (mk ca)) (modelInstances m), --- modelFree = free' --- }) - --- modelDeleteInstance :: ContractAddress -> Model -> Model --- modelDeleteInstance (ContractAddress ci csi) m = case Map.lookup ci (modelInstances m) of --- Nothing -> m --- Just (csi', _) -> if csi /= csi' then m else --- m { --- modelInstances = Map.delete ci (modelInstances m), --- modelFree = Map.insert ci (succ csi) (modelFree m) --- } - --- instanceTableToModel :: InstanceTable -> Model --- instanceTableToModel Empty = emptyModel --- instanceTableToModel (Tree _ t0) = ttm 0 emptyModel t0 --- where --- ttm offset m (Branch h _ _ _ l r) = --- let m' = ttm offset m l in --- ttm (offset + 2^h) m' r --- ttm offset m (Leaf inst) = m { --- modelInstances = Map.insert offset (contractSubindex $ instanceAddress inst, instanceData inst) (modelInstances m), --- modelBound = modelBound m + 1 --- } --- ttm offset m (VacantLeaf si) = m { --- modelFree = Map.insert offset (succ si) (modelFree m), --- modelBound = modelBound m + 1 --- } - --- modelCheck :: Instances -> Model -> Property --- modelCheck (Instances t) m = m === instanceTableToModel t - --- checkEqualThen :: (Monad m, Eq a, Show a) => a -> a -> m Property -> m Property --- checkEqualThen a b r = if a /= b then return (a === b) else r - --- checkBoolThen :: (Monad m) => String -> Bool -> m Property -> m Property --- checkBoolThen _ True r = r --- checkBoolThen ex False _ = return $ counterexample ex False - --- checkEitherThen_ :: (Monad m) => Either String a -> m Property -> m Property --- checkEitherThen_ (Left ex) _ = return $ counterexample ex False --- checkEitherThen_ (Right _) r = r - --- checkInvariantThen :: (Monad m) => Instances -> m Property -> m Property --- checkInvariantThen insts r = case invariantInstances insts of --- Right _ -> r --- Left ex -> return $ counterexample (ex ++ "\n" ++ show (_instances insts)) False - --- arbitraryMapElement :: Map.Map k v -> Gen (k, v) --- arbitraryMapElement m = do --- ind <- choose (0, Map.size m - 1) --- return (Map.elemAt ind m) - --- generateFromUpdates :: Int -> Gen (Instances, Model) --- generateFromUpdates n0 = gen n0 emptyInstances emptyModel --- where --- gen 0 insts model = return (insts, model) --- gen n insts model = oneof $ [create,create,create] ++ if null (modelInstances model) then [] else [deleteExisting] --- where --- create = do --- instData <- arbitrary --- dummyInstance <- makeDummyInstance instData --- let (_, insts') = createInstance dummyInstance insts --- let (_, model') = modelCreateInstance dummyInstance model --- gen (n-1) insts' model' --- deleteExisting = do --- (ci, (csi, _)) <- arbitraryMapElement (modelInstances model) --- let --- ca = ContractAddress ci csi --- insts' = deleteInstance ca insts --- model' = modelDeleteInstance ca model --- gen (n-1) insts' model' - - - --- testUpdates :: Int -> Gen Property --- testUpdates n0 = if n0 <= 0 then return (property True) else tu n0 emptyInstances emptyModel --- where --- tu 0 insts model = checkInvariantThen insts $ return $ modelCheck insts model --- tu n insts model = checkInvariantThen insts $ --- checkEqualThen model (instanceTableToModel $ _instances insts) $ --- oneof $ [create, deleteAbsent, updateAbsent] ++ --- (if null (modelInstances model) then [] else [updateExisting, deleteExisting]) ++ --- (if null (modelFree model) then [] else [deleteFree, updateFree]) --- where --- create = do --- instData <- arbitrary --- dummyInstance <- makeDummyInstance instData --- let (ca, insts') = createInstance dummyInstance insts --- let (cam, model') = modelCreateInstance dummyInstance model --- checkEqualThen (instanceAddress ca) cam $ --- tu (n-1) insts' model' --- deleteAbsent = do --- ci <- ContractIndex <$> choose (fromIntegral $ modelBound model, maxBound) --- csi <- ContractSubindex <$> arbitrary --- let --- ca = ContractAddress ci csi --- insts' = deleteInstance ca insts --- model' = modelDeleteInstance ca model --- tu (n-1) insts' model' --- updateAbsent = do --- ci <- ContractIndex <$> choose (fromIntegral $ modelBound model, maxBound) --- csi <- ContractSubindex <$> arbitrary --- InstanceData v a <- arbitrary --- let --- ca = ContractAddress ci csi --- insts' = updateInstanceAt' ca a (Just v) insts --- model' = modelUpdateInstanceAt ca a v model --- tu (n-1) insts' model' --- updateExisting = do --- (ci, (csi0, _)) <- arbitraryMapElement (modelInstances model) --- csi <- oneof [return csi0, ContractSubindex <$> arbitrary] --- InstanceData v a <- arbitrary --- let --- ca = ContractAddress ci csi --- insts' = updateInstanceAt' ca a (Just v) insts --- model' = modelUpdateInstanceAt ca a v model --- tu (n-1) insts' model' --- deleteExisting = do --- (ci, (csi0, _)) <- arbitraryMapElement (modelInstances model) --- csi <- oneof [return csi0, ContractSubindex <$> arbitrary] --- let --- ca = ContractAddress ci csi --- insts' = deleteInstance ca insts --- model' = modelDeleteInstance ca model --- tu (n-1) insts' model' --- updateFree = do --- (ci, csi0) <- arbitraryMapElement (modelFree model) --- csi <- ContractSubindex <$> oneof [choose (0, fromIntegral csi0 - 1), choose (fromIntegral csi0, maxBound)] --- InstanceData v a <- arbitrary --- let --- ca = ContractAddress ci csi --- insts' = updateInstanceAt' ca a (Just v) insts --- model' = modelUpdateInstanceAt ca a v model --- tu (n-1) insts' model' --- deleteFree = do --- (ci, csi0) <- arbitraryMapElement (modelFree model) --- csi <- oneof [return csi0, ContractSubindex <$> arbitrary] --- let --- ca = ContractAddress ci csi --- insts' = deleteInstance ca insts --- model' = modelDeleteInstance ca model --- tu (n-1) insts' model' - --- testCreateDelete :: Int -> Gen Property --- testCreateDelete n = do --- (insts, model) <- generateFromUpdates n --- checkInvariantThen insts $ return $ modelCheck insts model - --- testGetInstance :: Instances -> Model -> Gen Property --- testGetInstance insts model = oneof $ [present | not (null $ modelInstances model)] ++ --- [deleted | not (null $ modelFree model)] ++ --- [absent] --- where --- present = do --- (ci, (csi, d)) <- arbitraryMapElement (modelInstances model) --- return $ fmap instanceData (getInstance (ContractAddress ci csi) insts) === Just d --- deleted = do --- (ci, csi0) <- arbitraryMapElement (modelFree model) --- csi <- ContractSubindex <$> oneof [choose (0, fromIntegral csi0 - 1), choose (fromIntegral csi0, maxBound)] --- return $ fmap instanceData (getInstance (ContractAddress ci csi) insts) === Nothing --- absent = do --- ci <- ContractIndex <$> choose (fromIntegral $ modelBound model, maxBound) --- csi <- ContractSubindex <$> arbitrary --- return $ fmap instanceData (getInstance (ContractAddress ci csi) insts) === Nothing - --- testFoldInstances :: Instances -> Model -> Property --- testFoldInstances insts model = allInsts === modInsts --- where --- allInsts = (\i -> (instanceAddress i, instanceData i)) <$> (insts ^.. foldInstances) --- modInsts = (\(ci, (csi, d)) -> (ContractAddress ci csi, d)) <$> Map.toAscList (modelInstances model) - --- tests :: Word -> Spec --- tests lvl = describe "GlobalStateTests.Instances" $ do --- it "getInstance" $ withMaxSuccess (100 * fromIntegral lvl) --- $ forAllBlind (generateFromUpdates 5000) $ \(i,m) -> withMaxSuccess 100 $ testGetInstance i m --- it "foldInstances" $ withMaxSuccess 100 $ forAllBlind (generateFromUpdates 5000) $ uncurry testFoldInstances --- it "50000 create/delete - check at end" $ withMaxSuccess 10 $ testCreateDelete 50000 --- it "500 instance updates - check every step" $ withMaxSuccess (100 * fromIntegral lvl) $ testUpdates 500 - -tests = const (return ()) +import Data.Word +import Data.Maybe +import qualified Data.Text as Text +import qualified Data.Set as Set +import Control.Monad +import Data.Serialize +import qualified Data.Map.Strict as Map +import Lens.Micro.Platform +import Data.FileEmbed + +import qualified Concordium.Crypto.SHA256 as H +import Concordium.Types +import qualified Concordium.Wasm as Wasm +import qualified Concordium.Scheduler.WasmIntegration as WasmV0 +import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 +import qualified Concordium.GlobalState.Wasm as GSWasm +import qualified Concordium.GlobalState.ContractStateV1 as StateV1 +import Concordium.Types.HashableTo +import Concordium.GlobalState.Basic.BlockState.InstanceTable +import Concordium.GlobalState.Basic.BlockState.Instances +import Concordium.GlobalState.Instance + +import qualified Data.FixedByteString as FBS +import qualified Data.ByteString as BS + +import Test.QuickCheck +import Test.Hspec + +contractSourcesV0 :: [(FilePath, BS.ByteString)] +contractSourcesV0 = $(makeRelativeToProject "testdata/contracts/" >>= embedDir) + +-- Read all the files in testdata/contracts and get any valid contract interfaces. +-- This assumes there is at least one, otherwise the tests will fail. +validContractArtifactsV0 :: [(Wasm.ModuleSource GSWasm.V0, GSWasm.ModuleInterfaceV GSWasm.V0)] +validContractArtifactsV0 = mapMaybe packModule contractSourcesV0 + where packModule (_, sourceBytes) = + let source = Wasm.ModuleSource sourceBytes + in (source,) <$> WasmV0.processModule (Wasm.WasmModuleV source) + +contractSourcesV1 :: [(FilePath, BS.ByteString)] +contractSourcesV1 = $(makeRelativeToProject "testdata/contracts/v1" >>= embedDir) + +-- Read all the files in testdata/contracts/v1 and get any valid contract interfaces. +-- This assumes there is at least one, otherwise the tests will fail. +validContractArtifactsV1 :: [(Wasm.ModuleSource GSWasm.V1, GSWasm.ModuleInterfaceV GSWasm.V1)] +validContractArtifactsV1 = mapMaybe packModule contractSourcesV1 + where packModule (_, sourceBytes) = + let source = Wasm.ModuleSource sourceBytes + in (source,) <$> WasmV1.processModule (Wasm.WasmModuleV source) + +checkBinary :: Show a => (a -> a -> Bool) -> a -> a -> String -> String -> String -> Either String () +checkBinary bop x y sbop sx sy = unless (bop x y) $ Left $ "Not satisfied: " ++ sx ++ " (" ++ show x ++ ") " ++ sbop ++ " " ++ sy ++ " (" ++ show y ++ ")" + +invariantIT :: ContractIndex -> IT -> Either String (Word8, Bool, Bool, ContractIndex, H.Hash, Word64) +invariantIT offset (Leaf inst) = do + checkBinary (==) (contractIndex $ instanceAddress inst) offset "==" "account index" "expected value" + return (0, True, False, succ offset, getHash inst, 1) +invariantIT offset (VacantLeaf si) = return (0, True, True, succ offset, H.hash $ runPut $ put si, 0) +invariantIT offset (Branch h f v hsh l r) = do + (hl, fl, vl, offset', hshl, cl) <- invariantIT offset l + checkBinary (==) hl h "==" "sucessor level of left child" "node level" + unless fl $ Left "tree is not left-full" + (hr, fr, vr, offset'', hshr, cr) <- invariantIT offset' r + checkBinary (==) hsh (H.hash $ runPut $ put hshl <> put hshr) "==" "branch hash" "hash(leftHash <> rightHash)" + checkBinary (<=) hr h "<=" "successor level of right child" "node level" + checkBinary (==) f (fr && hr == h) "<->" "branch marked full" "right child is full at next lower level" + checkBinary (==) v (vl || vr) "<->" "branch has vacancies" "at least one child has vacancies" + return (succ h, f, v, offset'', hsh, cl + cr) + +invariantInstanceTable :: InstanceTable -> Either String () +invariantInstanceTable Empty = Right () +invariantInstanceTable (Tree c0 t) = do + (_, _, _, _, _, c) <- invariantIT 0 t + checkBinary (==) c0 c "==" "reported number of instances" "actual number" + +invariantInstances :: Instances -> Either String () +invariantInstances = invariantInstanceTable . _instances + +-- These generators name contracts as numbers to make sure the names are valid. +genInitName :: Gen Wasm.InitName +genInitName = + Wasm.InitName . Text.pack . ("init_" ++) . show <$> (arbitrary :: Gen Word) + +genReceiveName :: Gen Wasm.ReceiveName +genReceiveName = do + contract <- show <$> (arbitrary :: Gen Word) + receive <- show <$> (arbitrary :: Gen Word) + return . Wasm.ReceiveName . Text.pack $ receive ++ "." ++ contract + + +genReceiveNames :: Gen (Map.Map Wasm.InitName (Set.Set Wasm.ReceiveName)) +genReceiveNames = do + n <- choose (1,10) + ns <- replicateM n $ do + i <- genInitName + m <- choose (0,10) + receives <- replicateM m genReceiveName + return (i, Set.fromList receives) + return $ Map.fromList ns + +genV0ContractState :: Gen Wasm.ContractState +genV0ContractState = do + n <- choose (1,1000) + Wasm.ContractState . BS.pack <$> vector n + +-- This currently always generates the empty state. +genV1ContractState :: Gen StateV1.InMemoryPersistentState +genV1ContractState = do + seed <- arbitrary + len <- choose (0, 10) + return $ StateV1.generatePersistentTree seed len + +makeDummyInstance :: InstanceData -> Gen (ContractAddress -> Instance) +makeDummyInstance (InstanceDataV0 model amount) = do + let owner = AccountAddress . FBS.pack . replicate 32 $ 0 + (_, mInterface@GSWasm.ModuleInterface{..}) <- elements validContractArtifactsV0 + initName <- if Set.null miExposedInit then return (Wasm.InitName "init_") else elements (Set.toList miExposedInit) + let receiveNames = fromMaybe Set.empty $ Map.lookup initName miExposedReceive + return $ makeInstance initName receiveNames mInterface model amount owner +makeDummyInstance (InstanceDataV1 model amount) = do + let owner = AccountAddress . FBS.pack . replicate 32 $ 1 + (_, mInterface@GSWasm.ModuleInterface{..}) <- elements validContractArtifactsV1 + initName <- if Set.null miExposedInit then return (Wasm.InitName "init_") else elements (Set.toList miExposedInit) + let receiveNames = fromMaybe Set.empty $ Map.lookup initName miExposedReceive + return $ makeInstance initName receiveNames mInterface model amount owner + +data InstanceData = + InstanceDataV0 (InstanceStateV Wasm.V0) Amount + | InstanceDataV1 (InstanceStateV Wasm.V1) Amount + +instance Eq InstanceData where + (InstanceDataV0 (InstanceStateV0 v1) a1) == (InstanceDataV0 (InstanceStateV0 v2) a2) = v1 == v2 && a1 == a2 + (InstanceDataV1 v1 a1) == (InstanceDataV1 v2 a2) = encode v1 == encode v2 && a1 == a2 + _ == _ = False + +instance Show InstanceData where + show (InstanceDataV0 (InstanceStateV0 v) a) = "V0: " ++ show v ++ ", " ++ show a + show (InstanceDataV1 s a) = "V1: " ++ show (encode s) ++ ", " ++ show a + +instance Arbitrary InstanceData where + arbitrary = oneof [InstanceDataV0 <$> v0 <*> arbitrary, InstanceDataV1 <$> v1 <*> arbitrary] + where v0 = InstanceStateV0 <$> genV0ContractState + v1 = InstanceStateV1 <$> genV1ContractState + +instanceData :: Instance -> InstanceData +instanceData (InstanceV0 InstanceV{..}) = InstanceDataV0 _instanceVModel _instanceVAmount +instanceData (InstanceV1 InstanceV{..}) = InstanceDataV1 _instanceVModel _instanceVAmount + +data Model = Model { + -- Data of instances + modelInstances :: Map.Map ContractIndex (ContractSubindex, InstanceData), + -- The next free subindex for free indexes + modelFree :: Map.Map ContractIndex ContractSubindex, + -- The lowest index that has never been assigned + modelBound :: ContractIndex +} deriving (Eq, Show) + +emptyModel :: Model +emptyModel = Model Map.empty Map.empty 0 + +modelGetInstanceData :: ContractAddress -> Model -> Maybe InstanceData +modelGetInstanceData (ContractAddress ci csi) m = do + (csi', idata) <- Map.lookup ci (modelInstances m) + guard $ csi == csi' + return idata + +modelUpdateInstanceAt :: forall v . Wasm.IsWasmVersion v => ContractAddress -> Amount -> InstanceStateV v -> Model -> Model +modelUpdateInstanceAt (ContractAddress ci csi) amt val m = m {modelInstances = Map.adjust upd ci (modelInstances m)} + where + upd o@(csi', ex) + | csi == csi' = case Wasm.getWasmVersion @v of + Wasm.SV0 -> case ex of + InstanceDataV0 _ _ -> (csi, InstanceDataV0 val amt) + _ -> error "Contract version mismatch." + Wasm.SV1 -> case ex of + InstanceDataV1 _ _ -> (csi, InstanceDataV1 val amt) + _ -> error "Contract version mismatch." + | otherwise = o + +modelCreateInstance :: (ContractAddress -> Instance) -> Model -> (ContractAddress, Model) +modelCreateInstance mk m + | null (modelFree m) = + let ca = ContractAddress (modelBound m) 0 in + (ca, m { + modelInstances = Map.insert (modelBound m) (0, instanceData (mk ca)) (modelInstances m), + modelBound = succ $ modelBound m + }) + | otherwise = + let + ((ci, csi), free') = Map.deleteFindMin (modelFree m) + ca = ContractAddress ci csi + in + (ca, m { + modelInstances = Map.insert ci (csi, instanceData (mk ca)) (modelInstances m), + modelFree = free' + }) + +modelDeleteInstance :: ContractAddress -> Model -> Model +modelDeleteInstance (ContractAddress ci csi) m = case Map.lookup ci (modelInstances m) of + Nothing -> m + Just (csi', _) -> if csi /= csi' then m else + m { + modelInstances = Map.delete ci (modelInstances m), + modelFree = Map.insert ci (succ csi) (modelFree m) + } + +instanceTableToModel :: InstanceTable -> Model +instanceTableToModel Empty = emptyModel +instanceTableToModel (Tree _ t0) = ttm 0 emptyModel t0 + where + ttm offset m (Branch h _ _ _ l r) = + let m' = ttm offset m l in + ttm (offset + 2^h) m' r + ttm offset m (Leaf inst) = m { + modelInstances = Map.insert offset (contractSubindex $ instanceAddress inst, instanceData inst) (modelInstances m), + modelBound = modelBound m + 1 + } + ttm offset m (VacantLeaf si) = m { + modelFree = Map.insert offset (succ si) (modelFree m), + modelBound = modelBound m + 1 + } + +modelCheck :: Instances -> Model -> Property +modelCheck (Instances t) m = m === instanceTableToModel t + +checkEqualThen :: (Monad m, Eq a, Show a) => a -> a -> m Property -> m Property +checkEqualThen a b r = if a /= b then return (a === b) else r + +checkBoolThen :: (Monad m) => String -> Bool -> m Property -> m Property +checkBoolThen _ True r = r +checkBoolThen ex False _ = return $ counterexample ex False + +checkEitherThen_ :: (Monad m) => Either String a -> m Property -> m Property +checkEitherThen_ (Left ex) _ = return $ counterexample ex False +checkEitherThen_ (Right _) r = r + +checkInvariantThen :: (Monad m) => Instances -> m Property -> m Property +checkInvariantThen insts r = case invariantInstances insts of + Right _ -> r + Left ex -> return $ counterexample (ex ++ "\n" ++ show (_instances insts)) False + +arbitraryMapElement :: Map.Map k v -> Gen (k, v) +arbitraryMapElement m = do + ind <- choose (0, Map.size m - 1) + return (Map.elemAt ind m) + +generateFromUpdates :: Int -> Gen (Instances, Model) +generateFromUpdates n0 = gen n0 emptyInstances emptyModel + where + gen 0 insts model = return (insts, model) + gen n insts model = oneof $ [create,create,create] ++ if null (modelInstances model) then [] else [deleteExisting] + where + create = do + instData <- arbitrary + dummyInstance <- makeDummyInstance instData + let (_, insts') = createInstance dummyInstance insts + let (_, model') = modelCreateInstance dummyInstance model + gen (n-1) insts' model' + deleteExisting = do + (ci, (csi, _)) <- arbitraryMapElement (modelInstances model) + let + ca = ContractAddress ci csi + insts' = deleteInstance ca insts + model' = modelDeleteInstance ca model + gen (n-1) insts' model' + + + +testUpdates :: Int -> Gen Property +testUpdates n0 = if n0 <= 0 then return (property True) else tu n0 emptyInstances emptyModel + where + tu 0 insts model = checkInvariantThen insts $ return $ modelCheck insts model + tu n insts model = checkInvariantThen insts $ + checkEqualThen model (instanceTableToModel $ _instances insts) $ + oneof $ [create, deleteAbsent, updateAbsent] ++ + (if null (modelInstances model) then [] else [updateExisting, deleteExisting]) ++ + (if null (modelFree model) then [] else [deleteFree, updateFree]) + where + create = do + instData <- arbitrary + dummyInstance <- makeDummyInstance instData + let (ca, insts') = createInstance dummyInstance insts + let (cam, model') = modelCreateInstance dummyInstance model + checkEqualThen (instanceAddress ca) cam $ + tu (n-1) insts' model' + deleteAbsent = do + ci <- ContractIndex <$> choose (fromIntegral $ modelBound model, maxBound) + csi <- ContractSubindex <$> arbitrary + let + ca = ContractAddress ci csi + insts' = deleteInstance ca insts + model' = modelDeleteInstance ca model + tu (n-1) insts' model' + updateAbsent = do + ci <- ContractIndex <$> choose (fromIntegral $ modelBound model, maxBound) + csi <- ContractSubindex <$> arbitrary + arbitrary >>= \case + InstanceDataV0 v a -> do + let + ca = ContractAddress ci csi + insts' = updateInstanceAt' ca a (Just v) insts + model' = modelUpdateInstanceAt ca a v model + tu (n-1) insts' model' + InstanceDataV1 v a -> do + let + ca = ContractAddress ci csi + insts' = updateInstanceAt' ca a (Just v) insts + model' = modelUpdateInstanceAt ca a v model + tu (n-1) insts' model' + updateExisting = do + (ci, (csi0, curVer)) <- arbitraryMapElement (modelInstances model) + csi <- oneof [return csi0, ContractSubindex <$> arbitrary] + case curVer of + InstanceDataV0 _ _ -> do + v <- InstanceStateV0 <$> genV0ContractState + a <- arbitrary + let + ca = ContractAddress ci csi + insts' = updateInstanceAt' ca a (Just v) insts + model' = modelUpdateInstanceAt ca a v model + tu (n-1) insts' model' + InstanceDataV1 _ _ -> do + v <- InstanceStateV1 <$> genV1ContractState + a <- arbitrary + let + ca = ContractAddress ci csi + insts' = updateInstanceAt' ca a (Just v) insts + model' = modelUpdateInstanceAt ca a v model + tu (n-1) insts' model' + deleteExisting = do + (ci, (csi0, _)) <- arbitraryMapElement (modelInstances model) + csi <- oneof [return csi0, ContractSubindex <$> arbitrary] + let + ca = ContractAddress ci csi + insts' = deleteInstance ca insts + model' = modelDeleteInstance ca model + tu (n-1) insts' model' + updateFree = do + (ci, csi0) <- arbitraryMapElement (modelFree model) + csi <- ContractSubindex <$> oneof [choose (0, fromIntegral csi0 - 1), choose (fromIntegral csi0, maxBound)] + arbitrary >>= \case + InstanceDataV0 v a -> do + let + ca = ContractAddress ci csi + insts' = updateInstanceAt' ca a (Just v) insts + model' = modelUpdateInstanceAt ca a v model + tu (n-1) insts' model' + InstanceDataV1 v a -> do + let + ca = ContractAddress ci csi + insts' = updateInstanceAt' ca a (Just v) insts + model' = modelUpdateInstanceAt ca a v model + tu (n-1) insts' model' + deleteFree = do + (ci, csi0) <- arbitraryMapElement (modelFree model) + csi <- oneof [return csi0, ContractSubindex <$> arbitrary] + let + ca = ContractAddress ci csi + insts' = deleteInstance ca insts + model' = modelDeleteInstance ca model + tu (n-1) insts' model' + +testCreateDelete :: Int -> Gen Property +testCreateDelete n = do + (insts, model) <- generateFromUpdates n + checkInvariantThen insts $ return $ modelCheck insts model + +testGetInstance :: Instances -> Model -> Gen Property +testGetInstance insts model = oneof $ [present | not (null $ modelInstances model)] ++ + [deleted | not (null $ modelFree model)] ++ + [absent] + where + present = do + (ci, (csi, d)) <- arbitraryMapElement (modelInstances model) + return $ fmap instanceData (getInstance (ContractAddress ci csi) insts) === Just d + deleted = do + (ci, csi0) <- arbitraryMapElement (modelFree model) + csi <- ContractSubindex <$> oneof [choose (0, fromIntegral csi0 - 1), choose (fromIntegral csi0, maxBound)] + return $ fmap instanceData (getInstance (ContractAddress ci csi) insts) === Nothing + absent = do + ci <- ContractIndex <$> choose (fromIntegral $ modelBound model, maxBound) + csi <- ContractSubindex <$> arbitrary + return $ fmap instanceData (getInstance (ContractAddress ci csi) insts) === Nothing + +testFoldInstances :: Instances -> Model -> Property +testFoldInstances insts model = allInsts === modInsts + where + allInsts = (\i -> (instanceAddress i, instanceData i)) <$> (insts ^.. foldInstances) + modInsts = (\(ci, (csi, d)) -> (ContractAddress ci csi, d)) <$> Map.toAscList (modelInstances model) + +tests :: Word -> Spec +tests lvl = describe "GlobalStateTests.Instances" $ do + it "getInstance" $ withMaxSuccess (100 * fromIntegral lvl) + $ forAllBlind (generateFromUpdates 5000) $ \(i,m) -> withMaxSuccess 100 $ testGetInstance i m + it "foldInstances" $ withMaxSuccess 100 $ forAllBlind (generateFromUpdates 5000) $ uncurry testFoldInstances + it "10000 create/delete - check at end" $ withMaxSuccess 10 $ testCreateDelete 10000 + it "500 instance updates - check every step" $ withMaxSuccess (100 * fromIntegral lvl) $ testUpdates 500