From 3534f884cd68f736ec26fadb0c3541da967fe590 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Fri, 10 Dec 2021 15:07:59 +0100 Subject: [PATCH 01/51] WIP: Code compiles after parametrizing modules and instances. --- concordium-consensus/package.yaml | 2 +- concordium-consensus/smart-contracts | 2 +- .../GlobalState/Basic/BlockState.hs | 7 +- .../Basic/BlockState/InstanceTable.hs | 8 +- .../GlobalState/Basic/BlockState/Instances.hs | 33 ++- .../Basic/BlockState/Invariants.hs | 3 +- .../GlobalState/Basic/BlockState/Modules.hs | 76 ++++-- .../src/Concordium/GlobalState/Instance.hs | 229 ++++++++++++----- .../src/Concordium/GlobalState/Paired.hs | 6 +- .../GlobalState/Persistent/BlockState.hs | 60 +++-- .../Persistent/BlockState/Modules.hs | 113 +++++++-- .../GlobalState/Persistent/Instances.hs | 122 ++++++--- .../src/Concordium/GlobalState/Wasm.hs | 188 ++++++++++++-- .../src/Concordium/Scheduler.hs | 237 +++++++++--------- .../src/Concordium/Scheduler/Environment.hs | 62 ++--- .../Concordium/Scheduler/WasmIntegration.hs | 22 +- 16 files changed, 807 insertions(+), 363 deletions(-) diff --git a/concordium-consensus/package.yaml b/concordium-consensus/package.yaml index 39bc3d2686..ffe0589754 100644 --- a/concordium-consensus/package.yaml +++ b/concordium-consensus/package.yaml @@ -74,7 +74,7 @@ default-extensions: flags: dynamic: manual: True - default: True + default: False library: source-dirs: src diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 272186431c..7dd0ca7bb8 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 272186431cc0bcadddbededfa7f5efadcaca9d25 +Subproject commit 7dd0ca7bb8465e20790190b09cbb1dbf819550ed diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs index 8f179a6e7d..9f3abf0b10 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs @@ -303,8 +303,8 @@ getBlockState = do (_blockAccounts :: Accounts.Accounts pv) <- Accounts.deserializeAccounts cryptoParams let resolveModule modRef initName = do mi <- Modules.getInterface modRef _blockModules - return (GSWasm.miExposedReceive mi ^. at initName . non Set.empty, mi) - _blockInstances <- Instances.getInstancesV0 resolveModule + return (GSWasm.exposedReceive mi ^. at initName . non Set.empty, mi) + _blockInstances <- Instances.getInstancesV1 resolveModule -- FIXME: Make protocol version dependant _blockUpdates <- getUpdatesV0 _blockEpochBlocksBaked <- getHashedEpochBlocksV0 -- Construct the release schedule and active bakers from the accounts @@ -513,10 +513,9 @@ instance (IsProtocolVersion pv, Monad m) => BS.BlockStateOperations (PureBlockSt accounts = bs ^. blockAccounts newAccounts = Accounts.putAccountWithRegIds acct accounts - bsoPutNewInstance bs mkInstance = return (instanceAddress, bs') + bsoPutNewInstance bs mkInstance = return (Instances.instanceAddress inst, bs') where (inst, instances') = Instances.createInstance mkInstance (bs ^. blockInstances) - Instances.InstanceParameters{..} = Instances.instanceParameters inst bs' = bs -- Add the instance & blockInstances .~ instances' diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/InstanceTable.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/InstanceTable.hs index e509202e39..dff51e4e1e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/InstanceTable.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/InstanceTable.hs @@ -82,7 +82,7 @@ type instance IxValue InstanceTable = Instance instance Ixed InstanceTable where ix _ _ t@Empty = pure t - ix i upd (Tree s t) = Tree s <$> (ix (contractIndex i) . filtered ((== i) . instanceAddress . instanceParameters)) upd t + ix i upd (Tree s t) = Tree s <$> (ix (contractIndex i) . filtered ((== i) . instanceAddress)) upd t -- |Determine if an 'IT' is a full binary tree. isFull :: IT -> Bool @@ -127,7 +127,7 @@ deleteContractInstance _ Empty = Empty deleteContractInstance i0 (Tree s0 t0) = uncurry Tree $ dci i0 t0 where dci i l@(Leaf inst) - | i == 0 = (s0 - 1, VacantLeaf $ contractSubindex $ instanceAddress $ instanceParameters inst) + | i == 0 = (s0 - 1, VacantLeaf $ contractSubindex $ instanceAddress inst) | otherwise = (s0, l) dci _ vl@(VacantLeaf _) = (s0, vl) dci i b@(Branch h f _ _ l r) @@ -143,8 +143,8 @@ deleteContractInstanceExact _ Empty = Empty deleteContractInstanceExact addr (Tree s0 t0) = uncurry Tree $ dci (contractIndex addr) t0 where dci i l@(Leaf inst) - | i == 0 && addr == instanceAddress (instanceParameters inst) - = (s0 - 1, VacantLeaf $ contractSubindex $ instanceAddress $ instanceParameters inst) + | i == 0 && addr == instanceAddress inst + = (s0 - 1, VacantLeaf $ contractSubindex $ instanceAddress inst) | otherwise = (s0, l) dci _ vl@(VacantLeaf _) = (s0, vl) dci i b@(Branch h f _ _ l r) diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs index 60eed167a3..b21b0bf3a4 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs @@ -1,6 +1,8 @@ module Concordium.GlobalState.Basic.BlockState.Instances( InstanceParameters(..), Instance(..), + InstanceV(..), + HasInstanceParameters(..), makeInstance, iaddress, Instances, @@ -15,7 +17,8 @@ module Concordium.GlobalState.Basic.BlockState.Instances( instanceCount, -- * Serialization putInstancesV0, - getInstancesV0 + getInstancesV0, + getInstancesV1 ) where import Concordium.Types @@ -76,17 +79,37 @@ putInstancesV0 (Instances (Tree _ t)) = do putWord8 1 put si putOptInstance (Right inst) = do - putWord8 2 - putInstanceV0 inst + case inst of + InstanceV0 i -> do + putWord8 2 + putInstanceV0 i + InstanceV1 i -> do + putWord8 3 + putInstanceV1 i -- |Deserialize 'Instances' in V0 format. getInstancesV0 - :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterface)) + :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterfaceV GSWasm.V0)) -> Get Instances getInstancesV0 resolve = Instances <$> constructM buildInstance where buildInstance idx = getWord8 >>= \case 0 -> return Nothing 1 -> Just . Left <$> get - 2 -> Just . Right <$> getInstanceV0 resolve idx + 2 -> Just . Right . InstanceV0 <$> getInstanceV0 resolve idx + _ -> fail "Bad instance list" + + +-- |Deserialize 'Instances' in V0 format. +-- FIXME: This is wrong. We need getInstnacesV1 to be told which instance version to use. +getInstancesV1 + :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterface)) + -> Get Instances +getInstancesV1 resolve = Instances <$> constructM buildInstance + where + buildInstance idx = getWord8 >>= \case + 0 -> return Nothing + 1 -> Just . Left <$> get + 2 -> Just . Right <$> getInstanceV1 resolve idx + 3 -> Just . Right <$> getInstanceV1 resolve idx _ -> fail "Bad instance list" diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Invariants.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Invariants.hs index 1ec35fb9d9..19c88553ae 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Invariants.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Invariants.hs @@ -80,7 +80,8 @@ invariantBlockState bs extraBalance = do checkEpochBakers EpochBakers{..} = do checkBinary (==) (Vec.length _bakerInfos) (Vec.length _bakerStakes) "==" "#baker infos" "#baker stakes" checkBinary (==) _bakerTotalStake (sum _bakerStakes) "==" "baker total stake" "sum of baker stakes" - checkInstance amount Instance{..} = return $! (amount + instanceAmount) + checkInstance amount (InstanceV0 InstanceV{..}) = return $! (amount + _instanceVAmount) + checkInstance amount (InstanceV1 InstanceV{..}) = return $! (amount + _instanceVAmount) -- check that the two credential maps are the same, the one recorded in block state and the model one. checkCredentialResults modelCreds actualCreds = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs index 9c75990884..e5fffc6d85 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs @@ -1,6 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} module Concordium.GlobalState.Basic.BlockState.Modules ( Module(..), + ModuleV(..), + interface, + source, Modules, emptyModules, putInterface, @@ -11,17 +15,18 @@ module Concordium.GlobalState.Basic.BlockState.Modules _modulesMap, -- * Serialization putModulesV0, - getModulesV0 + getModulesV0, ) where import Concordium.Crypto.SHA256 -import Concordium.GlobalState.Wasm import Concordium.GlobalState.Basic.BlockState.LFMBTree (LFMBTree) import qualified Concordium.GlobalState.Basic.BlockState.LFMBTree as LFMB import Concordium.Types import Concordium.Types.HashableTo import Concordium.Wasm -import Concordium.Scheduler.WasmIntegration +import qualified Concordium.GlobalState.Wasm as GSWasm +import qualified Concordium.Scheduler.WasmIntegration as V0 +import qualified Concordium.Scheduler.WasmIntegration.V1 as V1 import Control.Monad import Data.Coerce import Data.Map.Strict (Map) @@ -38,23 +43,54 @@ type ModuleIndex = Word64 -- |A module contains both the module interface and the raw source code of the -- module. -data Module = Module { +data ModuleV v = ModuleV { -- | The instrumented module, ready to be instantiated. - interface :: !ModuleInterface, + moduleVInterface :: !(GSWasm.ModuleInterfaceV v), -- | The raw module binary source. - source :: !WasmModule + moduleVSource :: !WasmModule } deriving (Show) +-- Create the class HasSource a with a function +-- source :: Lens a WasmModule +makeFields ''ModuleV + +data Module where + ModuleV0 :: ModuleV GSWasm.V0 -> Module + ModuleV1 :: ModuleV GSWasm.V1 -> Module + deriving(Show) + +fromModule :: Module -> GSWasm.ModuleInterface +fromModule (ModuleV0 v) = GSWasm.ModuleInterfaceV0 (moduleVInterface v) +fromModule (ModuleV1 v) = GSWasm.ModuleInterfaceV1 (moduleVInterface v) + +toModule :: GSWasm.ModuleInterface -> WasmModule -> Module +toModule (GSWasm.ModuleInterfaceV0 moduleVInterface) moduleVSource = ModuleV0 ModuleV{..} +toModule (GSWasm.ModuleInterfaceV1 moduleVInterface) moduleVSource = ModuleV1 ModuleV{..} + +instance HasSource Module WasmModule where + source f (ModuleV0 m) = ModuleV0 <$> source f m + source f (ModuleV1 m) = ModuleV1 <$> source f m + +instance GSWasm.HasModuleRef Module where + {-# INLINE moduleReference #-} + moduleReference (ModuleV0 v) = GSWasm.moduleReference . moduleVInterface $ v + moduleReference (ModuleV1 v) = GSWasm.moduleReference . moduleVInterface $ v + instance HashableTo Hash Module where - getHash = coerce . miModuleRef . interface + getHash = coerce . GSWasm.moduleReference instance Serialize Module where - put = put . source + put = put . (^. source) get = do - source <- get - case processModule source of - Nothing -> fail "Invalid module" - Just interface -> return Module {..} + moduleVSource <- get + case wasmVersion moduleVSource of + 0 -> case V0.processModule moduleVSource of + Nothing -> fail "Invalid V0 module" + Just moduleVInterface -> return (ModuleV0 ModuleV {..}) + 1 -> case V1.processModule moduleVSource of + Nothing -> fail "Invalid V1 module" + Just moduleVInterface -> return (ModuleV1 ModuleV{..}) + v -> fail $ "Unsupported module version: " ++ show v -------------------------------------------------------------------------------- @@ -80,26 +116,26 @@ emptyModules = Modules LFMB.empty Map.empty -- |Try to add interfaces to the module table. If a module with the given -- reference exists returns @Nothing@. -putInterface :: (ModuleInterface, WasmModule) -> Modules -> Maybe Modules -putInterface (iface, source) m = +putInterface :: (GSWasm.ModuleInterface, WasmModule) -> Modules -> Maybe Modules +putInterface (iface, mSource) m = if Map.member mref (m ^. modulesMap) then Nothing else Just $ m & modulesTable .~ modulesTable' & modulesMap %~ Map.insert mref idx - where mref = miModuleRef iface - (idx, modulesTable') = LFMB.append (Module iface source) $ m ^. modulesTable + where mref = GSWasm.moduleReference iface + (idx, modulesTable') = LFMB.append (toModule iface mSource) $ m ^. modulesTable getModule :: ModuleRef -> Modules -> Maybe Module getModule ref mods = Map.lookup ref (mods ^. modulesMap) >>= flip LFMB.lookup (mods ^. modulesTable) -- |Get an interface by module reference. -getInterface :: ModuleRef -> Modules -> Maybe ModuleInterface -getInterface ref mods = fmap interface $ getModule ref mods +getInterface :: ModuleRef -> Modules -> Maybe GSWasm.ModuleInterface +getInterface ref mods = fromModule <$> getModule ref mods -- |Get the source of a module by module reference. getSource :: ModuleRef -> Modules -> Maybe WasmModule -getSource ref mods = fmap source $ getModule ref mods +getSource ref mods = (^. source) <$> getModule ref mods moduleRefList :: Modules -> [ModuleRef] moduleRefList mods = Map.keys (mods ^. modulesMap) @@ -123,6 +159,6 @@ getModulesV0 = do mtSize <- getWord64be _modulesTable <- LFMB.fromList <$> replicateM (fromIntegral mtSize) get let _modulesMap = Map.fromList - [(miModuleRef (interface iface), idx) + [(GSWasm.moduleReference iface, idx) | (idx, iface) <- LFMB.toAscPairList _modulesTable] return Modules{..} diff --git a/concordium-consensus/src/Concordium/GlobalState/Instance.hs b/concordium-consensus/src/Concordium/GlobalState/Instance.hs index f83433ffb8..957f23f412 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Instance.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Instance.hs @@ -1,20 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} module Concordium.GlobalState.Instance where import Data.Aeson import Data.Serialize import qualified Data.Set as Set import qualified Concordium.Crypto.SHA256 as H - +import Lens.Micro.Platform (makeLenses, (^.)) import Concordium.Types import Concordium.Types.HashableTo import qualified Concordium.Wasm as Wasm import qualified Concordium.GlobalState.Wasm as GSWasm +import Data.Word +import Lens.Micro (to, Lens') -- |The fixed parameters associated with a smart contract instance -data InstanceParameters = InstanceParameters { +data InstanceParameters v = InstanceParameters { -- |Address of the instance - instanceAddress :: !ContractAddress, + _instanceAddress :: !ContractAddress, -- |Address of this contract instance owner, i.e., the creator account. instanceOwner :: !AccountAddress, -- |The name of the init method which created this contract. @@ -23,50 +27,100 @@ data InstanceParameters = InstanceParameters { -- receive methods of the module. instanceReceiveFuns :: !(Set.Set Wasm.ReceiveName), -- |The interface of 'instanceContractModule' - instanceModuleInterface :: !GSWasm.ModuleInterface, + instanceModuleInterface :: !(GSWasm.ModuleInterfaceV v), -- |Hash of the fixed parameters instanceParameterHash :: !H.Hash } -instance Show InstanceParameters where - show InstanceParameters{..} = show instanceAddress ++ " :: " ++ show instanceContractModule ++ "." ++ show instanceInitName +class HasInstanceParameters a where + instanceAddress :: a -> ContractAddress + +instance HasInstanceParameters (InstanceParameters v) where + instanceAddress InstanceParameters{..} = _instanceAddress + +instance Show (InstanceParameters v) where + show InstanceParameters{..} = show _instanceAddress ++ " :: " ++ show instanceContractModule ++ "." ++ show instanceInitName where instanceContractModule = GSWasm.miModuleRef instanceModuleInterface -instance HashableTo H.Hash InstanceParameters where +instance HashableTo H.Hash (InstanceParameters v) where getHash = instanceParameterHash +data InstanceV v = InstanceV { + -- |The fixed parameters of the instance + _instanceVParameters :: !(InstanceParameters v), + -- |The current local state of the instance + _instanceVModel :: !Wasm.ContractState, + -- |The current amount of GTU owned by the instance + _instanceVAmount :: !Amount, + -- |Hash of the smart contract instance + _instanceVHash :: H.Hash + } + +-- TODO: Use MakeClassy with parameters? +makeLenses 'InstanceV + +class HasInstanceFields a where + instanceAmount :: Lens' a Amount + instanceModel :: Lens' a Wasm.ContractState + instanceHash :: Lens' a H.Hash + +instance HasInstanceFields (InstanceV v) where + instanceAmount = instanceVAmount + instanceModel = instanceVModel + instanceHash = instanceVHash + +instance HasInstanceFields Instance where + instanceAmount f (InstanceV0 i) = InstanceV0 <$> instanceAmount f i + instanceAmount f (InstanceV1 i) = InstanceV1 <$> instanceAmount f i + instanceModel f (InstanceV0 i) = InstanceV0 <$> instanceModel f i + instanceModel f (InstanceV1 i) = InstanceV1 <$> instanceModel f i + instanceHash f (InstanceV0 i) = InstanceV0 <$> instanceHash f i + instanceHash f (InstanceV1 i) = InstanceV1 <$> instanceHash f i + + +instance HasInstanceParameters (InstanceV v) where + instanceAddress = (^. instanceVParameters . to instanceAddress) + +instance HasInstanceParameters Instance where + instanceAddress (InstanceV0 i) = instanceAddress i + instanceAddress (InstanceV1 i) = instanceAddress i + -- |An instance of a smart contract. -data Instance = Instance { - -- |The fixed parameters of the instance - instanceParameters :: !InstanceParameters, - -- |The current local state of the instance - instanceModel :: !Wasm.ContractState, - -- |The current amount of GTU owned by the instance - instanceAmount :: !Amount, - -- |Hash of the smart contract instance - instanceHash :: H.Hash -} +data Instance = InstanceV0 (InstanceV GSWasm.V0) + | InstanceV1 (InstanceV GSWasm.V1) instance Show Instance where - show Instance{..} = show instanceParameters ++ " {balance=" ++ show instanceAmount ++ ", model=" ++ show instanceModel ++ ", hash=" ++ show instanceHash ++ "}" + show (InstanceV0 InstanceV{..}) = show _instanceVParameters ++ " {balance=" ++ show _instanceVAmount ++ ", model=" ++ show _instanceVModel ++ ", hash=" ++ show _instanceVHash ++ "}" + show (InstanceV1 InstanceV{..}) = show _instanceVParameters ++ " {balance=" ++ show _instanceVAmount ++ ", model=" ++ show _instanceVModel ++ ", hash=" ++ show _instanceVHash ++ "}" instance HashableTo H.Hash Instance where - getHash = instanceHash + getHash (InstanceV0 InstanceV{..}) = _instanceVHash + getHash (InstanceV1 InstanceV{..}) = _instanceVHash -- |Helper function for JSON encoding an 'Instance'. instancePairs :: KeyValue kv => Instance -> [kv] {-# INLINE instancePairs #-} -instancePairs istance = - [ "model" .= instanceModel istance, - "owner" .= instanceOwner params, - "amount" .= instanceAmount istance, - "methods" .= instanceReceiveFuns params, - "name" .= instanceInitName params, - "sourceModule" .= GSWasm.miModuleRef (instanceModuleInterface params) +-- TODO: Get the version from the module instead. +instancePairs (InstanceV0 InstanceV{..}) = + [ "model" .= _instanceVModel, + "owner" .= instanceOwner _instanceVParameters, + "amount" .= _instanceVAmount, + "methods" .= instanceReceiveFuns _instanceVParameters, + "name" .= instanceInitName _instanceVParameters, + "sourceModule" .= GSWasm.miModuleRef (instanceModuleInterface _instanceVParameters), + "version" .= (0 :: Word32) + ] +instancePairs (InstanceV1 InstanceV{..}) = + [ "model" .= _instanceVModel, + "owner" .= instanceOwner _instanceVParameters, + "amount" .= _instanceVAmount, + "methods" .= instanceReceiveFuns _instanceVParameters, + "name" .= instanceInitName _instanceVParameters, + "sourceModule" .= GSWasm.miModuleRef (instanceModuleInterface _instanceVParameters), + "version" .= (1 :: Word32) ] - where - params = instanceParameters istance + -- |JSON instance to support consensus queries. instance ToJSON Instance where @@ -86,15 +140,15 @@ makeInstanceHash' paramHash conState a = H.hashLazy $ runPutLazy $ do putByteString (H.hashToByteString (getHash conState)) put a -makeInstanceHash :: InstanceParameters -> Wasm.ContractState -> Amount -> H.Hash +makeInstanceHash :: InstanceParameters v -> Wasm.ContractState -> Amount -> H.Hash makeInstanceHash params = makeInstanceHash' (instanceParameterHash params) -makeInstance :: +makeInstanceV :: Wasm.InitName -- ^Name of the init method used to initialize the contract. -> Set.Set Wasm.ReceiveName -- ^Receive functions suitable for this instance. - -> GSWasm.ModuleInterface + -> GSWasm.ModuleInterfaceV v -- ^Module interface -> Wasm.ContractState -- ^Initial state @@ -104,58 +158,96 @@ makeInstance :: -- ^Owner/creator of the instance. -> ContractAddress -- ^Address for the instance - -> Instance -makeInstance instanceInitName instanceReceiveFuns instanceModuleInterface instanceModel instanceAmount instanceOwner instanceAddress - = Instance {..} + -> InstanceV v +makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress + = case GSWasm.miModule instanceModuleInterface of + GSWasm.InstrumentedWasmModuleV0 {} -> InstanceV{..} + GSWasm.InstrumentedWasmModuleV1 {} -> InstanceV{..} where instanceContractModule = GSWasm.miModuleRef instanceModuleInterface - instanceParameterHash = makeInstanceParameterHash instanceAddress instanceOwner instanceContractModule instanceInitName - instanceParameters = InstanceParameters {..} - instanceHash = makeInstanceHash instanceParameters instanceModel instanceAmount + instanceParameterHash = makeInstanceParameterHash _instanceAddress instanceOwner instanceContractModule instanceInitName + _instanceVParameters = InstanceParameters {..} + _instanceVHash = makeInstanceHash _instanceVParameters _instanceVModel _instanceVAmount + +makeInstance :: + Wasm.InitName + -- ^Name of the init method used to initialize the contract. + -> Set.Set Wasm.ReceiveName + -- ^Receive functions suitable for this instance. + -> GSWasm.ModuleInterfaceV v + -- ^Module interface + -> Wasm.ContractState + -- ^Initial state + -> Amount + -- ^Initial balance + -> AccountAddress + -- ^Owner/creator of the instance. + -> ContractAddress + -- ^Address for the instance + -> Instance +makeInstance instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress + = case GSWasm.miModule instanceModuleInterface of + GSWasm.InstrumentedWasmModuleV0 {} -> InstanceV0 (makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress) + GSWasm.InstrumentedWasmModuleV1 {} -> InstanceV1 (makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress) -- |The address of a smart contract instance. iaddress :: Instance -> ContractAddress -iaddress = instanceAddress . instanceParameters +iaddress (InstanceV0 InstanceV{..}) = _instanceAddress _instanceVParameters +iaddress (InstanceV1 InstanceV{..}) = _instanceAddress _instanceVParameters -- |Update a given smart contract instance. -- FIXME: Updates to the state should be done better in the future, we should not just replace it. +updateInstanceV :: AmountDelta -> Wasm.ContractState -> InstanceV v -> InstanceV v +updateInstanceV delta val i = updateInstanceV' amnt val i + where amnt = applyAmountDelta delta (_instanceVAmount i) + updateInstance :: AmountDelta -> Wasm.ContractState -> Instance -> Instance -updateInstance delta val i = updateInstance' amnt val i - where amnt = applyAmountDelta delta (instanceAmount i) +updateInstance delta val (InstanceV0 i) = InstanceV0 $ updateInstanceV delta val i +updateInstance delta val (InstanceV1 i) = InstanceV1 $ updateInstanceV delta val i + -- |Update a given smart contract instance with exactly the given amount and state. -updateInstance' :: Amount -> Wasm.ContractState -> Instance -> Instance -updateInstance' amnt val i = i { - instanceModel = val, - instanceAmount = amnt, - instanceHash = makeInstanceHash (instanceParameters i) val amnt +updateInstanceV' :: Amount -> Wasm.ContractState -> InstanceV v -> InstanceV v +updateInstanceV' amnt val i = i { + _instanceVModel = val, + _instanceVAmount = amnt, + _instanceVHash = makeInstanceHash ( _instanceVParameters i) val amnt } +updateInstance' :: Amount -> Wasm.ContractState -> Instance -> Instance +updateInstance' amnt val (InstanceV0 i) = InstanceV0 $ updateInstanceV' amnt val i +updateInstance' amnt val (InstanceV1 i) = InstanceV1 $ updateInstanceV' amnt val i + + -- |Serialize a smart contract instance in V0 format. -putInstanceV0 :: Putter Instance -putInstanceV0 Instance{instanceParameters = InstanceParameters{..}, ..} = do +putInstanceV0 :: Putter (InstanceV GSWasm.V0) +putInstanceV0 InstanceV{ _instanceVParameters = InstanceParameters{..}, ..} = do -- InstanceParameters -- Only put the Subindex part of the address - put (contractSubindex instanceAddress) + put (contractSubindex _instanceAddress) put instanceOwner put (GSWasm.miModuleRef instanceModuleInterface) put instanceInitName -- instanceReceiveFuns, instanceModuleInterface and instanceParameterHash -- are not included, since they can be derived from context. - put instanceModel - put instanceAmount + put _instanceVModel + put _instanceVAmount + +putInstanceV1 :: Putter (InstanceV GSWasm.V1) +putInstanceV1 = error "TODO" + -- |Deserialize a smart contract instance in V0 format. getInstanceV0 - :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterface)) + :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterfaceV GSWasm.V0)) -- ^Function for resolving the receive functions and module interface. -> ContractIndex -- ^Index of the contract - -> Get Instance + -> Get (InstanceV GSWasm.V0) getInstanceV0 resolve idx = do -- InstanceParameters subindex <- get - let instanceAddress = ContractAddress idx subindex + let _instanceAddress = ContractAddress idx subindex instanceOwner <- get instanceContractModule <- get instanceInitName <- get @@ -163,6 +255,31 @@ getInstanceV0 resolve idx = do case resolve instanceContractModule instanceInitName of Just r -> return r Nothing -> fail "Unable to resolve smart contract" - instanceModel <- get - instanceAmount <- get - return $ makeInstance instanceInitName instanceReceiveFuns instanceModuleInterface instanceModel instanceAmount instanceOwner instanceAddress + _instanceVModel <- get + _instanceVAmount <- get + return $ makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress + +getInstanceV1 + :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterface)) + -- ^Function for resolving the receive functions and module interface. + -> ContractIndex + -- ^Index of the contract + -> Get Instance +-- |Deserialize a smart contract instance in V0 format. +getInstanceV1 resolve idx = do + -- InstanceParameters + subindex <- get + let _instanceAddress = ContractAddress idx subindex + instanceOwner <- get + instanceContractModule <- get + instanceInitName <- get + _instanceVModel <- get + _instanceVAmount <- get + case resolve instanceContractModule instanceInitName of + Just (instanceReceiveFuns, GSWasm.ModuleInterfaceV0 instanceModuleInterface) -> + return $ InstanceV0 $ makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress + Just (instanceReceiveFuns, GSWasm.ModuleInterfaceV1 instanceModuleInterface) -> + return $ InstanceV1 $ makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress + Nothing -> fail "Unable to resolve smart contract" + + diff --git a/concordium-consensus/src/Concordium/GlobalState/Paired.hs b/concordium-consensus/src/Concordium/GlobalState/Paired.hs index 1725a6d7c5..83b3c356e5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Paired.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Paired.hs @@ -214,7 +214,7 @@ instance (Monad m, C.HasGlobalStateContext (PairGSContext lc rc) r, BlockStateQu getContractInstance (ls, rs) caddr = do c1 <- coerceBSML (getContractInstance ls caddr) c2 <- coerceBSMR (getContractInstance rs caddr) - assert (((==) `on` fmap instanceHash) c1 c2) $ return c1 + assert (((==) `on` fmap (^. instanceHash)) c1 c2) $ return c1 getModuleList (ls, rs) = do m1 <- coerceBSML (getModuleList ls) m2 <- coerceBSMR (getModuleList rs) @@ -226,7 +226,7 @@ instance (Monad m, C.HasGlobalStateContext (PairGSContext lc rc) r, BlockStateQu getContractInstanceList (ls, rs) = do a1 <- coerceBSML (getContractInstanceList ls) a2 <- coerceBSMR (getContractInstanceList rs) - assert (((==) `on` fmap instanceHash) a1 a2) $ return a1 + assert (((==) `on` fmap (^. instanceHash)) a1 a2) $ return a1 getSeedState (ls, rs) = do ss1 <- coerceBSML (getSeedState ls) ss2 <- coerceBSMR (getSeedState rs) @@ -378,7 +378,7 @@ instance (MonadLogger m, C.HasGlobalStateContext (PairGSContext lc rc) r, BlockS bsoGetInstance (bs1, bs2) iref = do r1 <- coerceBSML $ bsoGetInstance bs1 iref r2 <- coerceBSMR $ bsoGetInstance bs2 iref - assert (((==) `on` fmap instanceHash) r1 r2) $ return r1 + assert (((==) `on` fmap (^. instanceHash)) r1 r2) $ return r1 bsoAddressWouldClash (bs1, bs2) addr = do r1 <- coerceBSML $ bsoAddressWouldClash bs1 addr r2 <- coerceBSMR $ bsoAddressWouldClash bs2 addr diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 29b3be5c15..f568657ee2 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -57,8 +57,8 @@ import Concordium.GlobalState.Persistent.Bakers import qualified Concordium.GlobalState.Persistent.Instances as Instances import qualified Concordium.Types.Transactions as Transactions import qualified Concordium.Types.Execution as Transactions -import Concordium.GlobalState.Persistent.Instances(PersistentInstance(..), PersistentInstanceParameters(..)) -import Concordium.GlobalState.Instance (Instance(..),InstanceParameters(..),makeInstanceHash') +import Concordium.GlobalState.Persistent.Instances(PersistentInstance(..), PersistentInstanceV(..), PersistentInstanceParameters(..)) +import Concordium.GlobalState.Instance (Instance(..), InstanceV(..), InstanceParameters(..),makeInstanceHash') import Concordium.GlobalState.Persistent.Account import Concordium.GlobalState.Persistent.BlockState.Updates import qualified Concordium.GlobalState.Basic.BlockState.Account as TransientAccount @@ -973,29 +973,31 @@ doPutNewInstance pbs fnew = do mods <- refLoad (bspModules bsp) -- Create the instance (inst, insts) <- Instances.newContractInstance (fnew' mods) (bspInstances bsp) - let ca = instanceAddress (instanceParameters inst) + let ca = _instanceAddress (_instanceVParameters inst) (ca,) <$> storePBS pbs bsp{bspInstances = insts} where - fnew' mods ca = let inst@Instance{instanceParameters = InstanceParameters{..}, ..} = fnew ca in do - params <- makeBufferedRef $ PersistentInstanceParameters { - pinstanceAddress = instanceAddress, - pinstanceOwner = instanceOwner, - pinstanceContractModule = GSWasm.miModuleRef instanceModuleInterface, - pinstanceReceiveFuns = instanceReceiveFuns, - pinstanceInitName = instanceInitName, - pinstanceParameterHash = instanceParameterHash - } - -- This in an irrefutable pattern because otherwise it would have failed in previous stages - -- as it would be trying to create an instance of a module that doesn't exist. - ~(Just modRef) <- Modules.getModuleReference (GSWasm.miModuleRef instanceModuleInterface) mods - return (inst, PersistentInstance{ - pinstanceParameters = params, - pinstanceModuleInterface = modRef, - pinstanceModel = instanceModel, - pinstanceAmount = instanceAmount, - pinstanceHash = instanceHash - }) + fnew' mods ca = + case fnew ca of + InstanceV0 inst@InstanceV{_instanceVParameters = InstanceParameters{..}, ..} -> do + params <- makeBufferedRef $ PersistentInstanceParameters { + pinstanceAddress = _instanceAddress, + pinstanceOwner = instanceOwner, + pinstanceContractModule = GSWasm.miModuleRef instanceModuleInterface, + pinstanceReceiveFuns = instanceReceiveFuns, + pinstanceInitName = instanceInitName, + pinstanceParameterHash = instanceParameterHash + } + -- This in an irrefutable pattern because otherwise it would have failed in previous stages + -- as it would be trying to create an instance of a module that doesn't exist. + ~(Just modRef) <- undefined -- TODO: FIX signature of putnewinstance Modules.getModuleReference (GSWasm.miModuleRef instanceModuleInterface) mods + return (inst, PersistentInstanceV0 Instances.PersistentInstanceV{ + pinstanceParameters = params, + pinstanceModuleInterface = modRef, + pinstanceModel = _instanceVModel, + pinstanceAmount = _instanceVAmount, + pinstanceHash = _instanceVHash + }) doModifyInstance :: (IsProtocolVersion pv, MonadBlobStore m) => PersistentBlockState pv -> ContractAddress -> AmountDelta -> Wasm.ContractState -> m (PersistentBlockState pv) doModifyInstance pbs caddr deltaAmnt val = do @@ -1006,13 +1008,19 @@ doModifyInstance pbs caddr deltaAmnt val = do Just (_, insts) -> storePBS pbs bsp{bspInstances = insts} where - upd oldInst = do + upd (PersistentInstanceV0 oldInst) = do + (piParams, newParamsRef) <- cacheBufferedRef (pinstanceParameters oldInst) + if deltaAmnt == 0 then + return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef, pinstanceModel = val})) + else + return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceAmount = applyAmountDelta deltaAmnt (pinstanceAmount oldInst), pinstanceModel = val}) + upd (PersistentInstanceV1 oldInst) = do (piParams, newParamsRef) <- cacheBufferedRef (pinstanceParameters oldInst) if deltaAmnt == 0 then - return ((), rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceModel = val}) + return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef, pinstanceModel = val})) else - return ((), rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceAmount = applyAmountDelta deltaAmnt (pinstanceAmount oldInst), pinstanceModel = val}) - rehash iph inst@PersistentInstance {..} = inst {pinstanceHash = makeInstanceHash' iph pinstanceModel pinstanceAmount} + return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceAmount = applyAmountDelta deltaAmnt (pinstanceAmount oldInst), pinstanceModel = val}) + rehash iph inst@PersistentInstanceV {..} = inst {pinstanceHash = makeInstanceHash' iph pinstanceModel pinstanceAmount} doGetIdentityProvider :: (IsProtocolVersion pv, MonadBlobStore m) => PersistentBlockState pv -> ID.IdentityProviderIdentity -> m (Maybe IPS.IpInfo) doGetIdentityProvider pbs ipId = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs index 52371d429c..f4309af355 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs @@ -1,7 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} module Concordium.GlobalState.Persistent.BlockState.Modules ( Module(..), + ModuleV(..), Modules, + getModuleInterface, + source, emptyModules, getInterface, getSource, @@ -15,7 +19,7 @@ module Concordium.GlobalState.Persistent.BlockState.Modules import Concordium.Crypto.SHA256 import qualified Concordium.GlobalState.Basic.BlockState.Modules as TransientModules -import Concordium.GlobalState.Wasm +import qualified Concordium.GlobalState.Wasm as GSWasm import Concordium.GlobalState.Persistent.BlobStore import Concordium.GlobalState.Persistent.LFMBTree (LFMBTree) import qualified Concordium.GlobalState.Persistent.LFMBTree as LFMB @@ -40,35 +44,94 @@ type ModuleIndex = Word64 -- |A module contains both the module interface and a plain reference to where -- the raw source code of the module is stored in the blobstore. -data Module = Module { +data ModuleV v = ModuleV { -- | The instrumented module, ready to be instantiated. - interface :: !ModuleInterface, + moduleVInterface :: !(GSWasm.ModuleInterfaceV v), -- | A plain reference to the raw module binary source. - source :: !(BlobRef WasmModule) + moduleVSource :: !(BlobRef WasmModule) } + deriving(Show) +-- Create two typeclasses HasInterface a _ and HasSource a _ +-- with methods source :: Lens' a (BlobRef WasmModule) and +-- interface :: Lens' a (GSWasm.ModuleInterfaceV v) +makeFields ''ModuleV + +fromModule :: Module -> GSWasm.ModuleInterface +fromModule (ModuleV0 v) = GSWasm.ModuleInterfaceV0 (moduleVInterface v) +fromModule (ModuleV1 v) = GSWasm.ModuleInterfaceV1 (moduleVInterface v) + +toModule :: GSWasm.ModuleInterface -> BlobRef WasmModule -> Module +toModule (GSWasm.ModuleInterfaceV0 moduleVInterface) moduleVSource = ModuleV0 ModuleV{..} +toModule (GSWasm.ModuleInterfaceV1 moduleVInterface) moduleVSource = ModuleV1 ModuleV{..} + + +data Module where + ModuleV0 :: ModuleV GSWasm.V0 -> Module + ModuleV1 :: ModuleV GSWasm.V1 -> Module + deriving (Show) + +instance HasSource Module (BlobRef WasmModule) where + source f (ModuleV0 m) = ModuleV0 <$> source f m + source f (ModuleV1 m) = ModuleV1 <$> source f m + +getModuleInterface :: Module -> GSWasm.ModuleInterface +getModuleInterface (ModuleV0 m) = GSWasm.ModuleInterfaceV0 (moduleVInterface m) +getModuleInterface (ModuleV1 m) = GSWasm.ModuleInterfaceV1 (moduleVInterface m) + + +instance GSWasm.HasModuleRef Module where + moduleReference (ModuleV0 m) = GSWasm.moduleReference (moduleVInterface m) + moduleReference (ModuleV1 m) = GSWasm.moduleReference (moduleVInterface m) + +-- FIXME: This should probably take host versioning into account since that is not part of the reference instance HashableTo Hash Module where - getHash = coerce . miModuleRef . interface -instance MonadBlobStore m => MHashableTo m Hash Module + getHash = coerce . GSWasm.moduleReference + +instance Monad m => MHashableTo m Hash Module -- |This serialization is used for storing the module in the BlobStore. -- It should not be used for other purposes. instance Serialize Module where get = do - interface <- get - source <- get - return Module{..} - put Module{..} = do - put interface - put source + -- interface is versioned + moduleVInterface <- get + moduleVSource <- get + return $! toModule moduleVInterface moduleVSource + put m = do + put (fromModule m) + put (m ^. source) +-- |This serialization is used for storing the module in the BlobStore. +-- It should not be used for other purposes. +instance Serialize (ModuleV GSWasm.V0) where + get = do + -- interface is versioned + moduleVInterface <- get + moduleVSource <- get + return $! ModuleV {..} + put m = put m + +-- |This serialization is used for storing the module in the BlobStore. +-- It should not be used for other purposes. +instance Serialize (ModuleV GSWasm.V1) where + get = do + -- interface is versioned + moduleVInterface <- get + moduleVSource <- get + return $! ModuleV {..} + put m = put m + + +instance MonadBlobStore m => BlobStorable m (ModuleV GSWasm.V0) where +instance MonadBlobStore m => BlobStorable m (ModuleV GSWasm.V1) where instance MonadBlobStore m => BlobStorable m Module where instance MonadBlobStore m => Cacheable m Module where -- |Serialize a module in V0 format. -- This only serializes the source. putModuleV0 :: (MonadBlobStore m, MonadPut m) => Module -> m () -putModuleV0 = sPut <=< loadRef . source +putModuleV0 = sPut <=< loadRef . (^. source) -------------------------------------------------------------------------------- @@ -91,7 +154,7 @@ instance MonadBlobStore m => BlobStorable m Modules where return $ do _modulesTable <- table _modulesMap <- foldl' (\m (idx, aModule) -> - Map.insert (miModuleRef $ interface aModule) idx m) + Map.insert (GSWasm.moduleReference aModule) idx m) Map.empty <$> LFMB.toAscPairList _modulesTable return Modules{..} store = fmap fst . storeUpdate @@ -113,7 +176,7 @@ emptyModules = Modules LFMB.empty Map.empty -- |Try to add interfaces to the module table. If a module with the given -- reference exists returns @Nothing@. putInterface :: MonadBlobStore m - => (ModuleInterface, WasmModule) + => (GSWasm.ModuleInterface, WasmModule) -> Modules -> m (Maybe Modules) putInterface (modul, src) m = @@ -121,10 +184,10 @@ putInterface (modul, src) m = then return Nothing else do src' <- storeRef src - (idx, modulesTable') <- LFMB.append (Module modul src') $ m ^. modulesTable + (idx, modulesTable') <- LFMB.append (toModule modul src') $ m ^. modulesTable return $ Just $ m & modulesTable .~ modulesTable' & modulesMap %~ Map.insert mref idx - where mref = miModuleRef modul + where mref = GSWasm.moduleReference modul getModule :: MonadBlobStore m => ModuleRef -> Modules -> m (Maybe Module) getModule ref mods = @@ -142,12 +205,13 @@ getModuleReference ref mods = Nothing -> return Nothing Just idx -> fmap bufferedReference <$> LFMB.lookupRef idx (mods ^. modulesTable) + -- |Get an interface by module reference. getInterface :: MonadBlobStore m => ModuleRef -> Modules - -> m (Maybe ModuleInterface) -getInterface ref mods = fmap interface <$> getModule ref mods + -> m (Maybe GSWasm.ModuleInterface) +getInterface ref mods = fmap fromModule <$> getModule ref mods -- |Get the source of a module by module reference. getSource :: MonadBlobStore m => ModuleRef -> Modules -> m (Maybe WasmModule) @@ -155,7 +219,7 @@ getSource ref mods = do m <- getModule ref mods case m of Nothing -> return Nothing - Just modul -> Just <$> loadRef (source modul) + Just modul -> Just <$> loadRef (modul ^. source) -- |Get the list of all currently deployed modules. -- The order of the list is not specified. @@ -167,9 +231,12 @@ moduleRefList mods = Map.keys (mods ^. modulesMap) storePersistentModule :: MonadBlobStore m => TransientModules.Module -> m Module -storePersistentModule TransientModules.Module{..} = do - source' <- storeRef source - return Module{ source = source', ..} +storePersistentModule (TransientModules.ModuleV0 TransientModules.ModuleV{..}) = do + moduleVSource' <- storeRef moduleVSource + return (ModuleV0 (ModuleV { moduleVSource = moduleVSource', ..})) +storePersistentModule (TransientModules.ModuleV1 TransientModules.ModuleV{..}) = do + moduleVSource' <- storeRef moduleVSource + return (ModuleV1 (ModuleV { moduleVSource = moduleVSource', ..})) makePersistentModules :: MonadBlobStore m => TransientModules.Modules diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs index a14f4195db..6cbeca93ee 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs @@ -1,8 +1,8 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedStrings #-} - module Concordium.GlobalState.Persistent.Instances where import Data.Word @@ -74,13 +74,13 @@ instance Applicative m => Cacheable m PersistentInstanceParameters ---------------------------------------------------------------------------------------------------- -- |An instance of a smart contract. -data PersistentInstance = PersistentInstance { +data PersistentInstanceV v = PersistentInstanceV { -- |The fixed parameters of the instance pinstanceParameters :: !(BufferedRef PersistentInstanceParameters), -- |The interface of 'pinstanceContractModule'. Note this is a BufferedRef to a Module as this -- is how the data is stored in the Modules table. A 'Module' carries a BlobRef to the source -- but that reference should never be consulted in the scope of Instance operations. - pinstanceModuleInterface :: !(BufferedRef Module), + pinstanceModuleInterface :: !(BufferedRef (Modules.ModuleV v)), -- |The current local state of the instance pinstanceModel :: !Wasm.ContractState, -- |The current amount of GTU owned by the instance @@ -89,14 +89,33 @@ data PersistentInstance = PersistentInstance { pinstanceHash :: H.Hash } +data PersistentInstance where + PersistentInstanceV0 :: PersistentInstanceV GSWasm.V0 -> PersistentInstance + PersistentInstanceV1 :: PersistentInstanceV GSWasm.V1 -> PersistentInstance + instance Show PersistentInstance where - show PersistentInstance{..} = show pinstanceParameters ++ " {balance=" ++ show pinstanceAmount ++ ", model=" ++ show pinstanceModel ++ "}" + show (PersistentInstanceV0 PersistentInstanceV {..}) = show pinstanceParameters ++ " {balance=" ++ show pinstanceAmount ++ ", model=" ++ show pinstanceModel ++ "}" + show (PersistentInstanceV1 PersistentInstanceV {..}) = show pinstanceParameters ++ " {balance=" ++ show pinstanceAmount ++ ", model=" ++ show pinstanceModel ++ "}" + +loadInstanceParameters :: MonadBlobStore m => PersistentInstance -> m PersistentInstanceParameters +loadInstanceParameters (PersistentInstanceV0 PersistentInstanceV {..}) = loadBufferedRef pinstanceParameters +loadInstanceParameters (PersistentInstanceV1 PersistentInstanceV {..}) = loadBufferedRef pinstanceParameters + +cacheInstanceParameters :: MonadBlobStore m => PersistentInstance -> m (PersistentInstanceParameters, BufferedRef PersistentInstanceParameters) +cacheInstanceParameters (PersistentInstanceV0 PersistentInstanceV {..}) = cacheBufferedRef pinstanceParameters +cacheInstanceParameters (PersistentInstanceV1 PersistentInstanceV {..}) = cacheBufferedRef pinstanceParameters + +loadInstanceModule :: MonadBlobStore m => PersistentInstance -> m Module +loadInstanceModule (PersistentInstanceV0 PersistentInstanceV {..}) = ModuleV0 <$> loadBufferedRef pinstanceModuleInterface +loadInstanceModule (PersistentInstanceV1 PersistentInstanceV {..}) = ModuleV1 <$> loadBufferedRef pinstanceModuleInterface instance HashableTo H.Hash PersistentInstance where - getHash = pinstanceHash + getHash (PersistentInstanceV0 PersistentInstanceV{..})= pinstanceHash + getHash (PersistentInstanceV1 PersistentInstanceV{..})= pinstanceHash +-- FIXME: There is no way to retrofit this to two module versions since instance MonadBlobStore m => BlobStorable m PersistentInstance where - storeUpdate PersistentInstance{..} = do + storeUpdate (PersistentInstanceV0 PersistentInstanceV{..}) = do (pparams, newParameters) <- storeUpdate pinstanceParameters (pinterface, newpInterface) <- storeUpdate pinstanceModuleInterface let putInst = do @@ -104,7 +123,7 @@ instance MonadBlobStore m => BlobStorable m PersistentInstance where pinterface put pinstanceModel put pinstanceAmount - return (putInst, PersistentInstance{pinstanceParameters = newParameters, pinstanceModuleInterface = newpInterface, ..}) + return (putInst, PersistentInstanceV0 (PersistentInstanceV{pinstanceParameters = newParameters, pinstanceModuleInterface = newpInterface, ..})) store pinst = fst <$> storeUpdate pinst load = do rparams <- load @@ -116,12 +135,12 @@ instance MonadBlobStore m => BlobStorable m PersistentInstance where pinstanceModuleInterface <- rInterface pip <- loadBufferedRef pinstanceParameters let pinstanceHash = makeInstanceHash pip pinstanceModel pinstanceAmount - return PersistentInstance{..} + return $! PersistentInstanceV0 (PersistentInstanceV {..}) -- This cacheable instance is a bit unusual. Caching instances requires us to have access -- to the modules so that we can share the module interfaces from different instances. instance MonadBlobStore m => Cacheable (ReaderT Modules m) PersistentInstance where - cache p@PersistentInstance{..} = do + cache (PersistentInstanceV0 p@PersistentInstanceV{..}) = do modules <- ask lift $! do -- we only cache parameters and get the interface from the modules @@ -131,32 +150,44 @@ instance MonadBlobStore m => Cacheable (ReaderT Modules m) PersistentInstance wh ips <- cache pinstanceParameters params <- loadBufferedRef ips let modref = pinstanceContractModule params - miface <- Modules.getModuleReference modref modules + miface <- undefined -- FIXME: Modules.getModuleReference modref modules case miface of - Nothing -> return p{pinstanceParameters = ips} -- this case should never happen, but it is safe to do this. - Just iface -> return p{pinstanceModuleInterface = iface, pinstanceParameters = ips} + Nothing -> return (PersistentInstanceV0 p{pinstanceParameters = ips}) -- this case should never happen, but it is safe to do this. + Just iface -> return (PersistentInstanceV0 p{pinstanceModuleInterface = iface, pinstanceParameters = ips}) fromPersistentInstance :: MonadBlobStore m => PersistentInstance -> m Transient.Instance -fromPersistentInstance PersistentInstance{..} = do - PersistentInstanceParameters{..} <- loadBufferedRef pinstanceParameters - instanceModuleInterface <- interface <$> loadBufferedRef pinstanceModuleInterface - let instanceParameters = Transient.InstanceParameters { - instanceAddress = pinstanceAddress, +fromPersistentInstance pinst = do + PersistentInstanceParameters{..} <- loadInstanceParameters pinst + instanceModuleInterface <- getModuleInterface <$> loadInstanceModule pinst + let mkParams :: GSWasm.ModuleInterfaceV v -> Transient.InstanceParameters v + mkParams miface = Transient.InstanceParameters { + _instanceAddress = pinstanceAddress, instanceOwner = pinstanceOwner, instanceInitName = pinstanceInitName, instanceReceiveFuns = pinstanceReceiveFuns, - instanceModuleInterface = instanceModuleInterface, + instanceModuleInterface = miface, instanceParameterHash = pinstanceParameterHash } - return Transient.Instance{ instanceModel = pinstanceModel, - instanceAmount = pinstanceAmount, - instanceHash = pinstanceHash, - .. - } + let (instanceModel, instanceAmount, instanceHash) = case pinst of + PersistentInstanceV0 PersistentInstanceV{..} -> (pinstanceModel, pinstanceAmount, pinstanceHash) + PersistentInstanceV1 PersistentInstanceV{..} -> (pinstanceModel, pinstanceAmount, pinstanceHash) + case instanceModuleInterface of + GSWasm.ModuleInterfaceV0 iface -> + return $ Transient.InstanceV0 (Transient.InstanceV { _instanceVModel = instanceModel, + _instanceVAmount = instanceAmount, + _instanceVHash = instanceHash, + _instanceVParameters = mkParams iface + }) + GSWasm.ModuleInterfaceV1 iface -> + return $ Transient.InstanceV1 (Transient.InstanceV { _instanceVModel = instanceModel, + _instanceVAmount = instanceAmount, + _instanceVHash = instanceHash, + _instanceVParameters = mkParams iface + }) -- |Serialize a smart contract instance in V0 format. -putInstanceV0 :: (MonadBlobStore m, MonadPut m) => PersistentInstance -> m () -putInstanceV0 PersistentInstance{..} = do +putInstanceV0 :: (MonadBlobStore m, MonadPut m) => PersistentInstanceV GSWasm.V0 -> m () +putInstanceV0 PersistentInstanceV {..} = do -- Instance parameters PersistentInstanceParameters{..} <- refLoad pinstanceParameters liftPut $ do @@ -168,6 +199,22 @@ putInstanceV0 PersistentInstance{..} = do put pinstanceModel put pinstanceAmount +-- |Serialize a smart contract instance in V0 format. +-- FIXME: Add versioning +putInstanceV1 :: (MonadBlobStore m, MonadPut m) => PersistentInstanceV GSWasm.V1 -> m () +putInstanceV1 PersistentInstanceV {..} = do + -- Instance parameters + PersistentInstanceParameters{..} <- refLoad pinstanceParameters + liftPut $ do + -- only put the subindex part of the address + put (contractSubindex pinstanceAddress) + put pinstanceOwner + put pinstanceContractModule + put pinstanceInitName + put pinstanceModel + put pinstanceAmount + + ---------------------------------------------------------------------------------------------------- makeInstanceParameterHash :: ContractAddress -> AccountAddress -> ModuleRef -> Wasm.InitName -> H.Hash @@ -380,7 +427,7 @@ deleteContractInstance addr t0@(InstancesTree s it0) = dci (fmap (InstancesTree where dci succCont i (Leaf inst) | i == 0 = do - aaddr <- pinstanceAddress <$> loadBufferedRef (pinstanceParameters inst) + aaddr <- pinstanceAddress <$> loadInstanceParameters inst if addr == aaddr then succCont (VacantLeaf $ contractSubindex aaddr) else @@ -408,7 +455,7 @@ lookupContractInstance addr (InstancesTree _ it0) = lu (contractIndex addr) =<< where lu i (Leaf inst) | i == 0 = do - aaddr <- pinstanceAddress <$> loadBufferedRef (pinstanceParameters inst) + aaddr <- pinstanceAddress <$> loadInstanceParameters inst return $! if addr == aaddr then Just inst else Nothing | otherwise = return Nothing lu _ VacantLeaf{} = return Nothing @@ -426,7 +473,7 @@ updateContractInstance fupd addr (InstancesTree s it0) = upd baseSuccess (contra return $ Just (res, InstancesTree s it) upd succCont i (Leaf inst) | i == 0 = do - aaddr <- pinstanceAddress <$> loadBufferedRef (pinstanceParameters inst) + aaddr <- pinstanceAddress <$> loadInstanceParameters inst if addr == aaddr then do (res, inst') <- fupd inst succCont res (Leaf inst') @@ -467,9 +514,9 @@ makePersistent mods (Transient.Instances (Transient.Tree s t)) = InstancesTree s makeBufferedBlobbed (Branch lvl fll vac hsh l' r') conv (Transient.Leaf i) = convInst i >>= makeBufferedBlobbed . Leaf conv (Transient.VacantLeaf si) = makeBufferedBlobbed (VacantLeaf si) - convInst Transient.Instance{instanceParameters=Transient.InstanceParameters{..}, ..} = do + convInst (Transient.InstanceV0 Transient.InstanceV {_instanceVParameters=Transient.InstanceParameters{..}, ..}) = do pIParams <- makeBufferedRef $ PersistentInstanceParameters{ - pinstanceAddress = instanceAddress, + pinstanceAddress = _instanceAddress, pinstanceOwner = instanceOwner, pinstanceContractModule = GSWasm.miModuleRef instanceModuleInterface, pinstanceInitName = instanceInitName, @@ -478,13 +525,13 @@ makePersistent mods (Transient.Instances (Transient.Tree s t)) = InstancesTree s } -- This pattern is irrefutable because if the instance exists in the Basic version, -- then the module must be present in the persistent implementation. - ~(Just pIModuleInterface) <- Modules.getModuleReference (GSWasm.miModuleRef instanceModuleInterface) mods - return $ PersistentInstance { + ~(Just pIModuleInterface) <- undefined -- FIXME: Modules.getModuleReference (GSWasm.miModuleRef instanceModuleInterface) mods + return $ PersistentInstanceV0 PersistentInstanceV { pinstanceParameters = pIParams, pinstanceModuleInterface = pIModuleInterface, - pinstanceModel = instanceModel, - pinstanceAmount = instanceAmount, - pinstanceHash = instanceHash + pinstanceModel = _instanceVModel, + pinstanceAmount = _instanceVAmount, + pinstanceHash = _instanceVHash } -- |Serialize instances in V0 format. @@ -497,6 +544,9 @@ putInstancesV0 (InstancesTree _ it) = do putOptInstance (Left ca) = liftPut $ do putWord8 1 put (contractSubindex ca) - putOptInstance (Right inst) = do + putOptInstance (Right (PersistentInstanceV0 inst)) = do liftPut $ putWord8 2 putInstanceV0 inst + putOptInstance (Right (PersistentInstanceV1 inst)) = do + liftPut $ putWord8 2 + putInstanceV1 inst diff --git a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs index f93002472d..0714a42c6b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs @@ -1,16 +1,28 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-| Common types and functions used to support wasm module storage in block state. |-} module Concordium.GlobalState.Wasm ( -- ** Instrumented module -- -- | An instrumented module is a processed module that is ready to be -- instantiated and run. - ModuleArtifactV0(..), + V0, + V1, + ModuleArtifactV0, + ModuleArtifactV1, newModuleArtifactV0, - withModuleArtifactV0, - InstrumentedModule(..), - + newModuleArtifactV1, + withModuleArtifact, + InstrumentedModuleV(..), + imWasmVersion, + imWasmArtifact, -- *** Module interface - ModuleInterface(..) + ModuleInterface(..), + ModuleInterfaceV(..), + HasModuleRef(..), + HasEntrypoints(..) ) where @@ -32,22 +44,39 @@ foreign import ccall unsafe "&artifact_v0_free" freeArtifactV0 :: FunPtr (Ptr Mo foreign import ccall unsafe "artifact_v0_to_bytes" toBytesArtifactV0 :: Ptr ModuleArtifactV0 -> Ptr CSize -> IO (Ptr Word8) foreign import ccall unsafe "artifact_v0_from_bytes" fromBytesArtifactV0 :: Ptr Word8 -> CSize -> IO (Ptr ModuleArtifactV0) +foreign import ccall unsafe "&artifact_v1_free" freeArtifactV1 :: FunPtr (Ptr ModuleArtifactV1 -> IO ()) +foreign import ccall unsafe "artifact_v1_to_bytes" toBytesArtifactV1 :: Ptr ModuleArtifactV1 -> Ptr CSize -> IO (Ptr Word8) +foreign import ccall unsafe "artifact_v1_from_bytes" fromBytesArtifactV1 :: Ptr Word8 -> CSize -> IO (Ptr ModuleArtifactV1) + -- | A processed module artifact ready for execution. The actual module is -- allocated and stored on the Rust heap, in a reference counted pointer. -newtype ModuleArtifactV0 = ModuleArtifactV0 { maArtifactV0 :: ForeignPtr ModuleArtifactV0 } +newtype ModuleArtifact v = ModuleArtifact { maArtifact :: ForeignPtr (ModuleArtifact v) } deriving(Eq, Show) -- the Eq and Show instances are only for debugging and compare and show pointers. +data V0 +data V1 + +type ModuleArtifactV0 = ModuleArtifact V0 +type ModuleArtifactV1 = ModuleArtifact V1 + -- |Wrap the pointer to the module artifact together with a finalizer that will -- deallocate it when the module is no longer used. newModuleArtifactV0 :: Ptr ModuleArtifactV0 -> IO ModuleArtifactV0 newModuleArtifactV0 p = do - maArtifactV0 <- newForeignPtr freeArtifactV0 p - return ModuleArtifactV0{..} + maArtifact <- newForeignPtr freeArtifactV0 p + return ModuleArtifact{..} + +-- |Wrap the pointer to the module artifact together with a finalizer that will +-- deallocate it when the module is no longer used. +newModuleArtifactV1 :: Ptr ModuleArtifactV1 -> IO ModuleArtifactV1 +newModuleArtifactV1 p = do + maArtifact <- newForeignPtr freeArtifactV1 p + return ModuleArtifact{..} -- |Use the module artifact temporarily. The pointer must not be leaked from the -- computation. -withModuleArtifactV0 :: ModuleArtifactV0 -> (Ptr ModuleArtifactV0 -> IO a) -> IO a -withModuleArtifactV0 ModuleArtifactV0{..} = withForeignPtr maArtifactV0 +withModuleArtifact :: ModuleArtifact v -> (Ptr (ModuleArtifact v) -> IO a) -> IO a +withModuleArtifact ModuleArtifact{..} = withForeignPtr maArtifact instance Serialize ModuleArtifactV0 where get = do @@ -55,33 +84,80 @@ instance Serialize ModuleArtifactV0 where bs <- getByteString (fromIntegral len) case fromBytesHelper freeArtifactV0 fromBytesArtifactV0 bs of Nothing -> fail "Cannot decode module artifact." - Just maArtifactV0 -> return ModuleArtifactV0{..} + Just maArtifact -> return ModuleArtifact{..} - put ModuleArtifactV0{..} = - let bs = toBytesHelper toBytesArtifactV0 maArtifactV0 + put ModuleArtifact{..} = + let bs = toBytesHelper toBytesArtifactV0 maArtifact in putWord32be (fromIntegral (BS.length bs)) <> putByteString bs + +instance Serialize ModuleArtifactV1 where + get = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + case fromBytesHelper freeArtifactV1 fromBytesArtifactV1 bs of + Nothing -> fail "Cannot decode module artifact." + Just maArtifact -> return ModuleArtifact{..} + + put ModuleArtifact{..} = + let bs = toBytesHelper toBytesArtifactV1 maArtifact + in putWord32be (fromIntegral (BS.length bs)) <> putByteString bs + + -- |Web assembly module in binary format, instrumented with whatever it needs to -- be instrumented with, and preprocessed to an executable format, ready to be -- instantiated and run. -data InstrumentedModule = InstrumentedWasmModule { - -- |Version of the Wasm standard and on-chain API this module corresponds to. - imWasmVersion :: !Word32, - -- |Source in binary wasm format. - imWasmArtifact :: !ModuleArtifactV0 - } deriving(Eq, Show) +data InstrumentedModuleV v where + InstrumentedWasmModuleV0 :: { imWasmArtifactV0 :: ModuleArtifact V0 } -> InstrumentedModuleV V0 + InstrumentedWasmModuleV1 :: { imWasmArtifactV1 :: ModuleArtifact V1 } -> InstrumentedModuleV V1 + +deriving instance Eq (InstrumentedModuleV v) +deriving instance Show (InstrumentedModuleV v) + +-- This is just an internal helper +data InstrumentedModule where + IWMV0 :: { imwArtifactV0 :: ModuleArtifact V0 } -> InstrumentedModule + IWMV1 :: { imwArtifactV1 :: ModuleArtifact V1 } -> InstrumentedModule instance Serialize InstrumentedModule where - put InstrumentedWasmModule{..} = do - putWord32be imWasmVersion - put imWasmArtifact + put IWMV0{..} = do + putWord32be 0 + put imwArtifactV0 + put IWMV1{..} = do + putWord32be 1 + put imwArtifactV1 - get = InstrumentedWasmModule <$> getWord32be <*> get + get = getWord32be >>= \case + 0 -> IWMV0 <$> get + 1 -> IWMV1 <$> get + _ -> fail "Unsupported Wasm module version." + +imWasmVersion :: InstrumentedModuleV v -> Word32 +imWasmVersion (InstrumentedWasmModuleV0 _) = 0 +imWasmVersion (InstrumentedWasmModuleV1 _) = 1 + +instance Serialize (InstrumentedModuleV V0) where + put InstrumentedWasmModuleV0{..} = do + putWord32be 0 + put imWasmArtifactV0 + + get = getWord32be >>= \case + 0 -> InstrumentedWasmModuleV0 <$> get + _ -> fail "Unsupported Wasm module version." + +instance Serialize (InstrumentedModuleV V1) where + put InstrumentedWasmModuleV1{..} = do + putWord32be 1 + put imWasmArtifactV1 + + get = getWord32be >>= \case + 1 -> InstrumentedWasmModuleV1 <$> get + _ -> fail "Unsupported Wasm module version." -------------------------------------------------------------------------------- -- |A Wasm module interface with exposed entry-points. -data ModuleInterface = ModuleInterface { +data ModuleInterfaceV v = ModuleInterface { -- |Reference of the module on the chain. miModuleRef :: !ModuleRef, -- |Init methods exposed by this module. @@ -91,21 +167,79 @@ data ModuleInterface = ModuleInterface { -- They should each be exposed with a type Amount -> Word32 miExposedReceive :: !(Map.Map InitName (Set.Set ReceiveName)), -- |Module source in binary format, instrumented with whatever it needs to be instrumented with. - miModule :: !InstrumentedModule, + miModule :: !(InstrumentedModuleV v), miModuleSize :: !Word64 } deriving(Eq, Show) -instance Serialize ModuleInterface where +imWasmArtifact :: ModuleInterfaceV v -> ModuleArtifact v +imWasmArtifact ModuleInterface{miModule = InstrumentedWasmModuleV0{..}} = imWasmArtifactV0 +imWasmArtifact ModuleInterface{miModule = InstrumentedWasmModuleV1{..}} = imWasmArtifactV1 + +class HasModuleRef a where + moduleReference :: a -> ModuleRef + +class HasEntrypoints a where + exposedInit :: a -> Set.Set InitName + exposedReceive :: a -> Map.Map InitName (Set.Set ReceiveName) + +instance HasEntrypoints (ModuleInterfaceV v) where + exposedInit ModuleInterface{..} = miExposedInit + exposedReceive ModuleInterface{..} = miExposedReceive + +instance HasModuleRef (ModuleInterfaceV v) where + {-# INLINE moduleReference #-} + moduleReference = miModuleRef + +data ModuleInterface where + ModuleInterfaceV0 :: ModuleInterfaceV V0 -> ModuleInterface + ModuleInterfaceV1 :: ModuleInterfaceV V1 -> ModuleInterface + deriving (Eq, Show) + +instance HasModuleRef ModuleInterface where + {-# INLINE moduleReference #-} + moduleReference (ModuleInterfaceV0 mi) = miModuleRef mi + moduleReference (ModuleInterfaceV1 mi) = miModuleRef mi + +instance HasEntrypoints ModuleInterface where + exposedInit (ModuleInterfaceV0 m) = exposedInit m + exposedInit (ModuleInterfaceV1 m) = exposedInit m + exposedReceive (ModuleInterfaceV0 m) = miExposedReceive m + exposedReceive (ModuleInterfaceV1 m) = miExposedReceive m + +instance Serialize (InstrumentedModuleV v) => Serialize (ModuleInterfaceV v) where get = do miModuleRef <- get miExposedInit <- getSafeSetOf get miExposedReceive <- getSafeMapOf get (getSafeSetOf get) miModule <- get miModuleSize <- getWord64be - return ModuleInterface {..} + return ModuleInterface{..} put ModuleInterface{..} = do put miModuleRef putSafeSetOf put miExposedInit putSafeMapOf put (putSafeSetOf put) miExposedReceive put miModule putWord64be miModuleSize + +instance Serialize ModuleInterface where + get = do + miModuleRef <- get + miExposedInit <- getSafeSetOf get + miExposedReceive <- getSafeMapOf get (getSafeSetOf get) + miModuleV <- get + miModuleSize <- getWord64be + case miModuleV of + IWMV0 imWasmArtifactV0 -> return (ModuleInterfaceV0 ModuleInterface{miModule = InstrumentedWasmModuleV0 {..},..}) + IWMV1 imWasmArtifactV1 -> return (ModuleInterfaceV1 ModuleInterface{miModule = InstrumentedWasmModuleV1 {..},..}) + put (ModuleInterfaceV0 ModuleInterface{..}) = do + put miModuleRef + putSafeSetOf put miExposedInit + putSafeMapOf put (putSafeSetOf put) miExposedReceive + put miModule + putWord64be miModuleSize + put (ModuleInterfaceV1 ModuleInterface{..}) = do + put miModuleRef + putSafeSetOf put miExposedInit + putSafeMapOf put (putSafeSetOf put) miExposedReceive + put miModule + putWord64be miModuleSize diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 3ec16b702e..f7ea91c9f9 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -39,7 +39,7 @@ module Concordium.Scheduler ) where import qualified Concordium.GlobalState.Wasm as GSWasm import qualified Concordium.Wasm as Wasm -import qualified Concordium.Scheduler.WasmIntegration as Wasm +import qualified Concordium.Scheduler.WasmIntegration as WasmV0 import Concordium.Scheduler.Types import Concordium.Scheduler.Environment import Data.Time @@ -519,7 +519,7 @@ handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransfer usedEnergy) -- | Handle the deployment of a module. -handleDeployModule :: +handleDeployModule :: forall pv m . SchedulerMonad pv m => WithDepositContext m -> Wasm.WasmModule -- ^The module to deploy. @@ -535,21 +535,24 @@ handleDeployModule wtc mod = psize = Wasm.moduleSourceLength . Wasm.wasmSource $ mod c = do - tickEnergy (Cost.deployModuleCost psize) - case Wasm.processModule mod of - Nothing -> rejectTransaction ModuleNotWF - Just iface -> do - let mhash = GSWasm.miModuleRef iface - exists <- isJust <$> getModuleInterfaces mhash - when exists $ rejectTransaction (ModuleHashAlreadyExists mhash) - return ((iface, mod), mhash) + if demoteProtocolVersion (protocolVersion @pv) <= P3 then do + tickEnergy (Cost.deployModuleCost psize) + case WasmV0.processModule mod of + Nothing -> rejectTransaction ModuleNotWF + Just iface -> do + let mhash = GSWasm.moduleReference iface + exists <- isJust <$> getModuleInterfaces mhash + when exists $ rejectTransaction (ModuleHashAlreadyExists mhash) + return (iface, mhash) + else + rejectTransaction ModuleNotWF -- TODO: Handle P4 here k ls (iface, mhash) = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) chargeExecutionCost txHash senderAccount energyCost -- Add the module to the global state (module interface, value interface and module itself). -- We know the module does not exist at this point, so we can ignore the return value. - _ <- commitModule iface + _ <- commitModule (GSWasm.ModuleInterfaceV0 iface, mod) return (TxSuccess [ModuleDeployed mhash], energyCost, usedEnergy) -- | Tick energy for storing the given contract state. @@ -573,7 +576,9 @@ getCurrentContractInstanceTicking cref = do inst <- getCurrentContractInstance cref `rejectingWith` (InvalidContractAddress cref) -- Compute the size of the contract state value and charge for the lookup based on this size. -- This uses the 'ResourceMeasure' instance for 'Cost.LookupByteSize' to determine the cost for lookup. - tickEnergy (Cost.lookupContractState $ Wasm.contractStateSize (Ins.instanceModel inst)) + case inst of + InstanceV0 iv -> tickEnergy (Cost.lookupContractState $ Wasm.contractStateSize (Ins._instanceVModel iv)) + InstanceV1 iv -> error "TODO" return inst -- | Handle the initialization of a contract instance. @@ -604,34 +609,38 @@ handleInitContract wtc initAmount modref initName param = unless (senderAmount >= initAmount) $! rejectTransaction (AmountTooLarge (AddressAccount (thSender meta)) initAmount) -- First try to get the module interface of the parent module of the contract. - iface <- liftLocal (getModuleInterfaces modref) `rejectingWith` InvalidModuleReference modref - let iSize = GSWasm.miModuleSize iface - tickEnergy $ Cost.lookupModule iSize - - -- Then get the particular contract interface (in particular the type of the init method). - unless (Set.member initName (GSWasm.miExposedInit iface)) $ rejectTransaction $ InvalidInitMethod modref initName - - cm <- liftLocal getChainMetadata - -- Finally run the initialization function of the contract, resulting in an initial state - -- of the contract. This ticks energy during execution, failing when running out of energy. - -- NB: At this point the amount to initialize with has not yet been deducted from the - -- sender account. Thus if the initialization function were to observe the current balance it would - -- be amount - deposit. Currently this is in any case not exposed in contracts, but in case it - -- is in the future we should be mindful of which balance is exposed. - senderCredentials <- getAccountCredentials (snd senderAccount) - let initCtx = Wasm.InitContext{ - initOrigin = senderAddress, - icSenderPolicies = map (Wasm.mkSenderPolicy . snd) (OrdMap.toAscList senderCredentials) - } - result <- runInterpreter (return . Wasm.applyInitFun iface cm initCtx initName param initAmount) - `rejectingWith'` wasmRejectToRejectReasonInit - - -- Charge for storing the contract state. - tickEnergyStoreState (Wasm.newState result) - -- And for storing the instance. - tickEnergy Cost.initializeContractInstanceCreateCost - - return (iface, result) + viface <- liftLocal (getModuleInterfaces modref) `rejectingWith` InvalidModuleReference modref + case viface of + GSWasm.ModuleInterfaceV0 iface -> do + let iSize = GSWasm.miModuleSize iface + tickEnergy $ Cost.lookupModule iSize + + -- Then get the particular contract interface (in particular the type of the init method). + unless (Set.member initName (GSWasm.miExposedInit iface)) $ rejectTransaction $ InvalidInitMethod modref initName + + cm <- liftLocal getChainMetadata + -- Finally run the initialization function of the contract, resulting in an initial state + -- of the contract. This ticks energy during execution, failing when running out of energy. + -- NB: At this point the amount to initialize with has not yet been deducted from the + -- sender account. Thus if the initialization function were to observe the current balance it would + -- be amount - deposit. Currently this is in any case not exposed in contracts, but in case it + -- is in the future we should be mindful of which balance is exposed. + senderCredentials <- getAccountCredentials (snd senderAccount) + let initCtx = Wasm.InitContext{ + initOrigin = senderAddress, + icSenderPolicies = map (Wasm.mkSenderPolicy . snd) (OrdMap.toAscList senderCredentials) + } + result <- runInterpreter (return . WasmV0.applyInitFun iface cm initCtx initName param initAmount) + `rejectingWith'` wasmRejectToRejectReasonInit + + -- Charge for storing the contract state. + tickEnergyStoreState (Wasm.newState result) + -- And for storing the instance. + tickEnergy Cost.initializeContractInstanceCreateCost + + return (iface, result) + + GSWasm.ModuleInterfaceV1 miv -> error "TODO" k ls (iface, result) = do let model = Wasm.newState result @@ -715,7 +724,7 @@ handleMessage :: forall pv m. (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^The address that was used to send the top-level transaction. -> Instance -- ^The current state of the target contract of the transaction, which must exist. - -> Either (IndexedAccount m, Instance) (AccountAddress, IndexedAccount m) + -> Either (IndexedAccount m, InstanceV GSWasm.V0) (AccountAddress, IndexedAccount m) -- ^The sender of the message (contract instance or account). In case this is -- a contract the first parameter is the owner account of the instance. In case this is an account -- (i.e., this is called from a top-level transaction) the value is a pair of the address that was used @@ -727,74 +736,76 @@ handleMessage :: forall pv m. -> Wasm.ReceiveName -- ^Name of the contract to invoke. -> Wasm.Parameter -- ^Message to invoke the receive method with. -> m [Event] -- ^The events resulting from processing the message and all recursively processed messages. -handleMessage originAddr istance sender transferAmount receiveName parameter = do +handleMessage originAddr vistance sender transferAmount receiveName parameter = do -- Cover administrative costs. tickEnergy Cost.updateContractInstanceBaseCost - let model = instanceModel istance - -- Check whether the sender of the message has enough on its account/instance for the transfer. - -- If the amount is not sufficient, the top-level transaction is rejected. - -- Note that this returns the address that was used in the top-level transaction, or the contract address. - -- In the former case the credentials are credentials of the account, in the - -- latter they are credentials of the owner account. - (senderAddr, senderCredentials) <- mkSenderAddrCredentials sender - senderamount <- getCurrentAvailableAmount sender - unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) - - let iParams = instanceParameters istance - let cref = instanceAddress iParams - let receivefuns = instanceReceiveFuns . instanceParameters $ istance - unless (Set.member receiveName receivefuns) $ rejectTransaction $ - InvalidReceiveMethod (GSWasm.miModuleRef . instanceModuleInterface $ iParams) receiveName - -- Now we also check that the owner account of the receiver instance has at least one valid credential - -- and reject the transaction if not. - let ownerAccountAddress = instanceOwner iParams - -- The invariants maintained by global state should ensure that an owner account always exists. - -- However we are defensive here and reject the transaction instead of panicking in case it does not. - ownerAccount <- getStateAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress - cm <- getChainMetadata - - -- We have established that the owner account of the receiver instance has at least one valid credential. - let receiveCtx = Wasm.ReceiveContext { - invoker = originAddr, - selfAddress = cref, - selfBalance = instanceAmount istance, - sender = senderAddr, - owner = instanceOwner iParams, - rcSenderPolicies = map Wasm.mkSenderPolicy senderCredentials - } - -- Now run the receive function on the message. This ticks energy during execution, failing when running out of energy. - -- FIXME: Once errors can be caught in smart contracts update this to not terminate the transaction. - let iface = instanceModuleInterface iParams - -- charge for looking up the module - tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) - - result <- runInterpreter (return . Wasm.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) - `rejectingWith'` wasmRejectToRejectReasonReceive cref receiveName parameter - - -- If we reach here the contract accepted the message and returned a new state as well as outgoing messages. - let newModel = Wasm.newState result - txOut = Wasm.messages result - -- If we reached here we will charge for attempting to store this state. If - -- this message is part of a larger `and` composition then it is possible that - -- the contract will not actually be stored. We are not doing that because it - -- increases complexity and makes tracking of energy even less local than it - -- is now. - -- TODO We might want to change this behaviour to prevent charging for storage that is not done. - tickEnergyStoreState newModel - - -- Process the generated messages in the new context (transferred amount, updated state) in - -- sequence from left to right, depth first. - withToContractAmount sender istance transferAmount $ - withInstanceState istance newModel $ do - let initEvent = Updated{euAddress=cref, - euInstigator=senderAddr, - euAmount=transferAmount, - euMessage=parameter, - euReceiveName=receiveName, - euEvents = Wasm.logs result - } - foldEvents originAddr (ownerAccount, istance) initEvent txOut + case vistance of + InstanceV0 istance -> do + let model = _instanceVModel istance + -- Check whether the sender of the message has enough on its account/instance for the transfer. + -- If the amount is not sufficient, the top-level transaction is rejected. + -- Note that this returns the address that was used in the top-level transaction, or the contract address. + -- In the former case the credentials are credentials of the account, in the + -- latter they are credentials of the owner account. + (senderAddr, senderCredentials) <- mkSenderAddrCredentials sender + senderamount <- getCurrentAvailableAmount sender + unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) + + let iParams = _instanceVParameters istance + let cref = instanceAddress iParams + let receivefuns = instanceReceiveFuns . _instanceVParameters $ istance + unless (Set.member receiveName receivefuns) $ rejectTransaction $ + InvalidReceiveMethod (GSWasm.miModuleRef . instanceModuleInterface $ iParams) receiveName + -- Now we also check that the owner account of the receiver instance has at least one valid credential + -- and reject the transaction if not. + let ownerAccountAddress = instanceOwner iParams + -- The invariants maintained by global state should ensure that an owner account always exists. + -- However we are defensive here and reject the transaction instead of panicking in case it does not. + ownerAccount <- getStateAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress + cm <- getChainMetadata + + -- We have established that the owner account of the receiver instance has at least one valid credential. + let receiveCtx = Wasm.ReceiveContext { + invoker = originAddr, + selfAddress = cref, + selfBalance = _instanceVAmount istance, + sender = senderAddr, + owner = instanceOwner iParams, + rcSenderPolicies = map Wasm.mkSenderPolicy senderCredentials + } + -- Now run the receive function on the message. This ticks energy during execution, failing when running out of energy. + -- FIXME: Once errors can be caught in smart contracts update this to not terminate the transaction. + let iface = instanceModuleInterface iParams + -- charge for looking up the module + tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) + + result <- runInterpreter (return . WasmV0.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) + `rejectingWith'` wasmRejectToRejectReasonReceive cref receiveName parameter + + -- If we reach here the contract accepted the message and returned a new state as well as outgoing messages. + let newModel = Wasm.newState result + txOut = Wasm.messages result + -- If we reached here we will charge for attempting to store this state. If + -- this message is part of a larger `and` composition then it is possible that + -- the contract will not actually be stored. We are not doing that because it + -- increases complexity and makes tracking of energy even less local than it + -- is now. + -- TODO We might want to change this behaviour to prevent charging for storage that is not done. + tickEnergyStoreState newModel + + -- Process the generated messages in the new context (transferred amount, updated state) in + -- sequence from left to right, depth first. + withToContractAmountV0 sender istance transferAmount $ + withInstanceStateV0 istance newModel $ do + let initEvent = Updated{euAddress=cref, + euInstigator=senderAddr, + euAmount=transferAmount, + euMessage=parameter, + euReceiveName=receiveName, + euEvents = Wasm.logs result + } + foldEvents originAddr (ownerAccount, istance) initEvent txOut -- Cost of a step in the traversal of the actions tree. We need to charge for -- this separately to prevent problems with exponentially sized trees @@ -809,7 +820,7 @@ traversalStepCost = 10 foldEvents :: (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^Address that was used in the top-level transaction. - -> (IndexedAccount m, Instance) -- ^Instance that generated the events. + -> (IndexedAccount m, InstanceV GSWasm.V0) -- ^Instance that generated the events. -> Event -- ^Event generated by the invocation of the instance. -> Wasm.ActionsTree -- ^Actions to perform -> m [Event] -- ^List of events in order that transactions were traversed. @@ -837,12 +848,12 @@ foldEvents originAddr istance initEvent = fmap (initEvent:) . go go l `orElse` go r go Wasm.Accept = return [] -mkSenderAddrCredentials :: AccountOperations m => Either (IndexedAccount m, Instance) (AccountAddress, IndexedAccount m) -> m (Address, [ID.AccountCredential]) +mkSenderAddrCredentials :: AccountOperations m => Either (IndexedAccount m, InstanceV GSWasm.V0) (AccountAddress, IndexedAccount m) -> m (Address, [ID.AccountCredential]) mkSenderAddrCredentials sender = case sender of Left (ownerAccount, istance) -> do credentials <- getAccountCredentials (snd ownerAccount) - return (AddressContract (instanceAddress (instanceParameters istance)), map snd (OrdMap.toAscList credentials)) + return (AddressContract (instanceAddress (_instanceVParameters istance)), map snd (OrdMap.toAscList credentials)) Right (usedAddress, (_, acc)) -> do let addr = AddressAccount usedAddress credentials <- getAccountCredentials acc @@ -853,22 +864,22 @@ mkSenderAddrCredentials sender = handleTransferAccount :: TransactionMonad pv m => AccountAddress -- ^The target account address. - -> Instance -- ^The sender of this transfer. + -> InstanceV GSWasm.V0 -- ^The sender of this transfer. -> Amount -- ^The amount to transfer. -> m [Event] -- ^The events resulting from the transfer. handleTransferAccount accAddr senderInstance transferamount = do -- charge at the beginning, successful and failed transfers will have the same cost. tickEnergy Cost.simpleTransferCost -- Check whether the sender has the amount to be transferred and reject the transaction if not. - senderamount <- getCurrentContractAmount senderInstance - let addr = AddressContract (instanceAddress (instanceParameters senderInstance)) + senderamount <- getCurrentContractAmountV0 senderInstance + let addr = AddressContract (instanceAddress (_instanceVParameters senderInstance)) unless (senderamount >= transferamount) $! rejectTransaction (AmountTooLarge addr transferamount) -- Check whether target account exists and get it. targetAccount <- getStateAccount accAddr `rejectingWith` InvalidAccountReference accAddr -- Add the transfer to the current changeset and return the corresponding event. - withContractToAccountAmount senderInstance targetAccount transferamount $ + withContractToAccountAmountV0 senderInstance targetAccount transferamount $ return [Transferred addr transferamount (AddressAccount accAddr)] -- |Run the interpreter with the remaining amount of energy. If the interpreter diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index eff752dc41..995b23a781 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -287,11 +287,11 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- keep track of changes locally first, and only commit them at the end. -- Instance keeps track of its own address hence we need not provide it -- separately. - withInstanceState :: Instance -> Wasm.ContractState -> m a -> m a + withInstanceStateV0 :: InstanceV GSWasm.V0 -> Wasm.ContractState -> m a -> m a -- |Transfer amount from the first address to the second and run the -- computation in the modified environment. - withAccountToContractAmount :: IndexedAccount m -> Instance -> Amount -> m a -> m a + withAccountToContractAmountV0 :: IndexedAccount m -> InstanceV GSWasm.V0 -> Amount -> m a -> m a -- |Transfer an amount from the first account to the second and run the -- computation in the modified environment. @@ -299,11 +299,11 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Transfer an amount from the given instance to the given account and run the -- computation in the modified environment. - withContractToAccountAmount :: Instance -> IndexedAccount m -> Amount -> m a -> m a + withContractToAccountAmountV0 :: InstanceV GSWasm.V0 -> IndexedAccount m -> Amount -> m a -> m a -- |Transfer an amount from the first instance to the second and run the -- computation in the modified environment. - withContractToContractAmount :: Instance -> Instance -> Amount -> m a -> m a + withContractToContractAmountV0 :: InstanceV GSWasm.V0 -> InstanceV GSWasm.V0 -> Amount -> m a -> m a -- |Transfer a scheduled amount from the first address to the second and run -- the computation in the modified environment. @@ -335,16 +335,16 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Transfer an amount from the first given instance or account to the instance in the second -- parameter and run the computation in the modified environment. - {-# INLINE withToContractAmount #-} - withToContractAmount :: Either (IndexedAccount m, Instance) (AccountAddress, IndexedAccount m) -> Instance -> Amount -> m a -> m a - withToContractAmount (Left (_, i)) = withContractToContractAmount i - withToContractAmount (Right (_, a)) = withAccountToContractAmount a + {-# INLINE withToContractAmountV0 #-} + withToContractAmountV0 :: Either (IndexedAccount m, InstanceV GSWasm.V0) (AccountAddress, IndexedAccount m) -> InstanceV GSWasm.V0 -> Amount -> m a -> m a + withToContractAmountV0 (Left (_, i)) = withContractToContractAmountV0 i + withToContractAmountV0 (Right (_, a)) = withAccountToContractAmountV0 a getCurrentContractInstance :: ContractAddress -> m (Maybe Instance) {-# INLINE getCurrentAvailableAmount #-} - getCurrentAvailableAmount :: Either (IndexedAccount m, Instance) (AccountAddress, IndexedAccount m) -> m Amount - getCurrentAvailableAmount (Left (_, i)) = getCurrentContractAmount i + getCurrentAvailableAmount :: Either (IndexedAccount m, InstanceV GSWasm.V0) (AccountAddress, IndexedAccount m) -> m Amount + getCurrentAvailableAmount (Left (_, i)) = getCurrentContractAmountV0 i getCurrentAvailableAmount (Right (_, a)) = getCurrentAccountAvailableAmount a -- |Get an account with its state at the start of the transaction. @@ -362,7 +362,7 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - getCurrentAccountAvailableAmount :: IndexedAccount m -> m Amount -- |Same as above, but for contracts. - getCurrentContractAmount :: Instance -> m Amount + getCurrentContractAmountV0 :: InstanceV GSWasm.V0 -> m Amount -- |Get the amount of energy remaining for the transaction. getEnergy :: m (Energy, EnergyLimitReason) @@ -463,21 +463,21 @@ modifyAmountCS ai !amnt !cs = cs & (accountUpdates . ix ai . auAmount ) %~ -- |Add or update the contract state in the changeset with the given value. -- |NB: If the instance is not yet in the changeset we assume that its balance is -- as listed in the given instance structure. -addContractStatesToCS :: Instance -> Wasm.ContractState -> ChangeSet -> ChangeSet +addContractStatesToCS :: InstanceV GSWasm.V0 -> Wasm.ContractState -> ChangeSet -> ChangeSet addContractStatesToCS istance newState = instanceUpdates . at addr %~ \case Just (amnt, _) -> Just (amnt, newState) Nothing -> Just (0, newState) - where addr = instanceAddress . instanceParameters $ istance + where addr = instanceAddress istance -- |Add the given delta to the change set for the given contract instance. -- NB: If the contract is not yet in the changeset it is added, taking the -- model as given in the first argument to be current model (local state) -addContractAmountToCS :: Instance -> AmountDelta -> ChangeSet -> ChangeSet +addContractAmountToCS :: InstanceV GSWasm.V0 -> AmountDelta -> ChangeSet -> ChangeSet addContractAmountToCS istance amnt cs = - (cs & instanceUpdates . at addr %~ \case Just (d, v) -> Just (d + amnt, v) - Nothing -> Just (amnt, model)) - where addr = instanceAddress . instanceParameters $ istance - model = instanceModel istance + cs & instanceUpdates . at addr %~ \case Just (d, v) -> Just (d + amnt, v) + Nothing -> Just (amnt, model) + where addr = instanceAddress istance + model = istance ^. instanceModel -- |Add the given contract address to the set of initialized contract instances. -- As the changes on the blockstate are already performed in the handler for this operation, @@ -487,7 +487,7 @@ addContractAmountToCS istance amnt cs = addContractInitToCS :: Instance -> ChangeSet -> ChangeSet addContractInitToCS istance cs = cs { _instanceInits = HSet.insert addr (cs ^. instanceInits) } - where addr = instanceAddress . instanceParameters $ istance + where addr = instanceAddress istance -- |Whether the transaction energy limit is reached because of transaction max energy limit, -- or because of block energy limit @@ -711,8 +711,8 @@ instance StaticInformation m => StaticInformation (LocalT r m) where deriving via (MGSTrans (LocalT r) m) instance AccountOperations m => AccountOperations (LocalT r m) instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where - {-# INLINE withInstanceState #-} - withInstanceState istance val cont = do + {-# INLINE withInstanceStateV0 #-} + withInstanceStateV0 istance val cont = do changeSet %= addContractStatesToCS istance val cont @@ -723,21 +723,21 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where addAmountToCS fromAcc (amountDiff 0 amount)) cont - {-# INLINE withAccountToContractAmount #-} - withAccountToContractAmount fromAcc toAcc amount cont = do + {-# INLINE withAccountToContractAmountV0 #-} + withAccountToContractAmountV0 fromAcc toAcc amount cont = do cs <- changeSet <%= addContractAmountToCS toAcc (amountToDelta amount) changeSet <~ addAmountToCS fromAcc (amountDiff 0 amount) cs cont - {-# INLINE withContractToAccountAmount #-} - withContractToAccountAmount fromAcc toAcc amount cont = do + {-# INLINE withContractToAccountAmountV0 #-} + withContractToAccountAmountV0 fromAcc toAcc amount cont = do cs <- use changeSet cs' <- addAmountToCS toAcc (amountToDelta amount) cs changeSet .= addContractAmountToCS fromAcc (amountDiff 0 amount) cs' cont - {-# INLINE withContractToContractAmount #-} - withContractToContractAmount fromAcc toAcc amount cont = do + {-# INLINE withContractToContractAmountV0 #-} + withContractToContractAmountV0 fromAcc toAcc amount cont = do changeSet %= addContractAmountToCS toAcc (amountToDelta amount) changeSet %= addContractAmountToCS fromAcc (amountDiff 0 amount) cont @@ -827,10 +827,10 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where - max (oldLockedUp + newReleases) staked Nothing -> return $ netDeposit - max oldLockedUp staked - {-# INLINE getCurrentContractAmount #-} - getCurrentContractAmount inst = do - let amnt = instanceAmount inst - let addr = instanceAddress . instanceParameters $ inst + {-# INLINE getCurrentContractAmountV0 #-} + getCurrentContractAmountV0 inst = do + let amnt = inst ^. instanceAmount + let addr = instanceAddress inst use (changeSet . instanceUpdates . at addr) >>= \case Just (delta, _) -> return $! applyAmountDelta delta amnt Nothing -> return amnt diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration.hs index a38c9c1742..c85badef8a 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration.hs @@ -61,7 +61,7 @@ foreign import ccall "call_receive_v0" -- |Apply an init function which is assumed to be a part of the module. applyInitFun - :: ModuleInterface + :: ModuleInterfaceV V0 -> ChainMetadata -- ^Chain information available to the contracts. -> InitContext -- ^Additional parameters supplied by the chain and -- available to the init method. @@ -74,7 +74,7 @@ applyInitFun -- Just (result, remainingEnergy) otherwise, where @remainingEnergy@ is the amount of energy that is left from the amount given. applyInitFun miface cm initCtx iName param amnt iEnergy = processInterpreterResult (get :: Get ()) result where result = unsafePerformIO $ do - withModuleArtifactV0 wasmArtifact $ \wasmArtifactPtr -> + withModuleArtifact wasmArtifact $ \wasmArtifactPtr -> BSU.unsafeUseAsCStringLen initCtxBytes $ \(initCtxBytesPtr, initCtxBytesLen) -> BSU.unsafeUseAsCStringLen nameBytes $ \(nameBytesPtr, nameBytesLen) -> BSU.unsafeUseAsCStringLen paramBytes $ \(paramBytesPtr, paramBytesLen) -> @@ -91,7 +91,7 @@ applyInitFun miface cm initCtx iName param amnt iEnergy = processInterpreterResu len <- peek outputLenPtr bs <- BSU.unsafePackCStringFinalizer outPtr (fromIntegral len) (rs_free_array_len outPtr (fromIntegral len)) return (Just bs) - wasmArtifact = imWasmArtifact . miModule $ miface + wasmArtifact = imWasmArtifact miface initCtxBytes = encodeChainMeta cm <> encodeInitContext initCtx paramBytes = BSS.fromShort (parameter param) energy = fromIntegral iEnergy @@ -129,7 +129,7 @@ processInterpreterResult aDecoder result = case result of -- |Apply a receive function which is assumed to be part of the given module. applyReceiveFun - :: ModuleInterface + :: ModuleInterfaceV V0 -> ChainMetadata -- ^Metadata available to the contract. -> ReceiveContext -- ^Additional parameter supplied by the chain and -- available to the receive method. @@ -143,7 +143,7 @@ applyReceiveFun -- of execution with the amount of energy remaining. applyReceiveFun miface cm receiveCtx rName param amnt cs initialEnergy = processInterpreterResult getActionsTree result where result = unsafePerformIO $ do - withModuleArtifactV0 wasmArtifact $ \wasmArtifactPtr -> + withModuleArtifact wasmArtifact $ \wasmArtifactPtr -> BSU.unsafeUseAsCStringLen initCtxBytes $ \(initCtxBytesPtr, initCtxBytesLen) -> BSU.unsafeUseAsCStringLen nameBytes $ \(nameBytesPtr, nameBytesLen) -> BSU.unsafeUseAsCStringLen stateBytes $ \(stateBytesPtr, stateBytesLen) -> @@ -162,7 +162,7 @@ applyReceiveFun miface cm receiveCtx rName param amnt cs initialEnergy = process len <- peek outputLenPtr bs <- BSU.unsafePackCStringFinalizer outPtr (fromIntegral len) (rs_free_array_len outPtr (fromIntegral len)) return (Just bs) - wasmArtifact = imWasmArtifact . miModule $ miface + wasmArtifact = imWasmArtifact miface initCtxBytes = encodeChainMeta cm <> encodeReceiveContext receiveCtx amountWord = _amount amnt stateBytes = contractState cs @@ -177,17 +177,15 @@ applyReceiveFun miface cm receiveCtx rName param amnt cs initialEnergy = process -- compilation or instrumentation) that is needed to apply the exported -- functions from it in an efficient way. {-# NOINLINE processModule #-} -processModule :: WasmModule -> Maybe ModuleInterface +processModule :: WasmModule -> Maybe (ModuleInterfaceV V0) processModule modl = do - (bs, imWasmArtifact) <- ffiResult + guard (wasmVersion modl == 0) + (bs, imWasmArtifactV0) <- ffiResult case getExports bs of Left _ -> Nothing Right (miExposedInit, miExposedReceive) -> let miModuleRef = getModuleRef modl - miModule = InstrumentedWasmModule{ - imWasmVersion = wasmVersion modl, - .. - } + miModule = InstrumentedWasmModuleV0{..} in Just ModuleInterface{miModuleSize = moduleSourceLength $ wasmSource modl,..} where ffiResult = unsafePerformIO $ do From 84d501e102f399f2c9c7b6771e8a4ab033f1a433 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Sun, 12 Dec 2021 18:18:41 +0100 Subject: [PATCH 02/51] WIP: Introduce handling of init V1 contracts. --- concordium-consensus/smart-contracts | 2 +- .../GlobalState/Persistent/BlobStore.hs | 7 + .../GlobalState/Persistent/BlockState.hs | 31 ++- .../Persistent/BlockState/Modules.hs | 17 +- .../GlobalState/Persistent/Instances.hs | 196 ++++++++++++------ .../src/Concordium/Scheduler.hs | 59 +++++- 6 files changed, 237 insertions(+), 75 deletions(-) diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 7dd0ca7bb8..3fae957d6e 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 7dd0ca7bb8465e20790190b09cbb1dbf819550ed +Subproject commit 3fae957d6ea5ec3f71ee71a981c3d5ee79d7cd7d diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index 1d615cb34c..a2c25e44ef 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -31,6 +31,7 @@ module Concordium.GlobalState.Persistent.BlobStore where import Control.Concurrent.MVar import System.IO import Data.Serialize +import Data.Coerce import Data.Word import qualified Data.ByteString as BS import Control.Exception @@ -385,6 +386,12 @@ data BufferedRef a -- that inherited its parent's state) we can store the pointer to the 'brValue' data rather than -- storing all of the data again. +-- |Coerce one buffered ref to another. This is unsafe unless a and b have compatible +-- blobstorable instances. +unsafeCoerceBufferedRef :: (a -> b) -> BufferedRef a -> BufferedRef b +unsafeCoerceBufferedRef _ (BRBlobbed br) = BRBlobbed (coerce br) +unsafeCoerceBufferedRef f (BRMemory ioref val) = BRMemory (coerce ioref) (f val) + -- | Create a @BRMemory@ value in a @MonadIO@ context with the provided values makeBRMemory :: MonadIO m => (BlobRef a) -> a -> m (BufferedRef a) makeBRMemory r a = liftIO $ do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index f568657ee2..44a2e9a95f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -58,7 +58,7 @@ import qualified Concordium.GlobalState.Persistent.Instances as Instances import qualified Concordium.Types.Transactions as Transactions import qualified Concordium.Types.Execution as Transactions import Concordium.GlobalState.Persistent.Instances(PersistentInstance(..), PersistentInstanceV(..), PersistentInstanceParameters(..)) -import Concordium.GlobalState.Instance (Instance(..), InstanceV(..), InstanceParameters(..),makeInstanceHash') +import Concordium.GlobalState.Instance (Instance(..), InstanceV(..), InstanceParameters(..),makeInstanceHash', instanceAddress) import Concordium.GlobalState.Persistent.Account import Concordium.GlobalState.Persistent.BlockState.Updates import qualified Concordium.GlobalState.Basic.BlockState.Account as TransientAccount @@ -269,7 +269,7 @@ type PersistentBlockState (pv :: ProtocolVersion) = IORef (BufferedRef (BlockSta -- version. data BlockStatePointers (pv :: ProtocolVersion) = BlockStatePointers { bspAccounts :: !(Accounts.Accounts pv), - bspInstances :: !Instances.Instances, + bspInstances :: !(Instances.Instances pv), bspModules :: !(HashedBufferedRef Modules.Modules), bspBank :: !(Hashed Rewards.BankStatus), bspIdentityProviders :: !(HashedBufferedRef IPS.IdentityProviders), @@ -973,13 +973,13 @@ doPutNewInstance pbs fnew = do mods <- refLoad (bspModules bsp) -- Create the instance (inst, insts) <- Instances.newContractInstance (fnew' mods) (bspInstances bsp) - let ca = _instanceAddress (_instanceVParameters inst) + let ca = instanceAddress inst (ca,) <$> storePBS pbs bsp{bspInstances = insts} where fnew' mods ca = case fnew ca of - InstanceV0 inst@InstanceV{_instanceVParameters = InstanceParameters{..}, ..} -> do + inst@(InstanceV0 InstanceV{_instanceVParameters = InstanceParameters{..}, ..}) -> do params <- makeBufferedRef $ PersistentInstanceParameters { pinstanceAddress = _instanceAddress, pinstanceOwner = instanceOwner, @@ -990,7 +990,8 @@ doPutNewInstance pbs fnew = do } -- This in an irrefutable pattern because otherwise it would have failed in previous stages -- as it would be trying to create an instance of a module that doesn't exist. - ~(Just modRef) <- undefined -- TODO: FIX signature of putnewinstance Modules.getModuleReference (GSWasm.miModuleRef instanceModuleInterface) mods + -- TODO: FIX signature of putnewinstance + ~(Just modRef) <- Modules.unsafeGetModuleReferenceV0 (GSWasm.miModuleRef instanceModuleInterface) mods return (inst, PersistentInstanceV0 Instances.PersistentInstanceV{ pinstanceParameters = params, pinstanceModuleInterface = modRef, @@ -998,6 +999,26 @@ doPutNewInstance pbs fnew = do pinstanceAmount = _instanceVAmount, pinstanceHash = _instanceVHash }) + inst@(InstanceV1 InstanceV{_instanceVParameters = InstanceParameters{..}, ..}) -> do + params <- makeBufferedRef $ PersistentInstanceParameters { + pinstanceAddress = _instanceAddress, + pinstanceOwner = instanceOwner, + pinstanceContractModule = GSWasm.miModuleRef instanceModuleInterface, + pinstanceReceiveFuns = instanceReceiveFuns, + pinstanceInitName = instanceInitName, + pinstanceParameterHash = instanceParameterHash + } + -- This in an irrefutable pattern because otherwise it would have failed in previous stages + -- as it would be trying to create an instance of a module that doesn't exist. + -- TODO: FIX signature of putnewinstance + ~(Just modRef) <- Modules.unsafeGetModuleReferenceV1 (GSWasm.miModuleRef instanceModuleInterface) mods + return (inst, PersistentInstanceV1 Instances.PersistentInstanceV{ + pinstanceParameters = params, + pinstanceModuleInterface = modRef, + pinstanceModel = _instanceVModel, + pinstanceAmount = _instanceVAmount, + pinstanceHash = _instanceVHash + }) doModifyInstance :: (IsProtocolVersion pv, MonadBlobStore m) => PersistentBlockState pv -> ContractAddress -> AmountDelta -> Wasm.ContractState -> m (PersistentBlockState pv) doModifyInstance pbs caddr deltaAmnt val = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs index f4309af355..73e18f62d8 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs @@ -10,6 +10,8 @@ module Concordium.GlobalState.Persistent.BlockState.Modules getInterface, getSource, getModuleReference, + unsafeGetModuleReferenceV0, + unsafeGetModuleReferenceV1, putInterface, moduleRefList, makePersistentModules, @@ -110,7 +112,7 @@ instance Serialize (ModuleV GSWasm.V0) where moduleVInterface <- get moduleVSource <- get return $! ModuleV {..} - put m = put m + put ModuleV{..} = put moduleVInterface <> put moduleVSource -- |This serialization is used for storing the module in the BlobStore. -- It should not be used for other purposes. @@ -120,7 +122,7 @@ instance Serialize (ModuleV GSWasm.V1) where moduleVInterface <- get moduleVSource <- get return $! ModuleV {..} - put m = put m + put ModuleV{..} = put moduleVInterface <> put moduleVSource instance MonadBlobStore m => BlobStorable m (ModuleV GSWasm.V0) where @@ -205,6 +207,17 @@ getModuleReference ref mods = Nothing -> return Nothing Just idx -> fmap bufferedReference <$> LFMB.lookupRef idx (mods ^. modulesTable) +-- |Gets the buffered reference to a module as stored in the module table assuming it is version 0. +unsafeGetModuleReferenceV0 :: MonadBlobStore m => ModuleRef -> Modules -> m (Maybe (BufferedRef (ModuleV GSWasm.V0))) +unsafeGetModuleReferenceV0 ref mods = fmap (unsafeCoerceBufferedRef extract) <$> getModuleReference ref mods + where extract (ModuleV0 m) = m + extract _ = error "Precondition violation." +-- |Gets the buffered reference to a module as stored in the module table assuming it is version 0. +unsafeGetModuleReferenceV1 :: MonadBlobStore m => ModuleRef -> Modules -> m (Maybe (BufferedRef (ModuleV GSWasm.V1))) +unsafeGetModuleReferenceV1 ref mods = fmap (unsafeCoerceBufferedRef extract) <$> getModuleReference ref mods + where extract (ModuleV1 m) = m + extract _ = error "Precondition violation." + -- |Get an interface by module reference. getInterface :: MonadBlobStore m diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs index 6cbeca93ee..dec7fef125 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs @@ -3,6 +3,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} module Concordium.GlobalState.Persistent.Instances where import Data.Word @@ -11,6 +13,7 @@ import Control.Monad import Control.Monad.Reader import Data.Serialize import Data.Bits +import Data.Bifunctor (second) import qualified Data.Set as Set import Control.Exception @@ -89,57 +92,91 @@ data PersistentInstanceV v = PersistentInstanceV { pinstanceHash :: H.Hash } -data PersistentInstance where - PersistentInstanceV0 :: PersistentInstanceV GSWasm.V0 -> PersistentInstance - PersistentInstanceV1 :: PersistentInstanceV GSWasm.V1 -> PersistentInstance +data PersistentInstance (pv :: ProtocolVersion) where + PersistentInstanceV0 :: PersistentInstanceV GSWasm.V0 -> PersistentInstance pv + PersistentInstanceV1 :: PersistentInstanceV GSWasm.V1 -> PersistentInstance pv -instance Show PersistentInstance where +instance Show (PersistentInstance pv) where show (PersistentInstanceV0 PersistentInstanceV {..}) = show pinstanceParameters ++ " {balance=" ++ show pinstanceAmount ++ ", model=" ++ show pinstanceModel ++ "}" show (PersistentInstanceV1 PersistentInstanceV {..}) = show pinstanceParameters ++ " {balance=" ++ show pinstanceAmount ++ ", model=" ++ show pinstanceModel ++ "}" -loadInstanceParameters :: MonadBlobStore m => PersistentInstance -> m PersistentInstanceParameters +loadInstanceParameters :: MonadBlobStore m => PersistentInstance pv -> m PersistentInstanceParameters loadInstanceParameters (PersistentInstanceV0 PersistentInstanceV {..}) = loadBufferedRef pinstanceParameters loadInstanceParameters (PersistentInstanceV1 PersistentInstanceV {..}) = loadBufferedRef pinstanceParameters -cacheInstanceParameters :: MonadBlobStore m => PersistentInstance -> m (PersistentInstanceParameters, BufferedRef PersistentInstanceParameters) +cacheInstanceParameters :: MonadBlobStore m => PersistentInstance pv -> m (PersistentInstanceParameters, BufferedRef PersistentInstanceParameters) cacheInstanceParameters (PersistentInstanceV0 PersistentInstanceV {..}) = cacheBufferedRef pinstanceParameters cacheInstanceParameters (PersistentInstanceV1 PersistentInstanceV {..}) = cacheBufferedRef pinstanceParameters -loadInstanceModule :: MonadBlobStore m => PersistentInstance -> m Module +loadInstanceModule :: MonadBlobStore m => PersistentInstance pv -> m Module loadInstanceModule (PersistentInstanceV0 PersistentInstanceV {..}) = ModuleV0 <$> loadBufferedRef pinstanceModuleInterface loadInstanceModule (PersistentInstanceV1 PersistentInstanceV {..}) = ModuleV1 <$> loadBufferedRef pinstanceModuleInterface -instance HashableTo H.Hash PersistentInstance where +instance HashableTo H.Hash (PersistentInstance pv) where getHash (PersistentInstanceV0 PersistentInstanceV{..})= pinstanceHash getHash (PersistentInstanceV1 PersistentInstanceV{..})= pinstanceHash --- FIXME: There is no way to retrofit this to two module versions since -instance MonadBlobStore m => BlobStorable m PersistentInstance where - storeUpdate (PersistentInstanceV0 PersistentInstanceV{..}) = do - (pparams, newParameters) <- storeUpdate pinstanceParameters - (pinterface, newpInterface) <- storeUpdate pinstanceModuleInterface - let putInst = do - pparams - pinterface - put pinstanceModel - put pinstanceAmount - return (putInst, PersistentInstanceV0 (PersistentInstanceV{pinstanceParameters = newParameters, pinstanceModuleInterface = newpInterface, ..})) +-- In protocol versions 1, 2, 3 there was only a single instance type. Since +-- there is no accessible versioning when loading the persistent instance, to +-- decide whether we are loading instance V0 or instance V1, we essentially have +-- two implementations of BlobStorable. One for protocol versions <= P3, and +-- another one for later protocol versions. The latter ones add versioning information. +instance (IsProtocolVersion pv, MonadBlobStore m) => BlobStorable m (PersistentInstance pv) where + storeUpdate inst = do + if demoteProtocolVersion (protocolVersion @pv) <= P3 then + case inst of + PersistentInstanceV0 i -> second PersistentInstanceV0 <$> storeUnversioned i + PersistentInstanceV1 i -> second PersistentInstanceV1 <$> storeUnversioned i + else case inst of + PersistentInstanceV0 i -> addVersion 0 PersistentInstanceV0 <$> storeUnversioned i + PersistentInstanceV1 i -> addVersion 1 PersistentInstanceV1 <$> storeUnversioned i + where storeUnversioned PersistentInstanceV{..} = do + (pparams, newParameters) <- storeUpdate pinstanceParameters + (pinterface, newpInterface) <- storeUpdate pinstanceModuleInterface + let putInst = do + pparams + pinterface + put pinstanceModel + put pinstanceAmount + return (putInst, PersistentInstanceV{pinstanceParameters = newParameters, pinstanceModuleInterface = newpInterface, ..}) + addVersion v f (s, inst') = (putWord8 v <> s, f inst') + store pinst = fst <$> storeUpdate pinst load = do - rparams <- load - rInterface <- load - pinstanceModel <- get - pinstanceAmount <- get - return $ do - pinstanceParameters <- rparams - pinstanceModuleInterface <- rInterface - pip <- loadBufferedRef pinstanceParameters - let pinstanceHash = makeInstanceHash pip pinstanceModel pinstanceAmount - return $! PersistentInstanceV0 (PersistentInstanceV {..}) + if demoteProtocolVersion (protocolVersion @pv) <= P3 then do + loadIV0 + else + getWord8 >>= \case + 0 -> loadIV0 + 1 -> loadIV1 + n -> error $ "Unsupported persistent instance version " ++ show n + where + loadIV0 = do + rparams <- load + rInterface <- load + pinstanceModel <- get + pinstanceAmount <- get + return $ do + pinstanceParameters <- rparams + pinstanceModuleInterface <- rInterface + pip <- loadBufferedRef pinstanceParameters + let pinstanceHash = makeInstanceHash pip pinstanceModel pinstanceAmount + return $! PersistentInstanceV0 (PersistentInstanceV {..}) + loadIV1 = do + rparams <- load + rInterface <- load + pinstanceModel <- get + pinstanceAmount <- get + return $ do + pinstanceParameters <- rparams + pinstanceModuleInterface <- rInterface + pip <- loadBufferedRef pinstanceParameters + let pinstanceHash = makeInstanceHash pip pinstanceModel pinstanceAmount + return $! PersistentInstanceV1 (PersistentInstanceV {..}) -- This cacheable instance is a bit unusual. Caching instances requires us to have access -- to the modules so that we can share the module interfaces from different instances. -instance MonadBlobStore m => Cacheable (ReaderT Modules m) PersistentInstance where +instance MonadBlobStore m => Cacheable (ReaderT Modules m) (PersistentInstance pv) where cache (PersistentInstanceV0 p@PersistentInstanceV{..}) = do modules <- ask lift $! do @@ -150,12 +187,26 @@ instance MonadBlobStore m => Cacheable (ReaderT Modules m) PersistentInstance wh ips <- cache pinstanceParameters params <- loadBufferedRef ips let modref = pinstanceContractModule params - miface <- undefined -- FIXME: Modules.getModuleReference modref modules + miface <- Modules.unsafeGetModuleReferenceV0 modref modules case miface of Nothing -> return (PersistentInstanceV0 p{pinstanceParameters = ips}) -- this case should never happen, but it is safe to do this. Just iface -> return (PersistentInstanceV0 p{pinstanceModuleInterface = iface, pinstanceParameters = ips}) + cache (PersistentInstanceV1 p@PersistentInstanceV{..}) = do + modules <- ask + lift $! do + -- we only cache parameters and get the interface from the modules + -- table. The rest is already in memory at this point since the + -- fields are flat, i.e., without indirection via BufferedRef or + -- similar reference wrappers. + ips <- cache pinstanceParameters + params <- loadBufferedRef ips + let modref = pinstanceContractModule params + miface <- Modules.unsafeGetModuleReferenceV1 modref modules + case miface of + Nothing -> return (PersistentInstanceV1 p{pinstanceParameters = ips}) -- this case should never happen, but it is safe to do this. + Just iface -> return (PersistentInstanceV1 p{pinstanceModuleInterface = iface, pinstanceParameters = ips}) -fromPersistentInstance :: MonadBlobStore m => PersistentInstance -> m Transient.Instance +fromPersistentInstance :: MonadBlobStore m => PersistentInstance pv -> m Transient.Instance fromPersistentInstance pinst = do PersistentInstanceParameters{..} <- loadInstanceParameters pinst instanceModuleInterface <- getModuleInterface <$> loadInstanceModule pinst @@ -240,7 +291,7 @@ makeBranchHash h1 h2 = H.hashShort $! (H.hashToShortByteString h1 <> H.hashToSho -- * The hash is @computeBranchHash l r@ where @l@ and @r@ are the left and right subtrees -- * The first @Bool@ is @True@ if the tree is full, i.e. the right sub-tree is full with height 1 less than the parent -- * The second @Bool@ is @True@ if the either subtree has vacant leaves -data IT r +data IT pv r -- |A branch has the following fields: -- * the height of the branch (0 if all children are leaves) -- * whether the branch is a full binary tree @@ -256,31 +307,31 @@ data IT r branchRight :: r } -- |A leaf holds a contract instance - | Leaf !PersistentInstance + | Leaf !(PersistentInstance pv) -- |A vacant leaf records the 'ContractSubindex' of the last instance -- with this 'ContractIndex'. | VacantLeaf !ContractSubindex deriving (Show, Functor, Foldable, Traversable) -showITString :: IT String -> String +showITString :: IT pv String -> String showITString (Branch h _ _ _ l r) = show h ++ ":(" ++ l ++ ", " ++ r ++ ")" showITString (Leaf i) = show i showITString (VacantLeaf si) = "[Vacant " ++ show si ++ "]" -hasVacancies :: IT r -> Bool +hasVacancies :: IT pv r -> Bool hasVacancies Branch{..} = branchHasVacancies hasVacancies Leaf{} = False hasVacancies VacantLeaf{} = True -isFull :: IT r -> Bool +isFull :: IT pv r -> Bool isFull Branch{..} = branchFull isFull _ = True -nextHeight :: IT r -> Word8 +nextHeight :: IT pv r -> Word8 nextHeight Branch{..} = branchHeight + 1 nextHeight _ = 0 -instance HashableTo H.Hash (IT r) where +instance HashableTo H.Hash (IT pv r) where getHash (Branch {..}) = branchHash getHash (Leaf i) = getHash i getHash (VacantLeaf si) = H.hash $ runPut $ put si @@ -289,7 +340,7 @@ conditionalSetBit :: (Bits a) => Int -> Bool -> a -> a conditionalSetBit _ False x = x conditionalSetBit b True x = setBit x b -instance (BlobStorable m r, MonadIO m) => BlobStorable m (IT r) where +instance (IsProtocolVersion pv, BlobStorable m r, MonadIO m) => BlobStorable m (IT pv r) where storeUpdate (Branch {..}) = do (pl, l') <- storeUpdate branchLeft (pr, r') <- storeUpdate branchRight @@ -319,24 +370,24 @@ instance (BlobStorable m r, MonadIO m) => BlobStorable m (IT r) where else -- tag == 9 return . VacantLeaf <$> get -mapReduceIT :: forall a m t. (Monoid a, MRecursive m t, Base t ~ IT) => (Either ContractAddress PersistentInstance -> m a) -> t -> m a +mapReduceIT :: forall a m pv t. (Monoid a, MRecursive m t, Base t ~ IT pv) => (Either ContractAddress (PersistentInstance pv) -> m a) -> t -> m a mapReduceIT mfun = mr 0 <=< mproject where - mr :: ContractIndex -> IT t -> m a + mr :: ContractIndex -> IT pv t -> m a mr lowIndex (Branch hgt _ _ _ l r) = liftM2 (<>) (mr lowIndex =<< mproject l) (mr (setBit lowIndex (fromIntegral hgt)) =<< mproject r) mr _ (Leaf i) = mfun (Right i) mr lowIndex (VacantLeaf si) = mfun (Left (ContractAddress lowIndex si)) -makeBranch :: Word8 -> Bool -> IT t -> IT t -> t -> t -> IT t +makeBranch :: Word8 -> Bool -> IT pv t -> IT pv t -> t -> t -> IT pv t makeBranch branchHeight branchFull l r branchLeft branchRight = Branch{..} where branchHasVacancies = hasVacancies l || hasVacancies r branchHash = makeBranchHash (getHash l) (getHash r) -newContractInstanceIT :: forall m t a. (MRecursive m t, MCorecursive m t, Base t ~ IT) => (ContractAddress -> m (a, PersistentInstance)) -> t -> m (a, t) +newContractInstanceIT :: forall m pv t a. (MRecursive m t, MCorecursive m t, Base t ~ IT pv) => (ContractAddress -> m (a, PersistentInstance pv)) -> t -> m (a, t) newContractInstanceIT mk t0 = (\(res, v) -> (res,) <$> membed v) =<< nci 0 t0 =<< mproject t0 where - nci :: ContractIndex -> t -> IT t -> m (a, IT t) + nci :: ContractIndex -> t -> IT pv t -> m (a, IT pv t) -- Insert into a tree with vacancies: insert in left if it has vacancies, otherwise right nci offset _ (Branch h f True _ l r) = do projl <- mproject l @@ -373,21 +424,21 @@ newContractInstanceIT mk t0 = (\(res, v) -> (res,) <$> membed v) =<< nci 0 t0 =< return (res, Leaf c) -data Instances +data Instances pv -- |The empty instance table = InstancesEmpty -- |A non-empty instance table (recording the size) - | InstancesTree !Word64 !(BufferedBlobbed BlobRef IT) + | InstancesTree !Word64 !(BufferedBlobbed BlobRef (IT pv)) -instance Show Instances where +instance Show (Instances pv) where show InstancesEmpty = "Empty" show (InstancesTree _ t) = showFix showITString t -instance MonadBlobStore m => MHashableTo m H.Hash Instances where +instance (IsProtocolVersion pv, MonadBlobStore m) => MHashableTo m H.Hash (Instances pv) where getHashM InstancesEmpty = return $ H.hash "EmptyInstances" getHashM (InstancesTree _ t) = getHash <$> mproject t -instance (MonadBlobStore m) => BlobStorable m Instances where +instance (IsProtocolVersion pv, MonadBlobStore m) => BlobStorable m (Instances pv) where storeUpdate i@InstancesEmpty = return (putWord8 0, i) storeUpdate (InstancesTree s t) = do (pt, t') <- storeUpdate t @@ -401,27 +452,27 @@ instance (MonadBlobStore m) => BlobStorable m Instances where s <- get fmap (InstancesTree s) <$> load -instance (MonadBlobStore m) => Cacheable (ReaderT Modules m) Instances where +instance (IsProtocolVersion pv, MonadBlobStore m) => Cacheable (ReaderT Modules m) (Instances pv) where cache i@InstancesEmpty = return i cache (InstancesTree s r) = do modules <- ask - let cacheIT :: IT r -> m (IT r) + let cacheIT :: IT pv r -> m (IT pv r) cacheIT (Leaf l) = Leaf <$> runReaderT (cache l) modules cacheIT it = return it lift (InstancesTree s <$> cacheBufferedBlobbed cacheIT r) -emptyInstances :: Instances +emptyInstances :: Instances pv emptyInstances = InstancesEmpty -newContractInstance :: forall m a. MonadBlobStore m => (ContractAddress -> m (a, PersistentInstance)) -> Instances -> m (a, Instances) +newContractInstance :: forall m pv a. (IsProtocolVersion pv, MonadBlobStore m) => (ContractAddress -> m (a, PersistentInstance pv)) -> Instances pv -> m (a, Instances pv) newContractInstance fnew InstancesEmpty = do let ca = ContractAddress 0 0 (res, newInst) <- fnew ca (res,) . InstancesTree 1 <$> membed (Leaf newInst) newContractInstance fnew (InstancesTree s it) = (\(res, it') -> (res, InstancesTree (s+1) it')) <$> newContractInstanceIT fnew it -deleteContractInstance :: forall m. MonadBlobStore m => ContractAddress -> Instances -> m Instances +deleteContractInstance :: forall m pv. (IsProtocolVersion pv, MonadBlobStore m) => ContractAddress -> Instances pv -> m (Instances pv) deleteContractInstance _ InstancesEmpty = return InstancesEmpty deleteContractInstance addr t0@(InstancesTree s it0) = dci (fmap (InstancesTree (s-1)) . membed) (contractIndex addr) =<< mproject it0 where @@ -449,7 +500,7 @@ deleteContractInstance addr t0@(InstancesTree s it0) = dci (fmap (InstancesTree in dci newCont (i - 2^h) =<< mproject r | otherwise = return t0 -lookupContractInstance :: forall m. MonadBlobStore m => ContractAddress -> Instances -> m (Maybe PersistentInstance) +lookupContractInstance :: forall m pv. (IsProtocolVersion pv, MonadBlobStore m) => ContractAddress -> Instances pv -> m (Maybe (PersistentInstance pv)) lookupContractInstance _ InstancesEmpty = return Nothing lookupContractInstance addr (InstancesTree _ it0) = lu (contractIndex addr) =<< mproject it0 where @@ -464,7 +515,7 @@ lookupContractInstance addr (InstancesTree _ it0) = lu (contractIndex addr) =<< | i < 2^(h+1) = lu (i - 2^h) =<< mproject r | otherwise = return Nothing -updateContractInstance :: forall m a. MonadBlobStore m => (PersistentInstance -> m (a, PersistentInstance)) -> ContractAddress -> Instances -> m (Maybe (a, Instances)) +updateContractInstance :: forall m pv a. (IsProtocolVersion pv, MonadBlobStore m) => (PersistentInstance pv -> m (a, PersistentInstance pv)) -> ContractAddress -> Instances pv -> m (Maybe (a, Instances pv)) updateContractInstance _ _ InstancesEmpty = return Nothing updateContractInstance fupd addr (InstancesTree s it0) = upd baseSuccess (contractIndex addr) =<< mproject it0 where @@ -496,18 +547,18 @@ updateContractInstance fupd addr (InstancesTree s it0) = upd baseSuccess (contra in upd newCont (i - 2^h) =<< mproject r | otherwise = return Nothing -allInstances :: forall m. MonadBlobStore m => Instances -> m [PersistentInstance] +allInstances :: forall m pv. (IsProtocolVersion pv, MonadBlobStore m) => Instances pv -> m [PersistentInstance pv] allInstances InstancesEmpty = return [] allInstances (InstancesTree _ it) = mapReduceIT mfun it where mfun (Left _) = return mempty mfun (Right inst) = return [inst] -makePersistent :: forall m. MonadBlobStore m => Modules.Modules -> Transient.Instances -> m Instances +makePersistent :: forall m pv. MonadBlobStore m => Modules.Modules -> Transient.Instances -> m (Instances pv) makePersistent _ (Transient.Instances Transient.Empty) = return InstancesEmpty makePersistent mods (Transient.Instances (Transient.Tree s t)) = InstancesTree s <$> conv t where - conv :: Transient.IT -> m (BufferedBlobbed BlobRef IT) + conv :: Transient.IT -> m (BufferedBlobbed BlobRef (IT pv)) conv (Transient.Branch lvl fll vac hsh l r) = do l' <- conv l r' <- conv r @@ -525,7 +576,7 @@ makePersistent mods (Transient.Instances (Transient.Tree s t)) = InstancesTree s } -- This pattern is irrefutable because if the instance exists in the Basic version, -- then the module must be present in the persistent implementation. - ~(Just pIModuleInterface) <- undefined -- FIXME: Modules.getModuleReference (GSWasm.miModuleRef instanceModuleInterface) mods + ~(Just pIModuleInterface) <- Modules.unsafeGetModuleReferenceV0 (GSWasm.miModuleRef instanceModuleInterface) mods return $ PersistentInstanceV0 PersistentInstanceV { pinstanceParameters = pIParams, pinstanceModuleInterface = pIModuleInterface, @@ -533,9 +584,28 @@ makePersistent mods (Transient.Instances (Transient.Tree s t)) = InstancesTree s pinstanceAmount = _instanceVAmount, pinstanceHash = _instanceVHash } + convInst (Transient.InstanceV1 Transient.InstanceV {_instanceVParameters=Transient.InstanceParameters{..}, ..}) = do + pIParams <- makeBufferedRef $ PersistentInstanceParameters{ + pinstanceAddress = _instanceAddress, + pinstanceOwner = instanceOwner, + pinstanceContractModule = GSWasm.miModuleRef instanceModuleInterface, + pinstanceInitName = instanceInitName, + pinstanceParameterHash = instanceParameterHash, + pinstanceReceiveFuns = instanceReceiveFuns + } + -- This pattern is irrefutable because if the instance exists in the Basic version, + -- then the module must be present in the persistent implementation. + ~(Just pIModuleInterface) <- Modules.unsafeGetModuleReferenceV1 (GSWasm.miModuleRef instanceModuleInterface) mods + return $ PersistentInstanceV1 PersistentInstanceV { + pinstanceParameters = pIParams, + pinstanceModuleInterface = pIModuleInterface, + pinstanceModel = _instanceVModel, + pinstanceAmount = _instanceVAmount, + pinstanceHash = _instanceVHash + } -- |Serialize instances in V0 format. -putInstancesV0 :: (MonadBlobStore m, MonadPut m) => Instances -> m () +putInstancesV0 :: (IsProtocolVersion pv, MonadBlobStore m, MonadPut m) => Instances pv -> m () putInstancesV0 InstancesEmpty = liftPut $ putWord8 0 putInstancesV0 (InstancesTree _ it) = do mapReduceIT putOptInstance it @@ -548,5 +618,5 @@ putInstancesV0 (InstancesTree _ it) = do liftPut $ putWord8 2 putInstanceV0 inst putOptInstance (Right (PersistentInstanceV1 inst)) = do - liftPut $ putWord8 2 + liftPut $ putWord8 3 putInstanceV1 inst diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index f7ea91c9f9..6844b3303a 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -40,6 +40,7 @@ module Concordium.Scheduler import qualified Concordium.GlobalState.Wasm as GSWasm import qualified Concordium.Wasm as Wasm import qualified Concordium.Scheduler.WasmIntegration as WasmV0 +import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 import Concordium.Scheduler.Types import Concordium.Scheduler.Environment import Data.Time @@ -74,6 +75,7 @@ import qualified Concordium.Crypto.BlsSignature as Bls import Lens.Micro.Platform import Prelude hiding (exp, mod) +import qualified Concordium.Scheduler.WasmIntegration.V1 as V1 -- |Check that -- * the transaction has a valid sender, @@ -578,7 +580,7 @@ getCurrentContractInstanceTicking cref = do -- This uses the 'ResourceMeasure' instance for 'Cost.LookupByteSize' to determine the cost for lookup. case inst of InstanceV0 iv -> tickEnergy (Cost.lookupContractState $ Wasm.contractStateSize (Ins._instanceVModel iv)) - InstanceV1 iv -> error "TODO" + InstanceV1 iv -> tickEnergy (Cost.lookupContractState $ Wasm.contractStateSize (Ins._instanceVModel iv)) return inst -- | Handle the initialization of a contract instance. @@ -638,11 +640,38 @@ handleInitContract wtc initAmount modref initName param = -- And for storing the instance. tickEnergy Cost.initializeContractInstanceCreateCost - return (iface, result) + return (Left (iface, result)) - GSWasm.ModuleInterfaceV1 miv -> error "TODO" + GSWasm.ModuleInterfaceV1 iface -> do + let iSize = GSWasm.miModuleSize iface + tickEnergy $ Cost.lookupModule iSize + + -- Then get the particular contract interface (in particular the type of the init method). + unless (Set.member initName (GSWasm.miExposedInit iface)) $ rejectTransaction $ InvalidInitMethod modref initName + + cm <- liftLocal getChainMetadata + -- Finally run the initialization function of the contract, resulting in an initial state + -- of the contract. This ticks energy during execution, failing when running out of energy. + -- NB: At this point the amount to initialize with has not yet been deducted from the + -- sender account. Thus if the initialization function were to observe the current balance it would + -- be amount - deposit. Currently this is in any case not exposed in contracts, but in case it + -- is in the future we should be mindful of which balance is exposed. + senderCredentials <- getAccountCredentials (snd senderAccount) + let initCtx = Wasm.InitContext{ + initOrigin = senderAddress, + icSenderPolicies = map (Wasm.mkSenderPolicy . snd) (OrdMap.toAscList senderCredentials) + } + result <- runInterpreter (return . WasmV1.applyInitFun iface cm initCtx initName param initAmount) + `rejectingWith'` V1.cerToRejectReasonInit + + -- Charge for storing the contract state. + tickEnergyStoreState (V1.irdNewState result) + -- And for storing the instance. + tickEnergy Cost.initializeContractInstanceCreateCost + + return (Right (iface, result)) - k ls (iface, result) = do + k ls (Left (iface, result)) = do let model = Wasm.newState result (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) chargeExecutionCost txHash senderAccount energyCost @@ -664,6 +693,28 @@ handleInitContract wtc initAmount modref initName param = ecEvents=Wasm.logs result }], energyCost, usedEnergy ) + k ls (Right (iface, result)) = do + let model = V1.irdNewState result + (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + chargeExecutionCost txHash senderAccount energyCost + + -- Withdraw the amount the contract is initialized with from the sender account. + cs' <- addAmountToCS senderAccount (amountDiff 0 initAmount) (ls ^. changeSet) + + let receiveMethods = OrdMap.findWithDefault Set.empty initName (GSWasm.miExposedReceive iface) + let ins = makeInstance initName receiveMethods iface model initAmount senderAddress + addr <- putNewInstance ins + + -- add the contract initialization to the change set and commit the changes + commitChanges $ addContractInitToCS (ins addr) cs' + + return (TxSuccess [ContractInitialized{ecRef=modref, + ecAddress=addr, + ecAmount=initAmount, + ecInitName=initName, + ecEvents=V1.irdLogs result + }], energyCost, usedEnergy + ) handleSimpleTransfer :: SchedulerMonad pv m From 19831e0614cf67bf9e3df59cdb650f7c4520dfc9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Wed, 15 Dec 2021 14:36:40 +0100 Subject: [PATCH 03/51] WIP: Introduce handling of inter-contract calls in the scheduler. --- concordium-base | 2 +- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/Scheduler.hs | 357 ++++++++++++------ .../src/Concordium/Scheduler/Environment.hs | 83 +++- 4 files changed, 317 insertions(+), 127 deletions(-) diff --git a/concordium-base b/concordium-base index d588739f03..08bee7492e 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit d588739f0361a3084666fa4b22ed441a46be6a33 +Subproject commit 08bee7492e4cc8296d7eecaa44e3e8d8d50167bf diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 3fae957d6e..3552f05801 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 3fae957d6ea5ec3f71ee71a981c3d5ee79d7cd7d +Subproject commit 3552f058013538360c8a59d6b47baf87a150a236 diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 6844b3303a..0cebf55cb3 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -75,7 +75,7 @@ import qualified Concordium.Crypto.BlsSignature as Bls import Lens.Micro.Platform import Prelude hiding (exp, mod) -import qualified Concordium.Scheduler.WasmIntegration.V1 as V1 +import Concordium.Scheduler.WasmIntegration.V1 (ReceiveResultData(rrdCurrentState)) -- |Check that -- * the transaction has a valid sender, @@ -574,14 +574,26 @@ getCurrentContractInstanceTicking :: TransactionMonad pv m => ContractAddress -> m Instance -getCurrentContractInstanceTicking cref = do - inst <- getCurrentContractInstance cref `rejectingWith` (InvalidContractAddress cref) - -- Compute the size of the contract state value and charge for the lookup based on this size. - -- This uses the 'ResourceMeasure' instance for 'Cost.LookupByteSize' to determine the cost for lookup. - case inst of - InstanceV0 iv -> tickEnergy (Cost.lookupContractState $ Wasm.contractStateSize (Ins._instanceVModel iv)) - InstanceV1 iv -> tickEnergy (Cost.lookupContractState $ Wasm.contractStateSize (Ins._instanceVModel iv)) - return inst +getCurrentContractInstanceTicking cref = getCurrentContractInstanceTicking' cref `rejectingWith` InvalidContractAddress cref + +-- | Get the current contract state and charge for its lookup. +-- NB: In principle we should look up the state size, then charge, and only then lookup the full state +-- But since state size is limited to be small it is acceptable to look it up and then charge for it. +getCurrentContractInstanceTicking' :: + TransactionMonad pv m + => ContractAddress + -> m (Maybe Instance) +getCurrentContractInstanceTicking' cref = do + getCurrentContractInstance cref >>= \case + Nothing -> return Nothing + Just inst -> do + -- Compute the size of the contract state value and charge for the lookup based on this size. + -- This uses the 'ResourceMeasure' instance for 'Cost.LookupByteSize' to determine the cost for lookup. + case inst of + InstanceV0 iv -> tickEnergy (Cost.lookupContractState $ Wasm.contractStateSize (Ins._instanceVModel iv)) + InstanceV1 iv -> tickEnergy (Cost.lookupContractState $ Wasm.contractStateSize (Ins._instanceVModel iv)) -- FIXME: This will be revised + return (Just inst) + -- | Handle the initialization of a contract instance. handleInitContract :: @@ -662,10 +674,10 @@ handleInitContract wtc initAmount modref initName param = icSenderPolicies = map (Wasm.mkSenderPolicy . snd) (OrdMap.toAscList senderCredentials) } result <- runInterpreter (return . WasmV1.applyInitFun iface cm initCtx initName param initAmount) - `rejectingWith'` V1.cerToRejectReasonInit + `rejectingWith'` WasmV1.cerToRejectReasonInit -- Charge for storing the contract state. - tickEnergyStoreState (V1.irdNewState result) + tickEnergyStoreState (WasmV1.irdNewState result) -- And for storing the instance. tickEnergy Cost.initializeContractInstanceCreateCost @@ -694,7 +706,7 @@ handleInitContract wtc initAmount modref initName param = }], energyCost, usedEnergy ) k ls (Right (iface, result)) = do - let model = V1.irdNewState result + let model = WasmV1.irdNewState result (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) chargeExecutionCost txHash senderAccount energyCost @@ -712,7 +724,7 @@ handleInitContract wtc initAmount modref initName param = ecAddress=addr, ecAmount=initAmount, ecInitName=initName, - ecEvents=V1.irdLogs result + ecEvents=WasmV1.irdLogs result }], energyCost, usedEnergy ) @@ -757,25 +769,153 @@ handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta c = do - ins <- getCurrentContractInstanceTicking uAddress - -- Now invoke the general handler for contract messages. - handleMessage senderAddress - ins - (Right (senderAddress, senderAccount)) - uAmount - uReceiveName - uMessage - + getCurrentContractInstanceTicking uAddress >>= \case + InstanceV0 ins -> + -- Now invoke the general handler for contract messages. + handleMessage senderAddress + ins + (Right (senderAddress, senderAccount)) + uAmount + uReceiveName + uMessage + InstanceV1 ins -> do + handleContractUpdateV1 senderAddress ins (Right (senderAddress, senderAccount)) uAmount uReceiveName uMessage >>= \case + Left cer -> rejectTransaction (WasmV1.cerToRejectReasonReceive uAddress uReceiveName uMessage cer) + Right (_, events) -> return events + +handleContractUpdateV1 :: forall pv m vOrigin. + (TransactionMonad pv m, AccountOperations m) + => AccountAddress -- ^The address that was used to send the top-level transaction. + -> InstanceV GSWasm.V1 -- ^The current state of the target contract of the transaction, which must exist. + -> Either (IndexedAccount m, InstanceV vOrigin) (AccountAddress, IndexedAccount m) + -- ^The sender of the message (contract instance or account). In case this is + -- a contract the first parameter is the owner account of the instance. In case this is an account + -- (i.e., this is called from a top-level transaction) the value is a pair of the address that was used + -- as the sender address of the transaction, and the account to which it points. + -- On the first invocation of this function this will be the sender of the + -- top-level transaction, and in recursive calls the respective contract + -- instance that produced the message. + -> Amount -- ^The amount to be transferred from the sender of the message to the contract upon success. + -> Wasm.ReceiveName -- ^Name of the contract to invoke. + -> Wasm.Parameter -- ^Message to invoke the receive method with. + -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) -- ^The events resulting from processing the message and all recursively processed messages. +handleContractUpdateV1 originAddr istance sender transferAmount receiveName parameter = do + -- Cover administrative costs. + tickEnergy Cost.updateContractInstanceBaseCost + let model = _instanceVModel istance + + -- Check whether the sender of the message has enough on its account/instance for the transfer. + -- If the amount is not sufficient, the top-level transaction is rejected. + -- Note that this returns the address that was used in the top-level transaction, or the contract address. + -- In the former case the credentials are credentials of the account, in the + -- latter they are credentials of the owner account. + (senderAddr, senderCredentials) <- mkSenderAddrCredentials sender + + let iParams = _instanceVParameters istance + let cref = instanceAddress iParams + let receivefuns = instanceReceiveFuns . _instanceVParameters $ istance + unless (Set.member receiveName receivefuns) $ rejectTransaction $ + InvalidReceiveMethod (GSWasm.miModuleRef . instanceModuleInterface $ iParams) receiveName + let ownerAccountAddress = instanceOwner iParams + -- The invariants maintained by global state should ensure that an owner account always exists. + -- However we are defensive here and reject the transaction instead of panicking in case it does not. + ownerAccount <- getStateAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress + cm <- getChainMetadata + let receiveCtx = Wasm.ReceiveContext { + invoker = originAddr, + selfAddress = cref, + selfBalance = _instanceVAmount istance, + sender = senderAddr, + owner = instanceOwner iParams, + rcSenderPolicies = map Wasm.mkSenderPolicy senderCredentials + } + -- Now run the receive function on the message. This ticks energy during execution, failing when running out of energy. + -- FIXME: Once errors can be caught in smart contracts update this to not terminate the transaction. + let iface = instanceModuleInterface iParams + -- charge for looking up the module + tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) + + -- we've covered basic administrative costs now. Now iterate until the end of execution, handling any interrupts. + let go :: [Event] -> Either WasmV1.ContractExecutionReject WasmV1.ReceiveResultData -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) + go _ (Left cer) = return (Left (WasmV1.ExecutionReject cer)) + go events (Right rrData) = + case rrData of + WasmV1.ReceiveSuccess{..} -> + -- execution terminated, commit the new state + withInstanceStateV1 istance rrdNewState $ do + -- transfer the amount from the sender. We first check whether that is actually available for the sender at this point in time + -- since synchronous calls might have affected it before this point. + senderamount <- getCurrentAvailableAmount sender + if senderamount >= transferAmount then return (Left (WasmV1.EnvFailure (WasmV1.AmountTooLarge senderAddr transferAmount))) + else withToContractAmount sender istance transferAmount $ + let event = Updated{euAddress=instanceAddress istance, + euInstigator=senderAddr, + euAmount=transferAmount, + euMessage=parameter, + euReceiveName=receiveName, + euEvents = rrdLogs + } + in return (Right (rrdReturnValue, event:events)) + WasmV1.ReceiveInterrupt{..} -> do + case rrdMethod of + WasmV1.Transfer{..} -> + runExceptT (transferAccountSync imtTo istance imtAmount) >>= \case + Left errCode -> + go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) + Right transferEvents -> go (transferEvents ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success Nothing) + WasmV1.Call{..} -> + -- commit the current state of the contract. + withInstanceStateV1 istance rrdCurrentState $ do + -- lookup the instance + getCurrentContractInstanceTicking' imcTo >>= \case + Nothing -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MissingContract imcTo))) Nothing) + Just (InstanceV0 targetInstance) -> do + let runSuccess = Right <$> handleMessage originAddr targetInstance (Left (ownerAccount, istance)) imcAmount imcName imcParam + (runSuccess `orElseWith` (return . Left)) >>= \case + Left rr -> -- execution failed. + go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) + Right evs -> + go (evs ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success Nothing) + Just (InstanceV1 targetInstance) -> do + withRollback (handleContractUpdateV1 originAddr targetInstance (Left (ownerAccount, istance)) imcAmount imcName imcParam) >>= \case + Left cer -> + go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) + Right (rVal, callEvents) -> + go (callEvents ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success (Just rVal)) + + -- start contract execution + go [] =<< runInterpreter (return . WasmV1.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) + + where transferAccountSync :: AccountAddress -- ^The target account address. + -> InstanceV GSWasm.V1 -- ^The sender of this transfer. + -> Amount -- ^The amount to transfer. + -> ExceptT WasmV1.EnvFailure m [Event] -- ^The events resulting from the transfer. + transferAccountSync accAddr senderInstance tAmount = do + -- charge at the beginning, successful and failed transfers will have the same cost. + -- Check whether the sender has the amount to be transferred and reject the transaction if not. + senderamount <- lift $ do + tickEnergy Cost.simpleTransferCost + getCurrentContractAmount senderInstance + let addr = AddressContract (instanceAddress senderInstance) + unless (senderamount >= tAmount) $! throwError (WasmV1.AmountTooLarge addr tAmount) + -- Check whether target account exists and get it. + lift (getStateAccount accAddr) >>= \case + Nothing -> throwError (WasmV1.MissingAccount accAddr) + Just targetAccount -> + -- Add the transfer to the current changeset and return the corresponding event. + lift (withContractToAccountAmount senderInstance targetAccount tAmount $ + return [Transferred addr transferAmount (AddressAccount accAddr)]) + -- | Process a message to a contract. -- This includes the transfer of an amount from the sending account or instance. -- Recursively do the same for new messages created by contracts (from left to right, depth first). -- The target contract must exist, so that its state can be looked up. -handleMessage :: forall pv m. +handleMessage :: forall pv m v. (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^The address that was used to send the top-level transaction. - -> Instance -- ^The current state of the target contract of the transaction, which must exist. - -> Either (IndexedAccount m, InstanceV GSWasm.V0) (AccountAddress, IndexedAccount m) + -> InstanceV GSWasm.V0 -- ^The current state of the target contract of the transaction, which must exist. + -> Either (IndexedAccount m, InstanceV v) (AccountAddress, IndexedAccount m) -- ^The sender of the message (contract instance or account). In case this is -- a contract the first parameter is the owner account of the instance. In case this is an account -- (i.e., this is called from a top-level transaction) the value is a pair of the address that was used @@ -787,76 +927,74 @@ handleMessage :: forall pv m. -> Wasm.ReceiveName -- ^Name of the contract to invoke. -> Wasm.Parameter -- ^Message to invoke the receive method with. -> m [Event] -- ^The events resulting from processing the message and all recursively processed messages. -handleMessage originAddr vistance sender transferAmount receiveName parameter = do +handleMessage originAddr istance sender transferAmount receiveName parameter = do -- Cover administrative costs. tickEnergy Cost.updateContractInstanceBaseCost - case vistance of - InstanceV0 istance -> do - let model = _instanceVModel istance - -- Check whether the sender of the message has enough on its account/instance for the transfer. - -- If the amount is not sufficient, the top-level transaction is rejected. - -- Note that this returns the address that was used in the top-level transaction, or the contract address. - -- In the former case the credentials are credentials of the account, in the - -- latter they are credentials of the owner account. - (senderAddr, senderCredentials) <- mkSenderAddrCredentials sender - senderamount <- getCurrentAvailableAmount sender - unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) - - let iParams = _instanceVParameters istance - let cref = instanceAddress iParams - let receivefuns = instanceReceiveFuns . _instanceVParameters $ istance - unless (Set.member receiveName receivefuns) $ rejectTransaction $ - InvalidReceiveMethod (GSWasm.miModuleRef . instanceModuleInterface $ iParams) receiveName - -- Now we also check that the owner account of the receiver instance has at least one valid credential - -- and reject the transaction if not. - let ownerAccountAddress = instanceOwner iParams - -- The invariants maintained by global state should ensure that an owner account always exists. - -- However we are defensive here and reject the transaction instead of panicking in case it does not. - ownerAccount <- getStateAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress - cm <- getChainMetadata - - -- We have established that the owner account of the receiver instance has at least one valid credential. - let receiveCtx = Wasm.ReceiveContext { - invoker = originAddr, - selfAddress = cref, - selfBalance = _instanceVAmount istance, - sender = senderAddr, - owner = instanceOwner iParams, - rcSenderPolicies = map Wasm.mkSenderPolicy senderCredentials - } - -- Now run the receive function on the message. This ticks energy during execution, failing when running out of energy. - -- FIXME: Once errors can be caught in smart contracts update this to not terminate the transaction. - let iface = instanceModuleInterface iParams - -- charge for looking up the module - tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) - - result <- runInterpreter (return . WasmV0.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) - `rejectingWith'` wasmRejectToRejectReasonReceive cref receiveName parameter - - -- If we reach here the contract accepted the message and returned a new state as well as outgoing messages. - let newModel = Wasm.newState result - txOut = Wasm.messages result - -- If we reached here we will charge for attempting to store this state. If - -- this message is part of a larger `and` composition then it is possible that - -- the contract will not actually be stored. We are not doing that because it - -- increases complexity and makes tracking of energy even less local than it - -- is now. - -- TODO We might want to change this behaviour to prevent charging for storage that is not done. - tickEnergyStoreState newModel - - -- Process the generated messages in the new context (transferred amount, updated state) in - -- sequence from left to right, depth first. - withToContractAmountV0 sender istance transferAmount $ - withInstanceStateV0 istance newModel $ do - let initEvent = Updated{euAddress=cref, - euInstigator=senderAddr, - euAmount=transferAmount, - euMessage=parameter, - euReceiveName=receiveName, - euEvents = Wasm.logs result - } - foldEvents originAddr (ownerAccount, istance) initEvent txOut + let model = _instanceVModel istance + -- Check whether the sender of the message has enough on its account/instance for the transfer. + -- If the amount is not sufficient, the top-level transaction is rejected. + -- Note that this returns the address that was used in the top-level transaction, or the contract address. + -- In the former case the credentials are credentials of the account, in the + -- latter they are credentials of the owner account. + (senderAddr, senderCredentials) <- mkSenderAddrCredentials sender + senderamount <- getCurrentAvailableAmount sender + unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) + + let iParams = _instanceVParameters istance + let cref = instanceAddress iParams + let receivefuns = instanceReceiveFuns . _instanceVParameters $ istance + unless (Set.member receiveName receivefuns) $ rejectTransaction $ + InvalidReceiveMethod (GSWasm.miModuleRef . instanceModuleInterface $ iParams) receiveName + -- Now we also check that the owner account of the receiver instance has at least one valid credential + -- and reject the transaction if not. + let ownerAccountAddress = instanceOwner iParams + -- The invariants maintained by global state should ensure that an owner account always exists. + -- However we are defensive here and reject the transaction instead of panicking in case it does not. + ownerAccount <- getStateAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress + cm <- getChainMetadata + + -- We have established that the owner account of the receiver instance has at least one valid credential. + let receiveCtx = Wasm.ReceiveContext { + invoker = originAddr, + selfAddress = cref, + selfBalance = _instanceVAmount istance, + sender = senderAddr, + owner = instanceOwner iParams, + rcSenderPolicies = map Wasm.mkSenderPolicy senderCredentials + } + -- Now run the receive function on the message. This ticks energy during execution, failing when running out of energy. + -- FIXME: Once errors can be caught in smart contracts update this to not terminate the transaction. + let iface = instanceModuleInterface iParams + -- charge for looking up the module + tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) + + result <- runInterpreter (return . WasmV0.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) + `rejectingWith'` wasmRejectToRejectReasonReceive cref receiveName parameter + + -- If we reach here the contract accepted the message and returned a new state as well as outgoing messages. + let newModel = Wasm.newState result + txOut = Wasm.messages result + -- If we reached here we will charge for attempting to store this state. If + -- this message is part of a larger `and` composition then it is possible that + -- the contract will not actually be stored. We are not doing that because it + -- increases complexity and makes tracking of energy even less local than it + -- is now. + -- TODO We might want to change this behaviour to prevent charging for storage that is not done. + tickEnergyStoreState newModel + + -- Process the generated messages in the new context (transferred amount, updated state) in + -- sequence from left to right, depth first. + withToContractAmount sender istance transferAmount $ + withInstanceStateV0 istance newModel $ do + let initEvent = Updated{euAddress=cref, + euInstigator=senderAddr, + euAmount=transferAmount, + euMessage=parameter, + euReceiveName=receiveName, + euEvents = Wasm.logs result + } + foldEvents originAddr (ownerAccount, istance) initEvent txOut -- Cost of a step in the traversal of the actions tree. We need to charge for -- this separately to prevent problems with exponentially sized trees @@ -877,13 +1015,22 @@ foldEvents :: (TransactionMonad pv m, AccountOperations m) -> m [Event] -- ^List of events in order that transactions were traversed. foldEvents originAddr istance initEvent = fmap (initEvent:) . go where go Wasm.TSend{..} = do - cinstance <- getCurrentContractInstanceTicking erAddr - handleMessage originAddr - cinstance - (Left istance) - erAmount - erName - erParameter + getCurrentContractInstanceTicking erAddr >>= \case + InstanceV0 cinstance -> handleMessage originAddr + cinstance + (Left istance) + erAmount + erName + erParameter + InstanceV1 cinstance -> + let c = handleContractUpdateV1 + originAddr + cinstance + (Left istance) + erAmount + erName + erParameter + in snd <$> (c `rejectingWith'` WasmV1.cerToRejectReasonReceive erAddr erName erParameter) go Wasm.TSimpleTransfer{..} = do handleTransferAccount erTo (snd istance) erAmount go (Wasm.And l r) = do @@ -899,7 +1046,7 @@ foldEvents originAddr istance initEvent = fmap (initEvent:) . go go l `orElse` go r go Wasm.Accept = return [] -mkSenderAddrCredentials :: AccountOperations m => Either (IndexedAccount m, InstanceV GSWasm.V0) (AccountAddress, IndexedAccount m) -> m (Address, [ID.AccountCredential]) +mkSenderAddrCredentials :: AccountOperations m => Either (IndexedAccount m, InstanceV v) (AccountAddress, IndexedAccount m) -> m (Address, [ID.AccountCredential]) mkSenderAddrCredentials sender = case sender of Left (ownerAccount, istance) -> do @@ -913,24 +1060,24 @@ mkSenderAddrCredentials sender = -- | Handle the transfer of an amount from a contract instance to an account. handleTransferAccount :: - TransactionMonad pv m + (TransactionMonad pv m, HasInstanceParameters a, HasInstanceFields a) => AccountAddress -- ^The target account address. - -> InstanceV GSWasm.V0 -- ^The sender of this transfer. + -> a -- ^The sender of this transfer. -> Amount -- ^The amount to transfer. -> m [Event] -- ^The events resulting from the transfer. handleTransferAccount accAddr senderInstance transferamount = do -- charge at the beginning, successful and failed transfers will have the same cost. tickEnergy Cost.simpleTransferCost -- Check whether the sender has the amount to be transferred and reject the transaction if not. - senderamount <- getCurrentContractAmountV0 senderInstance - let addr = AddressContract (instanceAddress (_instanceVParameters senderInstance)) + senderamount <- getCurrentContractAmount senderInstance + let addr = AddressContract (instanceAddress senderInstance) unless (senderamount >= transferamount) $! rejectTransaction (AmountTooLarge addr transferamount) -- Check whether target account exists and get it. targetAccount <- getStateAccount accAddr `rejectingWith` InvalidAccountReference accAddr -- Add the transfer to the current changeset and return the corresponding event. - withContractToAccountAmountV0 senderInstance targetAccount transferamount $ + withContractToAccountAmount senderInstance targetAccount transferamount $ return [Transferred addr transferamount (AddressAccount accAddr)] -- |Run the interpreter with the remaining amount of energy. If the interpreter diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 995b23a781..997bb219bc 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -289,9 +289,16 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- separately. withInstanceStateV0 :: InstanceV GSWasm.V0 -> Wasm.ContractState -> m a -> m a + -- |Execute the code in a temporarily modified environment. This is needed in + -- nested calls to transactions which might end up failing at the end. Thus we + -- keep track of changes locally first, and only commit them at the end. + -- Instance keeps track of its own address hence we need not provide it + -- separately. + withInstanceStateV1 :: InstanceV GSWasm.V1 -> Wasm.ContractState -> m a -> m a + -- |Transfer amount from the first address to the second and run the -- computation in the modified environment. - withAccountToContractAmountV0 :: IndexedAccount m -> InstanceV GSWasm.V0 -> Amount -> m a -> m a + withAccountToContractAmount :: IndexedAccount m -> InstanceV v -> Amount -> m a -> m a -- |Transfer an amount from the first account to the second and run the -- computation in the modified environment. @@ -299,11 +306,11 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Transfer an amount from the given instance to the given account and run the -- computation in the modified environment. - withContractToAccountAmountV0 :: InstanceV GSWasm.V0 -> IndexedAccount m -> Amount -> m a -> m a + withContractToAccountAmount :: (HasInstanceParameters a, HasInstanceFields a) => a -> IndexedAccount m -> Amount -> m c -> m c -- |Transfer an amount from the first instance to the second and run the -- computation in the modified environment. - withContractToContractAmountV0 :: InstanceV GSWasm.V0 -> InstanceV GSWasm.V0 -> Amount -> m a -> m a + withContractToContractAmount :: InstanceV v1 -> InstanceV v2 -> Amount -> m a -> m a -- |Transfer a scheduled amount from the first address to the second and run -- the computation in the modified environment. @@ -335,16 +342,16 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Transfer an amount from the first given instance or account to the instance in the second -- parameter and run the computation in the modified environment. - {-# INLINE withToContractAmountV0 #-} - withToContractAmountV0 :: Either (IndexedAccount m, InstanceV GSWasm.V0) (AccountAddress, IndexedAccount m) -> InstanceV GSWasm.V0 -> Amount -> m a -> m a - withToContractAmountV0 (Left (_, i)) = withContractToContractAmountV0 i - withToContractAmountV0 (Right (_, a)) = withAccountToContractAmountV0 a + {-# INLINE withToContractAmount #-} + withToContractAmount :: Either (IndexedAccount m, InstanceV v1) (AccountAddress, IndexedAccount m) -> InstanceV v2 -> Amount -> m a -> m a + withToContractAmount (Left (_, i)) = withContractToContractAmount i + withToContractAmount (Right (_, a)) = withAccountToContractAmount a getCurrentContractInstance :: ContractAddress -> m (Maybe Instance) {-# INLINE getCurrentAvailableAmount #-} - getCurrentAvailableAmount :: Either (IndexedAccount m, InstanceV GSWasm.V0) (AccountAddress, IndexedAccount m) -> m Amount - getCurrentAvailableAmount (Left (_, i)) = getCurrentContractAmountV0 i + getCurrentAvailableAmount :: Either (IndexedAccount m, InstanceV v) (AccountAddress, IndexedAccount m) -> m Amount + getCurrentAvailableAmount (Left (_, i)) = getCurrentContractAmount i getCurrentAvailableAmount (Right (_, a)) = getCurrentAccountAvailableAmount a -- |Get an account with its state at the start of the transaction. @@ -362,7 +369,7 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - getCurrentAccountAvailableAmount :: IndexedAccount m -> m Amount -- |Same as above, but for contracts. - getCurrentContractAmountV0 :: InstanceV GSWasm.V0 -> m Amount + getCurrentContractAmount :: (HasInstanceParameters a, HasInstanceFields a) => a -> m Amount -- |Get the amount of energy remaining for the transaction. getEnergy :: m (Energy, EnergyLimitReason) @@ -383,6 +390,15 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- entire computation is aborted. orElse :: m a -> m a -> m a + -- |Try to run the first computation. If it leads to `reject` for a logic reason then + -- try the second computation. If the left computation fails with out of energy then the + -- entire computation is aborted. + orElseWith :: m a -> (RejectReason -> m a) -> m a + + -- |Try to run the first computation. If it leads to `Left err` then abort and revert all the changes. + withRollback :: m (Either a b) -> m (Either a b) + + -- |Fail transaction processing because we would have exceeded maximum block energy limit. outOfBlockEnergy :: m a @@ -463,7 +479,7 @@ modifyAmountCS ai !amnt !cs = cs & (accountUpdates . ix ai . auAmount ) %~ -- |Add or update the contract state in the changeset with the given value. -- |NB: If the instance is not yet in the changeset we assume that its balance is -- as listed in the given instance structure. -addContractStatesToCS :: InstanceV GSWasm.V0 -> Wasm.ContractState -> ChangeSet -> ChangeSet +addContractStatesToCS :: HasInstanceParameters a => a -> Wasm.ContractState -> ChangeSet -> ChangeSet addContractStatesToCS istance newState = instanceUpdates . at addr %~ \case Just (amnt, _) -> Just (amnt, newState) Nothing -> Just (0, newState) @@ -472,7 +488,7 @@ addContractStatesToCS istance newState = -- |Add the given delta to the change set for the given contract instance. -- NB: If the contract is not yet in the changeset it is added, taking the -- model as given in the first argument to be current model (local state) -addContractAmountToCS :: InstanceV GSWasm.V0 -> AmountDelta -> ChangeSet -> ChangeSet +addContractAmountToCS :: (HasInstanceParameters a, HasInstanceFields a) => a -> AmountDelta -> ChangeSet -> ChangeSet addContractAmountToCS istance amnt cs = cs & instanceUpdates . at addr %~ \case Just (d, v) -> Just (d + amnt, v) Nothing -> Just (amnt, model) @@ -716,6 +732,11 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where changeSet %= addContractStatesToCS istance val cont + {-# INLINE withInstanceStateV1 #-} + withInstanceStateV1 istance val cont = do + changeSet %= addContractStatesToCS istance val + cont + {-# INLINE withAccountToAccountAmount #-} withAccountToAccountAmount fromAcc toAcc amount cont = do cs <- use changeSet @@ -723,21 +744,21 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where addAmountToCS fromAcc (amountDiff 0 amount)) cont - {-# INLINE withAccountToContractAmountV0 #-} - withAccountToContractAmountV0 fromAcc toAcc amount cont = do + {-# INLINE withAccountToContractAmount #-} + withAccountToContractAmount fromAcc toAcc amount cont = do cs <- changeSet <%= addContractAmountToCS toAcc (amountToDelta amount) changeSet <~ addAmountToCS fromAcc (amountDiff 0 amount) cs cont - {-# INLINE withContractToAccountAmountV0 #-} - withContractToAccountAmountV0 fromAcc toAcc amount cont = do + {-# INLINE withContractToAccountAmount #-} + withContractToAccountAmount fromAcc toAcc amount cont = do cs <- use changeSet cs' <- addAmountToCS toAcc (amountToDelta amount) cs changeSet .= addContractAmountToCS fromAcc (amountDiff 0 amount) cs' cont - {-# INLINE withContractToContractAmountV0 #-} - withContractToContractAmountV0 fromAcc toAcc amount cont = do + {-# INLINE withContractToContractAmount #-} + withContractToContractAmount fromAcc toAcc amount cont = do changeSet %= addContractAmountToCS toAcc (amountToDelta amount) changeSet %= addContractAmountToCS fromAcc (amountDiff 0 amount) cont @@ -827,8 +848,8 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where - max (oldLockedUp + newReleases) staked Nothing -> return $ netDeposit - max oldLockedUp staked - {-# INLINE getCurrentContractAmountV0 #-} - getCurrentContractAmountV0 inst = do + {-# INLINE getCurrentContractAmount #-} + getCurrentContractAmount inst = do let amnt = inst ^. instanceAmount let addr = instanceAddress inst use (changeSet . instanceUpdates . at addr) >>= \case @@ -868,6 +889,28 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where runContT r k x -> return x + {-# INLINE orElseWith #-} + orElseWith (LocalT l) r = LocalT $ ContT $ \k -> do + initChangeSet <- use changeSet + runContT l k >>= \case + (Left (Just reason)) | reason /= OutOfEnergy -> do + -- reset changeSet, the left computation will have no effect at all other than + -- energy use. + changeSet .= initChangeSet + runContT (_runLocalT (r reason)) k + x -> return x + + + {-# INLINE withRollback #-} + withRollback (LocalT l) = LocalT $ ContT $ \k -> do + initChangeSet <- use changeSet + let kNew x@(Left _) = do + changeSet .= initChangeSet + k x + kNew x = k x + runContT l kNew + + {-# INLINE outOfBlockEnergy #-} outOfBlockEnergy = LocalT (ContT (\_ -> return (Left Nothing))) From 1c3e8dc0cfb3627b69b6301eeb8e5e09b15382f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Wed, 15 Dec 2021 19:14:02 +0100 Subject: [PATCH 04/51] Allow deployment of V1 modules. --- .../src/Concordium/Scheduler.hs | 31 ++++++++++++------- 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 0cebf55cb3..19815f760f 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -537,24 +537,31 @@ handleDeployModule wtc mod = psize = Wasm.moduleSourceLength . Wasm.wasmSource $ mod c = do - if demoteProtocolVersion (protocolVersion @pv) <= P3 then do - tickEnergy (Cost.deployModuleCost psize) - case WasmV0.processModule mod of - Nothing -> rejectTransaction ModuleNotWF - Just iface -> do - let mhash = GSWasm.moduleReference iface - exists <- isJust <$> getModuleInterfaces mhash - when exists $ rejectTransaction (ModuleHashAlreadyExists mhash) - return (iface, mhash) - else - rejectTransaction ModuleNotWF -- TODO: Handle P4 here + tickEnergy (Cost.deployModuleCost psize) + case Wasm.wasmVersion mod of + 0 -> case WasmV0.processModule mod of + Nothing -> rejectTransaction ModuleNotWF + Just iface -> do + let mhash = GSWasm.moduleReference iface + exists <- isJust <$> getModuleInterfaces mhash + when exists $ rejectTransaction (ModuleHashAlreadyExists mhash) + return (GSWasm.ModuleInterfaceV0 iface, mhash) + 1 | demoteProtocolVersion (protocolVersion @pv) >= P4 -> + case WasmV1.processModule mod of + Nothing -> rejectTransaction ModuleNotWF + Just iface -> do + let mhash = GSWasm.moduleReference iface + exists <- isJust <$> getModuleInterfaces mhash + when exists $ rejectTransaction (ModuleHashAlreadyExists mhash) + return (GSWasm.ModuleInterfaceV1 iface, mhash) + _ -> rejectTransaction ModuleNotWF k ls (iface, mhash) = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) chargeExecutionCost txHash senderAccount energyCost -- Add the module to the global state (module interface, value interface and module itself). -- We know the module does not exist at this point, so we can ignore the return value. - _ <- commitModule (GSWasm.ModuleInterfaceV0 iface, mod) + _ <- commitModule (iface, mod) return (TxSuccess [ModuleDeployed mhash], energyCost, usedEnergy) -- | Tick energy for storing the given contract state. From 2c78a92ade04dd40adb056e6171c7d3ee90c2058 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Wed, 15 Dec 2021 19:23:39 +0100 Subject: [PATCH 05/51] Implement serialization of V1 instances. --- .../GlobalState/Basic/BlockState.hs | 2 +- .../GlobalState/Basic/BlockState/Instances.hs | 21 ++--------- .../src/Concordium/GlobalState/Instance.hs | 35 ++++++++++++------- .../GlobalState/Persistent/Instances.hs | 2 +- 4 files changed, 27 insertions(+), 33 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs index 9f3abf0b10..e4edc2f635 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs @@ -304,7 +304,7 @@ getBlockState = do let resolveModule modRef initName = do mi <- Modules.getInterface modRef _blockModules return (GSWasm.exposedReceive mi ^. at initName . non Set.empty, mi) - _blockInstances <- Instances.getInstancesV1 resolveModule -- FIXME: Make protocol version dependant + _blockInstances <- Instances.getInstancesV0 resolveModule _blockUpdates <- getUpdatesV0 _blockEpochBlocksBaked <- getHashedEpochBlocksV0 -- Construct the release schedule and active bakers from the accounts diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs index b21b0bf3a4..9e4c4dd991 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs @@ -17,8 +17,7 @@ module Concordium.GlobalState.Basic.BlockState.Instances( instanceCount, -- * Serialization putInstancesV0, - getInstancesV0, - getInstancesV1 + getInstancesV0 ) where import Concordium.Types @@ -89,7 +88,7 @@ putInstancesV0 (Instances (Tree _ t)) = do -- |Deserialize 'Instances' in V0 format. getInstancesV0 - :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterfaceV GSWasm.V0)) + :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterface)) -> Get Instances getInstancesV0 resolve = Instances <$> constructM buildInstance where @@ -97,19 +96,5 @@ getInstancesV0 resolve = Instances <$> constructM buildInstance 0 -> return Nothing 1 -> Just . Left <$> get 2 -> Just . Right . InstanceV0 <$> getInstanceV0 resolve idx - _ -> fail "Bad instance list" - - --- |Deserialize 'Instances' in V0 format. --- FIXME: This is wrong. We need getInstnacesV1 to be told which instance version to use. -getInstancesV1 - :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterface)) - -> Get Instances -getInstancesV1 resolve = Instances <$> constructM buildInstance - where - buildInstance idx = getWord8 >>= \case - 0 -> return Nothing - 1 -> Just . Left <$> get - 2 -> Just . Right <$> getInstanceV1 resolve idx - 3 -> Just . Right <$> getInstanceV1 resolve idx + 3 -> Just . Right . InstanceV1 <$> getInstanceV1 resolve idx _ -> fail "Bad instance list" diff --git a/concordium-consensus/src/Concordium/GlobalState/Instance.hs b/concordium-consensus/src/Concordium/GlobalState/Instance.hs index 957f23f412..1e097fe99b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Instance.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Instance.hs @@ -234,12 +234,22 @@ putInstanceV0 InstanceV{ _instanceVParameters = InstanceParameters{..}, ..} = do put _instanceVAmount putInstanceV1 :: Putter (InstanceV GSWasm.V1) -putInstanceV1 = error "TODO" +putInstanceV1 InstanceV{ _instanceVParameters = InstanceParameters{..}, ..} = do + -- InstanceParameters + -- Only put the Subindex part of the address + put (contractSubindex _instanceAddress) + put instanceOwner + put (GSWasm.miModuleRef instanceModuleInterface) + put instanceInitName + -- instanceReceiveFuns, instanceModuleInterface and instanceParameterHash + -- are not included, since they can be derived from context. + put _instanceVModel + put _instanceVAmount -- |Deserialize a smart contract instance in V0 format. getInstanceV0 - :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterfaceV GSWasm.V0)) + :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterface)) -- ^Function for resolving the receive functions and module interface. -> ContractIndex -- ^Index of the contract @@ -253,19 +263,20 @@ getInstanceV0 resolve idx = do instanceInitName <- get (instanceReceiveFuns, instanceModuleInterface) <- case resolve instanceContractModule instanceInitName of - Just r -> return r + Just (r, GSWasm.ModuleInterfaceV0 iface) -> return (r, iface) + Just (_, GSWasm.ModuleInterfaceV1 _) -> fail "Expected module version 0, but module version 1 encountered." Nothing -> fail "Unable to resolve smart contract" _instanceVModel <- get _instanceVAmount <- get return $ makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress +-- |Deserialize a smart contract instance in V0 format. getInstanceV1 :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterface)) -- ^Function for resolving the receive functions and module interface. -> ContractIndex -- ^Index of the contract - -> Get Instance --- |Deserialize a smart contract instance in V0 format. + -> Get (InstanceV GSWasm.V1) getInstanceV1 resolve idx = do -- InstanceParameters subindex <- get @@ -273,13 +284,11 @@ getInstanceV1 resolve idx = do instanceOwner <- get instanceContractModule <- get instanceInitName <- get + (instanceReceiveFuns, instanceModuleInterface) <- + case resolve instanceContractModule instanceInitName of + Just (_, GSWasm.ModuleInterfaceV0 _) -> fail "Expected module version 1, but module version 0 encountered." + Just (r, GSWasm.ModuleInterfaceV1 iface) -> return (r, iface) + Nothing -> fail "Unable to resolve smart contract" _instanceVModel <- get _instanceVAmount <- get - case resolve instanceContractModule instanceInitName of - Just (instanceReceiveFuns, GSWasm.ModuleInterfaceV0 instanceModuleInterface) -> - return $ InstanceV0 $ makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress - Just (instanceReceiveFuns, GSWasm.ModuleInterfaceV1 instanceModuleInterface) -> - return $ InstanceV1 $ makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress - Nothing -> fail "Unable to resolve smart contract" - - + return $ makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs index dec7fef125..359e7a98ce 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs @@ -126,7 +126,7 @@ instance (IsProtocolVersion pv, MonadBlobStore m) => BlobStorable m (PersistentI if demoteProtocolVersion (protocolVersion @pv) <= P3 then case inst of PersistentInstanceV0 i -> second PersistentInstanceV0 <$> storeUnversioned i - PersistentInstanceV1 i -> second PersistentInstanceV1 <$> storeUnversioned i + PersistentInstanceV1 i -> error "Precondition violation. V1 instances do not exist in protocol versions <= 3." else case inst of PersistentInstanceV0 i -> addVersion 0 PersistentInstanceV0 <$> storeUnversioned i PersistentInstanceV1 i -> addVersion 1 PersistentInstanceV1 <$> storeUnversioned i From 7079b80100fc67425150241f7289ac9f1c8c99c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Wed, 15 Dec 2021 20:34:07 +0100 Subject: [PATCH 06/51] Fix tests after changes to datatypes. --- .../globalstate/GlobalStateTests/Instances.hs | 15 ++++++++------- .../SchedulerTests/FibonacciSelfMessageTest.hs | 3 ++- .../scheduler/SchedulerTests/InitContextTest.hs | 3 ++- .../scheduler/SchedulerTests/InitPoliciesTest.hs | 2 +- 4 files changed, 13 insertions(+), 10 deletions(-) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs index ec5a03a26e..72c7e34a19 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs @@ -20,6 +20,7 @@ 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 @@ -32,8 +33,8 @@ contractSources = $(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. -validContractArtifacts :: [(Wasm.ModuleSource, GSWasm.ModuleInterface)] -validContractArtifacts = mapMaybe packModule contractSources +validContractArtifactsV0 :: [(Wasm.ModuleSource, GSWasm.ModuleInterfaceV GSWasm.V0)] +validContractArtifactsV0 = mapMaybe packModule contractSources where packModule (_, sourceBytes) = let source = Wasm.ModuleSource sourceBytes in (source,) <$> WasmIntegration.processModule (Wasm.WasmModule 0 source) @@ -96,7 +97,7 @@ genContractState = do makeDummyInstance :: InstanceData -> Gen (ContractAddress -> Instance) makeDummyInstance (InstanceData model amount) = do - (_, mInterface@GSWasm.ModuleInterface{..}) <- elements validContractArtifacts + (_, 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 @@ -113,7 +114,7 @@ instance Arbitrary InstanceData where return $ InstanceData model amount instanceData :: Instance -> InstanceData -instanceData inst = InstanceData (instanceModel inst) (instanceAmount inst) +instanceData inst = InstanceData (inst ^. instanceModel) (inst ^. instanceAmount) data Model = Model { -- Data of instances @@ -175,7 +176,7 @@ instanceTableToModel (Tree _ t0) = ttm 0 emptyModel t0 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 $ instanceParameters inst, instanceData inst) (modelInstances m), + modelInstances = Map.insert offset (contractSubindex $ instanceAddress inst, instanceData inst) (modelInstances m), modelBound = modelBound m + 1 } ttm offset m (VacantLeaf si) = m { @@ -244,7 +245,7 @@ testUpdates n0 = if n0 <= 0 then return (property True) else tu n0 emptyInstance dummyInstance <- makeDummyInstance instData let (ca, insts') = createInstance dummyInstance insts let (cam, model') = modelCreateInstance dummyInstance model - checkEqualThen (instanceAddress $ instanceParameters ca) cam $ + checkEqualThen (instanceAddress ca) cam $ tu (n-1) insts' model' deleteAbsent = do ci <- ContractIndex <$> choose (fromIntegral $ modelBound model, maxBound) @@ -323,7 +324,7 @@ testGetInstance insts model = oneof $ [present | not (null $ modelInstances mode testFoldInstances :: Instances -> Model -> Property testFoldInstances insts model = allInsts === modInsts where - allInsts = (\i -> (instanceAddress (instanceParameters i), instanceData i)) <$> (insts ^.. foldInstances) + allInsts = (\i -> (instanceAddress i, instanceData i)) <$> (insts ^.. foldInstances) modInsts = (\(ci, (csi, d)) -> (ContractAddress ci csi, d)) <$> Map.toAscList (modelInstances model) tests :: Word -> Spec diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs index eb27377911..44da8fca78 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs @@ -21,6 +21,7 @@ import qualified Concordium.Scheduler.Types as Types import qualified Concordium.Crypto.SHA256 as Hash import Concordium.Scheduler.Runner +import Concordium.GlobalState.Instance import Concordium.GlobalState.Basic.BlockState.Accounts as Acc import Concordium.GlobalState.Basic.BlockState.Instances import Concordium.GlobalState.Basic.BlockState @@ -142,7 +143,7 @@ testCases = fibSpec n bs = specify "Contract state" $ case getInstance (Types.ContractAddress 0 0) (bs ^. blockInstances) of Nothing -> assertFailure "Instnace at <0,0> does not exist." - Just istance -> assertEqual "State contains the n-th Fibonacci number." (fibNBytes n) (instanceModel istance) + Just istance -> assertEqual "State contains the n-th Fibonacci number." (fibNBytes n) (istance ^. instanceModel) fib n = let go = 1:1:zipWith (+) go (tail go) in go !! n diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs index 82eb6cd7a5..056535c76e 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs @@ -18,6 +18,7 @@ import qualified Concordium.Scheduler.EnvironmentImplementation as Types import qualified Concordium.Scheduler as Sch import Concordium.Scheduler.Runner +import Concordium.GlobalState.Instance import Concordium.GlobalState.Basic.BlockState import Concordium.GlobalState.Basic.BlockState.Invariants import Concordium.GlobalState.Basic.BlockState.Instances @@ -81,7 +82,7 @@ checkInitResult proxy (suc, fails, instances) = do assertEqual "There should be no failed transactions." [] fails assertEqual "There should be no rejected transactions." [] reject assertEqual "There should be 1 instance." 1 (length instances) - let model = contractState . instanceModel . snd . head $ instances + let model = contractState . (^. instanceModel) . snd . head $ instances assertEqual "Instance model is the sender address of the account which inialized it." model (encode (senderAccount proxy)) where reject = filter (\case (_, Types.TxSuccess{}) -> False diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs index c06f5e61f7..e6cb403b44 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs @@ -21,7 +21,7 @@ import Concordium.Scheduler.WasmIntegration import Concordium.Types.DummyData import Concordium.Scheduler.DummyData -setup :: String -> IO ModuleInterface +setup :: String -> IO (ModuleInterfaceV V0) setup errString = do source <- BS.readFile "./testdata/contracts/context_test.wasm" let wasmMod = WasmModule 0 $ ModuleSource source From 98111cb86ea36501234a1c24d5acad72d1c209af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Fri, 17 Dec 2021 14:50:32 +0100 Subject: [PATCH 07/51] Add V1 Wasm module version. --- concordium-consensus/smart-contracts | 2 +- .../Scheduler/WasmIntegration/V1.hs | 474 ++++++++++++++++++ 2 files changed, 475 insertions(+), 1 deletion(-) create mode 100644 concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 3552f05801..a3ddf6166f 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 3552f058013538360c8a59d6b47baf87a150a236 +Subproject commit a3ddf6166f08de6f9904901827a61f4fbbb0cca5 diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs new file mode 100644 index 0000000000..473b086c88 --- /dev/null +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -0,0 +1,474 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} +module Concordium.Scheduler.WasmIntegration.V1( + InvokeMethod(..), + InitResultData(..), + ReceiveResultData(..), + applyInitFun, + cerToRejectReasonInit, + cerToRejectReasonReceive, + applyReceiveFun, + resumeReceiveFun, + processModule, + ReturnValue, + ReceiveInterruptedState, + InvokeResponseCode(..), + EnvFailure(..), + ContractExecutionReject(..), + ContractCallFailure(..), + ccfToReturnValue + ) where + +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils (new) +import Foreign.Storable +import Data.Bits +import Data.Int +import Data.Word +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Serialize +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as BSS +import qualified Data.ByteString.Unsafe as BSU +import System.IO.Unsafe +import Foreign.ForeignPtr +import Control.Monad + +import Concordium.Crypto.FFIHelpers(rs_free_array_len) +import Concordium.Types +import qualified Concordium.Types.Execution as Exec +import Concordium.Wasm +import Concordium.GlobalState.Wasm +import Concordium.Utils.Serialization + +foreign import ccall unsafe "&box_vec_u8_free" freeReturnValue :: FunPtr (Ptr ReturnValue -> IO ()) +foreign import ccall unsafe "&receive_interrupted_state_free" freeReceiveInterruptedState :: FunPtr (Ptr (Ptr ReceiveInterruptedState) -> IO ()) + +foreign import ccall "validate_and_process_v1" + validate_and_process :: Ptr Word8 -- ^Pointer to the Wasm module source. + -> CSize -- ^Length of the module source. + -> Ptr CSize -- ^Total length of the output. + -> Ptr (Ptr ModuleArtifactV1) -- ^Null, or the processed module artifact. This is null if and only if the return value is null. + -> IO (Ptr Word8) -- ^Null, or exports. + +-- TODO: Figure ownership. +newtype ReturnValue = ReturnValue { rvPtr :: ForeignPtr ReturnValue } +newtype ReceiveInterruptedState = ReceiveInterruptedState { risPtr :: ForeignPtr (Ptr ReceiveInterruptedState) } + +withReturnValue :: ReturnValue -> (Ptr ReturnValue -> IO a) -> IO a +withReturnValue ReturnValue{..} = withForeignPtr rvPtr + +withMaybeReturnValue :: Maybe ReturnValue -> (Ptr ReturnValue -> IO a) -> IO a +withMaybeReturnValue Nothing k = k nullPtr +withMaybeReturnValue (Just rv) k = withReturnValue rv k + +withReceiveInterruptedState :: ReceiveInterruptedState -> (Ptr (Ptr ReceiveInterruptedState) -> IO a) -> IO a +withReceiveInterruptedState = withForeignPtr . risPtr + +data ContractCallFailure = + ExecutionReject !ContractExecutionReject + | EnvFailure !EnvFailure -- failure of execution due to the state of the host. + +ccfToReturnValue :: ContractCallFailure -> Maybe ReturnValue +ccfToReturnValue (ExecutionReject LogicReject{..}) = Just cerReturnValue +ccfToReturnValue (ExecutionReject Trap) = Nothing +ccfToReturnValue (EnvFailure _) = Nothing + +data InvokeResponseCode = + Success + | Error !ContractCallFailure + +data EnvFailure = + AmountTooLarge !Address !Amount + | MissingAccount !AccountAddress + | MissingContract !ContractAddress + | MessageFailed !Exec.RejectReason -- message to a V0 contract failed. No further information is available. + -- FIXME: We could expose the reject reason if that is what happened. + +-- The response is encoded as follows. +-- - The first 24 bits are all 0 if success and all 1 if failure. +-- - the next 8 bits encode the "EnvFailure or Trap" +-- - the remaining 32 bits are for any response code from calling a contract +invokeResponseToWord64 :: InvokeResponseCode -> Word64 +invokeResponseToWord64 Success = 0 +invokeResponseToWord64 (Error (EnvFailure e)) = + case e of + AmountTooLarge _ _ -> 0xffff_ff01_0000_0000 + MissingAccount _ -> 0xffff_ff02_0000_0000 + MissingContract _ -> 0xffff_ff03_0000_0000 + MessageFailed _ -> 0xffff_ff04_0000_0000 +invokeResponseToWord64 (Error (ExecutionReject Trap)) = 0xffff_ff05_0000_0000 +invokeResponseToWord64 (Error (ExecutionReject LogicReject{..})) = + -- make the last 32 bits the value of the rejection reason + let unsigned = fromIntegral cerRejectReason :: Word32 -- reinterpret the bits + in 0xffff_ff00_0000_0000 .|. fromIntegral unsigned + + +foreign import ccall "call_init_v1" + call_init :: Ptr ModuleArtifactV1 -- ^Pointer to the Wasm artifact. + -> Ptr Word8 -- ^Pointer to the serialized chain meta + init ctx. + -> CSize -- ^Length of the preceding data. + -> Word64 -- ^Amount + -> Ptr Word8 -- ^Pointer to the name of function to invoke. + -> CSize -- ^Length of the name. + -> Ptr Word8 -- ^Pointer to the parameter. + -> CSize -- ^Length of the parameter bytes. + -> Word64 -- ^Available energy. + -> Ptr (Ptr ReturnValue) -- ^Location where the pointer to the return value will be written. + -> Ptr CSize -- ^Length of the output byte array, if non-null. + -> IO (Ptr Word8) -- ^New state and logs, if applicable, or null, signaling out-of-energy. + + +foreign import ccall "call_receive_v1" + call_receive :: Ptr ModuleArtifactV1 -- ^Pointer to the Wasm artifact. + -> Ptr Word8 -- ^Pointer to the serialized receive context. + -> CSize -- ^Length of the preceding data. + -> Word64 -- ^Amount + -> Ptr Word8 -- ^Pointer to the name of the function to invoke. + -> CSize -- ^Length of the name. + -> Ptr Word8 -- ^Pointer to the current state of the smart contracts. This will not be modified. + -> CSize -- ^Length of the state. + -> Ptr Word8 -- ^Pointer to the parameter. + -> CSize -- ^Length of the parameter bytes. + -> Word64 -- ^Available energy. + -> Ptr (Ptr ReturnValue) -- ^Location where the pointer to the return value will be written. + -> Ptr (Ptr ReceiveInterruptedState) -- ^Location where the pointer to interrupted config will be stored. + -> Ptr CSize -- ^Length of the output byte array, if non-null. + -> IO (Ptr Word8) -- ^New state, logs, and actions, if applicable, or null, signaling out-of-energy. + + +foreign import ccall "resume_receive_v1" + resume_receive :: Ptr (Ptr ReceiveInterruptedState) -- ^Location where the pointer to interrupted config will be stored. + -> Ptr Word8 -- ^Pointer to the current state of the smart contracts. This will not be modified. + -> CSize -- ^Length of the state. + -> Word64 -- ^Return status from the interrupt. + -> Ptr ReturnValue -- ^Return value from the call, if any. This will be replaced with an empty vector. + -> Word64 -- ^Available energy. + -> Ptr (Ptr ReturnValue) -- ^Location where the pointer to the return value will be written. + -> Ptr (Ptr ReceiveInterruptedState) -- ^Location where the pointer to interrupted config will be stored. + -> Ptr CSize -- ^Length of the output byte array, if non-null. + -> IO (Ptr Word8) -- ^New state, logs, and actions, if applicable, or null, signaling out-of-energy. + + +-- |Apply an init function which is assumed to be a part of the module. +applyInitFun + :: ModuleInterfaceV V1 + -> ChainMetadata -- ^Chain information available to the contracts. + -> InitContext -- ^Additional parameters supplied by the chain and + -- available to the init method. + -> InitName -- ^Which method to invoke. + -> Parameter -- ^User-provided parameter to the init method. + -> Amount -- ^Amount the contract is going to be initialized with. + -> InterpreterEnergy -- ^Maximum amount of energy that can be used by the interpreter. + -> Maybe (Either ContractExecutionReject InitResultData, InterpreterEnergy) + -- ^Nothing if execution ran out of energy. + -- Just (result, remainingEnergy) otherwise, where @remainingEnergy@ is the amount of energy that is left from the amount given. +applyInitFun miface cm initCtx iName param amnt iEnergy = unsafePerformIO $ do + withModuleArtifact wasmArtifact $ \wasmArtifactPtr -> + BSU.unsafeUseAsCStringLen initCtxBytes $ \(initCtxBytesPtr, initCtxBytesLen) -> + BSU.unsafeUseAsCStringLen nameBytes $ \(nameBytesPtr, nameBytesLen) -> + BSU.unsafeUseAsCStringLen paramBytes $ \(paramBytesPtr, paramBytesLen) -> + alloca $ \returnValuePtrPtr -> alloca $ \outputLenPtr -> do + outPtr <- call_init wasmArtifactPtr + (castPtr initCtxBytesPtr) (fromIntegral initCtxBytesLen) + amountWord + (castPtr nameBytesPtr) (fromIntegral nameBytesLen) + (castPtr paramBytesPtr) (fromIntegral paramBytesLen) + energy + returnValuePtrPtr + outputLenPtr + if outPtr == nullPtr then return (Just (Left Trap, 0)) -- This case should not happen. + else do + len <- peek outputLenPtr + bs <- BSU.unsafePackCStringFinalizer outPtr (fromIntegral len) (rs_free_array_len outPtr (fromIntegral len)) + returnValuePtr <- peek returnValuePtrPtr + processInitResult bs returnValuePtr + where + wasmArtifact = imWasmArtifact miface + initCtxBytes = encodeChainMeta cm <> encodeInitContext initCtx + paramBytes = BSS.fromShort (parameter param) + energy = fromIntegral iEnergy + amountWord = _amount amnt + nameBytes = Text.encodeUtf8 (initName iName) + +data InvokeMethod = + Transfer { + imtTo :: !AccountAddress, + imtAmount :: !Amount + } + | Call { + imcTo :: !ContractAddress, + imcParam :: !Parameter, + imcName :: !ReceiveName, -- FIXME: Should be entrypoint name + imcAmount :: !Amount + } + +getInvokeMethod :: Get InvokeMethod +getInvokeMethod = getWord8 >>= \case + 0 -> Transfer <$> get <*> get + 1 -> Call <$> get <*> get <*> get <*> get + n -> fail $ "Unsupported invoke method tag: " ++ show n + +data InitResultData = InitSuccess { + irdReturnValue :: !ReturnValue, + irdNewState :: !ContractState, + irdLogs :: ![ContractEvent] + } + +data ReceiveResultData = ReceiveSuccess { + rrdReturnValue :: !ReturnValue, + rrdNewState :: !ContractState, + rrdLogs :: ![ContractEvent] + } + | ReceiveInterrupt { + rrdCurrentState :: !ContractState, + rrdMethod :: !InvokeMethod, + rrdInterruptedConfig :: !ReceiveInterruptedState + } + + +getLogs :: Get [ContractEvent] +getLogs = do + len <- fromIntegral <$> getWord32be + replicateM len get + +-- |Reason for failure of contract execution. +data ContractExecutionReject = + LogicReject { cerRejectReason :: !Int32, + cerReturnValue :: !ReturnValue + } -- ^Contract decided to terminate execution. + | Trap -- ^A trap was triggered. + +cerToRejectReasonInit :: ContractExecutionReject -> Exec.RejectReason +cerToRejectReasonInit LogicReject{..} = Exec.RejectedInit cerRejectReason +cerToRejectReasonInit Trap = Exec.RuntimeFailure + +processInitResult :: + -- |Serialized output. + BS.ByteString + -> Ptr ReturnValue -- ^Location where the pointer to the return value is (potentially) stored. + -- |Result, and remaining energy. Returns 'Nothing' if and only if + -- execution ran out of energy. + -> IO (Maybe (Either ContractExecutionReject InitResultData, InterpreterEnergy)) +processInitResult result returnValuePtr = case BS.uncons result of + Nothing -> error "Internal error: Could not parse the result from the interpreter." + Just (tag, payload) -> + case tag of + 0 -> return Nothing + 1 -> let parser = do -- reject + rejectReason <- getInt32be + remainingEnergy <- getWord64be + return (rejectReason, remainingEnergy) + in let (cerRejectReason, remainingEnergy) = parseResult parser + in do cerReturnValue <- ReturnValue <$> newForeignPtr freeReturnValue returnValuePtr + return (Just (Left LogicReject{..}, fromIntegral remainingEnergy)) + 2 -> -- done + let parser = do + newState <- get + logs <- getLogs + remainingEnergy <- getWord64be + return (newState, logs, remainingEnergy) + in let (irdNewState, irdLogs, remainingEnergy) = parseResult parser + in do irdReturnValue <- ReturnValue <$> newForeignPtr freeReturnValue returnValuePtr + return (Just (Right InitSuccess{..}, fromIntegral remainingEnergy)) + _ -> fail $ "Invalid tag: " ++ show tag + where parseResult parser = + case runGet parser payload of + Right x -> x + Left err -> error $ "Internal error: Could not interpret output from interpreter: " ++ err + +-- The input was allocated with alloca. We allocate a fresh one with malloc and register +-- a finalizer for it. +newReceiveInterruptedState :: Ptr (Ptr ReceiveInterruptedState) -> IO ReceiveInterruptedState +newReceiveInterruptedState interruptedStatePtr = do + fp <- newForeignPtr finalizerFree =<< new =<< peek interruptedStatePtr -- allocate a new persistent location and register it for freeing. + -- this second finalizer will run **before** the first one we registered above + -- (see https://hackage.haskell.org/package/base-4.16.0.0/docs/Foreign-ForeignPtr.html#v:addForeignPtrFinalizer) + addForeignPtrFinalizer freeReceiveInterruptedState fp + return (ReceiveInterruptedState fp) + +cerToRejectReasonReceive :: ContractAddress -> ReceiveName -> Parameter -> ContractCallFailure -> Exec.RejectReason +cerToRejectReasonReceive contractAddress receiveName parameter (ExecutionReject LogicReject{..}) = Exec.RejectedReceive{rejectReason=cerRejectReason,..} +cerToRejectReasonReceive _ _ _ (ExecutionReject Trap) = Exec.RuntimeFailure +cerToRejectReasonReceive _ _ _ (EnvFailure e) = case e of + AmountTooLarge ad am -> Exec.AmountTooLarge ad am + MissingAccount aref -> Exec.InvalidAccountReference aref + MissingContract cref -> Exec.InvalidContractAddress cref + MessageFailed rr -> rr + + + +processReceiveResult :: + -- |Serialized output. + BS.ByteString + -> Ptr ReturnValue -- ^Location where the pointer to the return value is (potentially) stored. + -> Ptr (Ptr ReceiveInterruptedState) -- ^Location where the pointer to interrupted config is (potentially) stored. + -- |Result, and remaining energy. Returns 'Nothing' if and only if + -- execution ran out of energy. + -> IO (Maybe (Either ContractExecutionReject ReceiveResultData, InterpreterEnergy)) +processReceiveResult result returnValuePtr interruptedStatePtr = case BS.uncons result of + Nothing -> error "Internal error: Could not parse the result from the interpreter." + Just (tag, payload) -> + case tag of + 0 -> return Nothing + 1 -> let parser = do -- reject + rejectReason <- getInt32be + remainingEnergy <- getWord64be + return (rejectReason, remainingEnergy) + in let (cerRejectReason, remainingEnergy) = parseResult parser + in do cerReturnValue <- ReturnValue <$> newForeignPtr freeReturnValue returnValuePtr + return (Just (Left LogicReject{..}, fromIntegral remainingEnergy)) + 2 -> let parser = do + remainingEnergy <- getWord64be + currentState <- get + method <- getInvokeMethod + return (remainingEnergy, currentState, method) + in let (remainingEnergy, rrdCurrentState, rrdMethod)= parseResult parser + in do rrdInterruptedConfig <- newReceiveInterruptedState interruptedStatePtr + return (Just (Right ReceiveInterrupt{..}, fromIntegral remainingEnergy)) + 3 -> -- done + let parser = do + newState <- get + logs <- getLogs + remainingEnergy <- getWord64be + return (newState, logs, remainingEnergy) + in let (rrdNewState, rrdLogs, remainingEnergy) = parseResult parser + in do rrdReturnValue <- ReturnValue <$> newForeignPtr freeReturnValue returnValuePtr + return (Just (Right ReceiveSuccess{..}, fromIntegral remainingEnergy)) + _ -> fail $ "Invalid tag: " ++ show tag + where parseResult parser = + case runGet parser payload of + Right x -> x + Left err -> error $ "Internal error: Could not interpret output from interpreter: " ++ err + + +-- |Apply a receive function which is assumed to be part of the given module. +applyReceiveFun + :: ModuleInterfaceV V1 + -> ChainMetadata -- ^Metadata available to the contract. + -> ReceiveContext -- ^Additional parameter supplied by the chain and + -- available to the receive method. + -> ReceiveName -- ^Which method to invoke. + -> Parameter -- ^Parameters available to the method. + -> Amount -- ^Amount the contract is initialized with. + -> ContractState -- ^State of the contract to start in. + -> InterpreterEnergy -- ^Amount of energy available for execution. + -> Maybe (Either ContractExecutionReject ReceiveResultData, InterpreterEnergy) + -- ^Nothing if execution used up all the energy, and otherwise the result + -- of execution with the amount of energy remaining. +applyReceiveFun miface cm receiveCtx rName param amnt cs initialEnergy = unsafePerformIO $ do + withModuleArtifact wasmArtifact $ \wasmArtifactPtr -> + BSU.unsafeUseAsCStringLen initCtxBytes $ \(initCtxBytesPtr, initCtxBytesLen) -> + BSU.unsafeUseAsCStringLen nameBytes $ \(nameBytesPtr, nameBytesLen) -> + BSU.unsafeUseAsCStringLen stateBytes $ \(stateBytesPtr, stateBytesLen) -> + BSU.unsafeUseAsCStringLen paramBytes $ \(paramBytesPtr, paramBytesLen) -> + alloca $ \outputLenPtr -> alloca $ \outputReturnValuePtrPtr -> alloca $ \outputInterruptedConfigPtrPtr -> do + outPtr <- call_receive wasmArtifactPtr + (castPtr initCtxBytesPtr) (fromIntegral initCtxBytesLen) + amountWord + (castPtr nameBytesPtr) (fromIntegral nameBytesLen) + (castPtr stateBytesPtr) (fromIntegral stateBytesLen) + (castPtr paramBytesPtr) (fromIntegral paramBytesLen) + energy + outputReturnValuePtrPtr + outputInterruptedConfigPtrPtr + outputLenPtr + if outPtr == nullPtr then return (Just (Left Trap, 0)) -- this case should not happen + else do + len <- peek outputLenPtr + bs <- BSU.unsafePackCStringFinalizer outPtr (fromIntegral len) (rs_free_array_len outPtr (fromIntegral len)) + returnValuePtr <- peek outputReturnValuePtrPtr + processReceiveResult bs returnValuePtr outputInterruptedConfigPtrPtr + where + wasmArtifact = imWasmArtifact miface + initCtxBytes = encodeChainMeta cm <> encodeReceiveContext receiveCtx + amountWord = _amount amnt + stateBytes = contractState cs + energy = fromIntegral initialEnergy + paramBytes = BSS.fromShort (parameter param) + nameBytes = Text.encodeUtf8 (receiveName rName) + +-- |Apply a receive function which is assumed to be part of the given module. +resumeReceiveFun :: + ReceiveInterruptedState + -> ContractState -- ^State of the contract to start in. + -> InvokeResponseCode + -> Maybe ReturnValue + -> InterpreterEnergy -- ^Amount of energy available for execution. + -> Maybe (Either ContractExecutionReject ReceiveResultData, InterpreterEnergy) + -- ^Nothing if execution used up all the energy, and otherwise the result + -- of execution with the amount of energy remaining. +resumeReceiveFun is cs statusCode rVal remainingEnergy = unsafePerformIO $ do + withReceiveInterruptedState is $ \isPtr -> + BSU.unsafeUseAsCStringLen stateBytes $ \(stateBytesPtr, stateBytesLen) -> + withMaybeReturnValue rVal $ \rValPtr -> + alloca $ \outputLenPtr -> alloca $ \outputReturnValuePtrPtr -> alloca $ \outputInterruptedConfigPtrPtr -> do + outPtr <- resume_receive isPtr + (castPtr stateBytesPtr) (fromIntegral stateBytesLen) + (invokeResponseToWord64 statusCode) + rValPtr + energy + outputReturnValuePtrPtr + outputInterruptedConfigPtrPtr + outputLenPtr + if outPtr == nullPtr then return (Just (Left Trap, 0)) -- this case should not happen + else do + len <- peek outputLenPtr + bs <- BSU.unsafePackCStringFinalizer outPtr (fromIntegral len) (rs_free_array_len outPtr (fromIntegral len)) + returnValuePtr <- peek outputReturnValuePtrPtr + processReceiveResult bs returnValuePtr outputInterruptedConfigPtrPtr + where + stateBytes = contractState cs + energy = fromIntegral remainingEnergy + + +-- |Process a module as received and make a module interface. This should +-- check the module is well-formed, and has the right imports and exports. It +-- should also do any pre-processing of the module (such as partial +-- compilation or instrumentation) that is needed to apply the exported +-- functions from it in an efficient way. +{-# NOINLINE processModule #-} +processModule :: WasmModule -> Maybe (ModuleInterfaceV V1) +processModule modl = do + (bs, imWasmArtifactV1) <- ffiResult + case getExports bs of + Left _ -> Nothing + Right (miExposedInit, miExposedReceive) -> + let miModuleRef = getModuleRef modl + miModule = InstrumentedWasmModuleV1{..} + in Just ModuleInterface{miModuleSize = moduleSourceLength $ wasmSource modl,..} + + where ffiResult = unsafePerformIO $ do + unsafeUseModuleSourceAsCStringLen (wasmSource modl) $ \(wasmBytesPtr, wasmBytesLen) -> + alloca $ \outputLenPtr -> + alloca $ \outputModuleArtifactPtr -> do + outPtr <- validate_and_process (castPtr wasmBytesPtr) (fromIntegral wasmBytesLen) outputLenPtr outputModuleArtifactPtr + if outPtr == nullPtr then return Nothing + else do + len <- peek outputLenPtr + bs <- BSU.unsafePackCStringFinalizer outPtr (fromIntegral len) (rs_free_array_len outPtr (fromIntegral len)) + moduleArtifact <- newModuleArtifactV1 =<< peek outputModuleArtifactPtr + return (Just (bs, moduleArtifact)) + + getExports bs = + flip runGet bs $ do + len <- fromIntegral <$> getWord16be + namesByteStrings <- replicateM len getByteStringWord16 + let names = foldM (\(inits, receives) name -> do + case Text.decodeUtf8' name of + Left _ -> Nothing + Right nameText | isValidInitName nameText -> return (Set.insert (InitName nameText) inits, receives) + | isValidReceiveName nameText -> + let cname = "init_" <> Text.takeWhile (/= '.') nameText + in return (inits, Map.insertWith Set.union (InitName cname) (Set.singleton (ReceiveName nameText)) receives) + | otherwise -> Nothing + ) (Set.empty, Map.empty) namesByteStrings + case names of + Nothing -> fail "Incorrect response from FFI call." + Just x@(exposedInits, exposedReceives) -> + if Map.keysSet exposedReceives `Set.isSubsetOf` exposedInits then return x else fail "Receive functions that do not correspond to any contract." From 55ee7291b9330eada82fc18efe2db1b9392b5351 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Wed, 22 Dec 2021 11:53:00 +0100 Subject: [PATCH 08/51] Initial tests of V1 modules. --- concordium-base | 2 +- concordium-consensus/.diff-wat-wasm.sh | 2 +- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/GlobalState/AccountMap.hs | 4 +- .../GlobalState/Basic/BlockState.hs | 1 + .../GlobalState/Basic/BlockState/Account.hs | 2 + .../src/Concordium/GlobalState/Block.hs | 1 + .../GlobalState/Persistent/Account.hs | 3 + .../Persistent/BlockState/Modules.hs | 1 + .../GlobalState/Persistent/Instances.hs | 2 +- .../src/Concordium/Scheduler.hs | 2 +- .../Scheduler/WasmIntegration/V1.hs | 30 ++-- .../testdata/contracts/v1/call-counter.wasm | Bin 0 -> 339 bytes .../testdata/contracts/v1/call-counter.wat | 64 +++++++++ .../SmartContracts/V1/Counter.hs | 134 ++++++++++++++++++ .../scheduler/SchedulerTests/TestUtils.hs | 3 +- concordium-consensus/tests/scheduler/Spec.hs | 3 + 17 files changed, 233 insertions(+), 23 deletions(-) create mode 100644 concordium-consensus/testdata/contracts/v1/call-counter.wasm create mode 100644 concordium-consensus/testdata/contracts/v1/call-counter.wat create mode 100644 concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs diff --git a/concordium-base b/concordium-base index 08bee7492e..7c9058b863 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 08bee7492e4cc8296d7eecaa44e3e8d8d50167bf +Subproject commit 7c9058b8638eb7a1cbcff7b2d134bd7de7f7a253 diff --git a/concordium-consensus/.diff-wat-wasm.sh b/concordium-consensus/.diff-wat-wasm.sh index 34a131949a..90e2eb2604 100755 --- a/concordium-consensus/.diff-wat-wasm.sh +++ b/concordium-consensus/.diff-wat-wasm.sh @@ -11,7 +11,7 @@ pushd testdata/contracts RET=0 -for wat in *wat;do +for wat in $(find -name '*.wat'); do OUT=$(mktemp) wat2wasm $wat -o $OUT; if ! $(diff $OUT "${wat%.wat}.wasm") diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index a3ddf6166f..efc0aca1ee 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit a3ddf6166f08de6f9904901827a61f4fbbb0cca5 +Subproject commit efc0aca1eec9f4f0a1cc6aa74b6132ca7c175392 diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap.hs index b516eb3ce1..39c00ca639 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap.hs @@ -116,7 +116,7 @@ lookup addr (AccountMap am) = case protocolVersion @pv of -- addresses with the same prefix created in protocol versions 1 and 2 we have -- a fallback. If such a situation does occur then those accounts can only be -- referred to by the exact address. This is what the logic below implements. - SP3 -> Trie.lookupPrefix (mkPrefix addr) am >>= \case + _ -> Trie.lookupPrefix (mkPrefix addr) am >>= \case [] -> return Nothing [(_, v)] -> return (Just v) fs -> case filter ((== addr) . fst) fs of @@ -129,7 +129,7 @@ addressWouldClash :: forall pv fix m . (IsProtocolVersion pv, TrieGetContext fix addressWouldClash addr (AccountMap am) = case protocolVersion @pv of SP1 -> isJust <$> Trie.lookup addr am SP2 -> isJust <$> Trie.lookup addr am - SP3 -> not . null <$> Trie.lookupPrefix (mkPrefix addr) am + _ -> not . null <$> Trie.lookupPrefix (mkPrefix addr) am -- |Insert a new key value pair if it is fresh. If the key already exists in the -- map no changes are made and the existing 'AccountIndex' is returned. diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs index e4edc2f635..c2b66510c1 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs @@ -221,6 +221,7 @@ hashBlockState = case protocolVersion :: SProtocolVersion pv of SP1 -> hashBlockStateP1 SP2 -> hashBlockStateP1 SP3 -> hashBlockStateP1 + SP4 -> hashBlockStateP1 -- For protocol versions P1, P2, and P3, convert a @BlockState pv@ to a -- @HashedBlockState pv@ by computing the state hash. The state and hashing -- is the same. This function was introduced in protocol version 1 which is diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Account.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Account.hs index ebf15378cc..205344792b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Account.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Account.hs @@ -46,6 +46,7 @@ showAccountPersisting spv = case spv of SP1 -> show SP2 -> show SP3 -> show + SP4 -> show -- |An (in-memory) account. data Account (pv :: ProtocolVersion) = Account { @@ -163,6 +164,7 @@ instance (IsProtocolVersion pv) => HashableTo Hash.Hash (Account pv) where SP1 -> makeAccountHashP1 _accountNonce _accountAmount _accountEncryptedAmount (getHash _accountReleaseSchedule) (getHash _accountPersisting) bkrHash SP2 -> makeAccountHashP1 _accountNonce _accountAmount _accountEncryptedAmount (getHash _accountReleaseSchedule) (getHash _accountPersisting) bkrHash SP3 -> makeAccountHashP1 _accountNonce _accountAmount _accountEncryptedAmount (getHash _accountReleaseSchedule) (getHash _accountPersisting) bkrHash + SP4 -> makeAccountHashP1 _accountNonce _accountAmount _accountEncryptedAmount (getHash _accountReleaseSchedule) (getHash _accountPersisting) bkrHash where bkrHash = maybe nullAccountBakerHash getHash _accountBaker diff --git a/concordium-consensus/src/Concordium/GlobalState/Block.hs b/concordium-consensus/src/Concordium/GlobalState/Block.hs index 78c6f550a7..68d2483256 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Block.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Block.hs @@ -112,6 +112,7 @@ blockVersion :: SProtocolVersion pv -> Version blockVersion SP1 = 2 blockVersion SP2 = 2 blockVersion SP3 = 2 +blockVersion SP4 = 2 {-# INLINE blockVersion #-} -- |Type class that supports serialization of a block. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs index 150448918f..380de48128 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs @@ -359,6 +359,9 @@ makeAccountHash SP2 n a eas ars pd abh = do makeAccountHash SP3 n a eas ars pd abh = do pdHash <- getHashM pd return $ makeAccountHashP1 n a eas ars pdHash abh +makeAccountHash SP4 n a eas ars pd abh = do + pdHash <- getHashM pd + return $ makeAccountHashP1 n a eas ars pdHash abh -- |Recompute the hash of an account. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs index 73e18f62d8..9dbc4ce3df 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs @@ -6,6 +6,7 @@ module Concordium.GlobalState.Persistent.BlockState.Modules Modules, getModuleInterface, source, + interface, emptyModules, getInterface, getSource, diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs index 359e7a98ce..3016d357a8 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs @@ -126,7 +126,7 @@ instance (IsProtocolVersion pv, MonadBlobStore m) => BlobStorable m (PersistentI if demoteProtocolVersion (protocolVersion @pv) <= P3 then case inst of PersistentInstanceV0 i -> second PersistentInstanceV0 <$> storeUnversioned i - PersistentInstanceV1 i -> error "Precondition violation. V1 instances do not exist in protocol versions <= 3." + PersistentInstanceV1 _i -> error "Precondition violation. V1 instances do not exist in protocol versions <= 3." else case inst of PersistentInstanceV0 i -> addVersion 0 PersistentInstanceV0 <$> storeUnversioned i PersistentInstanceV1 i -> addVersion 1 PersistentInstanceV1 <$> storeUnversioned i diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 19815f760f..53b6f1b1af 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -853,7 +853,7 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para -- transfer the amount from the sender. We first check whether that is actually available for the sender at this point in time -- since synchronous calls might have affected it before this point. senderamount <- getCurrentAvailableAmount sender - if senderamount >= transferAmount then return (Left (WasmV1.EnvFailure (WasmV1.AmountTooLarge senderAddr transferAmount))) + if senderamount < transferAmount then return (Left (WasmV1.EnvFailure (WasmV1.AmountTooLarge senderAddr transferAmount))) else withToContractAmount sender istance transferAmount $ let event = Updated{euAddress=instanceAddress istance, euInstigator=senderAddr, diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 473b086c88..4335e74433 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -261,17 +261,17 @@ processInitResult result returnValuePtr = case BS.uncons result of case tag of 0 -> return Nothing 1 -> let parser = do -- reject - rejectReason <- getInt32be - remainingEnergy <- getWord64be + rejectReason <- label "Reject.rejectReason" getInt32be + remainingEnergy <- label "Reject.remainingEnergy" getWord64be return (rejectReason, remainingEnergy) in let (cerRejectReason, remainingEnergy) = parseResult parser in do cerReturnValue <- ReturnValue <$> newForeignPtr freeReturnValue returnValuePtr return (Just (Left LogicReject{..}, fromIntegral remainingEnergy)) 2 -> -- done let parser = do - newState <- get - logs <- getLogs - remainingEnergy <- getWord64be + newState <- label "Done.newState" get + logs <- label "Done.logs" getLogs + remainingEnergy <- label "Done.remainingEnergy" getWord64be return (newState, logs, remainingEnergy) in let (irdNewState, irdLogs, remainingEnergy) = parseResult parser in do irdReturnValue <- ReturnValue <$> newForeignPtr freeReturnValue returnValuePtr @@ -317,25 +317,25 @@ processReceiveResult result returnValuePtr interruptedStatePtr = case BS.uncons case tag of 0 -> return Nothing 1 -> let parser = do -- reject - rejectReason <- getInt32be - remainingEnergy <- getWord64be + rejectReason <- label "Reject.rejectReason" getInt32be + remainingEnergy <- label "Reject.remainingEnergy" getWord64be return (rejectReason, remainingEnergy) in let (cerRejectReason, remainingEnergy) = parseResult parser in do cerReturnValue <- ReturnValue <$> newForeignPtr freeReturnValue returnValuePtr return (Just (Left LogicReject{..}, fromIntegral remainingEnergy)) - 2 -> let parser = do - remainingEnergy <- getWord64be - currentState <- get - method <- getInvokeMethod + 3 -> let parser = do -- interrupt + remainingEnergy <- label "Interrupt.remainingEnergy" getWord64be + currentState <- label "Interrupt.currentState" get + method <- label "Interrupt.method" getInvokeMethod return (remainingEnergy, currentState, method) in let (remainingEnergy, rrdCurrentState, rrdMethod)= parseResult parser in do rrdInterruptedConfig <- newReceiveInterruptedState interruptedStatePtr return (Just (Right ReceiveInterrupt{..}, fromIntegral remainingEnergy)) - 3 -> -- done + 2 -> -- done let parser = do - newState <- get - logs <- getLogs - remainingEnergy <- getWord64be + newState <- label "Done.newState" get + logs <- label "Done.logs" getLogs + remainingEnergy <- label "Done.remainingEnergy" getWord64be return (newState, logs, remainingEnergy) in let (rrdNewState, rrdLogs, remainingEnergy) = parseResult parser in do rrdReturnValue <- ReturnValue <$> newForeignPtr freeReturnValue returnValuePtr diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wasm b/concordium-consensus/testdata/contracts/v1/call-counter.wasm new file mode 100644 index 0000000000000000000000000000000000000000..ec4a75935b941efc5a370e204cafc0f07f9f2885 GIT binary patch literal 339 zcmY+8u};J=5JYF~I2`dIu7KtWl!68c(b5tM_zXMBStko(M~MRsIv4yn4hd4&Eq3P3 zSTgFNB>;4r>nx_BsQGkG^NE_p2n}dDQDomFipIOf_Xj(+*GCgnSNC;mg6Y*@nqa*H zR+Zek5C3LBE4KaYZ7|A@p&J9(DkNPRm+XlIq@3OB;&!N}Eh{8d?u5Kb_8E_SqMJms3YYT!&+&aq Rslpw{*Q%4~Z BSS.ShortByteString +fibParamBytes n = BSS.toShort $ runPut (putWord64le n) + +counterSourceFile :: FilePath +counterSourceFile = "./testdata/contracts/v1/call-counter.wasm" + +wasmModVersion :: Word32 +wasmModVersion = 1 + +testCases :: [TestCase PV4] +testCases = + [ TestCase + { tcName = "Counter updates and returns." + , tcParameters = defaultParams {tpInitialBlockState=initialBlockState} + , tcTransactions = + [ ( TJSON { payload = DeployModule wasmModVersion counterSourceFile + , metadata = makeDummyHeader alesAccount 1 100000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary deploymentCostCheck, emptySpec) + ) + , ( TJSON { payload = InitContract 0 wasmModVersion counterSourceFile "init_counter" "" + , metadata = makeDummyHeader alesAccount 2 100000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary initializationCostCheck, counterSpec 0) + ) + , ( TJSON { payload = Update 0 (Types.ContractAddress 0 0) "counter.inc" BSS.empty + , metadata = makeDummyHeader alesAccount 3 700000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary ensureAllUpdates , counterSpec 1) + ) + , ( TJSON { payload = Update 0 (Types.ContractAddress 0 0) "counter.inc" BSS.empty + , metadata = makeDummyHeader alesAccount 4 700000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary ensureAllUpdates , counterSpec 2) + ) + ] + } + ] + + where + deploymentCostCheck :: Types.BlockItem -> Types.TransactionSummary -> Expectation + deploymentCostCheck _ Types.TransactionSummary{..} = do + checkSuccess "Module deployment failed: " tsResult + moduleSource <- BS.readFile counterSourceFile + let len = fromIntegral $ BS.length moduleSource + -- size of the module deploy payload + payloadSize = Types.payloadSize (Types.encodePayload (Types.DeployModule (WasmModule wasmModVersion ModuleSource{..}))) + -- size of the transaction minus the signatures. + txSize = Types.transactionHeaderSize + fromIntegral payloadSize + -- transaction is signed with 1 signature + assertEqual "Deployment has correct cost " (Cost.baseCost txSize 1 + Cost.deployModuleCost len) tsEnergyCost + + -- check that the initialization cost was at least the administrative cost. + -- It is not practical to check the exact cost because the execution cost of the init function is hard to + -- have an independent number for, other than executing. + initializationCostCheck :: Types.BlockItem -> Types.TransactionSummary -> Expectation + initializationCostCheck _ Types.TransactionSummary{..} = do + checkSuccess "Contract initialization failed: " tsResult + moduleSource <- BS.readFile counterSourceFile + let modLen = fromIntegral $ BS.length moduleSource + modRef = Types.ModuleRef (Hash.hash moduleSource) + payloadSize = Types.payloadSize (Types.encodePayload (Types.InitContract 0 modRef (InitName "init_counter") (Parameter ""))) + -- size of the transaction minus the signatures. + txSize = Types.transactionHeaderSize + fromIntegral payloadSize + -- transaction is signed with 1 signature + baseTxCost = Cost.baseCost txSize 1 + -- lower bound on the cost of the transaction, assuming no interpreter energy + -- we know the size of the state should be 8 bytes + costLowerBound = baseTxCost + Cost.initializeContractInstanceCost 0 modLen (Just 8) + unless (tsEnergyCost >= costLowerBound) $ + assertFailure $ "Actual initialization cost " ++ show tsEnergyCost ++ " not more than lower bound " ++ show costLowerBound + + ensureAllUpdates :: Types.BlockItem -> Types.TransactionSummary -> Expectation + ensureAllUpdates _ Types.TransactionSummary{..} = checkSuccess "Update failed" tsResult + + checkSuccess msg Types.TxReject{..} = assertFailure $ msg ++ show vrRejectReason + checkSuccess _ _ = return () + + -- Check that the contract state contains n. + counterSpec n bs = specify "Contract state" $ + case getInstance (Types.ContractAddress 0 0) (bs ^. blockInstances) of + Nothing -> assertFailure "Instnace at <0,0> does not exist." + Just istance -> assertEqual ("State contains " ++ show n ++ ".") (ContractState (runPut (putWord64le n))) (istance ^. instanceModel) + +tests :: Spec +tests = describe "Counter counts." $ + mkSpecs testCases diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/TestUtils.hs b/concordium-consensus/tests/scheduler/SchedulerTests/TestUtils.hs index 5d720fc708..8e62ea962d 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/TestUtils.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/TestUtils.hs @@ -10,7 +10,7 @@ Also checks invariants on the block state after each processed transaction. NOTE: This processes each transaction individually - for testing grouped transactions, see 'SchedulerTests.TransactionGroupingSpec' and 'SchedulerTests.TransactionGroupingSpec2'. -} -module SchedulerTests.TestUtils(PV1, PV2, PV3, ResultSpec,TResultSpec(..),emptySpec,emptyExpect,TestCase(..), +module SchedulerTests.TestUtils(PV1, PV2, PV3, PV4, ResultSpec,TResultSpec(..),emptySpec,emptyExpect,TestCase(..), TestParameters(..),defaultParams, mkSpec,mkSpecs, createAlias) where import Test.Hspec @@ -35,6 +35,7 @@ import Data.Time type PV1 = 'P1 type PV2 = 'P2 type PV3 = 'P3 +type PV4 = 'P4 -- | Specification on the expected result of executing a transaction and the resulting block state. diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index 144a54b94d..a20b25de56 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -25,6 +25,8 @@ import qualified SchedulerTests.StakedAmountLocked(tests) import qualified SchedulerTests.RejectReasons(tests) import qualified SchedulerTests.RejectReasonsRustContract(tests) +import qualified SchedulerTests.SmartContracts.V1.Counter(tests) + import Test.Hspec main :: IO () @@ -53,3 +55,4 @@ main = hspec $ do SchedulerTests.StakedAmountLocked.tests SchedulerTests.RejectReasons.tests SchedulerTests.RejectReasonsRustContract.tests + SchedulerTests.SmartContracts.V1.Counter.tests From 3ad4a23e778b3deb50995550360ad7e2c169bfe7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Wed, 22 Dec 2021 14:35:32 +0100 Subject: [PATCH 09/51] More tests of contract invocations. Fix some FFI bugs with mismatched parameters. --- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/Scheduler.hs | 14 ++++++++------ .../src/Concordium/Scheduler/Environment.hs | 8 ++++++++ .../Scheduler/WasmIntegration/V1.hs | 16 ++++++++-------- .../testdata/contracts/v1/call-counter.wasm | Bin 339 -> 444 bytes .../testdata/contracts/v1/call-counter.wat | 18 ++++++++++++++++++ .../SmartContracts/V1/Counter.hs | 15 ++++++++++++++- 7 files changed, 57 insertions(+), 16 deletions(-) diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index efc0aca1ee..2cd38a11f8 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit efc0aca1eec9f4f0a1cc6aa74b6132ca7c175392 +Subproject commit 2cd38a11f8333234b02c78748f99e573fceeaa51 diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 53b6f1b1af..10402ebe58 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -845,9 +845,9 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para -- we've covered basic administrative costs now. Now iterate until the end of execution, handling any interrupts. let go :: [Event] -> Either WasmV1.ContractExecutionReject WasmV1.ReceiveResultData -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) go _ (Left cer) = return (Left (WasmV1.ExecutionReject cer)) - go events (Right rrData) = + go events (Right rrData) = case rrData of - WasmV1.ReceiveSuccess{..} -> + WasmV1.ReceiveSuccess{..} -> do -- execution terminated, commit the new state withInstanceStateV1 istance rrdNewState $ do -- transfer the amount from the sender. We first check whether that is actually available for the sender at this point in time @@ -881,14 +881,16 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para (runSuccess `orElseWith` (return . Left)) >>= \case Left rr -> -- execution failed. go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) - Right evs -> - go (evs ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success Nothing) + Right evs -> do + newState <- getCurrentContractInstanceState istance + go (evs ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success Nothing) Just (InstanceV1 targetInstance) -> do withRollback (handleContractUpdateV1 originAddr targetInstance (Left (ownerAccount, istance)) imcAmount imcName imcParam) >>= \case Left cer -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) - Right (rVal, callEvents) -> - go (callEvents ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success (Just rVal)) + Right (rVal, callEvents) -> do + newState <- getCurrentContractInstanceState istance + go (callEvents ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success (Just rVal)) -- start contract execution go [] =<< runInterpreter (return . WasmV1.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 997bb219bc..d138481f4f 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -371,6 +371,8 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Same as above, but for contracts. getCurrentContractAmount :: (HasInstanceParameters a, HasInstanceFields a) => a -> m Amount + getCurrentContractInstanceState :: (HasInstanceParameters a, HasInstanceFields a) => a -> m Wasm.ContractState + -- |Get the amount of energy remaining for the transaction. getEnergy :: m (Energy, EnergyLimitReason) @@ -807,6 +809,12 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where let !updated = updateInstance delta newmodel i in return (Just updated) + getCurrentContractInstanceState istance = do + newStates <- use (changeSet . instanceUpdates) + case newStates ^. at (instanceAddress istance) of + Nothing -> return (istance ^. instanceModel) + Just (_, s) -> return s + {-# INLINE getStateAccount #-} getStateAccount = liftLocal . getAccount diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 4335e74433..5d862a4c22 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -150,7 +150,6 @@ foreign import ccall "resume_receive_v1" -> Ptr ReturnValue -- ^Return value from the call, if any. This will be replaced with an empty vector. -> Word64 -- ^Available energy. -> Ptr (Ptr ReturnValue) -- ^Location where the pointer to the return value will be written. - -> Ptr (Ptr ReceiveInterruptedState) -- ^Location where the pointer to interrupted config will be stored. -> Ptr CSize -- ^Length of the output byte array, if non-null. -> IO (Ptr Word8) -- ^New state, logs, and actions, if applicable, or null, signaling out-of-energy. @@ -307,11 +306,11 @@ processReceiveResult :: -- |Serialized output. BS.ByteString -> Ptr ReturnValue -- ^Location where the pointer to the return value is (potentially) stored. - -> Ptr (Ptr ReceiveInterruptedState) -- ^Location where the pointer to interrupted config is (potentially) stored. + -> Either ReceiveInterruptedState (Ptr (Ptr ReceiveInterruptedState)) -- ^Location where the pointer to interrupted config is (potentially) stored. -- |Result, and remaining energy. Returns 'Nothing' if and only if -- execution ran out of energy. -> IO (Maybe (Either ContractExecutionReject ReceiveResultData, InterpreterEnergy)) -processReceiveResult result returnValuePtr interruptedStatePtr = case BS.uncons result of +processReceiveResult result returnValuePtr eitherInterruptedStatePtr = case BS.uncons result of Nothing -> error "Internal error: Could not parse the result from the interpreter." Just (tag, payload) -> case tag of @@ -329,7 +328,9 @@ processReceiveResult result returnValuePtr interruptedStatePtr = case BS.uncons method <- label "Interrupt.method" getInvokeMethod return (remainingEnergy, currentState, method) in let (remainingEnergy, rrdCurrentState, rrdMethod)= parseResult parser - in do rrdInterruptedConfig <- newReceiveInterruptedState interruptedStatePtr + in do rrdInterruptedConfig <- case eitherInterruptedStatePtr of + Left rrid -> return rrid + Right interruptedStatePtr -> newReceiveInterruptedState interruptedStatePtr return (Just (Right ReceiveInterrupt{..}, fromIntegral remainingEnergy)) 2 -> -- done let parser = do @@ -383,7 +384,7 @@ applyReceiveFun miface cm receiveCtx rName param amnt cs initialEnergy = unsafeP len <- peek outputLenPtr bs <- BSU.unsafePackCStringFinalizer outPtr (fromIntegral len) (rs_free_array_len outPtr (fromIntegral len)) returnValuePtr <- peek outputReturnValuePtrPtr - processReceiveResult bs returnValuePtr outputInterruptedConfigPtrPtr + processReceiveResult bs returnValuePtr (Right outputInterruptedConfigPtrPtr) where wasmArtifact = imWasmArtifact miface initCtxBytes = encodeChainMeta cm <> encodeReceiveContext receiveCtx @@ -407,21 +408,20 @@ resumeReceiveFun is cs statusCode rVal remainingEnergy = unsafePerformIO $ do withReceiveInterruptedState is $ \isPtr -> BSU.unsafeUseAsCStringLen stateBytes $ \(stateBytesPtr, stateBytesLen) -> withMaybeReturnValue rVal $ \rValPtr -> - alloca $ \outputLenPtr -> alloca $ \outputReturnValuePtrPtr -> alloca $ \outputInterruptedConfigPtrPtr -> do + alloca $ \outputLenPtr -> alloca $ \outputReturnValuePtrPtr -> do outPtr <- resume_receive isPtr (castPtr stateBytesPtr) (fromIntegral stateBytesLen) (invokeResponseToWord64 statusCode) rValPtr energy outputReturnValuePtrPtr - outputInterruptedConfigPtrPtr outputLenPtr if outPtr == nullPtr then return (Just (Left Trap, 0)) -- this case should not happen else do len <- peek outputLenPtr bs <- BSU.unsafePackCStringFinalizer outPtr (fromIntegral len) (rs_free_array_len outPtr (fromIntegral len)) returnValuePtr <- peek outputReturnValuePtrPtr - processReceiveResult bs returnValuePtr outputInterruptedConfigPtrPtr + processReceiveResult bs returnValuePtr (Left is) where stateBytes = contractState cs energy = fromIntegral remainingEnergy diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wasm b/concordium-consensus/testdata/contracts/v1/call-counter.wasm index ec4a75935b941efc5a370e204cafc0f07f9f2885..e9d74571d4f71c92962a0ab86de92c1bd67ee68a 100644 GIT binary patch literal 444 zcmZ8b-AcnS7(HLoX4-66L~nMLT@GZpD{mJs6rZ9kU6812MwcpxEbpQ(YU(Cb6Zp<| z{z6dgHUxm?qmlxJG70fSh diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wat b/concordium-consensus/testdata/contracts/v1/call-counter.wat index 1dfe6b5942..25cfa10a0e 100644 --- a/concordium-consensus/testdata/contracts/v1/call-counter.wat +++ b/concordium-consensus/testdata/contracts/v1/call-counter.wat @@ -10,6 +10,7 @@ ;; Imports + (import "concordium" "get_parameter_size" (func $get_parameter_size (param $index i32) (result i32))) (import "concordium" "get_parameter_section" (func $get_parameter_section (param $index i32) (param $write_location i32) (param $length i32) (param $offset i32) (result i32))) (import "concordium" "invoke" (func $invoke (param $tag i32) (param $start i32) (param $length i32) (result i64))) (import "concordium" "write_output" (func $write_output (param $start i32) (param $length i32) (param $offset i32) (result i32))) @@ -60,5 +61,22 @@ ;; and return success (i32.const 0) ) + + ;; call the counter.inc method 10 times + (func $inc_counter_10 (export "counter.inc10") (param i64) (result i32) + (local $n i32) + (local $size i32) + (local.set $size (call $get_parameter_size (i32.const 0))) + (call $get_parameter_section (i32.const 0) (i32.const 0) (local.get $size) (i32.const 0)) + (loop $loop + (call $invoke (i32.const 1) (i32.const 0) (local.get $size)) + (drop) ;; ignore the return value + (local.set $n (i32.add (i32.const 1) (local.get $n))) + (br_if $loop (i32.lt_u (local.get $n) (i32.const 10)))) + (drop) + ;; and return success + (i32.const 0) + ) + (memory 1) ) \ No newline at end of file diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs index eeeff74dd5..26b4beb80f 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs @@ -12,7 +12,7 @@ import Test.HUnit(assertFailure, assertEqual) import qualified Data.ByteString.Short as BSS import qualified Data.ByteString as BS -import Data.Serialize(runPut, putWord64le) +import Data.Serialize(runPut, putWord64le, putWord32le, putByteString, putWord16le) import Data.Word import Lens.Micro.Platform import Control.Monad @@ -80,11 +80,24 @@ testCases = } , (SuccessWithSummary ensureAllUpdates , counterSpec 2) ) + , ( TJSON { payload = Update 0 (Types.ContractAddress 0 0) "counter.inc10" callArgs + , metadata = makeDummyHeader alesAccount 5 700000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary ensureAllUpdates , counterSpec 12) + ) ] } ] where + callArgs = BSS.toShort $ runPut $ do + putWord64le 0 -- contract index + putWord64le 0 -- contract subindex + putWord32le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "counter.inc")) + putByteString "counter.inc" + putWord64le 0 -- amount deploymentCostCheck :: Types.BlockItem -> Types.TransactionSummary -> Expectation deploymentCostCheck _ Types.TransactionSummary{..} = do checkSuccess "Module deployment failed: " tsResult From e5a0ec45ea5915f7895e4e617185175da376ee56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Wed, 22 Dec 2021 17:04:14 +0100 Subject: [PATCH 10/51] Add more checks to the call test. --- .../testdata/contracts/v1/call-counter.wasm | Bin 444 -> 562 bytes .../testdata/contracts/v1/call-counter.wat | 37 ++++++++++++++++-- 2 files changed, 33 insertions(+), 4 deletions(-) diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wasm b/concordium-consensus/testdata/contracts/v1/call-counter.wasm index e9d74571d4f71c92962a0ab86de92c1bd67ee68a..571bda64fa0dd2f746379189510181bcaac83837 100644 GIT binary patch delta 269 zcmdnPyorUIA+b1@k%57MQIBIHw<0rBUEM^j4fUKHEUYYS>_EWE%*epVZp*@xnU`4- zpPXNsSCU%9z{L$^>1F06GjQ|3cx9QX)ZMldTv7p85}tr83b6QpbTapgFASY;3H|j0}wIddxhTd6^~g$@!&u zC8B(tZYf6wZUE|X8zuk% diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wat b/concordium-consensus/testdata/contracts/v1/call-counter.wat index 25cfa10a0e..5aba54863c 100644 --- a/concordium-consensus/testdata/contracts/v1/call-counter.wat +++ b/concordium-consensus/testdata/contracts/v1/call-counter.wat @@ -26,6 +26,11 @@ (then nop) (else unreachable))) + (func $assert_eq_64 (param $actual i64) (param $expected i64) + (if (i64.eq (local.get $actual) (local.get $expected)) + (then nop) + (else unreachable))) + (func $assert_ne (param $actual i32) (param $expected i32) (if (i32.ne (local.get $actual) (local.get $expected)) (then nop) @@ -62,21 +67,45 @@ (i32.const 0) ) - ;; call the counter.inc method 10 times + ;; return the current value of the counter in the return value. + (func $view_counter (export "counter.view") (param i64) (result i32) + (call $load_state (i32.const 0) (i32.const 8) (i32.const 0)) + (drop) + (call $write_output (i32.const 0) (i32.const 8) (i32.const 0)) + (drop) + ;; and return success + (i32.const 0) + ) + + ;; call the counter.inc method 10 times. Check returns each time. (func $inc_counter_10 (export "counter.inc10") (param i64) (result i32) (local $n i32) (local $size i32) + (local $rv i64) + (local $index i32) (local.set $size (call $get_parameter_size (i32.const 0))) (call $get_parameter_section (i32.const 0) (i32.const 0) (local.get $size) (i32.const 0)) (loop $loop - (call $invoke (i32.const 1) (i32.const 0) (local.get $size)) - (drop) ;; ignore the return value + (local.set $rv (call $invoke (i32.const 1) (i32.const 0) (local.get $size))) + ;; get the index of the response + (local.set $index (i32.wrap_i64 (i64.shr_u (local.get $rv) (i64.const 40)))) + ;; and get the parameter size, check it that it is the value of the counter + ;; first check that the size is correct + (call $assert_eq (call $get_parameter_size (local.get $index)) (i32.const 8)) + ;; next check that the return value is the same as the current contract state (state after the call) + ;; write the parameter just after the initial parameter + (call $get_parameter_section (local.get $index) (local.get $size) (i32.const 8) (i32.const 0)) + (drop) + ;; read the contract state as well + (call $load_state (i32.add (local.get $size) (i32.const 8)) (i32.const 8) (i32.const 0)) + (drop) + ;; and then check that the return value is the same as the current state of the contract + (call $assert_eq_64 (i64.load (local.get $size)) (i64.load (i32.add (local.get $size) (i32.const 8)))) (local.set $n (i32.add (i32.const 1) (local.get $n))) (br_if $loop (i32.lt_u (local.get $n) (i32.const 10)))) (drop) ;; and return success (i32.const 0) ) - (memory 1) ) \ No newline at end of file From c058152874cf08e78ed706f080ca040f431d778f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Wed, 22 Dec 2021 17:40:58 +0100 Subject: [PATCH 11/51] Expose method to convert from return value to bytestring. --- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/Scheduler/WasmIntegration/V1.hs | 14 ++++++++++++-- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 2cd38a11f8..9f9c3427f9 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 2cd38a11f8333234b02c78748f99e573fceeaa51 +Subproject commit 9f9c3427f981b5bda8fac40c09bf527d938fbc6c diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 5d862a4c22..45be76d517 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -16,7 +16,8 @@ module Concordium.Scheduler.WasmIntegration.V1( EnvFailure(..), ContractExecutionReject(..), ContractCallFailure(..), - ccfToReturnValue + ccfToReturnValue, + returnValueToByteString ) where import Foreign.C.Types @@ -46,6 +47,8 @@ import Concordium.Wasm import Concordium.GlobalState.Wasm import Concordium.Utils.Serialization +foreign import ccall unsafe "return_value_to_byte_array" return_value_to_byte_array :: Ptr ReturnValue -> Ptr CSize -> IO (Ptr Word8) + foreign import ccall unsafe "&box_vec_u8_free" freeReturnValue :: FunPtr (Ptr ReturnValue -> IO ()) foreign import ccall unsafe "&receive_interrupted_state_free" freeReceiveInterruptedState :: FunPtr (Ptr (Ptr ReceiveInterruptedState) -> IO ()) @@ -56,7 +59,6 @@ foreign import ccall "validate_and_process_v1" -> Ptr (Ptr ModuleArtifactV1) -- ^Null, or the processed module artifact. This is null if and only if the return value is null. -> IO (Ptr Word8) -- ^Null, or exports. --- TODO: Figure ownership. newtype ReturnValue = ReturnValue { rvPtr :: ForeignPtr ReturnValue } newtype ReceiveInterruptedState = ReceiveInterruptedState { risPtr :: ForeignPtr (Ptr ReceiveInterruptedState) } @@ -195,6 +197,14 @@ applyInitFun miface cm initCtx iName param amnt iEnergy = unsafePerformIO $ do amountWord = _amount amnt nameBytes = Text.encodeUtf8 (initName iName) +{-# NOINLINE returnValueToByteString #-} +returnValueToByteString :: ReturnValue -> BS.ByteString +returnValueToByteString rv = unsafePerformIO $ + withReturnValue rv $ \p -> alloca $ \outputLenPtr -> do + rp <- return_value_to_byte_array p outputLenPtr + len <- peek outputLenPtr + BSU.unsafePackCStringFinalizer rp (fromIntegral len) (rs_free_array_len rp (fromIntegral len)) + data InvokeMethod = Transfer { imtTo :: !AccountAddress, From 8a1e5405c139e7a498a26e974ebf2b8748c8973e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Wed, 22 Dec 2021 21:36:35 +0100 Subject: [PATCH 12/51] Add tests for transfers from a contract to an account in the synchronous setup. Revise some of the implementation details of the transfers to enable more use-cases. --- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/Scheduler.hs | 40 +++--- .../Scheduler/WasmIntegration/V1.hs | 1 + .../testdata/contracts/v1/call-counter.wat | 11 +- .../testdata/contracts/v1/transfer.wasm | Bin 0 -> 348 bytes .../testdata/contracts/v1/transfer.wat | 48 +++++++ .../SmartContracts/V1/Counter.hs | 29 ++-- .../SmartContracts/V1/Transfer.hs | 125 ++++++++++++++++++ concordium-consensus/tests/scheduler/Spec.hs | 2 + 9 files changed, 216 insertions(+), 42 deletions(-) create mode 100644 concordium-consensus/testdata/contracts/v1/transfer.wasm create mode 100644 concordium-consensus/testdata/contracts/v1/transfer.wat create mode 100644 concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 9f9c3427f9..bd17bdb9c2 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 9f9c3427f981b5bda8fac40c09bf527d938fbc6c +Subproject commit bd17bdb9c2ec264104ce5f52fe98440eda3298dc diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 10402ebe58..751d836c11 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -827,10 +827,18 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para -- The invariants maintained by global state should ensure that an owner account always exists. -- However we are defensive here and reject the transaction instead of panicking in case it does not. ownerAccount <- getStateAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress + + -- transfer the amount from the sender to the contract at the start. This is so that the contract may immediately use it + -- for, e.g., forwarding. + senderamount <- getCurrentAvailableAmount sender + unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) + cm <- getChainMetadata let receiveCtx = Wasm.ReceiveContext { invoker = originAddr, selfAddress = cref, + -- NB: This means that the contract observes the balance without the incoming one + -- It gets the transfer amount as a separate parameter. selfBalance = _instanceVAmount istance, sender = senderAddr, owner = instanceOwner iParams, @@ -849,25 +857,20 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para case rrData of WasmV1.ReceiveSuccess{..} -> do -- execution terminated, commit the new state - withInstanceStateV1 istance rrdNewState $ do - -- transfer the amount from the sender. We first check whether that is actually available for the sender at this point in time - -- since synchronous calls might have affected it before this point. - senderamount <- getCurrentAvailableAmount sender - if senderamount < transferAmount then return (Left (WasmV1.EnvFailure (WasmV1.AmountTooLarge senderAddr transferAmount))) - else withToContractAmount sender istance transferAmount $ - let event = Updated{euAddress=instanceAddress istance, - euInstigator=senderAddr, - euAmount=transferAmount, - euMessage=parameter, - euReceiveName=receiveName, - euEvents = rrdLogs - } - in return (Right (rrdReturnValue, event:events)) + withInstanceStateV1 istance rrdNewState $ + let event = Updated{euAddress=instanceAddress istance, + euInstigator=senderAddr, + euAmount=transferAmount, + euMessage=parameter, + euReceiveName=receiveName, + euEvents = rrdLogs + } + in return (Right (rrdReturnValue, event:events)) WasmV1.ReceiveInterrupt{..} -> do case rrdMethod of WasmV1.Transfer{..} -> runExceptT (transferAccountSync imtTo istance imtAmount) >>= \case - Left errCode -> + Left errCode -> do go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) Right transferEvents -> go (transferEvents ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success Nothing) WasmV1.Call{..} -> @@ -891,9 +894,10 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para Right (rVal, callEvents) -> do newState <- getCurrentContractInstanceState istance go (callEvents ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success (Just rVal)) - - -- start contract execution - go [] =<< runInterpreter (return . WasmV1.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) + + -- start contract execution. + withToContractAmount sender istance transferAmount $ + go [] =<< runInterpreter (return . WasmV1.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) where transferAccountSync :: AccountAddress -- ^The target account address. -> InstanceV GSWasm.V1 -- ^The sender of this transfer. diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 45be76d517..ee8c0b55d9 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -90,6 +90,7 @@ data EnvFailure = | MissingAccount !AccountAddress | MissingContract !ContractAddress | MessageFailed !Exec.RejectReason -- message to a V0 contract failed. No further information is available. + deriving (Show) -- FIXME: We could expose the reject reason if that is what happened. -- The response is encoded as follows. diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wat b/concordium-consensus/testdata/contracts/v1/call-counter.wat index 5aba54863c..bf8de7e5bd 100644 --- a/concordium-consensus/testdata/contracts/v1/call-counter.wat +++ b/concordium-consensus/testdata/contracts/v1/call-counter.wat @@ -1,10 +1,7 @@ -;; Test for one contract calling another, both v1. -;; The first contract just maintains a counter as the state. -;; The second one calls it with a parameter which should be added to the counter. -;; The return value is the value of the counter after the call. -;; -;; Docs: -;; +;; Test for one contract calling itself. +;; There are two entrypoints, one which just increments the counter, and another +;; which repeatedly calls the former endpoint to increase the counter by 10. +;; This latter endpoint checks the return value. (module diff --git a/concordium-consensus/testdata/contracts/v1/transfer.wasm b/concordium-consensus/testdata/contracts/v1/transfer.wasm new file mode 100644 index 0000000000000000000000000000000000000000..923658e600c9fccd6c566d3a0a8267d0ce8acb36 GIT binary patch literal 348 zcmZ9DK~BRk5Jmqab_y{S5fYoOyg-Omw`>VFpcing#H}nyTsaPvSR{wxq6A!|z>GA1 z{(m#jeMrNMwzN)98u9oQ}Rh!Uc0V#zOh4lb1*?2wb!i)#;e|b z7+}F~|8Y|X>pIZlB(vSSdo@TF+11J0V3ZreaR^8kB!6?dQGL+C{K-Z9ID?ck#yICG zfmV0P+IBXm;C0vUjmJgtyKeW+pR{jqneW&d5|Uon6LAO;-R|r-N?eQWJm;1r3fh!X T;xUcMLy BSS.ShortByteString -fibParamBytes n = BSS.toShort $ runPut (putWord64le n) - counterSourceFile :: FilePath counterSourceFile = "./testdata/contracts/v1/call-counter.wasm" +-- Tests in this module use version 1, creating V1 instances. wasmModVersion :: Word32 wasmModVersion = 1 @@ -72,19 +68,19 @@ testCases = , metadata = makeDummyHeader alesAccount 3 700000 , keys = [(0,[(0, alesKP)])] } - , (SuccessWithSummary ensureAllUpdates , counterSpec 1) + , (SuccessWithSummary ensureSucces , counterSpec 1) ) , ( TJSON { payload = Update 0 (Types.ContractAddress 0 0) "counter.inc" BSS.empty , metadata = makeDummyHeader alesAccount 4 700000 , keys = [(0,[(0, alesKP)])] } - , (SuccessWithSummary ensureAllUpdates , counterSpec 2) + , (SuccessWithSummary ensureSucces , counterSpec 2) ) , ( TJSON { payload = Update 0 (Types.ContractAddress 0 0) "counter.inc10" callArgs , metadata = makeDummyHeader alesAccount 5 700000 , keys = [(0,[(0, alesKP)])] } - , (SuccessWithSummary ensureAllUpdates , counterSpec 12) + , (SuccessWithSummary ensureSucces , counterSpec 12) ) ] } @@ -130,8 +126,9 @@ testCases = unless (tsEnergyCost >= costLowerBound) $ assertFailure $ "Actual initialization cost " ++ show tsEnergyCost ++ " not more than lower bound " ++ show costLowerBound - ensureAllUpdates :: Types.BlockItem -> Types.TransactionSummary -> Expectation - ensureAllUpdates _ Types.TransactionSummary{..} = checkSuccess "Update failed" tsResult + -- ensure the transaction is successful + ensureSucces :: Types.BlockItem -> Types.TransactionSummary -> Expectation + ensureSucces _ Types.TransactionSummary{..} = checkSuccess "Update failed" tsResult checkSuccess msg Types.TxReject{..} = assertFailure $ msg ++ show vrRejectReason checkSuccess _ _ = return () @@ -139,9 +136,9 @@ testCases = -- Check that the contract state contains n. counterSpec n bs = specify "Contract state" $ case getInstance (Types.ContractAddress 0 0) (bs ^. blockInstances) of - Nothing -> assertFailure "Instnace at <0,0> does not exist." + Nothing -> assertFailure "Instance at <0,0> does not exist." Just istance -> assertEqual ("State contains " ++ show n ++ ".") (ContractState (runPut (putWord64le n))) (istance ^. instanceModel) tests :: Spec -tests = describe "Counter counts." $ +tests = describe "V1: Counter counts." $ mkSpecs testCases diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs new file mode 100644 index 0000000000..e783fa4c69 --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| This module tests making a transfer from a contract to an account. +-} +module SchedulerTests.SmartContracts.V1.Transfer (tests) where + +import Test.Hspec +import Test.HUnit(assertFailure, assertEqual) + +import qualified Data.ByteString.Short as BSS +import qualified Data.ByteString as BS +import Data.Serialize(encode) +import Data.Word +import Lens.Micro.Platform +import Control.Monad + +import qualified Concordium.Scheduler.Types as Types +import qualified Concordium.Crypto.SHA256 as Hash +import Concordium.Scheduler.Runner + +import Concordium.GlobalState.Instance +import Concordium.GlobalState.Basic.BlockState.Accounts as Acc +import Concordium.GlobalState.Basic.BlockState.Instances +import Concordium.GlobalState.Basic.BlockState +import Concordium.Wasm +import qualified Concordium.Cost as Cost + +import Concordium.Scheduler.DummyData +import Concordium.GlobalState.DummyData +import Concordium.Types.DummyData +import Concordium.Crypto.DummyData + +import SchedulerTests.TestUtils + + +initialBlockState :: BlockState PV4 +initialBlockState = blockStateWithAlesAccount + 100000000 + (Acc.putAccountWithRegIds (mkAccount thomasVK thomasAccount 100000000) Acc.emptyAccounts) + +transferSourceFile :: FilePath +transferSourceFile = "./testdata/contracts/v1/transfer.wasm" + +-- Tests in this module use version 1, creating V1 instances. +wasmModVersion :: Word32 +wasmModVersion = 1 + +testCases :: [TestCase PV4] +testCases = + [ TestCase + { tcName = "Transfer from V1 contract to account." + , tcParameters = defaultParams {tpInitialBlockState=initialBlockState} + , tcTransactions = + [ ( TJSON { payload = DeployModule wasmModVersion transferSourceFile + , metadata = makeDummyHeader alesAccount 1 100000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary deploymentCostCheck, emptySpec) + ) + , ( TJSON { payload = InitContract 0 wasmModVersion transferSourceFile "init_transfer" "" + , metadata = makeDummyHeader alesAccount 2 100000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary initializationCostCheck, transferSpec) + ) + , ( TJSON { payload = Update 123 (Types.ContractAddress 0 0) "transfer.forward" (BSS.toShort (encode alesAccount)) + , metadata = makeDummyHeader alesAccount 3 700000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary ensureSucces , transferSpec) + ) + ] + } + ] + + where + deploymentCostCheck :: Types.BlockItem -> Types.TransactionSummary -> Expectation + deploymentCostCheck _ Types.TransactionSummary{..} = do + checkSuccess "Module deployment failed: " tsResult + moduleSource <- BS.readFile transferSourceFile + let len = fromIntegral $ BS.length moduleSource + -- size of the module deploy payload + payloadSize = Types.payloadSize (Types.encodePayload (Types.DeployModule (WasmModule wasmModVersion ModuleSource{..}))) + -- size of the transaction minus the signatures. + txSize = Types.transactionHeaderSize + fromIntegral payloadSize + -- transaction is signed with 1 signature + assertEqual "Deployment has correct cost " (Cost.baseCost txSize 1 + Cost.deployModuleCost len) tsEnergyCost + + -- check that the initialization cost was at least the administrative cost. + -- It is not practical to check the exact cost because the execution cost of the init function is hard to + -- have an independent number for, other than executing. + initializationCostCheck :: Types.BlockItem -> Types.TransactionSummary -> Expectation + initializationCostCheck _ Types.TransactionSummary{..} = do + checkSuccess "Contract initialization failed: " tsResult + moduleSource <- BS.readFile transferSourceFile + let modLen = fromIntegral $ BS.length moduleSource + modRef = Types.ModuleRef (Hash.hash moduleSource) + payloadSize = Types.payloadSize (Types.encodePayload (Types.InitContract 0 modRef (InitName "init_transfer") (Parameter ""))) + -- size of the transaction minus the signatures. + txSize = Types.transactionHeaderSize + fromIntegral payloadSize + -- transaction is signed with 1 signature + baseTxCost = Cost.baseCost txSize 1 + -- lower bound on the cost of the transaction, assuming no interpreter energy + -- we know the size of the state should be 8 bytes + costLowerBound = baseTxCost + Cost.initializeContractInstanceCost 0 modLen (Just 0) + unless (tsEnergyCost >= costLowerBound) $ + assertFailure $ "Actual initialization cost " ++ show tsEnergyCost ++ " not more than lower bound " ++ show costLowerBound + + -- ensure the transaction is successful + ensureSucces :: Types.BlockItem -> Types.TransactionSummary -> Expectation + ensureSucces _ Types.TransactionSummary{..} = checkSuccess "Update failed" tsResult + + checkSuccess msg Types.TxReject{..} = assertFailure $ msg ++ show vrRejectReason + checkSuccess _ _ = return () + + -- Check that the contract state contains n. + transferSpec bs = specify "Contract state" $ + case getInstance (Types.ContractAddress 0 0) (bs ^. blockInstances) of + Nothing -> assertFailure "Instance at <0,0> does not exist." + Just istance -> do + assertEqual ("State contains.") (ContractState "") (istance ^. instanceModel) + assertEqual ("Contract has 0 CCD.") (Types.Amount 0) (istance ^. instanceAmount) + +tests :: Spec +tests = describe "V1: Transfer from contract to account." $ + mkSpecs testCases diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index a20b25de56..264918c2bc 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -26,6 +26,7 @@ import qualified SchedulerTests.RejectReasons(tests) import qualified SchedulerTests.RejectReasonsRustContract(tests) import qualified SchedulerTests.SmartContracts.V1.Counter(tests) +import qualified SchedulerTests.SmartContracts.V1.Transfer(tests) import Test.Hspec @@ -56,3 +57,4 @@ main = hspec $ do SchedulerTests.RejectReasons.tests SchedulerTests.RejectReasonsRustContract.tests SchedulerTests.SmartContracts.V1.Counter.tests + SchedulerTests.SmartContracts.V1.Transfer.tests From aac9385a449b07ea9e188d9092ed3e23e8de3250 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Thu, 23 Dec 2021 07:09:45 +0100 Subject: [PATCH 13/51] Add V1 instances to globalstate tests. --- .../globalstate/GlobalStateTests/Instances.hs | 39 +++++++++++++------ 1 file changed, 28 insertions(+), 11 deletions(-) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs index 72c7e34a19..aadcea5fd8 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs @@ -15,7 +15,8 @@ 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 WasmIntegration +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 @@ -28,17 +29,27 @@ import qualified Data.ByteString as BS import Test.QuickCheck import Test.Hspec -contractSources :: [(FilePath, BS.ByteString)] -contractSources = $(makeRelativeToProject "testdata/contracts/" >>= embedDir) +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.ModuleInterfaceV GSWasm.V0)] -validContractArtifactsV0 = mapMaybe packModule contractSources +validContractArtifactsV0 = mapMaybe packModule contractSourcesV0 where packModule (_, sourceBytes) = let source = Wasm.ModuleSource sourceBytes - in (source,) <$> WasmIntegration.processModule (Wasm.WasmModule 0 source) + in (source,) <$> WasmV0.processModule (Wasm.WasmModule 0 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.ModuleInterfaceV GSWasm.V1)] +validContractArtifactsV1 = mapMaybe packModule contractSourcesV1 + where packModule (_, sourceBytes) = + let source = Wasm.ModuleSource sourceBytes + in (source,) <$> WasmV1.processModule (Wasm.WasmModule 1 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 ++ ")" @@ -96,12 +107,18 @@ genContractState = do Wasm.ContractState . BS.pack <$> vector n makeDummyInstance :: InstanceData -> Gen (ContractAddress -> Instance) -makeDummyInstance (InstanceData model amount) = 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 - where +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 From 6773577588ea2ef91e571a49d0244ddf8e7b584a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Thu, 23 Dec 2021 10:05:43 +0100 Subject: [PATCH 14/51] Add tests for cross-version-contract calls. --- .../testdata/contracts/v1/call-counter.wasm | Bin 562 -> 636 bytes .../testdata/contracts/v1/call-counter.wat | 16 +++ .../contracts/v1/send-message-v1.wasm | Bin 0 -> 235 bytes .../testdata/contracts/v1/send-message-v1.wat | 34 +++++ .../SmartContracts/V1/CrossMessaging.hs | 126 ++++++++++++++++++ concordium-consensus/tests/scheduler/Spec.hs | 3 + 6 files changed, 179 insertions(+) create mode 100644 concordium-consensus/testdata/contracts/v1/send-message-v1.wasm create mode 100644 concordium-consensus/testdata/contracts/v1/send-message-v1.wat create mode 100644 concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wasm b/concordium-consensus/testdata/contracts/v1/call-counter.wasm index 571bda64fa0dd2f746379189510181bcaac83837..c7aed328d368a46b0a6e3a80234bb897b5bb51e2 100644 GIT binary patch delta 91 zcmdnQ@`q)@ePJ$67FHHEb`W4?W@KPw4`H47(MDP%IlnZoB(+E{GcVcDATK{TBQ-gj rfsbno6X#|_Mn*+HF9WxfBLg=8&-D{M delta 38 scmeyvvWaEFeIZT`7FHHEb|7G7W@KPww`H05$%ciiiHT#gCnF;x0GvDrA^-pY diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wat b/concordium-consensus/testdata/contracts/v1/call-counter.wat index bf8de7e5bd..ee39d2dedb 100644 --- a/concordium-consensus/testdata/contracts/v1/call-counter.wat +++ b/concordium-consensus/testdata/contracts/v1/call-counter.wat @@ -104,5 +104,21 @@ ;; and return success (i32.const 0) ) + + ;; like $inc_counter_10 above, but does not check return values. + (func $inc_counter_10_no_check (export "counter.inc10nocheck") (param i64) (result i32) + (local $n i32) + (local $size i32) + (local.set $size (call $get_parameter_size (i32.const 0))) + (call $get_parameter_section (i32.const 0) (i32.const 0) (local.get $size) (i32.const 0)) + (loop $loop + (call $invoke (i32.const 1) (i32.const 0) (local.get $size)) + (drop) + (local.set $n (i32.add (i32.const 1) (local.get $n))) + (br_if $loop (i32.lt_u (local.get $n) (i32.const 10)))) + (drop) + ;; and return success + (i32.const 0) + ) (memory 1) ) \ No newline at end of file diff --git a/concordium-consensus/testdata/contracts/v1/send-message-v1.wasm b/concordium-consensus/testdata/contracts/v1/send-message-v1.wasm new file mode 100644 index 0000000000000000000000000000000000000000..d0fa076aca597279f4b3d577e1ca958b99359949 GIT binary patch literal 235 zcmZ8ZO$&lR6r8uK6iOsQ9U{VRb*Xd5{S#ePbc+>qV>S9XxPQG(I!G{YW|$cs^0p=b zwDvNP&A7GJ$)xYCb#Rt?vh2)*LN|prrMlPgRd(quH+d~PY0_4`B{1q2f4wX^r5n&_ z; Types.TransactionSummary -> Expectation + ensureSuccess _ Types.TransactionSummary{..} = checkSuccess "Update failed" tsResult + + checkSuccess msg Types.TxReject{..} = assertFailure $ msg ++ show vrRejectReason + checkSuccess _ _ = return () + + -- Check that the contract state contains n. + counterSpec n bs = specify "Contract state" $ + case getInstance (Types.ContractAddress 0 0) (bs ^. blockInstances) of + Nothing -> assertFailure "Instance at <0,0> does not exist." + Just istance -> assertEqual ("State contains " ++ show n ++ ".") (ContractState (runPut (putWord64le n))) (istance ^. instanceModel) + +tests :: Spec +tests = describe "V1: Counter with cross-messaging." $ + mkSpecs testCases diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index 264918c2bc..3edf0c0bad 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -27,6 +27,8 @@ import qualified SchedulerTests.RejectReasonsRustContract(tests) import qualified SchedulerTests.SmartContracts.V1.Counter(tests) import qualified SchedulerTests.SmartContracts.V1.Transfer(tests) +import qualified SchedulerTests.SmartContracts.V1.CrossMessaging(tests) + import Test.Hspec @@ -58,3 +60,4 @@ main = hspec $ do SchedulerTests.RejectReasonsRustContract.tests SchedulerTests.SmartContracts.V1.Counter.tests SchedulerTests.SmartContracts.V1.Transfer.tests + SchedulerTests.SmartContracts.V1.CrossMessaging.tests From cdd07b98dea9449e87a0d6b6df8a1a3469509f94 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Thu, 23 Dec 2021 19:10:03 +0100 Subject: [PATCH 15/51] Make serialization of parameter size consistent, and revise tests accordingly. --- concordium-consensus/smart-contracts | 2 +- .../testdata/contracts/v1/send-message-v1.wasm | Bin 235 -> 235 bytes .../testdata/contracts/v1/send-message-v1.wat | 4 ++-- .../SchedulerTests/SmartContracts/V1/Counter.hs | 4 ++-- .../SmartContracts/V1/CrossMessaging.hs | 6 +++--- 5 files changed, 8 insertions(+), 8 deletions(-) diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index bd17bdb9c2..33133ff451 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit bd17bdb9c2ec264104ce5f52fe98440eda3298dc +Subproject commit 33133ff451f3ba77e750b79323c6ada3315b0b6a diff --git a/concordium-consensus/testdata/contracts/v1/send-message-v1.wasm b/concordium-consensus/testdata/contracts/v1/send-message-v1.wasm index d0fa076aca597279f4b3d577e1ca958b99359949..5bdb9eeb59d96b4e118b8ce79bf7bbb9775523fa 100644 GIT binary patch delta 28 ecmaFO_?mITHBk{q0ewb>EJq;-4P*;2aRUH!J_X(Y delta 28 fcmaFO_?mITHBm7~0ewb>EJq;-t--_~z{CvzbVCK& diff --git a/concordium-consensus/testdata/contracts/v1/send-message-v1.wat b/concordium-consensus/testdata/contracts/v1/send-message-v1.wat index c1b49f2e11..628f28614d 100644 --- a/concordium-consensus/testdata/contracts/v1/send-message-v1.wat +++ b/concordium-consensus/testdata/contracts/v1/send-message-v1.wat @@ -26,8 +26,8 @@ (call $send (i64.load (i32.const 0)) (i64.load (i32.const 8)) (i32.const 18) (i32.load16_u (i32.const 16)) ;; receive name (2 bytes for length + data) (local.get $amount) - (i32.add (i32.const 22) (i32.load16_u (i32.const 16))) ;; start of parameter - (i32.load (i32.add (i32.const 18) (i32.load16_u (i32.const 16)))) ;; length of the parameter + (i32.add (i32.const 20) (i32.load16_u (i32.const 16))) ;; start of parameter + (i32.load16_u (i32.add (i32.const 18) (i32.load16_u (i32.const 16)))) ;; length of the parameter, 2 bytes ) ) (memory 1) diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs index 9e53071733..74a530f4a0 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs @@ -10,7 +10,7 @@ import Test.HUnit(assertFailure, assertEqual) import qualified Data.ByteString.Short as BSS import qualified Data.ByteString as BS -import Data.Serialize(runPut, putWord64le, putWord32le, putByteString, putWord16le) +import Data.Serialize(runPut, putWord64le, putByteString, putWord16le) import Data.Word import Lens.Micro.Platform import Control.Monad @@ -90,7 +90,7 @@ testCases = callArgs = BSS.toShort $ runPut $ do putWord64le 0 -- contract index putWord64le 0 -- contract subindex - putWord32le 0 -- length of parameter + putWord16le 0 -- length of parameter putWord16le (fromIntegral (BSS.length "counter.inc")) putByteString "counter.inc" putWord64le 0 -- amount diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs index 5a461ad14c..45f7705853 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs @@ -8,7 +8,7 @@ import Test.HUnit(assertFailure, assertEqual) import qualified Data.ByteString.Short as BSS import qualified Data.ByteString as BS -import Data.Serialize(runPut, putWord64le, putWord32le, putByteString, putWord16le) +import Data.Serialize(runPut, putWord64le, putByteString, putWord16le) import Data.Word import Lens.Micro.Platform @@ -97,12 +97,12 @@ testCases = putWord64le 0 -- subindex of the counter contract putWord16le (fromIntegral (BSS.length "counter.inc")) putByteString "counter.inc" - putWord32le 0 -- length of parameter + putWord16le 0 -- length of parameter callArgs = BSS.toShort $ runPut $ do putWord64le 1 -- contract index (the proxy contract) putWord64le 0 -- contract subindex - putWord32le (fromIntegral (BS.length forwardParameter)) -- length of parameter + putWord16le (fromIntegral (BS.length forwardParameter)) -- length of parameter putByteString forwardParameter putWord16le (fromIntegral (BSS.length "proxy.forward")) putByteString "proxy.forward" From e6c9ca112224dfcbfb0976168b9f04a15e7add09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Thu, 23 Dec 2021 21:07:15 +0100 Subject: [PATCH 16/51] Add documentation. --- concordium-consensus/package.yaml | 2 +- .../GlobalState/Basic/BlockState/Instances.hs | 8 +- .../GlobalState/Basic/BlockState/Modules.hs | 13 ++- .../src/Concordium/GlobalState/Instance.hs | 23 ++--- .../Persistent/BlockState/Modules.hs | 27 +++--- .../GlobalState/Persistent/Instances.hs | 24 ++--- .../src/Concordium/GlobalState/Wasm.hs | 54 ++++++------ .../src/Concordium/Scheduler/Environment.hs | 11 +-- .../Scheduler/WasmIntegration/V1.hs | 88 +++++++++++++------ 9 files changed, 151 insertions(+), 99 deletions(-) diff --git a/concordium-consensus/package.yaml b/concordium-consensus/package.yaml index ffe0589754..39bc3d2686 100644 --- a/concordium-consensus/package.yaml +++ b/concordium-consensus/package.yaml @@ -74,7 +74,7 @@ default-extensions: flags: dynamic: manual: True - default: False + default: True library: source-dirs: src diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs index 9e4c4dd991..ad05112790 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs @@ -81,10 +81,10 @@ putInstancesV0 (Instances (Tree _ t)) = do case inst of InstanceV0 i -> do putWord8 2 - putInstanceV0 i + putV0InstanceV0 i InstanceV1 i -> do putWord8 3 - putInstanceV1 i + putV1InstanceV0 i -- |Deserialize 'Instances' in V0 format. getInstancesV0 @@ -95,6 +95,6 @@ getInstancesV0 resolve = Instances <$> constructM buildInstance buildInstance idx = getWord8 >>= \case 0 -> return Nothing 1 -> Just . Left <$> get - 2 -> Just . Right . InstanceV0 <$> getInstanceV0 resolve idx - 3 -> Just . Right . InstanceV1 <$> getInstanceV1 resolve idx + 2 -> Just . Right . InstanceV0 <$> getV0InstanceV0 resolve idx + 3 -> Just . Right . InstanceV1 <$> getV1InstanceV0 resolve idx _ -> fail "Bad instance list" diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs index e5fffc6d85..87a822e004 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs @@ -42,7 +42,8 @@ type ModuleIndex = Word64 -------------------------------------------------------------------------------- -- |A module contains both the module interface and the raw source code of the --- module. +-- module. The module is parameterized by the wasm version, which determines the shape +-- of the module interface. data ModuleV v = ModuleV { -- | The instrumented module, ready to be instantiated. moduleVInterface :: !(GSWasm.ModuleInterfaceV v), @@ -50,19 +51,25 @@ data ModuleV v = ModuleV { moduleVSource :: !WasmModule } deriving (Show) --- Create the class HasSource a with a function --- source :: Lens a WasmModule +-- Create the class HasSource a with functions +-- source :: Lens a WasmModule and interface :: Lens (ModuleV v) (GSWasm.ModuleInterfaceV v) makeFields ''ModuleV +-- |A module, either of version 0 or 1. This is only used when storing a module +-- independently, e.g., in the module table. When a module is referenced from a +-- contract instance we use the ModuleV type directly so we may tie the version +-- of the module to the version of the instance. data Module where ModuleV0 :: ModuleV GSWasm.V0 -> Module ModuleV1 :: ModuleV GSWasm.V1 -> Module deriving(Show) +-- |Helper (internal to the module) to convert from a module to an interface. fromModule :: Module -> GSWasm.ModuleInterface fromModule (ModuleV0 v) = GSWasm.ModuleInterfaceV0 (moduleVInterface v) fromModule (ModuleV1 v) = GSWasm.ModuleInterfaceV1 (moduleVInterface v) +-- |Helper to convert from an interface to a module. toModule :: GSWasm.ModuleInterface -> WasmModule -> Module toModule (GSWasm.ModuleInterfaceV0 moduleVInterface) moduleVSource = ModuleV0 ModuleV{..} toModule (GSWasm.ModuleInterfaceV1 moduleVInterface) moduleVSource = ModuleV1 ModuleV{..} diff --git a/concordium-consensus/src/Concordium/GlobalState/Instance.hs b/concordium-consensus/src/Concordium/GlobalState/Instance.hs index 1e097fe99b..ca3e2ec846 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Instance.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Instance.hs @@ -219,9 +219,9 @@ updateInstance' amnt val (InstanceV0 i) = InstanceV0 $ updateInstanceV' amnt val updateInstance' amnt val (InstanceV1 i) = InstanceV1 $ updateInstanceV' amnt val i --- |Serialize a smart contract instance in V0 format. -putInstanceV0 :: Putter (InstanceV GSWasm.V0) -putInstanceV0 InstanceV{ _instanceVParameters = InstanceParameters{..}, ..} = do +-- |Serialize a V0 smart contract instance in V0 format. +putV0InstanceV0 :: Putter (InstanceV GSWasm.V0) +putV0InstanceV0 InstanceV{ _instanceVParameters = InstanceParameters{..}, ..} = do -- InstanceParameters -- Only put the Subindex part of the address put (contractSubindex _instanceAddress) @@ -233,8 +233,9 @@ putInstanceV0 InstanceV{ _instanceVParameters = InstanceParameters{..}, ..} = do put _instanceVModel put _instanceVAmount -putInstanceV1 :: Putter (InstanceV GSWasm.V1) -putInstanceV1 InstanceV{ _instanceVParameters = InstanceParameters{..}, ..} = do +-- |Serialize a V1 smart contract instance in V0 format. +putV1InstanceV0 :: Putter (InstanceV GSWasm.V1) +putV1InstanceV0 InstanceV{ _instanceVParameters = InstanceParameters{..}, ..} = do -- InstanceParameters -- Only put the Subindex part of the address put (contractSubindex _instanceAddress) @@ -247,14 +248,14 @@ putInstanceV1 InstanceV{ _instanceVParameters = InstanceParameters{..}, ..} = do put _instanceVAmount --- |Deserialize a smart contract instance in V0 format. -getInstanceV0 +-- |Deserialize a V0 smart contract instance in V0 format. +getV0InstanceV0 :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterface)) -- ^Function for resolving the receive functions and module interface. -> ContractIndex -- ^Index of the contract -> Get (InstanceV GSWasm.V0) -getInstanceV0 resolve idx = do +getV0InstanceV0 resolve idx = do -- InstanceParameters subindex <- get let _instanceAddress = ContractAddress idx subindex @@ -270,14 +271,14 @@ getInstanceV0 resolve idx = do _instanceVAmount <- get return $ makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress --- |Deserialize a smart contract instance in V0 format. -getInstanceV1 +-- |Deserialize a V1 smart contract instance in V0 format. +getV1InstanceV0 :: (ModuleRef -> Wasm.InitName -> Maybe (Set.Set Wasm.ReceiveName, GSWasm.ModuleInterface)) -- ^Function for resolving the receive functions and module interface. -> ContractIndex -- ^Index of the contract -> Get (InstanceV GSWasm.V1) -getInstanceV1 resolve idx = do +getV1InstanceV0 resolve idx = do -- InstanceParameters subindex <- get let _instanceAddress = ContractAddress idx subindex diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs index 9dbc4ce3df..3b1faadf95 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs @@ -45,30 +45,33 @@ type ModuleIndex = Word64 -------------------------------------------------------------------------------- --- |A module contains both the module interface and a plain reference to where --- the raw source code of the module is stored in the blobstore. +-- |A module contains both the module interface and the raw source code of the +-- module. The module is parameterized by the wasm version, which determines the shape +-- of the module interface. data ModuleV v = ModuleV { -- | The instrumented module, ready to be instantiated. moduleVInterface :: !(GSWasm.ModuleInterfaceV v), - -- | A plain reference to the raw module binary source. + -- | A plain reference to the raw module binary source. This is generally not needed by consensus, so + -- it is almost always simply kept on disk. moduleVSource :: !(BlobRef WasmModule) } deriving(Show) -- Create two typeclasses HasInterface a _ and HasSource a _ -- with methods source :: Lens' a (BlobRef WasmModule) and --- interface :: Lens' a (GSWasm.ModuleInterfaceV v) +-- interface :: Lens' (ModuleV v) (GSWasm.ModuleInterfaceV v) makeFields ''ModuleV -fromModule :: Module -> GSWasm.ModuleInterface -fromModule (ModuleV0 v) = GSWasm.ModuleInterfaceV0 (moduleVInterface v) -fromModule (ModuleV1 v) = GSWasm.ModuleInterfaceV1 (moduleVInterface v) - +-- |Helper to convert from an interface to a module. toModule :: GSWasm.ModuleInterface -> BlobRef WasmModule -> Module toModule (GSWasm.ModuleInterfaceV0 moduleVInterface) moduleVSource = ModuleV0 ModuleV{..} toModule (GSWasm.ModuleInterfaceV1 moduleVInterface) moduleVSource = ModuleV1 ModuleV{..} +-- |A module, either of version 0 or 1. This is only used when storing a module +-- independently, e.g., in the module table. When a module is referenced from a +-- contract instance we use the ModuleV type directly so we may tie the version +-- of the module to the version of the instance. data Module where ModuleV0 :: ModuleV GSWasm.V0 -> Module ModuleV1 :: ModuleV GSWasm.V1 -> Module @@ -87,7 +90,7 @@ instance GSWasm.HasModuleRef Module where moduleReference (ModuleV0 m) = GSWasm.moduleReference (moduleVInterface m) moduleReference (ModuleV1 m) = GSWasm.moduleReference (moduleVInterface m) --- FIXME: This should probably take host versioning into account since that is not part of the reference +-- The module reference already takes versioning into account, so this instance is reasonable. instance HashableTo Hash Module where getHash = coerce . GSWasm.moduleReference @@ -102,7 +105,7 @@ instance Serialize Module where moduleVSource <- get return $! toModule moduleVInterface moduleVSource put m = do - put (fromModule m) + put (getModuleInterface m) put (m ^. source) -- |This serialization is used for storing the module in the BlobStore. @@ -213,7 +216,7 @@ unsafeGetModuleReferenceV0 :: MonadBlobStore m => ModuleRef -> Modules -> m (May unsafeGetModuleReferenceV0 ref mods = fmap (unsafeCoerceBufferedRef extract) <$> getModuleReference ref mods where extract (ModuleV0 m) = m extract _ = error "Precondition violation." --- |Gets the buffered reference to a module as stored in the module table assuming it is version 0. +-- |Gets the buffered reference to a module as stored in the module table assuming it is version 1. unsafeGetModuleReferenceV1 :: MonadBlobStore m => ModuleRef -> Modules -> m (Maybe (BufferedRef (ModuleV GSWasm.V1))) unsafeGetModuleReferenceV1 ref mods = fmap (unsafeCoerceBufferedRef extract) <$> getModuleReference ref mods where extract (ModuleV1 m) = m @@ -225,7 +228,7 @@ getInterface :: MonadBlobStore m => ModuleRef -> Modules -> m (Maybe GSWasm.ModuleInterface) -getInterface ref mods = fmap fromModule <$> getModule ref mods +getInterface ref mods = fmap getModuleInterface <$> getModule ref mods -- |Get the source of a module by module reference. getSource :: MonadBlobStore m => ModuleRef -> Modules -> m (Maybe WasmModule) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs index 3016d357a8..08a0e54e92 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs @@ -76,9 +76,12 @@ instance Applicative m => Cacheable m PersistentInstanceParameters ---------------------------------------------------------------------------------------------------- --- |An instance of a smart contract. +-- |An instance of a smart contract. This is parametrized by the Wasm version +-- `v` that is used to tie the instance version to the module version. At +-- present the version only appears in the module, but with the state changes it +-- will also appear in the contract state. data PersistentInstanceV v = PersistentInstanceV { - -- |The fixed parameters of the instance + -- |The fixed parameters of the instance. pinstanceParameters :: !(BufferedRef PersistentInstanceParameters), -- |The interface of 'pinstanceContractModule'. Note this is a BufferedRef to a Module as this -- is how the data is stored in the Modules table. A 'Module' carries a BlobRef to the source @@ -236,9 +239,9 @@ fromPersistentInstance pinst = do _instanceVParameters = mkParams iface }) --- |Serialize a smart contract instance in V0 format. -putInstanceV0 :: (MonadBlobStore m, MonadPut m) => PersistentInstanceV GSWasm.V0 -> m () -putInstanceV0 PersistentInstanceV {..} = do +-- |Serialize a V0 smart contract instance in V0 format. +putV0InstanceV0 :: (MonadBlobStore m, MonadPut m) => PersistentInstanceV GSWasm.V0 -> m () +putV0InstanceV0 PersistentInstanceV {..} = do -- Instance parameters PersistentInstanceParameters{..} <- refLoad pinstanceParameters liftPut $ do @@ -250,10 +253,9 @@ putInstanceV0 PersistentInstanceV {..} = do put pinstanceModel put pinstanceAmount --- |Serialize a smart contract instance in V0 format. --- FIXME: Add versioning -putInstanceV1 :: (MonadBlobStore m, MonadPut m) => PersistentInstanceV GSWasm.V1 -> m () -putInstanceV1 PersistentInstanceV {..} = do +-- |Serialize a V1 smart contract instance in V0 format. +putV1InstanceV0 :: (MonadBlobStore m, MonadPut m) => PersistentInstanceV GSWasm.V1 -> m () +putV1InstanceV0 PersistentInstanceV {..} = do -- Instance parameters PersistentInstanceParameters{..} <- refLoad pinstanceParameters liftPut $ do @@ -616,7 +618,7 @@ putInstancesV0 (InstancesTree _ it) = do put (contractSubindex ca) putOptInstance (Right (PersistentInstanceV0 inst)) = do liftPut $ putWord8 2 - putInstanceV0 inst + putV0InstanceV0 inst putOptInstance (Right (PersistentInstanceV1 inst)) = do liftPut $ putWord8 3 - putInstanceV1 inst + putV1InstanceV0 inst diff --git a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs index 0714a42c6b..9b41e8bf97 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} @@ -50,11 +51,26 @@ foreign import ccall unsafe "artifact_v1_from_bytes" fromBytesArtifactV1 :: Ptr -- | A processed module artifact ready for execution. The actual module is -- allocated and stored on the Rust heap, in a reference counted pointer. -newtype ModuleArtifact v = ModuleArtifact { maArtifact :: ForeignPtr (ModuleArtifact v) } +newtype ModuleArtifact (v :: WasmVersion) = ModuleArtifact { maArtifact :: ForeignPtr (ModuleArtifact v) } deriving(Eq, Show) -- the Eq and Show instances are only for debugging and compare and show pointers. -data V0 -data V1 +-- |Supported versions of Wasm modules. This version defines available host +-- functions, their semantics, and limitations of contracts. +data WasmVersion = V0 | V1 + +instance Serialize WasmVersion where + put V0 = putWord32be 0 + put V1 = putWord32be 1 + + get = getWord32be >>= \case + 0 -> return V0 + 1 -> return V1 + n -> fail $ "Unrecognized Wasm version " ++ show n + +-- These type aliases are provided for convenience to avoid having to enable +-- DataKinds everywhere we need wasm version. +type V0 = 'V0 +type V1 = 'V1 type ModuleArtifactV0 = ModuleArtifact V0 type ModuleArtifactV1 = ModuleArtifact V1 @@ -114,24 +130,6 @@ data InstrumentedModuleV v where deriving instance Eq (InstrumentedModuleV v) deriving instance Show (InstrumentedModuleV v) --- This is just an internal helper -data InstrumentedModule where - IWMV0 :: { imwArtifactV0 :: ModuleArtifact V0 } -> InstrumentedModule - IWMV1 :: { imwArtifactV1 :: ModuleArtifact V1 } -> InstrumentedModule - -instance Serialize InstrumentedModule where - put IWMV0{..} = do - putWord32be 0 - put imwArtifactV0 - put IWMV1{..} = do - putWord32be 1 - put imwArtifactV1 - - get = getWord32be >>= \case - 0 -> IWMV0 <$> get - 1 -> IWMV1 <$> get - _ -> fail "Unsupported Wasm module version." - imWasmVersion :: InstrumentedModuleV v -> Word32 imWasmVersion (InstrumentedWasmModuleV0 _) = 0 imWasmVersion (InstrumentedWasmModuleV1 _) = 1 @@ -226,11 +224,15 @@ instance Serialize ModuleInterface where miModuleRef <- get miExposedInit <- getSafeSetOf get miExposedReceive <- getSafeMapOf get (getSafeSetOf get) - miModuleV <- get - miModuleSize <- getWord64be - case miModuleV of - IWMV0 imWasmArtifactV0 -> return (ModuleInterfaceV0 ModuleInterface{miModule = InstrumentedWasmModuleV0 {..},..}) - IWMV1 imWasmArtifactV1 -> return (ModuleInterfaceV1 ModuleInterface{miModule = InstrumentedWasmModuleV1 {..},..}) + get >>= \case + V0 -> do + miModule <- InstrumentedWasmModuleV0 <$> get + miModuleSize <- getWord64be + return (ModuleInterfaceV0 ModuleInterface{..}) + V1 -> do + miModule <- InstrumentedWasmModuleV1 <$> get + miModuleSize <- getWord64be + return (ModuleInterfaceV1 ModuleInterface{..}) put (ModuleInterfaceV0 ModuleInterface{..}) = do put miModuleRef putSafeSetOf put miExposedInit diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index d138481f4f..643ca02095 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -392,15 +392,16 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- entire computation is aborted. orElse :: m a -> m a -> m a - -- |Try to run the first computation. If it leads to `reject` for a logic reason then - -- try the second computation. If the left computation fails with out of energy then the - -- entire computation is aborted. + -- |Try to run the first computation. If it leads to `reject` for a logic + -- reason then try the second computation. If the left computation fails with + -- out of energy then the entire computation is aborted. Compared to 'orElse' + -- above, here the right computation gets access to the rejection reason of the left one. orElseWith :: m a -> (RejectReason -> m a) -> m a - -- |Try to run the first computation. If it leads to `Left err` then abort and revert all the changes. + -- |Try to run the first computation. If it leads to `Left err` then abort and revert all the changes + -- apart from consumed energy. withRollback :: m (Either a b) -> m (Either a b) - -- |Fail transaction processing because we would have exceeded maximum block energy limit. outOfBlockEnergy :: m a diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index ee8c0b55d9..510888b72d 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -1,5 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NumericUnderscores #-} +-- |This module provides most of the functionality that deals with calling V1 smart contracts, processing responses, +-- and resuming computations. It is used directly by the Scheduler to run smart contracts. +-- +-- This module uses FFI very heavily. The functions that are imported are defined in smart-contracts/wasm-chain-integration/src/v1/ffi.rs +-- in the smart contracts submodule. module Concordium.Scheduler.WasmIntegration.V1( InvokeMethod(..), InitResultData(..), @@ -48,7 +53,6 @@ import Concordium.GlobalState.Wasm import Concordium.Utils.Serialization foreign import ccall unsafe "return_value_to_byte_array" return_value_to_byte_array :: Ptr ReturnValue -> Ptr CSize -> IO (Ptr Word8) - foreign import ccall unsafe "&box_vec_u8_free" freeReturnValue :: FunPtr (Ptr ReturnValue -> IO ()) foreign import ccall unsafe "&receive_interrupted_state_free" freeReceiveInterruptedState :: FunPtr (Ptr (Ptr ReceiveInterruptedState) -> IO ()) @@ -59,12 +63,30 @@ foreign import ccall "validate_and_process_v1" -> Ptr (Ptr ModuleArtifactV1) -- ^Null, or the processed module artifact. This is null if and only if the return value is null. -> IO (Ptr Word8) -- ^Null, or exports. +-- |Return value of a V1 contract call. This is deliberately opaque so that we avoid redundant data copying +-- for return values for inner contract calls. newtype ReturnValue = ReturnValue { rvPtr :: ForeignPtr ReturnValue } + +{-# NOINLINE returnValueToByteString #-} +-- |Convert a return value to a byte array. This copies the data of the return value. +returnValueToByteString :: ReturnValue -> BS.ByteString +returnValueToByteString rv = unsafePerformIO $ + withReturnValue rv $ \p -> alloca $ \outputLenPtr -> do + rp <- return_value_to_byte_array p outputLenPtr + len <- peek outputLenPtr + BSU.unsafePackCStringFinalizer rp (fromIntegral len) (rs_free_array_len rp (fromIntegral len)) + +-- |State of the Wasm module when a host operation is invoked (a host operation +-- is either a transfer to an account, or a contract call, at present). This can +-- only be resumed once. Calling resume on this twice will lead to unpredictable +-- behaviour, including the possibility of segmentation faults. newtype ReceiveInterruptedState = ReceiveInterruptedState { risPtr :: ForeignPtr (Ptr ReceiveInterruptedState) } withReturnValue :: ReturnValue -> (Ptr ReturnValue -> IO a) -> IO a withReturnValue ReturnValue{..} = withForeignPtr rvPtr +-- |Use the (maybe) return value in a foreign computation. If the first argument +-- is 'Nothing' then the computation is given the null pointer. withMaybeReturnValue :: Maybe ReturnValue -> (Ptr ReturnValue -> IO a) -> IO a withMaybeReturnValue Nothing k = k nullPtr withMaybeReturnValue (Just rv) k = withReturnValue rv k @@ -72,31 +94,44 @@ withMaybeReturnValue (Just rv) k = withReturnValue rv k withReceiveInterruptedState :: ReceiveInterruptedState -> (Ptr (Ptr ReceiveInterruptedState) -> IO a) -> IO a withReceiveInterruptedState = withForeignPtr . risPtr +-- |Possible reasons why a contract call failed. data ContractCallFailure = + -- |The contract call failed because the contract rejected execution for its own reason, or execution trapped. ExecutionReject !ContractExecutionReject - | EnvFailure !EnvFailure -- failure of execution due to the state of the host. + -- |Contract call failed due to other, environment reasons, such as the intended contract not existing. + | EnvFailure !EnvFailure +-- |Convert a contract call failure to a return value. If a contract call fails +-- due to the contract itself, then it can return some data (e.g., an error +-- message). This function extracts that, if it can. ccfToReturnValue :: ContractCallFailure -> Maybe ReturnValue ccfToReturnValue (ExecutionReject LogicReject{..}) = Just cerReturnValue ccfToReturnValue (ExecutionReject Trap) = Nothing ccfToReturnValue (EnvFailure _) = Nothing +-- |Result of an invoke. This just adds Success to the contract call failure. data InvokeResponseCode = Success | Error !ContractCallFailure +-- |Possible reasons why invocation failed that are not directly logic failure of a V1 call. data EnvFailure = AmountTooLarge !Address !Amount | MissingAccount !AccountAddress | MissingContract !ContractAddress | MessageFailed !Exec.RejectReason -- message to a V0 contract failed. No further information is available. deriving (Show) - -- FIXME: We could expose the reject reason if that is what happened. +-- TODO: In principle we could extract a more precise reason than MessageFailed. +-- |Encode the response into 64 bits. This is necessary since Wasm only allows +-- us to pass simple scalars as parameters. Everything else requires passing +-- data in memory, or via host functions, both of which are difficult.. -- The response is encoded as follows. --- - The first 24 bits are all 0 if success and all 1 if failure. --- - the next 8 bits encode the "EnvFailure or Trap" --- - the remaining 32 bits are for any response code from calling a contract +-- - success is encoded as 0 +-- - every failure has all bits of the first 3 bytes set +-- - in case of failure +-- - if the 4th byte is 0 then the remaining 4 bytes encode the rejection reason from the contract +-- - otherwise only the 4th byte is used, and encodes the enviroment failure. invokeResponseToWord64 :: InvokeResponseCode -> Word64 invokeResponseToWord64 Success = 0 invokeResponseToWord64 (Error (EnvFailure e)) = @@ -198,23 +233,18 @@ applyInitFun miface cm initCtx iName param amnt iEnergy = unsafePerformIO $ do amountWord = _amount amnt nameBytes = Text.encodeUtf8 (initName iName) -{-# NOINLINE returnValueToByteString #-} -returnValueToByteString :: ReturnValue -> BS.ByteString -returnValueToByteString rv = unsafePerformIO $ - withReturnValue rv $ \p -> alloca $ \outputLenPtr -> do - rp <- return_value_to_byte_array p outputLenPtr - len <- peek outputLenPtr - BSU.unsafePackCStringFinalizer rp (fromIntegral len) (rs_free_array_len rp (fromIntegral len)) - +-- |Allowed methods that a contract can invoke. data InvokeMethod = + -- |Transfer to an account. Transfer { imtTo :: !AccountAddress, imtAmount :: !Amount } + -- |Call another smart contract with the given parameter. | Call { imcTo :: !ContractAddress, imcParam :: !Parameter, - imcName :: !ReceiveName, -- FIXME: Should be entrypoint name + imcName :: !ReceiveName, -- FIXME: Should be entrypoint name, but that requires changes elsewhere to maintain consistency. imcAmount :: !Amount } @@ -224,22 +254,27 @@ getInvokeMethod = getWord8 >>= \case 1 -> Call <$> get <*> get <*> get <*> get n -> fail $ "Unsupported invoke method tag: " ++ show n +-- |Data return from the contract in case of successful initialization. data InitResultData = InitSuccess { irdReturnValue :: !ReturnValue, irdNewState :: !ContractState, irdLogs :: ![ContractEvent] } -data ReceiveResultData = ReceiveSuccess { - rrdReturnValue :: !ReturnValue, - rrdNewState :: !ContractState, - rrdLogs :: ![ContractEvent] +-- |Data returned from the receive call. In contrast to an init call, a receive call may interrupt. +data ReceiveResultData = + -- |Execution terminated with success. + ReceiveSuccess { + rrdReturnValue :: !ReturnValue, + rrdNewState :: !ContractState, + rrdLogs :: ![ContractEvent] + } | + -- |Execution invoked a method. The current state is returned. + ReceiveInterrupt { + rrdCurrentState :: !ContractState, + rrdMethod :: !InvokeMethod, + rrdInterruptedConfig :: !ReceiveInterruptedState } - | ReceiveInterrupt { - rrdCurrentState :: !ContractState, - rrdMethod :: !InvokeMethod, - rrdInterruptedConfig :: !ReceiveInterruptedState - } getLogs :: Get [ContractEvent] @@ -292,7 +327,7 @@ processInitResult result returnValuePtr = case BS.uncons result of Right x -> x Left err -> error $ "Internal error: Could not interpret output from interpreter: " ++ err --- The input was allocated with alloca. We allocate a fresh one with malloc and register +-- The input was allocated with alloca. We allocate a fresh one with malloc (via 'new') and register -- a finalizer for it. newReceiveInterruptedState :: Ptr (Ptr ReceiveInterruptedState) -> IO ReceiveInterruptedState newReceiveInterruptedState interruptedStatePtr = do @@ -302,6 +337,7 @@ newReceiveInterruptedState interruptedStatePtr = do addForeignPtrFinalizer freeReceiveInterruptedState fp return (ReceiveInterruptedState fp) +-- |Convert a contract call failure to the Scheduler's reject reason. cerToRejectReasonReceive :: ContractAddress -> ReceiveName -> Parameter -> ContractCallFailure -> Exec.RejectReason cerToRejectReasonReceive contractAddress receiveName parameter (ExecutionReject LogicReject{..}) = Exec.RejectedReceive{rejectReason=cerRejectReason,..} cerToRejectReasonReceive _ _ _ (ExecutionReject Trap) = Exec.RuntimeFailure @@ -405,7 +441,7 @@ applyReceiveFun miface cm receiveCtx rName param amnt cs initialEnergy = unsafeP paramBytes = BSS.fromShort (parameter param) nameBytes = Text.encodeUtf8 (receiveName rName) --- |Apply a receive function which is assumed to be part of the given module. +-- |Resume execution after processing the interrupt. This can only be called once on a single 'ReceiveInterruptedState'. resumeReceiveFun :: ReceiveInterruptedState -> ContractState -- ^State of the contract to start in. From 6e76821bc3d988995804d59305018c5298f1218e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Fri, 24 Dec 2021 10:11:35 +0100 Subject: [PATCH 17/51] Add P4 support for testing. --- concordium-base | 2 +- .../GlobalState/Basic/BlockState.hs | 4 +++ .../src/Concordium/GlobalState/Instance.hs | 4 ++- .../src/Concordium/GlobalState/Wasm.hs | 36 ++++++++++++++----- .../src/Concordium/ProtocolUpdate.hs | 1 + .../src/Concordium/Startup.hs | 5 +++ 6 files changed, 41 insertions(+), 11 deletions(-) diff --git a/concordium-base b/concordium-base index 7c9058b863..9b1e031158 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 7c9058b8638eb7a1cbcff7b2d134bd7de7f7a253 +Subproject commit 9b1e031158b6879ffa63e6d0a981d082142f6b9a diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs index c2b66510c1..5987a7307f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs @@ -31,6 +31,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.P1 as P1 import qualified Concordium.Genesis.Data.P2 as P2 import qualified Concordium.Genesis.Data.P3 as P3 +import qualified Concordium.Genesis.Data.P4 as P4 import qualified Concordium.GlobalState.Types as GT import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.Parameters @@ -899,6 +900,9 @@ genesisState gd = case protocolVersion @pv of SP3 -> case gd of GDP3 P3.GDP3Initial{..} -> mkGenesisStateInitial genesisCore genesisInitialState GDP3 P3.GDP3Regenesis{..} -> mkGenesisStateRegenesis genesisRegenesis + SP4 -> case gd of + GDP4 P4.GDP4Initial{..} -> mkGenesisStateInitial genesisCore genesisInitialState + GDP4 P4.GDP4Regenesis{..} -> mkGenesisStateRegenesis genesisRegenesis where mkGenesisStateInitial GenesisData.CoreGenesisParameters{..} GenesisData.GenesisState{..} = do accounts <- mapM mkAccount (zip [0..] (toList genesisAccounts)) diff --git a/concordium-consensus/src/Concordium/GlobalState/Instance.hs b/concordium-consensus/src/Concordium/GlobalState/Instance.hs index ca3e2ec846..c3f08069fb 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Instance.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Instance.hs @@ -57,7 +57,6 @@ data InstanceV v = InstanceV { _instanceVHash :: H.Hash } --- TODO: Use MakeClassy with parameters? makeLenses 'InstanceV class HasInstanceFields a where @@ -66,8 +65,11 @@ class HasInstanceFields a where instanceHash :: Lens' a H.Hash instance HasInstanceFields (InstanceV v) where + {-# INLINE instanceAmount #-} instanceAmount = instanceVAmount + {-# INLINE instanceModel #-} instanceModel = instanceVModel + {-# INLINE instanceHash #-} instanceHash = instanceVHash instance HasInstanceFields Instance where diff --git a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs index 9b41e8bf97..a25cd2d220 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs @@ -1,8 +1,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} {-| Common types and functions used to support wasm module storage in block state. |-} module Concordium.GlobalState.Wasm ( -- ** Instrumented module @@ -94,6 +97,9 @@ newModuleArtifactV1 p = do withModuleArtifact :: ModuleArtifact v -> (Ptr (ModuleArtifact v) -> IO a) -> IO a withModuleArtifact ModuleArtifact{..} = withForeignPtr maArtifact +-- This serialization instance does not add explicit versioning on its own. The +-- module artifact is always stored as part of another structure that has +-- versioning. instance Serialize ModuleArtifactV0 where get = do len <- getWord32be @@ -119,7 +125,6 @@ instance Serialize ModuleArtifactV1 where let bs = toBytesHelper toBytesArtifactV1 maArtifact in putWord32be (fromIntegral (BS.length bs)) <> putByteString bs - -- |Web assembly module in binary format, instrumented with whatever it needs to -- be instrumented with, and preprocessed to an executable format, ready to be -- instantiated and run. @@ -139,22 +144,23 @@ instance Serialize (InstrumentedModuleV V0) where putWord32be 0 put imWasmArtifactV0 - get = getWord32be >>= \case - 0 -> InstrumentedWasmModuleV0 <$> get + get = get >>= \case + V0 -> InstrumentedWasmModuleV0 <$> get _ -> fail "Unsupported Wasm module version." + instance Serialize (InstrumentedModuleV V1) where put InstrumentedWasmModuleV1{..} = do putWord32be 1 put imWasmArtifactV1 - get = getWord32be >>= \case - 1 -> InstrumentedWasmModuleV1 <$> get + get = get >>= \case + V1 -> InstrumentedWasmModuleV1 <$> get _ -> fail "Unsupported Wasm module version." -------------------------------------------------------------------------------- --- |A Wasm module interface with exposed entry-points. +-- |A Wasm module interface of a given version, specified via a type parameter. data ModuleInterfaceV v = ModuleInterface { -- |Reference of the module on the chain. miModuleRef :: !ModuleRef, @@ -164,8 +170,10 @@ data ModuleInterfaceV v = ModuleInterface { -- |Receive methods exposed by this module, indexed by contract name. -- They should each be exposed with a type Amount -> Word32 miExposedReceive :: !(Map.Map InitName (Set.Set ReceiveName)), - -- |Module source in binary format, instrumented with whatever it needs to be instrumented with. + -- |Module source in binary format, instrumented with whatever it needs to be + -- instrumented with to be able to run efficiently. miModule :: !(InstrumentedModuleV v), + -- |Size of the module as deployed in the transaction. miModuleSize :: !Word64 } deriving(Eq, Show) @@ -174,10 +182,15 @@ imWasmArtifact ModuleInterface{miModule = InstrumentedWasmModuleV0{..}} = imWasm imWasmArtifact ModuleInterface{miModule = InstrumentedWasmModuleV1{..}} = imWasmArtifactV1 class HasModuleRef a where + -- |Retrieve the module reference (the way a module is identified on the chain). moduleReference :: a -> ModuleRef +-- |A class that makes it more convenient to retrieve certain fields both from +-- versioned and unversioned modules. class HasEntrypoints a where + -- |Retrieve the set of contracts/init names from a module. exposedInit :: a -> Set.Set InitName + -- |Retrieve the set of exposed entrypoints indexed by contract names. exposedReceive :: a -> Map.Map InitName (Set.Set ReceiveName) instance HasEntrypoints (ModuleInterfaceV v) where @@ -187,7 +200,10 @@ instance HasEntrypoints (ModuleInterfaceV v) where instance HasModuleRef (ModuleInterfaceV v) where {-# INLINE moduleReference #-} moduleReference = miModuleRef - + +-- |A module interface in either version 0 or 1. This is generally only used +-- when looking up a module before an instance is created. Afterwards an +-- expliclitly versioned module interface (ModuleInterfaceV) is used. data ModuleInterface where ModuleInterfaceV0 :: ModuleInterfaceV V0 -> ModuleInterface ModuleInterfaceV1 :: ModuleInterfaceV V1 -> ModuleInterface @@ -204,6 +220,8 @@ instance HasEntrypoints ModuleInterface where exposedReceive (ModuleInterfaceV0 m) = miExposedReceive m exposedReceive (ModuleInterfaceV1 m) = miExposedReceive m +-- This serialization instance relies on the versioning of the +-- InstrumentedModuleV for its own versioning. instance Serialize (InstrumentedModuleV v) => Serialize (ModuleInterfaceV v) where get = do miModuleRef <- get diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate.hs b/concordium-consensus/src/Concordium/ProtocolUpdate.hs index 0db244086f..0bb026c057 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate.hs @@ -30,6 +30,7 @@ checkUpdate = case protocolVersion @pv of SP1 -> fmap UpdateP1 . P1.checkUpdate SP2 -> fmap UpdateP2 . P2.checkUpdate SP3 -> const $ Left "Unsupported update." + SP4 -> const $ Left "Unsupported update." -- |Construct the genesis data for a P1 update. -- It is assumed that the last finalized block is the terminal block of the old chain: diff --git a/concordium-consensus/src/Concordium/Startup.hs b/concordium-consensus/src/Concordium/Startup.hs index 82f90ea8aa..e6a3e4a482 100644 --- a/concordium-consensus/src/Concordium/Startup.hs +++ b/concordium-consensus/src/Concordium/Startup.hs @@ -38,6 +38,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.P1 as P1 import qualified Concordium.Genesis.Data.P2 as P2 import qualified Concordium.Genesis.Data.P3 as P3 +import qualified Concordium.Genesis.Data.P4 as P4 makeBakersByStake :: [Amount] -> [(BakerIdentity, FullBakerInfo, GenesisAccount, SigScheme.KeyPair)] makeBakersByStake = mbs 0 @@ -160,3 +161,7 @@ makeGenesisData genesisCore=GenesisData.CoreGenesisParameters{..}, genesisInitialState=GenesisData.GenesisState{genesisAccounts = Vec.fromList genesisAccounts, ..} } + SP4 -> GDP4 P4.GDP4Initial{ + genesisCore=GenesisData.CoreGenesisParameters{..}, + genesisInitialState=GenesisData.GenesisState{genesisAccounts = Vec.fromList genesisAccounts, ..} + } From 3e1917d51f83fce85f9ba738d89d79f868eb3cc9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Fri, 24 Dec 2021 10:24:50 +0100 Subject: [PATCH 18/51] Remove needless use of lenses. --- concordium-base | 2 +- .../src/Concordium/GlobalState/Instance.hs | 30 ++++++++----------- .../src/Concordium/GlobalState/Paired.hs | 6 ++-- .../src/Concordium/Scheduler/Environment.hs | 6 ++-- .../globalstate/GlobalStateTests/Instances.hs | 2 +- .../FibonacciSelfMessageTest.hs | 2 +- .../SchedulerTests/InitContextTest.hs | 4 ++- .../SmartContracts/V1/Counter.hs | 2 +- .../SmartContracts/V1/CrossMessaging.hs | 2 +- .../SmartContracts/V1/Transfer.hs | 4 +-- 10 files changed, 29 insertions(+), 31 deletions(-) diff --git a/concordium-base b/concordium-base index 9b1e031158..681176d566 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 9b1e031158b6879ffa63e6d0a981d082142f6b9a +Subproject commit 681176d566b2a3bdc12fdb7b0f63b7215ba0da14 diff --git a/concordium-consensus/src/Concordium/GlobalState/Instance.hs b/concordium-consensus/src/Concordium/GlobalState/Instance.hs index c3f08069fb..97b8b13deb 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Instance.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Instance.hs @@ -7,13 +7,11 @@ import Data.Aeson import Data.Serialize import qualified Data.Set as Set import qualified Concordium.Crypto.SHA256 as H -import Lens.Micro.Platform (makeLenses, (^.)) import Concordium.Types import Concordium.Types.HashableTo import qualified Concordium.Wasm as Wasm import qualified Concordium.GlobalState.Wasm as GSWasm import Data.Word -import Lens.Micro (to, Lens') -- |The fixed parameters associated with a smart contract instance data InstanceParameters v = InstanceParameters { @@ -57,32 +55,30 @@ data InstanceV v = InstanceV { _instanceVHash :: H.Hash } -makeLenses 'InstanceV - class HasInstanceFields a where - instanceAmount :: Lens' a Amount - instanceModel :: Lens' a Wasm.ContractState - instanceHash :: Lens' a H.Hash + instanceAmount :: a -> Amount + instanceModel :: a -> Wasm.ContractState + instanceHash :: a -> H.Hash instance HasInstanceFields (InstanceV v) where {-# INLINE instanceAmount #-} - instanceAmount = instanceVAmount + instanceAmount = _instanceVAmount {-# INLINE instanceModel #-} - instanceModel = instanceVModel + instanceModel = _instanceVModel {-# INLINE instanceHash #-} - instanceHash = instanceVHash + instanceHash = _instanceVHash instance HasInstanceFields Instance where - instanceAmount f (InstanceV0 i) = InstanceV0 <$> instanceAmount f i - instanceAmount f (InstanceV1 i) = InstanceV1 <$> instanceAmount f i - instanceModel f (InstanceV0 i) = InstanceV0 <$> instanceModel f i - instanceModel f (InstanceV1 i) = InstanceV1 <$> instanceModel f i - instanceHash f (InstanceV0 i) = InstanceV0 <$> instanceHash f i - instanceHash f (InstanceV1 i) = InstanceV1 <$> instanceHash f i + instanceAmount (InstanceV0 i) = instanceAmount i + instanceAmount (InstanceV1 i) = instanceAmount i + instanceModel (InstanceV0 i) = instanceModel i + instanceModel (InstanceV1 i) = instanceModel i + instanceHash (InstanceV0 i) = instanceHash i + instanceHash (InstanceV1 i) = instanceHash i instance HasInstanceParameters (InstanceV v) where - instanceAddress = (^. instanceVParameters . to instanceAddress) + instanceAddress = instanceAddress . _instanceVParameters instance HasInstanceParameters Instance where instanceAddress (InstanceV0 i) = instanceAddress i diff --git a/concordium-consensus/src/Concordium/GlobalState/Paired.hs b/concordium-consensus/src/Concordium/GlobalState/Paired.hs index 83b3c356e5..1725a6d7c5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Paired.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Paired.hs @@ -214,7 +214,7 @@ instance (Monad m, C.HasGlobalStateContext (PairGSContext lc rc) r, BlockStateQu getContractInstance (ls, rs) caddr = do c1 <- coerceBSML (getContractInstance ls caddr) c2 <- coerceBSMR (getContractInstance rs caddr) - assert (((==) `on` fmap (^. instanceHash)) c1 c2) $ return c1 + assert (((==) `on` fmap instanceHash) c1 c2) $ return c1 getModuleList (ls, rs) = do m1 <- coerceBSML (getModuleList ls) m2 <- coerceBSMR (getModuleList rs) @@ -226,7 +226,7 @@ instance (Monad m, C.HasGlobalStateContext (PairGSContext lc rc) r, BlockStateQu getContractInstanceList (ls, rs) = do a1 <- coerceBSML (getContractInstanceList ls) a2 <- coerceBSMR (getContractInstanceList rs) - assert (((==) `on` fmap (^. instanceHash)) a1 a2) $ return a1 + assert (((==) `on` fmap instanceHash) a1 a2) $ return a1 getSeedState (ls, rs) = do ss1 <- coerceBSML (getSeedState ls) ss2 <- coerceBSMR (getSeedState rs) @@ -378,7 +378,7 @@ instance (MonadLogger m, C.HasGlobalStateContext (PairGSContext lc rc) r, BlockS bsoGetInstance (bs1, bs2) iref = do r1 <- coerceBSML $ bsoGetInstance bs1 iref r2 <- coerceBSMR $ bsoGetInstance bs2 iref - assert (((==) `on` fmap (^. instanceHash)) r1 r2) $ return r1 + assert (((==) `on` fmap instanceHash) r1 r2) $ return r1 bsoAddressWouldClash (bs1, bs2) addr = do r1 <- coerceBSML $ bsoAddressWouldClash bs1 addr r2 <- coerceBSMR $ bsoAddressWouldClash bs2 addr diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 643ca02095..497fa6286e 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -496,7 +496,7 @@ addContractAmountToCS istance amnt cs = cs & instanceUpdates . at addr %~ \case Just (d, v) -> Just (d + amnt, v) Nothing -> Just (amnt, model) where addr = instanceAddress istance - model = istance ^. instanceModel + model = instanceModel istance -- |Add the given contract address to the set of initialized contract instances. -- As the changes on the blockstate are already performed in the handler for this operation, @@ -813,7 +813,7 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where getCurrentContractInstanceState istance = do newStates <- use (changeSet . instanceUpdates) case newStates ^. at (instanceAddress istance) of - Nothing -> return (istance ^. instanceModel) + Nothing -> return (instanceModel istance) Just (_, s) -> return s {-# INLINE getStateAccount #-} @@ -859,7 +859,7 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where {-# INLINE getCurrentContractAmount #-} getCurrentContractAmount inst = do - let amnt = inst ^. instanceAmount + let amnt = instanceAmount inst let addr = instanceAddress inst use (changeSet . instanceUpdates . at addr) >>= \case Just (delta, _) -> return $! applyAmountDelta delta amnt diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs index aadcea5fd8..df2479c086 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs @@ -131,7 +131,7 @@ instance Arbitrary InstanceData where return $ InstanceData model amount instanceData :: Instance -> InstanceData -instanceData inst = InstanceData (inst ^. instanceModel) (inst ^. instanceAmount) +instanceData inst = InstanceData (instanceModel inst) (instanceAmount inst) data Model = Model { -- Data of instances diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs index 44da8fca78..9f0b3d7b75 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs @@ -143,7 +143,7 @@ testCases = fibSpec n bs = specify "Contract state" $ case getInstance (Types.ContractAddress 0 0) (bs ^. blockInstances) of Nothing -> assertFailure "Instnace at <0,0> does not exist." - Just istance -> assertEqual "State contains the n-th Fibonacci number." (fibNBytes n) (istance ^. instanceModel) + Just istance -> assertEqual "State contains the n-th Fibonacci number." (fibNBytes n) (instanceModel istance) fib n = let go = 1:1:zipWith (+) go (tail go) in go !! n diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs index 056535c76e..183bdda2e9 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs @@ -82,7 +82,7 @@ checkInitResult proxy (suc, fails, instances) = do assertEqual "There should be no failed transactions." [] fails assertEqual "There should be no rejected transactions." [] reject assertEqual "There should be 1 instance." 1 (length instances) - let model = contractState . (^. instanceModel) . snd . head $ instances + let model = contractState . instanceModel . snd . head $ instances assertEqual "Instance model is the sender address of the account which inialized it." model (encode (senderAccount proxy)) where reject = filter (\case (_, Types.TxSuccess{}) -> False @@ -99,3 +99,5 @@ tests = testInit (Proxy @'P2) >>= checkInitResult (Proxy @'P2) specify "Passing init context to contract P3" $ testInit (Proxy @'P3) >>= checkInitResult (Proxy @'P3) + specify "Passing init context to contract P4" $ + testInit (Proxy @'P4) >>= checkInitResult (Proxy @'P4) diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs index 74a530f4a0..53461f7706 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs @@ -137,7 +137,7 @@ testCases = counterSpec n bs = specify "Contract state" $ case getInstance (Types.ContractAddress 0 0) (bs ^. blockInstances) of Nothing -> assertFailure "Instance at <0,0> does not exist." - Just istance -> assertEqual ("State contains " ++ show n ++ ".") (ContractState (runPut (putWord64le n))) (istance ^. instanceModel) + Just istance -> assertEqual ("State contains " ++ show n ++ ".") (ContractState (runPut (putWord64le n))) (instanceModel istance) tests :: Spec tests = describe "V1: Counter counts." $ diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs index 45f7705853..90673416e8 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs @@ -119,7 +119,7 @@ testCases = counterSpec n bs = specify "Contract state" $ case getInstance (Types.ContractAddress 0 0) (bs ^. blockInstances) of Nothing -> assertFailure "Instance at <0,0> does not exist." - Just istance -> assertEqual ("State contains " ++ show n ++ ".") (ContractState (runPut (putWord64le n))) (istance ^. instanceModel) + Just istance -> assertEqual ("State contains " ++ show n ++ ".") (ContractState (runPut (putWord64le n))) (instanceModel istance) tests :: Spec tests = describe "V1: Counter with cross-messaging." $ diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs index e783fa4c69..dd68d817ce 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs @@ -117,8 +117,8 @@ testCases = case getInstance (Types.ContractAddress 0 0) (bs ^. blockInstances) of Nothing -> assertFailure "Instance at <0,0> does not exist." Just istance -> do - assertEqual ("State contains.") (ContractState "") (istance ^. instanceModel) - assertEqual ("Contract has 0 CCD.") (Types.Amount 0) (istance ^. instanceAmount) + assertEqual ("State contains.") (ContractState "") (instanceModel istance) + assertEqual ("Contract has 0 CCD.") (Types.Amount 0) (instanceAmount istance) tests :: Spec tests = describe "V1: Transfer from contract to account." $ From 6dd1053fd3b569a8febd4671c379b69637a42a68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Sun, 26 Dec 2021 07:15:51 +0100 Subject: [PATCH 19/51] Haskell parts of invoking a contract as a query. --- concordium-base | 2 +- concordium-consensus/lib.def | 1 + .../src/Concordium/External.hs | 23 +++ .../GlobalState/Basic/BlockState.hs | 4 + .../GlobalState/Basic/BlockState/Instances.hs | 4 +- .../src/Concordium/GlobalState/BlockState.hs | 7 +- .../src/Concordium/GlobalState/Instance.hs | 14 +- .../src/Concordium/GlobalState/Paired.hs | 4 + .../GlobalState/Persistent/BlockState.hs | 19 +- .../src/Concordium/Queries.hs | 14 ++ .../src/Concordium/Scheduler.hs | 150 +++++++------- .../src/Concordium/Scheduler/Environment.hs | 153 +++++++------- .../Scheduler/EnvironmentImplementation.hs | 13 +- .../Concordium/Scheduler/InvokeContract.hs | 187 ++++++++++++++++++ .../Scheduler/WasmIntegration/V1.hs | 6 + .../globalstate/GlobalStateTests/Instances.hs | 6 +- 16 files changed, 437 insertions(+), 170 deletions(-) create mode 100644 concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs diff --git a/concordium-base b/concordium-base index 681176d566..2543626ed0 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 681176d566b2a3bdc12fdb7b0f63b7215ba0da14 +Subproject commit 2543626ed02b5f23031d7b4b0ee8a3e33f04081f diff --git a/concordium-consensus/lib.def b/concordium-consensus/lib.def index 801385526c..d1835ed259 100644 --- a/concordium-consensus/lib.def +++ b/concordium-consensus/lib.def @@ -22,6 +22,7 @@ EXPORTS getInstances getAccountInfo getInstanceInfo + InvokeContract getRewardStatus getBirkParameters getModuleList diff --git a/concordium-consensus/src/Concordium/External.hs b/concordium-consensus/src/Concordium/External.hs index 5b692d1f57..f14bc41869 100644 --- a/concordium-consensus/src/Concordium/External.hs +++ b/concordium-consensus/src/Concordium/External.hs @@ -33,6 +33,7 @@ import Concordium.Crypto.ByteStringHelpers import Concordium.GlobalState import Concordium.GlobalState.Persistent.LMDB (addDatabaseVersion) import Concordium.GlobalState.Persistent.TreeState (InitException (..)) +import qualified Concordium.Scheduler.InvokeContract as InvokeContract import Concordium.MultiVersion ( Callbacks (..), CatchUpConfiguration (..), @@ -873,6 +874,10 @@ decodeInstanceAddress inststr = AE.decodeStrict <$> BS.packCString inststr decodeModuleRef :: CString -> IO (Maybe ModuleRef) decodeModuleRef modstr = readMaybe <$> peekCString modstr +-- |Decode the context passed to the @invokeContract@ method. +decodeContractContext :: CString -> IO (Maybe InvokeContract.ContractContext) +decodeContractContext ctxStr = AE.decodeStrict <$> BS.packCString ctxStr + -- |Decode a transaction hash from a null-terminated base-16 string. decodeTransactionHash :: CString -> IO (Maybe TransactionHash) decodeTransactionHash trHashStr = readMaybe <$> peekCString trHashStr @@ -1051,6 +1056,23 @@ getInstanceInfo cptr blockcstr instcstr = do (Just bh, Just inst) -> jsonQuery cptr (Q.getInstanceInfo bh inst) _ -> jsonCString AE.Null +-- |Run the smart contract entrypoint in a given context and the state at the end of the given block. +-- The block must be given as a null-terminated base16 encoding of the block +-- hash and the context (second CString) must be given as a null-terminated +-- JSON-encoded value. +-- The return value is a null-terminated, json encoded information. It is either null +-- in case the input cannot be decoded, or the block does not exist, +-- or the JSON encoding of InvokeContract.InvokeContractResult. +-- The returned string should be freed by calling 'freeCStr'. +invokeContract :: StablePtr ConsensusRunner -> CString -> CString -> IO CString +invokeContract cptr blockcstr ctxcstr = do + mblock <- decodeBlockHash blockcstr + mctx <- decodeContractContext ctxcstr + case (mblock, mctx) of + (Just bh, Just ctx) -> jsonQuery cptr (Q.invokeContract bh ctx) + _ -> jsonCString AE.Null + + -- |Get the source code of a module as deployed on the chain at a particular block. -- The block must be given as a null-terminated base16 encoding of the block hash. -- The module is referenced by a null-terminated base16 encoding of the module hash. @@ -1269,6 +1291,7 @@ foreign export ccall getAccountList :: StablePtr ConsensusRunner -> CString -> I foreign export ccall getInstances :: StablePtr ConsensusRunner -> CString -> IO CString foreign export ccall getAccountInfo :: StablePtr ConsensusRunner -> CString -> CString -> IO CString foreign export ccall getInstanceInfo :: StablePtr ConsensusRunner -> CString -> CString -> IO CString +foreign export ccall invokeContract :: StablePtr ConsensusRunner -> CString -> CString -> IO CString foreign export ccall getRewardStatus :: StablePtr ConsensusRunner -> CString -> IO CString foreign export ccall getBirkParameters :: StablePtr ConsensusRunner -> CString -> IO CString foreign export ccall getModuleList :: StablePtr ConsensusRunner -> CString -> IO CString diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs index 5987a7307f..e586b2b6b1 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs @@ -352,6 +352,10 @@ instance (IsProtocolVersion pv, Monad m) => BS.BlockStateQuery (PureBlockStateMo getModule bs mref = return $ bs ^. blockModules . to (Modules.getSource mref) + {-# INLINE getModuleInterface #-} + getModuleInterface bs mref = + return $ bs ^. blockModules . to (Modules.getInterface mref) + {-# INLINE getContractInstance #-} getContractInstance bs caddr = return (Instances.getInstance caddr (bs ^. blockInstances)) diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs index ad05112790..d3cb8baed5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs @@ -41,12 +41,12 @@ getInstance addr (Instances iss) = iss ^? ix addr -- |Update the instance at the specified address with an amount delta and value. -- If there is no instance with the given address, this does nothing. -updateInstanceAt :: ContractAddress -> AmountDelta -> Wasm.ContractState -> Instances -> Instances +updateInstanceAt :: ContractAddress -> AmountDelta -> Maybe Wasm.ContractState -> Instances -> Instances updateInstanceAt ca amt val (Instances iss) = Instances (iss & ix ca %~ updateInstance amt val) -- |Update the instance at the specified address with a __new amount__ and value. -- If there is no instance with the given address, this does nothing. -updateInstanceAt' :: ContractAddress -> Amount -> Wasm.ContractState -> Instances -> Instances +updateInstanceAt' :: ContractAddress -> Amount -> Maybe Wasm.ContractState -> Instances -> Instances updateInstanceAt' ca amt val (Instances iss) = Instances (iss & ix ca %~ updateInstance' amt val) -- |Create a new smart contract instance. diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 42de6c398f..c873113430 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -190,6 +190,10 @@ class (BlockStateTypes m, Monad m) => AccountOperations m where class AccountOperations m => BlockStateQuery m where -- |Get the module source from the module table as deployed to the chain. getModule :: BlockState m -> ModuleRef -> m (Maybe Wasm.WasmModule) + + -- |Get the module source from the module table as deployed to the chain. + getModuleInterface :: BlockState m -> ModuleRef -> m (Maybe GSWasm.ModuleInterface) + -- |Get the account state from the account table of the state instance. getAccount :: BlockState m -> AccountAddress -> m (Maybe (AccountIndex, Account m)) @@ -369,7 +373,7 @@ class (BlockStateQuery m) => BlockStateOperations m where bsoModifyInstance :: UpdatableBlockState m -> ContractAddress -> AmountDelta - -> Wasm.ContractState + -> Maybe Wasm.ContractState -> m (UpdatableBlockState m) -- |Notify that some amount was transferred from/to encrypted balance of some account. @@ -619,6 +623,7 @@ class (BlockStateOperations m, Serialize (BlockStateRef m)) => BlockStateStorage instance (Monad (t m), MonadTrans t, BlockStateQuery m) => BlockStateQuery (MGSTrans t m) where getModule s = lift . getModule s + getModuleInterface s = lift . getModuleInterface s getAccount s = lift . getAccount s getAccountByCredId s = lift . getAccountByCredId s getBakerAccount s = lift . getBakerAccount s diff --git a/concordium-consensus/src/Concordium/GlobalState/Instance.hs b/concordium-consensus/src/Concordium/GlobalState/Instance.hs index 97b8b13deb..fa15c4112d 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Instance.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Instance.hs @@ -4,6 +4,7 @@ module Concordium.GlobalState.Instance where import Data.Aeson +import Data.Maybe import Data.Serialize import qualified Data.Set as Set import qualified Concordium.Crypto.SHA256 as H @@ -195,24 +196,25 @@ iaddress (InstanceV1 InstanceV{..}) = _instanceAddress _instanceVParameters -- |Update a given smart contract instance. -- FIXME: Updates to the state should be done better in the future, we should not just replace it. -updateInstanceV :: AmountDelta -> Wasm.ContractState -> InstanceV v -> InstanceV v +updateInstanceV :: AmountDelta -> Maybe Wasm.ContractState -> InstanceV v -> InstanceV v updateInstanceV delta val i = updateInstanceV' amnt val i where amnt = applyAmountDelta delta (_instanceVAmount i) -updateInstance :: AmountDelta -> Wasm.ContractState -> Instance -> Instance +updateInstance :: AmountDelta -> Maybe Wasm.ContractState -> Instance -> Instance updateInstance delta val (InstanceV0 i) = InstanceV0 $ updateInstanceV delta val i updateInstance delta val (InstanceV1 i) = InstanceV1 $ updateInstanceV delta val i -- |Update a given smart contract instance with exactly the given amount and state. -updateInstanceV' :: Amount -> Wasm.ContractState -> InstanceV v -> InstanceV v +updateInstanceV' :: Amount -> Maybe Wasm.ContractState -> InstanceV v -> InstanceV v updateInstanceV' amnt val i = i { - _instanceVModel = val, + _instanceVModel = newVal, _instanceVAmount = amnt, - _instanceVHash = makeInstanceHash ( _instanceVParameters i) val amnt + _instanceVHash = makeInstanceHash ( _instanceVParameters i) newVal amnt } + where newVal = fromMaybe (_instanceVModel i) val -updateInstance' :: Amount -> Wasm.ContractState -> Instance -> Instance +updateInstance' :: Amount -> Maybe Wasm.ContractState -> Instance -> Instance updateInstance' amnt val (InstanceV0 i) = InstanceV0 $ updateInstanceV' amnt val i updateInstance' amnt val (InstanceV1 i) = InstanceV1 $ updateInstanceV' amnt val i diff --git a/concordium-consensus/src/Concordium/GlobalState/Paired.hs b/concordium-consensus/src/Concordium/GlobalState/Paired.hs index 1725a6d7c5..7a132354e9 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Paired.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Paired.hs @@ -178,6 +178,10 @@ instance (Monad m, C.HasGlobalStateContext (PairGSContext lc rc) r, BlockStateQu m1 <- coerceBSML (getModule ls modRef) m2 <- coerceBSMR (getModule rs modRef) assert (m1 == m2) $ return m1 + getModuleInterface (bs1, bs2) mref = do + r1 <- coerceBSML $ getModuleInterface bs1 mref + r2 <- coerceBSMR $ getModuleInterface bs2 mref + assert (r1 == r2) $ return r1 getAccount (ls, rs) addr = do a1 <- coerceBSML (getAccount ls addr) a2 <- coerceBSMR (getAccount rs addr) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 44a2e9a95f..5a2b0043a2 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -1020,7 +1020,7 @@ doPutNewInstance pbs fnew = do pinstanceHash = _instanceVHash }) -doModifyInstance :: (IsProtocolVersion pv, MonadBlobStore m) => PersistentBlockState pv -> ContractAddress -> AmountDelta -> Wasm.ContractState -> m (PersistentBlockState pv) +doModifyInstance :: (IsProtocolVersion pv, MonadBlobStore m) => PersistentBlockState pv -> ContractAddress -> AmountDelta -> Maybe Wasm.ContractState -> m (PersistentBlockState pv) doModifyInstance pbs caddr deltaAmnt val = do bsp <- loadPBS pbs -- Update the instance @@ -1032,15 +1032,23 @@ doModifyInstance pbs caddr deltaAmnt val = do upd (PersistentInstanceV0 oldInst) = do (piParams, newParamsRef) <- cacheBufferedRef (pinstanceParameters oldInst) if deltaAmnt == 0 then - return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef, pinstanceModel = val})) + case val of + Nothing -> return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef})) + Just newVal -> return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef, pinstanceModel = newVal})) else - return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceAmount = applyAmountDelta deltaAmnt (pinstanceAmount oldInst), pinstanceModel = val}) + case val of + Nothing -> return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceAmount = applyAmountDelta deltaAmnt (pinstanceAmount oldInst)}) + Just newVal -> return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceAmount = applyAmountDelta deltaAmnt (pinstanceAmount oldInst), pinstanceModel = newVal}) upd (PersistentInstanceV1 oldInst) = do (piParams, newParamsRef) <- cacheBufferedRef (pinstanceParameters oldInst) if deltaAmnt == 0 then - return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef, pinstanceModel = val})) + case val of + Nothing -> return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef})) + Just newVal -> return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef, pinstanceModel = newVal})) else - return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceAmount = applyAmountDelta deltaAmnt (pinstanceAmount oldInst), pinstanceModel = val}) + case val of + Nothing -> return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceAmount = applyAmountDelta deltaAmnt (pinstanceAmount oldInst)}) + Just newVal -> return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceAmount = applyAmountDelta deltaAmnt (pinstanceAmount oldInst), pinstanceModel = newVal}) rehash iph inst@PersistentInstanceV {..} = inst {pinstanceHash = makeInstanceHash' iph pinstanceModel pinstanceAmount} doGetIdentityProvider :: (IsProtocolVersion pv, MonadBlobStore m) => PersistentBlockState pv -> ID.IdentityProviderIdentity -> m (Maybe IPS.IpInfo) @@ -1259,6 +1267,7 @@ instance BlockStateTypes (PersistentBlockStateMonad pv r m) where instance (IsProtocolVersion pv, PersistentState r m) => BlockStateQuery (PersistentBlockStateMonad pv r m) where getModule = doGetModuleSource . hpbsPointers + getModuleInterface pbs mref = doGetModule (hpbsPointers pbs) mref getAccount = doGetAccount . hpbsPointers getAccountByCredId = doGetAccountByCredId . hpbsPointers getContractInstance = doGetInstance . hpbsPointers diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index daeae16ef3..2050b46cd0 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -32,6 +32,8 @@ import Concordium.Types.Queries import Concordium.Types.SeedState import qualified Concordium.Wasm as Wasm +import qualified Concordium.Scheduler.InvokeContract as InvokeContract + import Concordium.Afgjort.Finalize.Types (FinalizationCommittee (..), PartyInfo (..)) import Concordium.Afgjort.Monad import Concordium.Birk.Bake @@ -569,6 +571,18 @@ getTransactionStatusInBlock trHash blockHash = else return $ Just BTSNotInBlock ) +-- * Smart contract invocations +invokeContract :: BlockHash -> InvokeContract.ContractContext -> MVR gsconf finconf (Maybe InvokeContract.InvokeContractResult) +invokeContract bh cctx = + liftSkovQueryBlockAndVersion + (\(_ :: VersionedConfiguration gsconf finconf pv) bp -> do + bs <- blockState bp + cm <- ChainMetadata <$> getSlotTimestamp (blockSlot bp) + InvokeContract.invokeContract (protocolVersion @pv) cctx cm bs) + bh + + + -- * Miscellaneous -- |Check whether the node is currently a member of the finalization committee. diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 751d836c11..ae94145f1b 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -35,6 +35,10 @@ module Concordium.Scheduler (filterTransactions ,runTransactions ,execTransactions + ,handleContractUpdateV1 + ,handleContractUpdateV0 + ,checkAndGetBalanceInstance + ,checkAndGetBalanceAccount ,FilteredTransactions(..) ) where import qualified Concordium.GlobalState.Wasm as GSWasm @@ -163,7 +167,7 @@ dispatch msg = do -- the header and reject the transaction; we have checked that the amount -- exists on the account with 'checkHeader'. payment <- energyToGtu checkHeaderCost - chargeExecutionCost (transactionHash msg) senderAccount payment + chargeExecutionCost senderAccount payment return $ Just $ TxValid $ TransactionSummary{ tsEnergyCost = checkHeaderCost, tsCost = payment, @@ -301,7 +305,7 @@ handleTransferWithSchedule wtc twsTo twsSchedule maybeMemo = withDeposit wtc c k unless (senderAmount >= transferAmount) $! rejectTransaction (AmountTooLarge (AddressAccount senderAddress) transferAmount) -- check the target account - targetAccount <- getStateAccount twsTo `rejectingWith` InvalidAccountReference twsTo + targetAccount <- getAccount twsTo `rejectingWith` InvalidAccountReference twsTo -- In protocol version P3 account addresses are no longer in 1-1 -- correspondence with accounts. Thus to check that a scheduled -- transfer is not a self transfer we need to check canonical @@ -318,7 +322,7 @@ handleTransferWithSchedule wtc twsTo twsSchedule maybeMemo = withDeposit wtc c k k ls () = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost commitChanges (ls ^. changeSet) let eventList = TransferredWithSchedule{etwsFrom = senderAddress, etwsTo = twsTo, etwsAmount = twsSchedule} : (TransferMemo <$> maybeToList maybeMemo) @@ -336,7 +340,6 @@ handleTransferToPublic wtc transferData@SecToPubAmountTransferData{..} = do cryptoParams <- getCryptoParams withDeposit wtc (c cryptoParams) k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta c cryptoParams = do @@ -365,7 +368,7 @@ handleTransferToPublic wtc transferData@SecToPubAmountTransferData{..} = do k ls senderAmount = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost notifyEncryptedBalanceChange $ amountDiff 0 stpatdTransferAmount commitChanges (ls ^. changeSet) return (TxSuccess [EncryptedAmountsRemoved{ @@ -391,7 +394,6 @@ handleTransferToEncrypted wtc toEncrypted = do cryptoParams <- getCryptoParams withDeposit wtc (c cryptoParams) k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta @@ -416,7 +418,7 @@ handleTransferToEncrypted wtc toEncrypted = do k ls encryptedAmount = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost notifyEncryptedBalanceChange $ amountToDelta toEncrypted commitChanges (ls ^. changeSet) @@ -439,7 +441,6 @@ handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransfer cryptoParams <- getCryptoParams withDeposit wtc (c cryptoParams) k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta @@ -462,7 +463,7 @@ handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransfer -- Look up the receiver account first, and don't charge if it does not exist -- and does not have a valid credential. - targetAccount <- getStateAccount toAddress `rejectingWith` InvalidAccountReference toAddress + targetAccount <- getAccount toAddress `rejectingWith` InvalidAccountReference toAddress -- Check that the account is not transferring to itself since that -- causes technical complications. In protocol versions 1 and 2 -- account addresses and accounts were in 1-1 correspondence. In @@ -501,7 +502,7 @@ handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransfer k ls (targetAccountEncryptedAmountIndex, senderAmount) = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost commitChanges (ls ^. changeSet) let eventList = [EncryptedAmountsRemoved{ earAccount = senderAddress, @@ -530,7 +531,6 @@ handleDeployModule wtc mod = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader -- Size of the module source @@ -558,7 +558,7 @@ handleDeployModule wtc mod = k ls (iface, mhash) = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost -- Add the module to the global state (module interface, value interface and module itself). -- We know the module does not exist at this point, so we can ignore the return value. _ <- commitModule (iface, mod) @@ -614,7 +614,6 @@ handleInitContract :: handleInitContract wtc initAmount modref initName param = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader -- The contract gets the address that was used when signing the -- transactions, as opposed to the canonical one. @@ -693,7 +692,7 @@ handleInitContract wtc initAmount modref initName param = k ls (Left (iface, result)) = do let model = Wasm.newState result (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost -- Withdraw the amount the contract is initialized with from the sender account. cs' <- addAmountToCS senderAccount (amountDiff 0 initAmount) (ls ^. changeSet) @@ -715,7 +714,7 @@ handleInitContract wtc initAmount modref initName param = k ls (Right (iface, result)) = do let model = WasmV1.irdNewState result (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost -- Withdraw the amount the contract is initialized with from the sender account. cs' <- addAmountToCS senderAccount (amountDiff 0 initAmount) (ls ^. changeSet) @@ -755,7 +754,7 @@ handleSimpleTransfer wtc toAddr transferamount maybeMemo = unless (senderamount >= transferamount) $! rejectTransaction (AmountTooLarge (AddressAccount senderAddress) transferamount) -- Check whether target account exists and get it. - targetAccount <- getStateAccount toAddr `rejectingWith` InvalidAccountReference toAddr + targetAccount <- getAccount toAddr `rejectingWith` InvalidAccountReference toAddr -- Add the transfer to the current changeset and return the corresponding event. withAccountToAccountAmount senderAccount targetAccount transferamount $ @@ -775,49 +774,64 @@ handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = where senderAccount = wtc ^. wtcSenderAccount meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta + checkAndGetBalance = checkAndGetBalanceAccount senderAddress senderAccount c = do getCurrentContractInstanceTicking uAddress >>= \case InstanceV0 ins -> -- Now invoke the general handler for contract messages. - handleMessage senderAddress + handleContractUpdateV0 senderAddress ins - (Right (senderAddress, senderAccount)) + checkAndGetBalance uAmount uReceiveName uMessage InstanceV1 ins -> do - handleContractUpdateV1 senderAddress ins (Right (senderAddress, senderAccount)) uAmount uReceiveName uMessage >>= \case + handleContractUpdateV1 senderAddress ins checkAndGetBalance uAmount uReceiveName uMessage >>= \case Left cer -> rejectTransaction (WasmV1.cerToRejectReasonReceive uAddress uReceiveName uMessage cer) Right (_, events) -> return events -handleContractUpdateV1 :: forall pv m vOrigin. +checkAndGetBalanceAccount :: (TransactionMonad pv m, AccountOperations m) + => AccountAddress -- ^Used address + -> IndexedAccount m + -> Amount + -> m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress)) +checkAndGetBalanceAccount usedAddress senderAccount transferAmount = do + (senderAddr, senderCredentials) <- mkSenderAddrCredentials (Right (usedAddress, senderAccount)) + senderamount <- getAccountAvailableAmount (snd senderAccount) + unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) + canonicalAddr <- getAccountCanonicalAddress (snd senderAccount) + return (senderAddr, senderCredentials, Right (fst senderAccount, canonicalAddr)) + +checkAndGetBalanceInstance :: (TransactionMonad pv m, AccountOperations m) + => IndexedAccount m + -> InstanceV vOrigin + -> Amount + -> m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress)) +checkAndGetBalanceInstance ownerAccount istance transferAmount = do + (senderAddr, senderCredentials) <- mkSenderAddrCredentials (Left (ownerAccount, instanceAddress istance)) + senderamount <- getCurrentContractAmount istance + unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) + return (senderAddr, senderCredentials, (Left (instanceAddress istance))) + +handleContractUpdateV1 :: forall pv m. (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^The address that was used to send the top-level transaction. -> InstanceV GSWasm.V1 -- ^The current state of the target contract of the transaction, which must exist. - -> Either (IndexedAccount m, InstanceV vOrigin) (AccountAddress, IndexedAccount m) - -- ^The sender of the message (contract instance or account). In case this is - -- a contract the first parameter is the owner account of the instance. In case this is an account + -> (Amount -> m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress))) + -- ^Check that the sender has sufficient amount to cover the given amount and return a triple of + -- - used address + -- - credentials of the address, either account or owner of the contract + -- - resolved address. In case this is an account -- (i.e., this is called from a top-level transaction) the value is a pair of the address that was used -- as the sender address of the transaction, and the account to which it points. - -- On the first invocation of this function this will be the sender of the - -- top-level transaction, and in recursive calls the respective contract - -- instance that produced the message. -> Amount -- ^The amount to be transferred from the sender of the message to the contract upon success. -> Wasm.ReceiveName -- ^Name of the contract to invoke. -> Wasm.Parameter -- ^Message to invoke the receive method with. -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) -- ^The events resulting from processing the message and all recursively processed messages. -handleContractUpdateV1 originAddr istance sender transferAmount receiveName parameter = do +handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount receiveName parameter = do -- Cover administrative costs. tickEnergy Cost.updateContractInstanceBaseCost let model = _instanceVModel istance - - -- Check whether the sender of the message has enough on its account/instance for the transfer. - -- If the amount is not sufficient, the top-level transaction is rejected. - -- Note that this returns the address that was used in the top-level transaction, or the contract address. - -- In the former case the credentials are credentials of the account, in the - -- latter they are credentials of the owner account. - (senderAddr, senderCredentials) <- mkSenderAddrCredentials sender - let iParams = _instanceVParameters istance let cref = instanceAddress iParams let receivefuns = instanceReceiveFuns . _instanceVParameters $ istance @@ -826,12 +840,9 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para let ownerAccountAddress = instanceOwner iParams -- The invariants maintained by global state should ensure that an owner account always exists. -- However we are defensive here and reject the transaction instead of panicking in case it does not. - ownerAccount <- getStateAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress + ownerAccount <- getAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress - -- transfer the amount from the sender to the contract at the start. This is so that the contract may immediately use it - -- for, e.g., forwarding. - senderamount <- getCurrentAvailableAmount sender - unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) + (senderAddr, senderCredentials, sender) <- checkAndGetSender transferAmount cm <- getChainMetadata let receiveCtx = Wasm.ReceiveContext { @@ -880,7 +891,7 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para getCurrentContractInstanceTicking' imcTo >>= \case Nothing -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MissingContract imcTo))) Nothing) Just (InstanceV0 targetInstance) -> do - let runSuccess = Right <$> handleMessage originAddr targetInstance (Left (ownerAccount, istance)) imcAmount imcName imcParam + let runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount imcName imcParam (runSuccess `orElseWith` (return . Left)) >>= \case Left rr -> -- execution failed. go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) @@ -888,7 +899,7 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para newState <- getCurrentContractInstanceState istance go (evs ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success Nothing) Just (InstanceV1 targetInstance) -> do - withRollback (handleContractUpdateV1 originAddr targetInstance (Left (ownerAccount, istance)) imcAmount imcName imcParam) >>= \case + withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount imcName imcParam) >>= \case Left cer -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) Right (rVal, callEvents) -> do @@ -896,6 +907,8 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para go (callEvents ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success (Just rVal)) -- start contract execution. + -- transfer the amount from the sender to the contract at the start. This is so that the contract may immediately use it + -- for, e.g., forwarding. withToContractAmount sender istance transferAmount $ go [] =<< runInterpreter (return . WasmV1.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) @@ -912,11 +925,11 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para let addr = AddressContract (instanceAddress senderInstance) unless (senderamount >= tAmount) $! throwError (WasmV1.AmountTooLarge addr tAmount) -- Check whether target account exists and get it. - lift (getStateAccount accAddr) >>= \case + lift (getAccount accAddr) >>= \case Nothing -> throwError (WasmV1.MissingAccount accAddr) Just targetAccount -> -- Add the transfer to the current changeset and return the corresponding event. - lift (withContractToAccountAmount senderInstance targetAccount tAmount $ + lift (withContractToAccountAmount (instanceAddress senderInstance) targetAccount tAmount $ return [Transferred addr transferAmount (AddressAccount accAddr)]) @@ -924,11 +937,11 @@ handleContractUpdateV1 originAddr istance sender transferAmount receiveName para -- This includes the transfer of an amount from the sending account or instance. -- Recursively do the same for new messages created by contracts (from left to right, depth first). -- The target contract must exist, so that its state can be looked up. -handleMessage :: forall pv m v. +handleContractUpdateV0 :: forall pv m. (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^The address that was used to send the top-level transaction. -> InstanceV GSWasm.V0 -- ^The current state of the target contract of the transaction, which must exist. - -> Either (IndexedAccount m, InstanceV v) (AccountAddress, IndexedAccount m) + -> (Amount -> m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress))) -- ^The sender of the message (contract instance or account). In case this is -- a contract the first parameter is the owner account of the instance. In case this is an account -- (i.e., this is called from a top-level transaction) the value is a pair of the address that was used @@ -940,7 +953,7 @@ handleMessage :: forall pv m v. -> Wasm.ReceiveName -- ^Name of the contract to invoke. -> Wasm.Parameter -- ^Message to invoke the receive method with. -> m [Event] -- ^The events resulting from processing the message and all recursively processed messages. -handleMessage originAddr istance sender transferAmount receiveName parameter = do +handleContractUpdateV0 originAddr istance checkAndGetSender transferAmount receiveName parameter = do -- Cover administrative costs. tickEnergy Cost.updateContractInstanceBaseCost @@ -950,9 +963,7 @@ handleMessage originAddr istance sender transferAmount receiveName parameter = d -- Note that this returns the address that was used in the top-level transaction, or the contract address. -- In the former case the credentials are credentials of the account, in the -- latter they are credentials of the owner account. - (senderAddr, senderCredentials) <- mkSenderAddrCredentials sender - senderamount <- getCurrentAvailableAmount sender - unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) + (senderAddr, senderCredentials, sender) <- checkAndGetSender transferAmount let iParams = _instanceVParameters istance let cref = instanceAddress iParams @@ -964,7 +975,7 @@ handleMessage originAddr istance sender transferAmount receiveName parameter = d let ownerAccountAddress = instanceOwner iParams -- The invariants maintained by global state should ensure that an owner account always exists. -- However we are defensive here and reject the transaction instead of panicking in case it does not. - ownerAccount <- getStateAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress + ownerAccount <- getAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress cm <- getChainMetadata -- We have established that the owner account of the receiver instance has at least one valid credential. @@ -1029,9 +1040,9 @@ foldEvents :: (TransactionMonad pv m, AccountOperations m) foldEvents originAddr istance initEvent = fmap (initEvent:) . go where go Wasm.TSend{..} = do getCurrentContractInstanceTicking erAddr >>= \case - InstanceV0 cinstance -> handleMessage originAddr + InstanceV0 cinstance -> handleContractUpdateV0 originAddr cinstance - (Left istance) + (uncurry checkAndGetBalanceInstance istance) erAmount erName erParameter @@ -1039,7 +1050,7 @@ foldEvents originAddr istance initEvent = fmap (initEvent:) . go let c = handleContractUpdateV1 originAddr cinstance - (Left istance) + (uncurry checkAndGetBalanceInstance istance) erAmount erName erParameter @@ -1059,12 +1070,12 @@ foldEvents originAddr istance initEvent = fmap (initEvent:) . go go l `orElse` go r go Wasm.Accept = return [] -mkSenderAddrCredentials :: AccountOperations m => Either (IndexedAccount m, InstanceV v) (AccountAddress, IndexedAccount m) -> m (Address, [ID.AccountCredential]) +mkSenderAddrCredentials :: AccountOperations m => Either (IndexedAccount m, ContractAddress) (AccountAddress, IndexedAccount m) -> m (Address, [ID.AccountCredential]) mkSenderAddrCredentials sender = case sender of - Left (ownerAccount, istance) -> do + Left (ownerAccount, iaddr) -> do credentials <- getAccountCredentials (snd ownerAccount) - return (AddressContract (instanceAddress (_instanceVParameters istance)), map snd (OrdMap.toAscList credentials)) + return (AddressContract iaddr, map snd (OrdMap.toAscList credentials)) Right (usedAddress, (_, acc)) -> do let addr = AddressAccount usedAddress credentials <- getAccountCredentials acc @@ -1087,10 +1098,10 @@ handleTransferAccount accAddr senderInstance transferamount = do unless (senderamount >= transferamount) $! rejectTransaction (AmountTooLarge addr transferamount) -- Check whether target account exists and get it. - targetAccount <- getStateAccount accAddr `rejectingWith` InvalidAccountReference accAddr + targetAccount <- getAccount accAddr `rejectingWith` InvalidAccountReference accAddr -- Add the transfer to the current changeset and return the corresponding event. - withContractToAccountAmount senderInstance targetAccount transferamount $ + withContractToAccountAmount (instanceAddress senderInstance) targetAccount transferamount $ return [Transferred addr transferamount (AddressAccount accAddr)] -- |Run the interpreter with the remaining amount of energy. If the interpreter @@ -1151,7 +1162,6 @@ handleAddBaker :: handleAddBaker wtc abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyKey abProofSig abProofElection abProofAggregation abBakingStake abRestakeEarnings = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta c = do @@ -1161,7 +1171,7 @@ handleAddBaker wtc abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyK getCurrentAccountTotalAmount senderAccount k ls accountBalance = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost let challenge = addBakerChallenge senderAddress abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyKey electionP = checkElectionKeyProof challenge abElectionVerifyKey abProofElection @@ -1214,13 +1224,12 @@ handleRemoveBaker :: handleRemoveBaker wtc = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta c = tickEnergy Cost.removeBakerCost k ls () = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost res <- removeBaker (fst senderAccount) case res of @@ -1243,7 +1252,6 @@ handleUpdateBakerStake wtc newStake = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta c = do @@ -1253,7 +1261,7 @@ handleUpdateBakerStake wtc newStake = getCurrentAccountTotalAmount senderAccount k ls accountBalance = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost if accountBalance < newStake then -- The balance is insufficient. return (TxReject InsufficientBalanceForBakerStake, energyCost, usedEnergy) @@ -1281,13 +1289,12 @@ handleUpdateBakerRestakeEarnings :: handleUpdateBakerRestakeEarnings wtc newRestakeEarnings = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta c = tickEnergy Cost.updateBakerRestakeCost k ls () = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost res <- updateBakerRestakeEarnings (fst senderAccount) newRestakeEarnings case res of @@ -1322,13 +1329,12 @@ handleUpdateBakerKeys :: handleUpdateBakerKeys wtc bkuElectionKey bkuSignKey bkuAggregationKey bkuProofSig bkuProofElection bkuProofAggregation = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta c = tickEnergy Cost.updateBakerKeysCost k ls _ = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost let challenge = updateBakerKeyChallenge senderAddress bkuElectionKey bkuSignKey bkuAggregationKey electionP = checkElectionKeyProof challenge bkuElectionKey bkuProofElection @@ -1451,7 +1457,6 @@ handleUpdateCredentialKeys wtc cid keys sigs = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader c = do @@ -1473,7 +1478,7 @@ handleUpdateCredentialKeys wtc cid keys sigs = return index k ls index = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost updateCredentialKeys (fst senderAccount) index keys return (TxSuccess [CredentialKeysUpdated cid], energyCost, usedEnergy) @@ -1552,7 +1557,6 @@ handleUpdateCredentials wtc cdis removeRegIds threshold = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta @@ -1572,7 +1576,7 @@ handleUpdateCredentials wtc cdis removeRegIds threshold = k ls existingCredentials = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost cryptoParams <- getCryptoParams -- check that all credentials that are to be removed actually exist. diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 497fa6286e..0f2417b2fc 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} @@ -42,6 +43,11 @@ import Control.Exception(assert) import qualified Concordium.ID.Types as ID +-- |An account index togehter with the canonical address. Sometimes it is +-- difficult to pass an IndexedAccount and we only need the addresses. That is +-- when this type is useful. +type IndexedAccountAddress = (AccountIndex, AccountAddress) + -- |Whether the current energy limit is block energy or current transaction energy. data EnergyLimitReason = BlockEnergy | TransactionEnergy deriving(Eq, Show) @@ -61,6 +67,13 @@ class (Monad m) => StaticInformation m where -- |Get maximum number of account creation transactions per block. getAccountCreationLimit :: m CredentialsPerBlockLimit + -- |Return a contract instance if it exists at the given address. + getContractInstance :: ContractAddress -> m (Maybe Instance) + + -- |Get the amount of funds at the particular account address. + -- To get the amount of funds for a contract instance use getInstance and lookup amount there. + getAccount :: AccountAddress -> m (Maybe (IndexedAccount m)) + -- |Information needed to execute transactions in the form that is easy to use. class (Monad m, StaticInformation m, CanRecordFootprint (Footprint (ATIStorage m)), AccountOperations m, MonadLogger m, IsProtocolVersion pv) => SchedulerMonad pv m | m -> pv where @@ -70,13 +83,6 @@ class (Monad m, StaticInformation m, CanRecordFootprint (Footprint (ATIStorage m -- nothing, or the set of accounts affected by the transaction. tlNotifyAccountEffect :: Footprint (ATIStorage m) -> TransactionSummary -> m () - -- |Return a contract instance if it exists at the given address. - getContractInstance :: ContractAddress -> m (Maybe Instance) - - -- |Get the amount of funds at the particular account address. - -- To get the amount of funds for a contract instance use getInstance and lookup amount there. - getAccount :: AccountAddress -> m (Maybe (IndexedAccount m)) - -- |Get the 'AccountIndex' for an account, if it exists. getAccountIndex :: AccountAddress -> m (Maybe AccountIndex) @@ -298,7 +304,7 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Transfer amount from the first address to the second and run the -- computation in the modified environment. - withAccountToContractAmount :: IndexedAccount m -> InstanceV v -> Amount -> m a -> m a + withAccountToContractAmount :: IndexedAccountAddress -> InstanceV v -> Amount -> m a -> m a -- |Transfer an amount from the first account to the second and run the -- computation in the modified environment. @@ -306,11 +312,11 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Transfer an amount from the given instance to the given account and run the -- computation in the modified environment. - withContractToAccountAmount :: (HasInstanceParameters a, HasInstanceFields a) => a -> IndexedAccount m -> Amount -> m c -> m c + withContractToAccountAmount :: ContractAddress -> IndexedAccount m -> Amount -> m c -> m c -- |Transfer an amount from the first instance to the second and run the -- computation in the modified environment. - withContractToContractAmount :: InstanceV v1 -> InstanceV v2 -> Amount -> m a -> m a + withContractToContractAmount :: ContractAddress -> InstanceV v2 -> Amount -> m a -> m a -- |Transfer a scheduled amount from the first address to the second and run -- the computation in the modified environment. @@ -343,9 +349,9 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Transfer an amount from the first given instance or account to the instance in the second -- parameter and run the computation in the modified environment. {-# INLINE withToContractAmount #-} - withToContractAmount :: Either (IndexedAccount m, InstanceV v1) (AccountAddress, IndexedAccount m) -> InstanceV v2 -> Amount -> m a -> m a - withToContractAmount (Left (_, i)) = withContractToContractAmount i - withToContractAmount (Right (_, a)) = withAccountToContractAmount a + withToContractAmount :: Either ContractAddress IndexedAccountAddress -> InstanceV v2 -> Amount -> m a -> m a + withToContractAmount (Left i) = withContractToContractAmount i + withToContractAmount (Right a) = withAccountToContractAmount a getCurrentContractInstance :: ContractAddress -> m (Maybe Instance) @@ -354,9 +360,6 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - getCurrentAvailableAmount (Left (_, i)) = getCurrentContractAmount i getCurrentAvailableAmount (Right (_, a)) = getCurrentAccountAvailableAmount a - -- |Get an account with its state at the start of the transaction. - getStateAccount :: AccountAddress -> m (Maybe (IndexedAccount m)) - -- |Get the current total public balance of an account. -- This accounts for any pending changes in the course of execution of the transaction. -- This includes any funds that cannot be spent due to lock-up or baking. @@ -427,9 +430,8 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |The set of changes to be commited on a successful transaction. data ChangeSet = ChangeSet - {_affectedTx :: !TransactionHash, -- ^Transaction affected by this changeset. - _accountUpdates :: !(HMap.HashMap AccountIndex AccountUpdate) -- ^Accounts whose states changed. - ,_instanceUpdates :: !(HMap.HashMap ContractAddress (AmountDelta, Wasm.ContractState)) -- ^Contracts whose states changed. + {_accountUpdates :: !(HMap.HashMap AccountIndex AccountUpdate) -- ^Accounts whose states changed. + ,_instanceUpdates :: !(HMap.HashMap ContractAddress (AmountDelta, Maybe Wasm.ContractState)) -- ^Contracts whose states changed. ,_instanceInits :: !(HSet.HashSet ContractAddress) -- ^Contracts that were initialized. ,_encryptedChange :: !AmountDelta -- ^Change in the encrypted balance of the system as a result of this contract's execution. ,_addedReleaseSchedules :: !(Map.Map AccountAddress Timestamp) -- ^The release schedules added to accounts on this block, to be added on the per block map. @@ -437,18 +439,24 @@ data ChangeSet = ChangeSet makeLenses ''ChangeSet -emptyCS :: TransactionHash -> ChangeSet -emptyCS txHash = ChangeSet txHash HMap.empty HMap.empty HSet.empty 0 Map.empty +emptyCS :: ChangeSet +emptyCS = ChangeSet HMap.empty HMap.empty HSet.empty 0 Map.empty -csWithAccountDelta :: TransactionHash -> AccountIndex -> AccountAddress -> AmountDelta -> ChangeSet -csWithAccountDelta txHash ai addr !amnt = do - emptyCS txHash & accountUpdates . at ai ?~ (emptyAccountUpdate ai addr & auAmount ?~ amnt) +csWithAccountDelta :: AccountIndex -> AccountAddress -> AmountDelta -> ChangeSet +csWithAccountDelta ai addr !amnt = do + emptyCS & accountUpdates . at ai ?~ (emptyAccountUpdate ai addr & auAmount ?~ amnt) -- |Record an addition to the amount of the given account in the changeset. {-# INLINE addAmountToCS #-} addAmountToCS :: AccountOperations m => IndexedAccount m -> AmountDelta -> ChangeSet -> m ChangeSet addAmountToCS (ai, acc) !amnt !cs = do addr <- getAccountCanonicalAddress acc + addAmountToCS' (ai, addr) amnt cs + +-- |Record an addition to the amount of the given account in the changeset. +{-# INLINE addAmountToCS' #-} +addAmountToCS' :: Monad m => IndexedAccountAddress -> AmountDelta -> ChangeSet -> m ChangeSet +addAmountToCS' (ai, addr) !amnt !cs = -- Check whether there already is an 'AccountUpdate' for the given account in the changeset. -- If so, modify it accordingly, otherwise add a new entry. return $ cs & accountUpdates . at ai %~ (\case Just upd -> Just (upd & auAmount %~ \case @@ -457,6 +465,7 @@ addAmountToCS (ai, acc) !amnt !cs = do ) Nothing -> Just (emptyAccountUpdate ai addr & auAmount ?~ amnt)) + -- |Record a list of scheduled releases that has to be pushed into the global map and into the map of the account. {-# INLINE addScheduledAmountToCS #-} addScheduledAmountToCS :: AccountOperations m => IndexedAccount m -> ([(Timestamp, Amount)], TransactionHash) -> ChangeSet -> m ChangeSet @@ -484,19 +493,17 @@ modifyAmountCS ai !amnt !cs = cs & (accountUpdates . ix ai . auAmount ) %~ -- as listed in the given instance structure. addContractStatesToCS :: HasInstanceParameters a => a -> Wasm.ContractState -> ChangeSet -> ChangeSet addContractStatesToCS istance newState = - instanceUpdates . at addr %~ \case Just (amnt, _) -> Just (amnt, newState) - Nothing -> Just (0, newState) + instanceUpdates . at addr %~ \case Just (amnt, _) -> Just (amnt, Just newState) + Nothing -> Just (0, Just newState) where addr = instanceAddress istance -- |Add the given delta to the change set for the given contract instance. -- NB: If the contract is not yet in the changeset it is added, taking the -- model as given in the first argument to be current model (local state) -addContractAmountToCS :: (HasInstanceParameters a, HasInstanceFields a) => a -> AmountDelta -> ChangeSet -> ChangeSet -addContractAmountToCS istance amnt cs = +addContractAmountToCS :: ContractAddress -> AmountDelta -> ChangeSet -> ChangeSet +addContractAmountToCS addr amnt cs = cs & instanceUpdates . at addr %~ \case Just (d, v) -> Just (d + amnt, v) - Nothing -> Just (amnt, model) - where addr = instanceAddress istance - model = instanceModel istance + Nothing -> Just (amnt, Nothing) -- |Add the given contract address to the set of initialized contract instances. -- As the changes on the blockstate are already performed in the handler for this operation, @@ -543,28 +550,27 @@ runRST rst r s = flip runStateT s . flip runReaderT r $ rst -- order to avoid expensive bind operation of the latter. The bind operation is -- expensive because it needs to check at each step whether the result is @Left@ -- or @Right@. -newtype LocalT r m a = LocalT { _runLocalT :: ContT (Either (Maybe RejectReason) r) (RST TransactionContext LocalState m) a } +newtype LocalT (pv :: ProtocolVersion) r m a = LocalT { _runLocalT :: ContT (Either (Maybe RejectReason) r) (RST TransactionContext LocalState m) a } deriving(Functor, Applicative, Monad, MonadState LocalState, MonadReader TransactionContext) -runLocalT :: SchedulerMonad pv m - => LocalT a m a - -> TransactionHash +runLocalT :: forall pv m a . Monad m + => LocalT pv a m a -> Amount -> AccountIndex -> Energy -- Energy limit by the transaction header. -> Energy -- remaining block energy -> m (Either (Maybe RejectReason) a, LocalState) -runLocalT (LocalT st) txHash _tcDepositedAmount _tcTxSender _energyLeft _blockEnergyLeft = do - let s = LocalState{_changeSet = emptyCS txHash,..} +runLocalT (LocalT st) _tcDepositedAmount _tcTxSender _energyLeft _blockEnergyLeft = do + let s = LocalState{_changeSet = emptyCS,..} (a, s') <- runRST (runContT st (return . Right)) ctx s return (a, s') where !ctx = TransactionContext{..} -instance BlockStateTypes (LocalT r m) where - type BlockState (LocalT r m) = BlockState m - type UpdatableBlockState (LocalT r m) = UpdatableBlockState m - type Account (LocalT r m) = Account m +instance BlockStateTypes (LocalT pv r m) where + type BlockState (LocalT pv r m) = BlockState m + type UpdatableBlockState (LocalT pv r m) = UpdatableBlockState m + type Account (LocalT pv r m) = Account m {-# INLINE energyUsed #-} -- |Compute how much energy was used from the upper bound in the header of a @@ -590,12 +596,12 @@ computeExecutionCharge meta energy = -- is the only one affected by the transaction, either because a transaction was -- rejected, or because it was a transaction which only affects one account's -- balance such as DeployCredential, or DeployModule. -chargeExecutionCost :: (AccountOperations m) => SchedulerMonad pv m => TransactionHash -> IndexedAccount m -> Amount -> m () -chargeExecutionCost txHash (ai, acc) amnt = do +chargeExecutionCost :: (AccountOperations m) => SchedulerMonad pv m => IndexedAccount m -> Amount -> m () +chargeExecutionCost (ai, acc) amnt = do balance <- getAccountAmount acc addr <- getAccountCanonicalAddress acc assert (balance >= amnt) $ - commitChanges (csWithAccountDelta txHash ai addr (amountDiff 0 amnt)) + commitChanges (csWithAccountDelta ai addr (amountDiff 0 amnt)) notifyExecutionCost amnt data WithDepositContext m = WithDepositContext{ @@ -630,7 +636,7 @@ makeLenses ''WithDepositContext withDeposit :: SchedulerMonad pv m => WithDepositContext m - -> LocalT a m a + -> LocalT pv a m a -- ^The computation to run in the modified environment with reduced amount on the initial account. -> (LocalState -> a -> m (ValidResult, Amount, Energy)) -- ^Continuation for the successful branch of the computation. @@ -649,7 +655,7 @@ withDeposit wtc comp k = do let energy = totalEnergyToUse - wtc ^. wtcTransactionCheckHeaderCost -- record how much we have deposited. This cannot be touched during execution. depositedAmount <- energyToGtu totalEnergyToUse - (res, ls) <- runLocalT comp tsHash depositedAmount (wtc ^. wtcSenderAccount . _1) energy beLeft + (res, ls) <- runLocalT comp depositedAmount (wtc ^. wtcSenderAccount . _1) energy beLeft case res of -- Failure: maximum block energy exceeded Left Nothing -> return Nothing @@ -658,7 +664,7 @@ withDeposit wtc comp k = do -- The only effect of this transaction is that the sender is charged for the execution cost -- (energy ticked so far). (usedEnergy, payment) <- computeExecutionCharge txHeader (ls ^. energyLeft) - chargeExecutionCost tsHash (wtc ^. wtcSenderAccount) payment + chargeExecutionCost (wtc ^. wtcSenderAccount) payment return $! Just $! TransactionSummary{ tsSender = Just (thSender txHeader), tsCost = payment, @@ -686,11 +692,10 @@ withDeposit wtc comp k = do defaultSuccess :: SchedulerMonad pv m => WithDepositContext m -> LocalState -> [Event] -> m (ValidResult, Amount, Energy) defaultSuccess wtc = \ls events -> do - let txHash = wtc ^. wtcTransactionHash - meta = wtc ^. wtcTransactionHeader + let meta = wtc ^. wtcTransactionHeader senderAccount = wtc ^. wtcSenderAccount (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost commitChanges (ls ^. changeSet) return (TxSuccess events, energyCost, usedEnergy) @@ -706,15 +711,15 @@ defaultSuccess wtc = \ls events -> do -- execLocalT (LocalT st) energy = execStateT (runContT st (return . Right)) (energy, emptyCS) {-# INLINE liftLocal #-} -liftLocal :: Monad m => m a -> LocalT r m a +liftLocal :: Monad m => m a -> LocalT pv r m a liftLocal m = LocalT (ContT (\k -> ReaderT (\r -> StateT (\s -> m >>= \f -> runRST (k f) r s)))) -instance MonadTrans (LocalT r) where +instance MonadTrans (LocalT pv r) where {-# INLINE lift #-} lift = liftLocal -instance StaticInformation m => StaticInformation (LocalT r m) where +instance StaticInformation m => StaticInformation (LocalT pv r m) where {-# INLINE getMaxBlockEnergy #-} getMaxBlockEnergy = liftLocal getMaxBlockEnergy @@ -727,9 +732,15 @@ instance StaticInformation m => StaticInformation (LocalT r m) where {-# INLINE getAccountCreationLimit #-} getAccountCreationLimit = liftLocal getAccountCreationLimit -deriving via (MGSTrans (LocalT r) m) instance AccountOperations m => AccountOperations (LocalT r m) + {-# INLINE getContractInstance #-} + getContractInstance = liftLocal . getContractInstance + + {-# INLINE getAccount #-} + getAccount = liftLocal . getAccount -instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where +deriving via (MGSTrans (LocalT pv r) m) instance AccountOperations m => AccountOperations (LocalT pv r m) + +instance (IsProtocolVersion pv, StaticInformation m, AccountOperations m, Monad m) => TransactionMonad pv (LocalT pv r m) where {-# INLINE withInstanceStateV0 #-} withInstanceStateV0 istance val cont = do changeSet %= addContractStatesToCS istance val @@ -749,8 +760,8 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where {-# INLINE withAccountToContractAmount #-} withAccountToContractAmount fromAcc toAcc amount cont = do - cs <- changeSet <%= addContractAmountToCS toAcc (amountToDelta amount) - changeSet <~ addAmountToCS fromAcc (amountDiff 0 amount) cs + cs <- changeSet <%= addContractAmountToCS (instanceAddress toAcc) (amountToDelta amount) + changeSet <~ addAmountToCS' fromAcc (amountDiff 0 amount) cs cont {-# INLINE withContractToAccountAmount #-} @@ -762,7 +773,7 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where {-# INLINE withContractToContractAmount #-} withContractToContractAmount fromAcc toAcc amount cont = do - changeSet %= addContractAmountToCS toAcc (amountToDelta amount) + changeSet %= addContractAmountToCS (instanceAddress toAcc) (amountToDelta amount) changeSet %= addContractAmountToCS fromAcc (amountDiff 0 amount) cont @@ -799,25 +810,21 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where getCurrentContractInstance addr = do newStates <- use (changeSet . instanceUpdates) - liftLocal $! do - mistance <- getContractInstance addr - case mistance of - Nothing -> return Nothing - Just i -> - case newStates ^. at addr of - Nothing -> return $ Just i - Just (delta, newmodel) -> - let !updated = updateInstance delta newmodel i - in return (Just updated) + mistance <- getContractInstance addr + case mistance of + Nothing -> return Nothing + Just i -> + case newStates ^. at addr of + Nothing -> return $ Just i + Just (delta, newmodel) -> + let !updated = updateInstance delta newmodel i + in return (Just updated) getCurrentContractInstanceState istance = do newStates <- use (changeSet . instanceUpdates) case newStates ^. at (instanceAddress istance) of - Nothing -> return (instanceModel istance) - Just (_, s) -> return s - - {-# INLINE getStateAccount #-} - getStateAccount = liftLocal . getAccount + Just (_, (Just s)) -> return s + _ -> return (instanceModel istance) getCurrentAccountTotalAmount (ai, acc) = do oldTotal <- getAccountAmount acc diff --git a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs index ed5fcd80f9..002656ed3d 100644 --- a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs +++ b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs @@ -122,6 +122,13 @@ instance (MonadReader ContextState m, {-# INLINE getAccountCreationLimit #-} getAccountCreationLimit = view accountCreationLimit + {-# INLINE getContractInstance #-} + getContractInstance addr = lift . flip bsoGetInstance addr =<< use schedulerBlockState + + {-# INLINE getAccount #-} + getAccount !addr = lift . flip bsoGetAccount addr =<< use schedulerBlockState + + instance (MonadReader ContextState m, SS state ~ UpdatableBlockState m, HasSchedulerState state, @@ -152,12 +159,6 @@ instance (MonadReader ContextState m, {-# INLINE bumpTransactionIndex #-} bumpTransactionIndex = nextIndex <<%= (+1) - {-# INLINE getContractInstance #-} - getContractInstance addr = lift . flip bsoGetInstance addr =<< use schedulerBlockState - - {-# INLINE getAccount #-} - getAccount !addr = lift . flip bsoGetAccount addr =<< use schedulerBlockState - {-# INLINE getAccountIndex #-} getAccountIndex addr = lift . flip bsoGetAccountIndex addr =<< use schedulerBlockState diff --git a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs new file mode 100644 index 0000000000..41b89e2634 --- /dev/null +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Concordium.Scheduler.InvokeContract where + +import qualified Data.Aeson as AE +import Lens.Micro.Platform +import Control.Monad.Reader + +import qualified Data.FixedByteString as FBS +import qualified Concordium.Wasm as Wasm +import Concordium.Logger +import Concordium.GlobalState.Types +import qualified Concordium.GlobalState.Instance as Instance +import qualified Concordium.GlobalState.BlockState as BS +import Concordium.GlobalState.TreeState (MGSTrans(..)) + +import Concordium.Scheduler.Environment +import Concordium.Scheduler.Types +import Concordium.Scheduler.EnvironmentImplementation (ContextState(..), maxBlockEnergy, chainMetadata, accountCreationLimit) +import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 +import Concordium.Scheduler (handleContractUpdateV0, handleContractUpdateV1, checkAndGetBalanceInstance, checkAndGetBalanceAccount) + +newtype InvokeContractMonad (pv :: ProtocolVersion) m a = InvokeContractMonad {_runInvokeContract :: ReaderT (ContextState, BlockState m) m a} + deriving (Functor, + Applicative, + Monad, + MonadLogger) + +deriving instance (Monad m, r ~ BlockState m) => MonadReader (ContextState, r) (InvokeContractMonad pv m) + +instance MonadTrans (InvokeContractMonad pv) where + {-# INLINE lift #-} + lift = InvokeContractMonad . lift + +deriving via (MGSTrans (InvokeContractMonad pv) m) instance BlockStateTypes (InvokeContractMonad pv m) +deriving via (MGSTrans (InvokeContractMonad pv) m) instance BS.AccountOperations m => BS.AccountOperations (InvokeContractMonad pv m) + +instance (Monad m, BS.BlockStateQuery m) => StaticInformation (InvokeContractMonad pv m) where + + {-# INLINE getMaxBlockEnergy #-} + getMaxBlockEnergy = view (_1 . maxBlockEnergy) + + {-# INLINE getChainMetadata #-} + getChainMetadata = view (_1 . chainMetadata) + + {-# INLINE getModuleInterfaces #-} + getModuleInterfaces mref = do + s <- view _2 + lift (BS.getModuleInterface s mref) + + {-# INLINE getAccountCreationLimit #-} + getAccountCreationLimit = view (_1 . accountCreationLimit) + + {-# INLINE getContractInstance #-} + getContractInstance addr = lift . flip BS.getContractInstance addr =<< view _2 + + {-# INLINE getAccount #-} + getAccount !addr = lift . flip BS.getAccount addr =<< view _2 + +data ContractContext = ContractContext { + -- |Invoker of the contract. If this is not supplied then the contract will be + -- invoked, by an account with address 0, no credentials and sufficient amount + -- of CCD to cover the transfer amount. If given, the relevant address must + -- exist in the blockstate. + ccInvoker :: !(Maybe Address), + -- |Contract to invoke. + ccContract :: !ContractAddress, + -- |Amount to invoke the contract with. + ccAmount :: !Amount, + -- |Which entrypoint to invoke. + ccMethod :: !Wasm.ReceiveName, + -- |And with what parameter. + ccParameter :: !Wasm.Parameter, + -- |And what amount of energy to allow for execution. + ccEnergy :: !Energy + } + +-- |This FromJSON instance defaults a number of values if they are not given +-- - energy defaults to maximum possible +-- - amount defaults to 0 +-- - parameter defaults to the empty one +instance AE.FromJSON ContractContext where + parseJSON = AE.withObject "ContractContext" $ \obj -> do + ccInvoker <- obj AE..:? "invoker" + ccContract <- obj AE..: "contract" + ccAmount <- obj AE..:? "amount" AE..!= 0 + ccMethod <- obj AE..: "method" + ccParameter <- obj AE..:? "parameter" AE..!= Wasm.emptyParameter + ccEnergy <- obj AE..:? "energy" AE..!= maxBound + return ContractContext{..} + +data InvokeContractResult = + -- |Contract execution failed for the given reason. + Failure { + rcrReason :: !RejectReason, + -- |Energy used by the execution. + rcrUsedEnergy :: !Energy + } + -- |Contract execution succeeded. + | Success { + -- |If invoking a V0 contract this is Nothing, otherwise it is + -- the return value produced by the call. + rcrReturnValue :: !(Maybe WasmV1.ReturnValue), + -- |Events produced by contract execution. + rcrEvents :: ![Event], + -- |Energy used by the execution. + rcrUsedEnergy :: !Energy + } + +instance AE.ToJSON InvokeContractResult where + toJSON Failure{..} = AE.object [ + "tag" AE..= AE.String "failure", + "reason" AE..= rcrReason, + "usedEnergy" AE..= rcrUsedEnergy + ] + toJSON Success{..} = AE.object [ + "tag" AE..= AE.String "success", + "returnValue" AE..= rcrReturnValue, + "events" AE..= rcrEvents, + "usedEnergy" AE..= rcrUsedEnergy + ] + +-- |Invoke the contract in the given context. +invokeContract :: forall pv m . (IsProtocolVersion pv, BS.BlockStateQuery m) => + SProtocolVersion pv -- An argument to fix the protocol version, to make the type non-ambiguous. + -> ContractContext -- ^Context in which to invoke the contract. + -> ChainMetadata -- ^Chain metadata corresponding to the block state. + -> BlockState m -- ^The block state in which to invoke the contract. + -> m InvokeContractResult +invokeContract _ ContractContext{..} cm bs = do + let getInvoker = + case ccInvoker of + Nothing -> -- if the invoker is not supplied create a dummy one + let zeroAddress = AccountAddress . FBS.pack . replicate 32 $ 0 + maxIndex = maxBound + in return (Right (const (return (AddressAccount zeroAddress, [], Right (maxIndex, zeroAddress))), zeroAddress, maxIndex)) + Just (AddressAccount accInvoker) -> getAccount accInvoker >>= \case + Nothing -> return (Left (Just (InvalidAccountReference accInvoker))) + Just acc -> return (Right (checkAndGetBalanceAccount accInvoker acc, accInvoker, (fst acc))) + Just (AddressContract contractInvoker) -> getContractInstance contractInvoker >>= \case + Nothing -> return (Left (Just (InvalidContractAddress contractInvoker))) + Just (Instance.InstanceV0 i@Instance.InstanceV{..}) -> do + let ownerAccountAddress = instanceOwner _instanceVParameters + getAccount ownerAccountAddress >>= \case + Nothing -> return (Left (Just $ InvalidAccountReference ownerAccountAddress)) + Just acc -> return (Right (checkAndGetBalanceInstance acc i, ownerAccountAddress, (fst acc))) + Just (Instance.InstanceV1 i@Instance.InstanceV{..}) -> do + let ownerAccountAddress = instanceOwner _instanceVParameters + getAccount ownerAccountAddress >>= \case + Nothing -> return (Left (Just $ InvalidAccountReference ownerAccountAddress)) + Just acc -> return (Right (checkAndGetBalanceInstance acc i, ownerAccountAddress, (fst acc))) + let runContractComp = + getInvoker >>= \case + Left err -> return (Left err, ccEnergy) + Right (invoker, addr, ai) -> do + let comp = do + istance <- getContractInstance ccContract `rejectingWith` InvalidContractAddress ccContract + case istance of + InstanceV0 i -> Left <$> handleContractUpdateV0 addr i invoker ccAmount ccMethod ccParameter + InstanceV1 i -> Right <$> handleContractUpdateV1 addr i invoker ccAmount ccMethod ccParameter + (r, cs) <- runLocalT @pv comp ccAmount ai ccEnergy ccEnergy + return (r, _energyLeft cs) + contextState = ContextState{_maxBlockEnergy = ccEnergy, _accountCreationLimit = 0, _chainMetadata = cm} + runReaderT (_runInvokeContract runContractComp) (contextState, bs) >>= \case + (Left Nothing, re) -> -- cannot happen, but this is safe to do and not wrong + return Failure{rcrReason = OutOfEnergy, rcrUsedEnergy = ccEnergy - re} + (Left (Just rcrReason), re) -> + return Failure{rcrUsedEnergy = ccEnergy - re,..} + (Right (Left rcrEvents), re) -> + return Success{rcrReturnValue=Nothing, + rcrUsedEnergy = ccEnergy - re, + ..} + (Right (Right (Left cf)), re) -> + return (Failure{ + rcrReason = WasmV1.cerToRejectReasonReceive ccContract ccMethod ccParameter cf, + rcrUsedEnergy = ccEnergy - re}) + (Right (Right (Right (rv, rcrEvents))), re) -> + return Success{rcrReturnValue=Just rv, + rcrUsedEnergy = ccEnergy - re, + ..} diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 510888b72d..7d2ac9a142 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -33,12 +33,14 @@ import Foreign.Storable import Data.Bits import Data.Int import Data.Word +import qualified Data.Aeson as AE import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Serialize import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Short as BSS import qualified Data.ByteString.Unsafe as BSU import System.IO.Unsafe @@ -76,6 +78,10 @@ returnValueToByteString rv = unsafePerformIO $ len <- peek outputLenPtr BSU.unsafePackCStringFinalizer rp (fromIntegral len) (rs_free_array_len rp (fromIntegral len)) +-- json instance based on hex +instance AE.ToJSON ReturnValue where + toJSON = AE.String . Text.decodeUtf8 . BS16.encode . returnValueToByteString + -- |State of the Wasm module when a host operation is invoked (a host operation -- is either a transfer to an account, or a contract call, at present). This can -- only be resumed once. Calling resume on this twice will lead to unpredictable diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs index df2479c086..7c97425c94 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs @@ -278,7 +278,7 @@ testUpdates n0 = if n0 <= 0 then return (property True) else tu n0 emptyInstance InstanceData v a <- arbitrary let ca = ContractAddress ci csi - insts' = updateInstanceAt' ca a v insts + insts' = updateInstanceAt' ca a (Just v) insts model' = modelUpdateInstanceAt ca a v model tu (n-1) insts' model' updateExisting = do @@ -287,7 +287,7 @@ testUpdates n0 = if n0 <= 0 then return (property True) else tu n0 emptyInstance InstanceData v a <- arbitrary let ca = ContractAddress ci csi - insts' = updateInstanceAt' ca a v insts + insts' = updateInstanceAt' ca a (Just v) insts model' = modelUpdateInstanceAt ca a v model tu (n-1) insts' model' deleteExisting = do @@ -304,7 +304,7 @@ testUpdates n0 = if n0 <= 0 then return (property True) else tu n0 emptyInstance InstanceData v a <- arbitrary let ca = ContractAddress ci csi - insts' = updateInstanceAt' ca a v insts + insts' = updateInstanceAt' ca a (Just v) insts model' = modelUpdateInstanceAt ca a v model tu (n-1) insts' model' deleteFree = do From 5b0e683ac02e0a1d13a35c90b96d80034579f449 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Mon, 27 Dec 2021 11:08:41 +0100 Subject: [PATCH 20/51] Expose invoke contract externally. --- concordium-grpc-api | 2 +- concordium-node/src/consensus_ffi/ffi.rs | 15 +++++++++++++++ concordium-node/src/rpc.rs | 10 ++++++++++ 3 files changed, 26 insertions(+), 1 deletion(-) diff --git a/concordium-grpc-api b/concordium-grpc-api index 1ea1adde19..018edd386c 160000 --- a/concordium-grpc-api +++ b/concordium-grpc-api @@ -1 +1 @@ -Subproject commit 1ea1adde19bf18dcbb334e505e2ed684addd32d4 +Subproject commit 018edd386c03d59db39ee5ab972a17570a8a3fde diff --git a/concordium-node/src/consensus_ffi/ffi.rs b/concordium-node/src/consensus_ffi/ffi.rs index c3d80ecc4b..6af57c901b 100644 --- a/concordium-node/src/consensus_ffi/ffi.rs +++ b/concordium-node/src/consensus_ffi/ffi.rs @@ -352,6 +352,11 @@ extern "C" { block_hash: *const u8, contract_address: *const u8, ) -> *const c_char; + pub fn invokeContract( + consensus: *mut consensus_runner, + block_hash: *const u8, + context: *const u8, + ) -> *const c_char; pub fn getRewardStatus( consensus: *mut consensus_runner, block_hash: *const u8, @@ -637,6 +642,16 @@ impl ConsensusContainer { )) } + pub fn invoke_contract(&self, block_hash: &str, context: &str) -> String { + let block_hash = CString::new(block_hash).unwrap(); + let context = CString::new(context).unwrap(); + wrap_c_call_string!(self, consensus, |consensus| invokeContract( + consensus, + block_hash.as_ptr() as *const u8, + context.as_ptr() as *const u8 + )) + } + pub fn get_reward_status(&self, block_hash: &str) -> String { let block_hash = CString::new(block_hash).unwrap(); wrap_c_call_string!(self, consensus, |consensus| getRewardStatus( diff --git a/concordium-node/src/rpc.rs b/concordium-node/src/rpc.rs index 65d09b2229..1908f4f96f 100644 --- a/concordium-node/src/rpc.rs +++ b/concordium-node/src/rpc.rs @@ -654,6 +654,16 @@ impl P2p for RpcServerImpl { }) } + async fn invoke_contract( + &self, + req: Request, + ) -> Result, Status> { + authenticate!(req, self.access_token); + call_consensus!(self, "InvokeContract", JsonResponse, |cc: &ConsensusContainer| { + cc.invoke_contract(&req.get_ref().block_hash, &req.get_ref().context) + }) + } + async fn get_reward_status( &self, req: Request, From 456babc270771599a3b13ae49859c8966ba440ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Mon, 3 Jan 2022 19:41:46 +0100 Subject: [PATCH 21/51] Use entrypoint names when specifying a call target for V1 contracts. --- concordium-base | 2 +- concordium-consensus/smart-contracts | 2 +- concordium-consensus/src/Concordium/Scheduler.hs | 6 ++++-- .../src/Concordium/Scheduler/WasmIntegration/V1.hs | 2 +- .../scheduler/SchedulerTests/SmartContracts/V1/Counter.hs | 4 ++-- .../SchedulerTests/SmartContracts/V1/CrossMessaging.hs | 6 +++--- 6 files changed, 12 insertions(+), 10 deletions(-) diff --git a/concordium-base b/concordium-base index 2543626ed0..ded7f4cd8b 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 2543626ed02b5f23031d7b4b0ee8a3e33f04081f +Subproject commit ded7f4cd8b616338ea6423f34980afb1ecb41171 diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 33133ff451..6df0919b2b 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 33133ff451f3ba77e750b79323c6ada3315b0b6a +Subproject commit 6df0919b2b05ff471119ebd87a11b81a699438c6 diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index ae94145f1b..b974e969b4 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -891,7 +891,8 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei getCurrentContractInstanceTicking' imcTo >>= \case Nothing -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MissingContract imcTo))) Nothing) Just (InstanceV0 targetInstance) -> do - let runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount imcName imcParam + let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName + runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount rName imcParam (runSuccess `orElseWith` (return . Left)) >>= \case Left rr -> -- execution failed. go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) @@ -899,7 +900,8 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei newState <- getCurrentContractInstanceState istance go (evs ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success Nothing) Just (InstanceV1 targetInstance) -> do - withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount imcName imcParam) >>= \case + let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName + withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount rName imcParam) >>= \case Left cer -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) Right (rVal, callEvents) -> do diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 7d2ac9a142..ee41465314 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -250,7 +250,7 @@ data InvokeMethod = | Call { imcTo :: !ContractAddress, imcParam :: !Parameter, - imcName :: !ReceiveName, -- FIXME: Should be entrypoint name, but that requires changes elsewhere to maintain consistency. + imcName :: !EntrypointName, imcAmount :: !Amount } diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs index 53461f7706..34bc97e2d3 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs @@ -91,8 +91,8 @@ testCases = putWord64le 0 -- contract index putWord64le 0 -- contract subindex putWord16le 0 -- length of parameter - putWord16le (fromIntegral (BSS.length "counter.inc")) - putByteString "counter.inc" + putWord16le (fromIntegral (BSS.length "inc")) + putByteString "inc" -- entrypoint name putWord64le 0 -- amount deploymentCostCheck :: Types.BlockItem -> Types.TransactionSummary -> Expectation deploymentCostCheck _ Types.TransactionSummary{..} = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs index 90673416e8..4eff7fb742 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs @@ -96,7 +96,7 @@ testCases = putWord64le 0 -- index of the counter putWord64le 0 -- subindex of the counter contract putWord16le (fromIntegral (BSS.length "counter.inc")) - putByteString "counter.inc" + putByteString "counter.inc" -- receive name, actions for V0 contracts must still use the full name putWord16le 0 -- length of parameter callArgs = BSS.toShort $ runPut $ do @@ -104,8 +104,8 @@ testCases = putWord64le 0 -- contract subindex putWord16le (fromIntegral (BS.length forwardParameter)) -- length of parameter putByteString forwardParameter - putWord16le (fromIntegral (BSS.length "proxy.forward")) - putByteString "proxy.forward" + putWord16le (fromIntegral (BSS.length "forward")) + putByteString "forward" -- entrypoint name, calls for V1 contracts use just the entrypoint name putWord64le 0 -- amount -- ensure the transaction is successful From e802acbe6c3a80499c9b7b8b0130ec8f33b21847 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Wed, 5 Jan 2022 08:52:47 +0100 Subject: [PATCH 22/51] Introduce an Interrupted event for transaction execution. This makes execution event log, in case of success, reflect the trace of actions more closely. --- concordium-base | 2 +- concordium-consensus/smart-contracts | 2 +- concordium-consensus/src/Concordium/Scheduler.hs | 10 +++++++--- .../src/Concordium/Scheduler/WasmIntegration/V1.hs | 6 ++++-- 4 files changed, 13 insertions(+), 7 deletions(-) diff --git a/concordium-base b/concordium-base index ded7f4cd8b..0b37ac6731 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit ded7f4cd8b616338ea6423f34980afb1ecb41171 +Subproject commit 0b37ac6731820e5041339f8813dc056a8cdad2cb diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 6df0919b2b..58886a89dd 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 6df0919b2b05ff471119ebd87a11b81a699438c6 +Subproject commit 58886a89dd07556210dc452bb5dd2d5d7d05b222 diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index b974e969b4..b934dd4327 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -878,12 +878,16 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei } in return (Right (rrdReturnValue, event:events)) WasmV1.ReceiveInterrupt{..} -> do + let interruptEvent = Interrupted{ + erAddress = instanceAddress istance, + erEvents = rrdLogs + } case rrdMethod of WasmV1.Transfer{..} -> runExceptT (transferAccountSync imtTo istance imtAmount) >>= \case Left errCode -> do go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) - Right transferEvents -> go (transferEvents ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success Nothing) + Right transferEvents -> go (transferEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success Nothing) WasmV1.Call{..} -> -- commit the current state of the contract. withInstanceStateV1 istance rrdCurrentState $ do @@ -898,7 +902,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) Right evs -> do newState <- getCurrentContractInstanceState istance - go (evs ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success Nothing) + go (evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success Nothing) Just (InstanceV1 targetInstance) -> do let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount rName imcParam) >>= \case @@ -906,7 +910,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) Right (rVal, callEvents) -> do newState <- getCurrentContractInstanceState istance - go (callEvents ++ events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success (Just rVal)) + go (callEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success (Just rVal)) -- start contract execution. -- transfer the amount from the sender to the contract at the start. This is so that the contract may immediately use it diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index ee41465314..1eead4aede 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -279,6 +279,7 @@ data ReceiveResultData = ReceiveInterrupt { rrdCurrentState :: !ContractState, rrdMethod :: !InvokeMethod, + rrdLogs :: ![ContractEvent], rrdInterruptedConfig :: !ReceiveInterruptedState } @@ -378,9 +379,10 @@ processReceiveResult result returnValuePtr eitherInterruptedStatePtr = case BS.u 3 -> let parser = do -- interrupt remainingEnergy <- label "Interrupt.remainingEnergy" getWord64be currentState <- label "Interrupt.currentState" get + logs <- label "Interrupt.logs" getLogs method <- label "Interrupt.method" getInvokeMethod - return (remainingEnergy, currentState, method) - in let (remainingEnergy, rrdCurrentState, rrdMethod)= parseResult parser + return (remainingEnergy, currentState, logs, method) + in let (remainingEnergy, rrdCurrentState, rrdLogs, rrdMethod)= parseResult parser in do rrdInterruptedConfig <- case eitherInterruptedStatePtr of Left rrid -> return rrid Right interruptedStatePtr -> newReceiveInterruptedState interruptedStatePtr From d69f485e4943b44799266be092e3074c58794b66 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Thu, 6 Jan 2022 07:39:15 +0100 Subject: [PATCH 23/51] Scope the calls. --- concordium-base | 2 +- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/GlobalState/Instance.hs | 4 +--- .../src/Concordium/Scheduler.hs | 20 +++++++++++-------- 4 files changed, 15 insertions(+), 13 deletions(-) diff --git a/concordium-base b/concordium-base index 0b37ac6731..60f6b5bb58 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 0b37ac6731820e5041339f8813dc056a8cdad2cb +Subproject commit 60f6b5bb58a73c70758aa33accf9635ee47feb62 diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 58886a89dd..c907ab25f6 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 58886a89dd07556210dc452bb5dd2d5d7d05b222 +Subproject commit c907ab25f69b62d68757f6f698a5978cf12b6a81 diff --git a/concordium-consensus/src/Concordium/GlobalState/Instance.hs b/concordium-consensus/src/Concordium/GlobalState/Instance.hs index fa15c4112d..e7c141db57 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Instance.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Instance.hs @@ -100,7 +100,6 @@ instance HashableTo H.Hash Instance where -- |Helper function for JSON encoding an 'Instance'. instancePairs :: KeyValue kv => Instance -> [kv] {-# INLINE instancePairs #-} --- TODO: Get the version from the module instead. instancePairs (InstanceV0 InstanceV{..}) = [ "model" .= _instanceVModel, "owner" .= instanceOwner _instanceVParameters, @@ -111,8 +110,7 @@ instancePairs (InstanceV0 InstanceV{..}) = "version" .= (0 :: Word32) ] instancePairs (InstanceV1 InstanceV{..}) = - [ "model" .= _instanceVModel, - "owner" .= instanceOwner _instanceVParameters, + [ "owner" .= instanceOwner _instanceVParameters, "amount" .= _instanceVAmount, "methods" .= instanceReceiveFuns _instanceVParameters, "name" .= instanceInitName _instanceVParameters, diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index b934dd4327..d39a9746e0 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -879,15 +879,19 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei in return (Right (rrdReturnValue, event:events)) WasmV1.ReceiveInterrupt{..} -> do let interruptEvent = Interrupted{ - erAddress = instanceAddress istance, - erEvents = rrdLogs + iAddress = instanceAddress istance, + iEvents = rrdLogs + } + resumeEvent rSuccess = Resumed{ + rAddress = instanceAddress istance, + .. } case rrdMethod of WasmV1.Transfer{..} -> runExceptT (transferAccountSync imtTo istance imtAmount) >>= \case Left errCode -> do - go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) - Right transferEvents -> go (transferEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success Nothing) + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) + Right transferEvents -> go (resumeEvent True:transferEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success Nothing) WasmV1.Call{..} -> -- commit the current state of the contract. withInstanceStateV1 istance rrdCurrentState $ do @@ -899,18 +903,18 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount rName imcParam (runSuccess `orElseWith` (return . Left)) >>= \case Left rr -> -- execution failed. - go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) Right evs -> do newState <- getCurrentContractInstanceState istance - go (evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success Nothing) + go (resumeEvent True:evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success Nothing) Just (InstanceV1 targetInstance) -> do let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount rName imcParam) >>= \case Left cer -> - go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) Right (rVal, callEvents) -> do newState <- getCurrentContractInstanceState istance - go (callEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success (Just rVal)) + go (resumeEvent True:callEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success (Just rVal)) -- start contract execution. -- transfer the amount from the sender to the contract at the start. This is so that the contract may immediately use it From 8747175f3eed40ea9b661ab783fc30abd44c758b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Thu, 6 Jan 2022 19:53:09 +0100 Subject: [PATCH 24/51] Fix failure transfer through FFI. --- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/Scheduler/WasmIntegration/V1.hs | 10 +++++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index c907ab25f6..0fc77ff095 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit c907ab25f69b62d68757f6f698a5978cf12b6a81 +Subproject commit 0fc77ff095ddfc9bc3681e092c971a20d1123119 diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 1eead4aede..65150a747d 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -369,14 +369,18 @@ processReceiveResult result returnValuePtr eitherInterruptedStatePtr = case BS.u Just (tag, payload) -> case tag of 0 -> return Nothing - 1 -> let parser = do -- reject + 1 -> let parser = -- runtime failure + label "Reject.remainingEnergy" getWord64be + in let remainingEnergy = parseResult parser + in do return (Just (Left Trap, fromIntegral remainingEnergy)) + 2 -> let parser = do -- reject rejectReason <- label "Reject.rejectReason" getInt32be remainingEnergy <- label "Reject.remainingEnergy" getWord64be return (rejectReason, remainingEnergy) in let (cerRejectReason, remainingEnergy) = parseResult parser in do cerReturnValue <- ReturnValue <$> newForeignPtr freeReturnValue returnValuePtr return (Just (Left LogicReject{..}, fromIntegral remainingEnergy)) - 3 -> let parser = do -- interrupt + 4 -> let parser = do -- interrupt remainingEnergy <- label "Interrupt.remainingEnergy" getWord64be currentState <- label "Interrupt.currentState" get logs <- label "Interrupt.logs" getLogs @@ -387,7 +391,7 @@ processReceiveResult result returnValuePtr eitherInterruptedStatePtr = case BS.u Left rrid -> return rrid Right interruptedStatePtr -> newReceiveInterruptedState interruptedStatePtr return (Just (Right ReceiveInterrupt{..}, fromIntegral remainingEnergy)) - 2 -> -- done + 3 -> -- done let parser = do newState <- label "Done.newState" get logs <- label "Done.logs" getLogs From eae7cecf0dc0a7d195f3e2d49161107cf11d3da8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Fri, 7 Jan 2022 21:09:25 +0100 Subject: [PATCH 25/51] Tell the invoker contract whether its state was updated by the call. --- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/Scheduler.hs | 26 +++++---- .../src/Concordium/Scheduler/Environment.hs | 55 ++++++++++++------ .../Scheduler/EnvironmentImplementation.hs | 2 +- .../Scheduler/WasmIntegration/V1.hs | 11 +++- .../testdata/contracts/v1/call-counter.wasm | Bin 636 -> 642 bytes .../testdata/contracts/v1/call-counter.wat | 3 +- 7 files changed, 63 insertions(+), 36 deletions(-) diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 0fc77ff095..ca3aaad128 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 0fc77ff095ddfc9bc3681e092c971a20d1123119 +Subproject commit ca3aaad1282cc59e52f94d8d14dace3066ba9c2b diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index d39a9746e0..def88279c3 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -817,7 +817,7 @@ handleContractUpdateV1 :: forall pv m. (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^The address that was used to send the top-level transaction. -> InstanceV GSWasm.V1 -- ^The current state of the target contract of the transaction, which must exist. - -> (Amount -> m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress))) + -> (Amount -> m (Address, [ID.AccountCredential], Either ContractAddress IndexedAccountAddress)) -- ^Check that the sender has sufficient amount to cover the given amount and return a triple of -- - used address -- - credentials of the address, either account or owner of the contract @@ -868,7 +868,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei case rrData of WasmV1.ReceiveSuccess{..} -> do -- execution terminated, commit the new state - withInstanceStateV1 istance rrdNewState $ + withInstanceStateV1 istance rrdNewState $ \_modifiedIndex -> let event = Updated{euAddress=instanceAddress istance, euInstigator=senderAddr, euAmount=transferAmount, @@ -890,31 +890,33 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei WasmV1.Transfer{..} -> runExceptT (transferAccountSync imtTo istance imtAmount) >>= \case Left errCode -> do - go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) - Right transferEvents -> go (resumeEvent True:transferEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState WasmV1.Success Nothing) + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) + Right transferEvents -> go (resumeEvent True:transferEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing WasmV1.Success Nothing) WasmV1.Call{..} -> -- commit the current state of the contract. - withInstanceStateV1 istance rrdCurrentState $ do + withInstanceStateV1 istance rrdCurrentState $ \modificationIndex -> do -- lookup the instance getCurrentContractInstanceTicking' imcTo >>= \case - Nothing -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MissingContract imcTo))) Nothing) + Nothing -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MissingContract imcTo))) Nothing) Just (InstanceV0 targetInstance) -> do let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount rName imcParam (runSuccess `orElseWith` (return . Left)) >>= \case Left rr -> -- execution failed. - go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) Right evs -> do - newState <- getCurrentContractInstanceState istance - go (resumeEvent True:evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success Nothing) + (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance + let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState + go (resumeEvent True:evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState WasmV1.Success Nothing) Just (InstanceV1 targetInstance) -> do let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount rName imcParam) >>= \case Left cer -> - go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig rrdCurrentState (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) Right (rVal, callEvents) -> do - newState <- getCurrentContractInstanceState istance - go (resumeEvent True:callEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig newState WasmV1.Success (Just rVal)) + (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance + let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState + go (resumeEvent True:callEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState WasmV1.Success (Just rVal)) -- start contract execution. -- transfer the amount from the sender to the contract at the start. This is so that the contract may immediately use it diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 0f2417b2fc..32bad18fe8 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -300,7 +300,7 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- keep track of changes locally first, and only commit them at the end. -- Instance keeps track of its own address hence we need not provide it -- separately. - withInstanceStateV1 :: InstanceV GSWasm.V1 -> Wasm.ContractState -> m a -> m a + withInstanceStateV1 :: InstanceV GSWasm.V1 -> Wasm.ContractState -> (ModificationIndex -> m a) -> m a -- |Transfer amount from the first address to the second and run the -- computation in the modified environment. @@ -374,7 +374,9 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Same as above, but for contracts. getCurrentContractAmount :: (HasInstanceParameters a, HasInstanceFields a) => a -> m Amount - getCurrentContractInstanceState :: (HasInstanceParameters a, HasInstanceFields a) => a -> m Wasm.ContractState + -- |Get the current contract instance state, together with the modification + -- index of the last modification. + getCurrentContractInstanceState :: (HasInstanceParameters a, HasInstanceFields a) => a -> m (ModificationIndex, Wasm.ContractState) -- |Get the amount of energy remaining for the transaction. getEnergy :: m (Energy, EnergyLimitReason) @@ -427,11 +429,15 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - rejectingWith' !c reason = c >>= \case Right b -> return b Left a -> rejectTransaction (reason a) +-- |Index that keeps track of modifications of smart contracts inside a single +-- transaction. This is used to cheaply detect whether a contract state has +-- changed or not when a contract calls another. +type ModificationIndex = Word -- |The set of changes to be commited on a successful transaction. data ChangeSet = ChangeSet {_accountUpdates :: !(HMap.HashMap AccountIndex AccountUpdate) -- ^Accounts whose states changed. - ,_instanceUpdates :: !(HMap.HashMap ContractAddress (AmountDelta, Maybe Wasm.ContractState)) -- ^Contracts whose states changed. + ,_instanceUpdates :: !(HMap.HashMap ContractAddress (ModificationIndex, AmountDelta, Maybe Wasm.ContractState)) -- ^Contracts whose states changed. ,_instanceInits :: !(HSet.HashSet ContractAddress) -- ^Contracts that were initialized. ,_encryptedChange :: !AmountDelta -- ^Change in the encrypted balance of the system as a result of this contract's execution. ,_addedReleaseSchedules :: !(Map.Map AccountAddress Timestamp) -- ^The release schedules added to accounts on this block, to be added on the per block map. @@ -491,10 +497,10 @@ modifyAmountCS ai !amnt !cs = cs & (accountUpdates . ix ai . auAmount ) %~ -- |Add or update the contract state in the changeset with the given value. -- |NB: If the instance is not yet in the changeset we assume that its balance is -- as listed in the given instance structure. -addContractStatesToCS :: HasInstanceParameters a => a -> Wasm.ContractState -> ChangeSet -> ChangeSet -addContractStatesToCS istance newState = - instanceUpdates . at addr %~ \case Just (amnt, _) -> Just (amnt, Just newState) - Nothing -> Just (0, Just newState) +addContractStatesToCS :: HasInstanceParameters a => a -> ModificationIndex -> Wasm.ContractState -> ChangeSet -> ChangeSet +addContractStatesToCS istance curIdx newState = + instanceUpdates . at addr %~ \case Just (_, amnt, _) -> Just (curIdx, amnt, Just newState) + Nothing -> Just (curIdx, 0, Just newState) where addr = instanceAddress istance -- |Add the given delta to the change set for the given contract instance. @@ -502,8 +508,9 @@ addContractStatesToCS istance newState = -- model as given in the first argument to be current model (local state) addContractAmountToCS :: ContractAddress -> AmountDelta -> ChangeSet -> ChangeSet addContractAmountToCS addr amnt cs = - cs & instanceUpdates . at addr %~ \case Just (d, v) -> Just (d + amnt, v) - Nothing -> Just (amnt, Nothing) + -- updating amounts does not update the modification index. Only state updates do. + cs & instanceUpdates . at addr %~ \case Just (idx, d, v) -> Just (idx, d + amnt, v) + Nothing -> Just (0, amnt, Nothing) -- |Add the given contract address to the set of initialized contract instances. -- As the changes on the blockstate are already performed in the handler for this operation, @@ -524,6 +531,8 @@ data LocalState = LocalState{ _energyLeft :: !Energy, -- |Changes accumulated thus far. _changeSet :: !ChangeSet, + -- |Maximum number of modified contract instances. + _nextContractModificationIndex :: !ModificationIndex, _blockEnergyLeft :: !Energy } @@ -561,7 +570,7 @@ runLocalT :: forall pv m a . Monad m -> Energy -- remaining block energy -> m (Either (Maybe RejectReason) a, LocalState) runLocalT (LocalT st) _tcDepositedAmount _tcTxSender _energyLeft _blockEnergyLeft = do - let s = LocalState{_changeSet = emptyCS,..} + let s = LocalState{_changeSet = emptyCS,_nextContractModificationIndex = 0,..} (a, s') <- runRST (runContT st (return . Right)) ctx s return (a, s') @@ -743,13 +752,17 @@ deriving via (MGSTrans (LocalT pv r) m) instance AccountOperations m => AccountO instance (IsProtocolVersion pv, StaticInformation m, AccountOperations m, Monad m) => TransactionMonad pv (LocalT pv r m) where {-# INLINE withInstanceStateV0 #-} withInstanceStateV0 istance val cont = do - changeSet %= addContractStatesToCS istance val - cont + nextModificationIndex <- use nextContractModificationIndex + nextContractModificationIndex += 1 + changeSet %= addContractStatesToCS istance nextModificationIndex val + cont {-# INLINE withInstanceStateV1 #-} withInstanceStateV1 istance val cont = do - changeSet %= addContractStatesToCS istance val - cont + nextModificationIndex <- use nextContractModificationIndex + nextContractModificationIndex += 1 + changeSet %= addContractStatesToCS istance nextModificationIndex val + cont nextModificationIndex {-# INLINE withAccountToAccountAmount #-} withAccountToAccountAmount fromAcc toAcc amount cont = do @@ -816,15 +829,15 @@ instance (IsProtocolVersion pv, StaticInformation m, AccountOperations m, Monad Just i -> case newStates ^. at addr of Nothing -> return $ Just i - Just (delta, newmodel) -> + Just (_, delta, newmodel) -> let !updated = updateInstance delta newmodel i in return (Just updated) getCurrentContractInstanceState istance = do newStates <- use (changeSet . instanceUpdates) case newStates ^. at (instanceAddress istance) of - Just (_, (Just s)) -> return s - _ -> return (instanceModel istance) + Just (idx, _, (Just s)) -> return (idx, s) + _ -> return (0, instanceModel istance) getCurrentAccountTotalAmount (ai, acc) = do oldTotal <- getAccountAmount acc @@ -869,7 +882,7 @@ instance (IsProtocolVersion pv, StaticInformation m, AccountOperations m, Monad let amnt = instanceAmount inst let addr = instanceAddress inst use (changeSet . instanceUpdates . at addr) >>= \case - Just (delta, _) -> return $! applyAmountDelta delta amnt + Just (_, delta, _) -> return $! applyAmountDelta delta amnt Nothing -> return amnt {-# INLINE getEnergy #-} @@ -897,22 +910,26 @@ instance (IsProtocolVersion pv, StaticInformation m, AccountOperations m, Monad {-# INLINE orElse #-} orElse (LocalT l) (LocalT r) = LocalT $ ContT $ \k -> do initChangeSet <- use changeSet + initModificationIndex <- use nextContractModificationIndex runContT l k >>= \case Left (Just reason) | reason /= OutOfEnergy -> do -- reset changeSet, the left computation will have no effect at all other than -- energy use. changeSet .= initChangeSet + nextContractModificationIndex .= initModificationIndex runContT r k x -> return x {-# INLINE orElseWith #-} orElseWith (LocalT l) r = LocalT $ ContT $ \k -> do initChangeSet <- use changeSet + initModificationIndex <- use nextContractModificationIndex runContT l k >>= \case (Left (Just reason)) | reason /= OutOfEnergy -> do -- reset changeSet, the left computation will have no effect at all other than -- energy use. changeSet .= initChangeSet + nextContractModificationIndex .= initModificationIndex runContT (_runLocalT (r reason)) k x -> return x @@ -920,8 +937,10 @@ instance (IsProtocolVersion pv, StaticInformation m, AccountOperations m, Monad {-# INLINE withRollback #-} withRollback (LocalT l) = LocalT $ ContT $ \k -> do initChangeSet <- use changeSet + initModificationIndex <- use nextContractModificationIndex let kNew x@(Left _) = do changeSet .= initChangeSet + nextContractModificationIndex .= initModificationIndex k x kNew x = k x runContT l kNew diff --git a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs index 002656ed3d..330818865e 100644 --- a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs +++ b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs @@ -209,7 +209,7 @@ instance (MonadReader ContextState m, -- ASSUMPTION: the property which should hold at this point is that any -- changed instance must exist in the global state and moreover all instances -- are distinct by the virtue of a HashMap being a function - s' <- lift (foldM (\s' (addr, (amnt, val)) -> do + s' <- lift (foldM (\s' (addr, (_, amnt, val)) -> do tell (logContract addr) bsoModifyInstance s' addr amnt val) s diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 65150a747d..dd6ef1936a 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -188,6 +188,8 @@ foreign import ccall "call_receive_v1" foreign import ccall "resume_receive_v1" resume_receive :: Ptr (Ptr ReceiveInterruptedState) -- ^Location where the pointer to interrupted config will be stored. + -> Word8 -- ^Tag of whether the state has been updated or not. If this is 0 then the next two values are not used. + -- If it is non-zero then they are. -> Ptr Word8 -- ^Pointer to the current state of the smart contracts. This will not be modified. -> CSize -- ^Length of the state. -> Word64 -- ^Return status from the interrupt. @@ -456,7 +458,7 @@ applyReceiveFun miface cm receiveCtx rName param amnt cs initialEnergy = unsafeP -- |Resume execution after processing the interrupt. This can only be called once on a single 'ReceiveInterruptedState'. resumeReceiveFun :: ReceiveInterruptedState - -> ContractState -- ^State of the contract to start in. + -> Maybe ContractState -- ^State of the contract to start in. -> InvokeResponseCode -> Maybe ReturnValue -> InterpreterEnergy -- ^Amount of energy available for execution. @@ -465,10 +467,11 @@ resumeReceiveFun :: -- of execution with the amount of energy remaining. resumeReceiveFun is cs statusCode rVal remainingEnergy = unsafePerformIO $ do withReceiveInterruptedState is $ \isPtr -> - BSU.unsafeUseAsCStringLen stateBytes $ \(stateBytesPtr, stateBytesLen) -> + withStateBytes $ \(stateBytesPtr, stateBytesLen) -> withMaybeReturnValue rVal $ \rValPtr -> alloca $ \outputLenPtr -> alloca $ \outputReturnValuePtrPtr -> do outPtr <- resume_receive isPtr + newStateTag (castPtr stateBytesPtr) (fromIntegral stateBytesLen) (invokeResponseToWord64 statusCode) rValPtr @@ -482,7 +485,9 @@ resumeReceiveFun is cs statusCode rVal remainingEnergy = unsafePerformIO $ do returnValuePtr <- peek outputReturnValuePtrPtr processReceiveResult bs returnValuePtr (Left is) where - stateBytes = contractState cs + (withStateBytes, newStateTag) = case cs of + Just stateBytes -> (BSU.unsafeUseAsCStringLen (contractState stateBytes), 1::Word8) + Nothing -> (\f -> f (nullPtr, 0), 0::Word8) energy = fromIntegral remainingEnergy diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wasm b/concordium-consensus/testdata/contracts/v1/call-counter.wasm index c7aed328d368a46b0a6e3a80234bb897b5bb51e2..4bc04bbaf04c867dd316c585cf96eec95d11fe57 100644 GIT binary patch delta 36 scmeyv(!{#KjgfKJWOv4Cj75|0F)H&o{{R1 Date: Tue, 11 Jan 2022 10:58:20 +0100 Subject: [PATCH 26/51] Add a unit test for invoking a contract. --- .../Concordium/Scheduler/InvokeContract.hs | 3 +- .../Scheduler/WasmIntegration/V1.hs | 5 + .../SchedulerTests/SmartContracts/Invoke.hs | 117 ++++++++++++++++++ concordium-consensus/tests/scheduler/Spec.hs | 3 +- 4 files changed, 126 insertions(+), 2 deletions(-) create mode 100644 concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs diff --git a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs index 41b89e2634..1ec42073a1 100644 --- a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -93,7 +94,7 @@ instance AE.FromJSON ContractContext where ccAmount <- obj AE..:? "amount" AE..!= 0 ccMethod <- obj AE..: "method" ccParameter <- obj AE..:? "parameter" AE..!= Wasm.emptyParameter - ccEnergy <- obj AE..:? "energy" AE..!= maxBound + ccEnergy <- obj AE..:? "energy" AE..!= 10_000_000 return ContractContext{..} data InvokeContractResult = diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index dd6ef1936a..22f6536bc1 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -40,6 +40,7 @@ import Data.Serialize import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Short as BSS import qualified Data.ByteString.Unsafe as BSU @@ -82,6 +83,9 @@ returnValueToByteString rv = unsafePerformIO $ instance AE.ToJSON ReturnValue where toJSON = AE.String . Text.decodeUtf8 . BS16.encode . returnValueToByteString +instance Show ReturnValue where + show = BS8.unpack . BS16.encode . returnValueToByteString + -- |State of the Wasm module when a host operation is invoked (a host operation -- is either a transfer to an account, or a contract call, at present). This can -- only be resumed once. Calling resume on this twice will lead to unpredictable @@ -297,6 +301,7 @@ data ContractExecutionReject = cerReturnValue :: !ReturnValue } -- ^Contract decided to terminate execution. | Trap -- ^A trap was triggered. + deriving (Show) cerToRejectReasonInit :: ContractExecutionReject -> Exec.RejectReason cerToRejectReasonInit LogicReject{..} = Exec.RejectedInit cerRejectReason diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs new file mode 100644 index 0000000000..13954c3ab7 --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} +{-| This module tests invoking a contract directly using invokeContract. +-} +module SchedulerTests.SmartContracts.Invoke (tests) where + +import Test.Hspec +import Test.HUnit(assertFailure, assertEqual, Assertion) + +import Control.Monad.Reader +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as OrdMap +import qualified Data.Set as Set +import Data.Word + +import qualified Concordium.Scheduler.Types as Types +import qualified Concordium.Crypto.SHA256 as Hash + +import Concordium.Types.SeedState (initialSeedState) +import Concordium.GlobalState.Persistent.BlobStore +import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlockState +import Concordium.GlobalState.Instance +import Concordium.Wasm +import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 +import qualified Concordium.GlobalState.Wasm as GSWasm +import qualified Concordium.Scheduler.InvokeContract as InvokeContract + +import Concordium.Types.DummyData +import Concordium.Crypto.DummyData +import Concordium.GlobalState.DummyData + +import SchedulerTests.TestUtils + +type ContextM = PersistentBlockStateMonad PV4 BlobStore (ReaderT BlobStore IO) + +-- empty state, no accounts, no modules, no instances +initialBlockState :: ContextM (HashedPersistentBlockState PV4) +initialBlockState = initialPersistentState + (initialSeedState (Hash.hash "") 1000) + dummyCryptographicParameters + [mkAccount alesVK alesAccount 1000] + dummyIdentityProviders + dummyArs + dummyKeyCollection + dummyChainParameters + +counterSourceFile :: FilePath +counterSourceFile = "./testdata/contracts/v1/call-counter.wasm" + +-- Tests in this module use version 1, creating V1 instances. +wasmModVersion :: Word32 +wasmModVersion = 1 + +deployModule :: ContextM (PersistentBlockState PV4, GSWasm.ModuleInterfaceV GSWasm.V1, WasmModule) +deployModule = do + wasmSource <- liftIO $ BS.readFile counterSourceFile + let wm = WasmModule wasmModVersion (ModuleSource wasmSource) + case WasmV1.processModule wm of + Nothing -> liftIO $ assertFailure "Invalid counter module." + Just miv -> do + let mi = GSWasm.ModuleInterfaceV1 miv + (_, modState) <- flip bsoPutNewModule (mi, wm) . hpbsPointers =<< initialBlockState + return (modState, miv, wm) + +initContract :: (PersistentBlockState PV4, GSWasm.ModuleInterfaceV GSWasm.V1, WasmModule) -> ContextM (Types.ContractAddress, HashedPersistentBlockState PV4) +initContract (bs, miv, _) = do + let cm = Types.ChainMetadata 0 + let senderAddress = alesAccount + let initContext = InitContext{ + initOrigin = senderAddress, + icSenderPolicies = [] + } + let initName = InitName "init_counter" + let initParam = emptyParameter + let initAmount = 0 + let initInterpreterEnergy = 1_000_000_000 + case WasmV1.applyInitFun miv cm initContext initName initParam initAmount initInterpreterEnergy of + Nothing -> -- out of energy + liftIO $ assertFailure "Initialization ran out of energy." + Just (Left failure, _) -> + liftIO $ assertFailure $ "Initialization failed: " ++ show failure + Just (Right WasmV1.InitSuccess{..}, _) -> do + let receiveMethods = OrdMap.findWithDefault Set.empty initName (GSWasm.miExposedReceive miv) + let mkInstance = makeInstance initName receiveMethods miv irdNewState initAmount senderAddress + (addr, instState) <- bsoPutNewInstance bs mkInstance + (addr,) <$> freezeBlockState instState + +invokeContract :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract ccContract bs = do + let cm = Types.ChainMetadata 0 + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 0, + ccMethod = ReceiveName "counter.inc", + ccParameter = emptyParameter, + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + +runCounterTests :: Assertion +runCounterTests = do + invokeResult <- runBlobStoreTemp "." . runPersistentBlockStateMonad $ do + bsWithMod <- deployModule + (addr, stateWithContract) <- initContract bsWithMod + invokeContract addr stateWithContract + case invokeResult of + InvokeContract.Failure{..} -> assertFailure $ "Invocation failed: " ++ show rcrReason + InvokeContract.Success{..} -> + case rcrReturnValue of + Nothing -> assertFailure $ "Invoking a V1 contract must produce a return value." + Just rv -> assertEqual "Invoking a counter in initial state should return 1" (BS.unpack (WasmV1.returnValueToByteString rv)) [1,0,0,0,0,0,0,0] + +tests :: Spec +tests = describe "Invoke contract" $ do + specify "Counter contract" $ runCounterTests diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index 3edf0c0bad..228113098a 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -28,7 +28,7 @@ import qualified SchedulerTests.RejectReasonsRustContract(tests) import qualified SchedulerTests.SmartContracts.V1.Counter(tests) import qualified SchedulerTests.SmartContracts.V1.Transfer(tests) import qualified SchedulerTests.SmartContracts.V1.CrossMessaging(tests) - +import qualified SchedulerTests.SmartContracts.Invoke (tests) import Test.Hspec @@ -61,3 +61,4 @@ main = hspec $ do SchedulerTests.SmartContracts.V1.Counter.tests SchedulerTests.SmartContracts.V1.Transfer.tests SchedulerTests.SmartContracts.V1.CrossMessaging.tests + SchedulerTests.SmartContracts.Invoke.tests From 11cbbc6b80ae2f986d21b2ea588f5f242cb177db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Tue, 11 Jan 2022 13:49:05 +0100 Subject: [PATCH 27/51] Additional tests. --- .../SchedulerTests/SmartContracts/Invoke.hs | 100 ++++++++++++++++-- 1 file changed, 90 insertions(+), 10 deletions(-) diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs index 13954c3ab7..3325d851c5 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs @@ -8,6 +8,8 @@ import Test.Hspec import Test.HUnit(assertFailure, assertEqual, Assertion) import Control.Monad.Reader +import Data.Serialize +import qualified Data.ByteString.Short as BSS import qualified Data.ByteString as BS import qualified Data.Map.Strict as OrdMap import qualified Data.Set as Set @@ -86,8 +88,9 @@ initContract (bs, miv, _) = do (addr, instState) <- bsoPutNewInstance bs mkInstance (addr,) <$> freezeBlockState instState -invokeContract :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult -invokeContract ccContract bs = do +-- |Invoke the contract without an invoker expecting success. +invokeContract1 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract1 ccContract bs = do let cm = Types.ChainMetadata 0 let ctx = InvokeContract.ContractContext{ ccInvoker = Nothing, @@ -99,18 +102,95 @@ invokeContract ccContract bs = do } InvokeContract.invokeContract Types.SP4 ctx cm bs +-- |Invoke an entrypoint that calls other entrypoints, and expects a parameter. +-- This entrypoint does not return anything, meaning the return value is an empty byte array. +invokeContract2 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract2 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord64le 0 -- contract index + putWord64le 0 -- contract subindex + putWord16le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "inc")) + putByteString "inc" -- entrypoint name + putWord64le 0 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 0, + ccMethod = ReceiveName "counter.inc10", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + + +-- |Same as 2, but a wrong parameter is passed. +-- Expects runtime failure +invokeContract3 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract3 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 0, + ccMethod = ReceiveName "counter.inc10", + ccEnergy = 1_000_000_000, + ccParameter = emptyParameter, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + + +-- |Same as 2, but with an invoker. +invokeContract4 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract4 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord64le 0 -- contract index + putWord64le 0 -- contract subindex + putWord16le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "inc")) + putByteString "inc" -- entrypoint name + putWord64le 0 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Just (Types.AddressContract (Types.ContractAddress 0 0)), + ccAmount = 0, + ccMethod = ReceiveName "counter.inc10", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + + runCounterTests :: Assertion runCounterTests = do - invokeResult <- runBlobStoreTemp "." . runPersistentBlockStateMonad $ do + runBlobStoreTemp "." . runPersistentBlockStateMonad $ do bsWithMod <- deployModule (addr, stateWithContract) <- initContract bsWithMod - invokeContract addr stateWithContract - case invokeResult of - InvokeContract.Failure{..} -> assertFailure $ "Invocation failed: " ++ show rcrReason - InvokeContract.Success{..} -> - case rcrReturnValue of - Nothing -> assertFailure $ "Invoking a V1 contract must produce a return value." - Just rv -> assertEqual "Invoking a counter in initial state should return 1" (BS.unpack (WasmV1.returnValueToByteString rv)) [1,0,0,0,0,0,0,0] + invokeContract1 addr stateWithContract >>= \case + InvokeContract.Failure{..} -> liftIO $ assertFailure $ "Invocation failed: " ++ show rcrReason + InvokeContract.Success{..} -> + case rcrReturnValue of + Nothing -> liftIO $ assertFailure $ "Invoking a V1 contract must produce a return value." + Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return 1" [1,0,0,0,0,0,0,0] (BS.unpack (WasmV1.returnValueToByteString rv)) + + invokeContract2 addr stateWithContract >>= \case + InvokeContract.Failure{..} -> liftIO $ assertFailure $ "Invocation failed: " ++ show rcrReason + InvokeContract.Success{..} -> + case rcrReturnValue of + Nothing -> liftIO $ assertFailure $ "Invoking a V1 contract must produce a return value." + Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return nothing" [] (BS.unpack (WasmV1.returnValueToByteString rv)) + + invokeContract3 addr stateWithContract >>= \case + InvokeContract.Failure{..} -> liftIO $ assertEqual "Invocation should fail: " Types.RuntimeFailure rcrReason + InvokeContract.Success{} -> liftIO $ assertFailure $ "Invocation succeeded, but should fail." + + invokeContract4 addr stateWithContract >>= \case + InvokeContract.Failure{..} -> liftIO $ assertFailure $ "Invocation failed: " ++ show rcrReason + InvokeContract.Success{..} -> + case rcrReturnValue of + Nothing -> liftIO $ assertFailure $ "Invoking a V1 contract must produce a return value." + Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return nothing." [] (BS.unpack (WasmV1.returnValueToByteString rv)) + tests :: Spec tests = describe "Invoke contract" $ do From 9d2d5a6b178ee4324ff09830d38f09677dfeffe1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Tue, 11 Jan 2022 18:49:54 +0100 Subject: [PATCH 28/51] Fix bug in transferring failures to smart contracts. --- concordium-consensus/smart-contracts | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index ca3aaad128..f3616a0b1b 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit ca3aaad1282cc59e52f94d8d14dace3066ba9c2b +Subproject commit f3616a0b1ba8e5cdd49413e0bbc18808a98e9ae5 From 91a8e759c0e0bb5deeae55b89e3f3f167efad38e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Sat, 15 Jan 2022 10:11:16 +0100 Subject: [PATCH 29/51] Add testing of error codes returned to contracts, and fix related issues. --- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/Scheduler.hs | 245 ++++++++++-------- .../Concordium/Scheduler/InvokeContract.hs | 10 +- .../Scheduler/WasmIntegration/V1.hs | 9 +- .../testdata/contracts/empty.wasm | Bin 0 -> 50 bytes .../testdata/contracts/empty.wat | 9 + .../testdata/contracts/v1/caller.wasm | Bin 0 -> 306 bytes .../testdata/contracts/v1/caller.wat | 45 ++++ .../SchedulerTests/SmartContracts/Invoke.hs | 2 +- concordium-consensus/tests/scheduler/Spec.hs | 2 + 10 files changed, 210 insertions(+), 114 deletions(-) create mode 100644 concordium-consensus/testdata/contracts/empty.wasm create mode 100644 concordium-consensus/testdata/contracts/empty.wat create mode 100644 concordium-consensus/testdata/contracts/v1/caller.wasm create mode 100644 concordium-consensus/testdata/contracts/v1/caller.wat diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index f3616a0b1b..e980394b84 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit f3616a0b1ba8e5cdd49413e0bbc18808a98e9ae5 +Subproject commit e980394b84a305290092d33bd1942ce627f65077 diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index def88279c3..c7625aff8e 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -37,8 +37,10 @@ module Concordium.Scheduler ,execTransactions ,handleContractUpdateV1 ,handleContractUpdateV0 - ,checkAndGetBalanceInstance - ,checkAndGetBalanceAccount + ,checkAndGetBalanceInstanceV1 + ,checkAndGetBalanceInstanceV0 + ,checkAndGetBalanceAccountV1 + ,checkAndGetBalanceAccountV0 ,FilteredTransactions(..) ) where import qualified Concordium.GlobalState.Wasm as GSWasm @@ -774,50 +776,85 @@ handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = where senderAccount = wtc ^. wtcSenderAccount meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta - checkAndGetBalance = checkAndGetBalanceAccount senderAddress senderAccount + checkAndGetBalanceV1 = checkAndGetBalanceAccountV1 senderAddress senderAccount + checkAndGetBalanceV0 = checkAndGetBalanceAccountV0 senderAddress senderAccount c = do getCurrentContractInstanceTicking uAddress >>= \case InstanceV0 ins -> -- Now invoke the general handler for contract messages. handleContractUpdateV0 senderAddress ins - checkAndGetBalance + checkAndGetBalanceV0 uAmount uReceiveName uMessage InstanceV1 ins -> do - handleContractUpdateV1 senderAddress ins checkAndGetBalance uAmount uReceiveName uMessage >>= \case + handleContractUpdateV1 senderAddress ins checkAndGetBalanceV1 uAmount uReceiveName uMessage >>= \case Left cer -> rejectTransaction (WasmV1.cerToRejectReasonReceive uAddress uReceiveName uMessage cer) Right (_, events) -> return events -checkAndGetBalanceAccount :: (TransactionMonad pv m, AccountOperations m) +checkAndGetBalanceAccountV1 :: (TransactionMonad pv m, AccountOperations m) + => AccountAddress -- ^Used address + -> IndexedAccount m + -> Amount + -> m (Either WasmV1.ContractCallFailure (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress))) +checkAndGetBalanceAccountV1 usedAddress senderAccount transferAmount = do + (senderAddr, senderCredentials) <- mkSenderAddrCredentials (Right (usedAddress, senderAccount)) + senderamount <- getAccountAvailableAmount (snd senderAccount) + if senderamount >= transferAmount then do + canonicalAddr <- getAccountCanonicalAddress (snd senderAccount) + return (Right (senderAddr, senderCredentials, Right (fst senderAccount, canonicalAddr))) + else + return (Left (WasmV1.EnvFailure (WasmV1.AmountTooLarge senderAddr transferAmount))) + +checkAndGetBalanceAccountV0 :: (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^Used address -> IndexedAccount m -> Amount -> m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress)) -checkAndGetBalanceAccount usedAddress senderAccount transferAmount = do +checkAndGetBalanceAccountV0 usedAddress senderAccount transferAmount = do (senderAddr, senderCredentials) <- mkSenderAddrCredentials (Right (usedAddress, senderAccount)) senderamount <- getAccountAvailableAmount (snd senderAccount) - unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) - canonicalAddr <- getAccountCanonicalAddress (snd senderAccount) - return (senderAddr, senderCredentials, Right (fst senderAccount, canonicalAddr)) + if senderamount >= transferAmount then do + canonicalAddr <- getAccountCanonicalAddress (snd senderAccount) + return (senderAddr, senderCredentials, Right (fst senderAccount, canonicalAddr)) + else + rejectTransaction (AmountTooLarge senderAddr transferAmount) -checkAndGetBalanceInstance :: (TransactionMonad pv m, AccountOperations m) + +checkAndGetBalanceInstanceV1 :: (TransactionMonad pv m, AccountOperations m) => IndexedAccount m -> InstanceV vOrigin -> Amount - -> m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress)) -checkAndGetBalanceInstance ownerAccount istance transferAmount = do + -> m (Either WasmV1.ContractCallFailure (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress))) +checkAndGetBalanceInstanceV1 ownerAccount istance transferAmount = do (senderAddr, senderCredentials) <- mkSenderAddrCredentials (Left (ownerAccount, instanceAddress istance)) senderamount <- getCurrentContractAmount istance - unless (senderamount >= transferAmount) $ rejectTransaction (AmountTooLarge senderAddr transferAmount) - return (senderAddr, senderCredentials, (Left (instanceAddress istance))) + if senderamount >= transferAmount then + return (Right (senderAddr, senderCredentials, (Left (instanceAddress istance)))) + else + return (Left (WasmV1.EnvFailure (WasmV1.AmountTooLarge senderAddr transferAmount))) + + +checkAndGetBalanceInstanceV0 :: (TransactionMonad pv m, AccountOperations m) + => IndexedAccount m + -> InstanceV vOrigin + -> Amount + -> m (Address, [ID.AccountCredential], Either ContractAddress IndexedAccountAddress) +checkAndGetBalanceInstanceV0 ownerAccount istance transferAmount = do + (senderAddr, senderCredentials) <- mkSenderAddrCredentials (Left (ownerAccount, instanceAddress istance)) + senderamount <- getCurrentContractAmount istance + if senderamount >= transferAmount then + return (senderAddr, senderCredentials, Left (instanceAddress istance)) + else + rejectTransaction (AmountTooLarge senderAddr transferAmount) + handleContractUpdateV1 :: forall pv m. (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^The address that was used to send the top-level transaction. -> InstanceV GSWasm.V1 -- ^The current state of the target contract of the transaction, which must exist. - -> (Amount -> m (Address, [ID.AccountCredential], Either ContractAddress IndexedAccountAddress)) + -> (Amount -> m (Either WasmV1.ContractCallFailure (Address, [ID.AccountCredential], Either ContractAddress IndexedAccountAddress))) -- ^Check that the sender has sufficient amount to cover the given amount and return a triple of -- - used address -- - credentials of the address, either account or owner of the contract @@ -835,94 +872,96 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei let iParams = _instanceVParameters istance let cref = instanceAddress iParams let receivefuns = instanceReceiveFuns . _instanceVParameters $ istance - unless (Set.member receiveName receivefuns) $ rejectTransaction $ - InvalidReceiveMethod (GSWasm.miModuleRef . instanceModuleInterface $ iParams) receiveName let ownerAccountAddress = instanceOwner iParams -- The invariants maintained by global state should ensure that an owner account always exists. -- However we are defensive here and reject the transaction instead of panicking in case it does not. - ownerAccount <- getAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress - - (senderAddr, senderCredentials, sender) <- checkAndGetSender transferAmount - - cm <- getChainMetadata - let receiveCtx = Wasm.ReceiveContext { - invoker = originAddr, - selfAddress = cref, - -- NB: This means that the contract observes the balance without the incoming one - -- It gets the transfer amount as a separate parameter. - selfBalance = _instanceVAmount istance, - sender = senderAddr, - owner = instanceOwner iParams, - rcSenderPolicies = map Wasm.mkSenderPolicy senderCredentials - } - -- Now run the receive function on the message. This ticks energy during execution, failing when running out of energy. - -- FIXME: Once errors can be caught in smart contracts update this to not terminate the transaction. - let iface = instanceModuleInterface iParams - -- charge for looking up the module - tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) - - -- we've covered basic administrative costs now. Now iterate until the end of execution, handling any interrupts. - let go :: [Event] -> Either WasmV1.ContractExecutionReject WasmV1.ReceiveResultData -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) - go _ (Left cer) = return (Left (WasmV1.ExecutionReject cer)) - go events (Right rrData) = - case rrData of - WasmV1.ReceiveSuccess{..} -> do - -- execution terminated, commit the new state - withInstanceStateV1 istance rrdNewState $ \_modifiedIndex -> - let event = Updated{euAddress=instanceAddress istance, - euInstigator=senderAddr, - euAmount=transferAmount, - euMessage=parameter, - euReceiveName=receiveName, - euEvents = rrdLogs - } - in return (Right (rrdReturnValue, event:events)) - WasmV1.ReceiveInterrupt{..} -> do - let interruptEvent = Interrupted{ - iAddress = instanceAddress istance, - iEvents = rrdLogs - } - resumeEvent rSuccess = Resumed{ - rAddress = instanceAddress istance, - .. - } - case rrdMethod of - WasmV1.Transfer{..} -> - runExceptT (transferAccountSync imtTo istance imtAmount) >>= \case - Left errCode -> do - go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) - Right transferEvents -> go (resumeEvent True:transferEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing WasmV1.Success Nothing) - WasmV1.Call{..} -> - -- commit the current state of the contract. - withInstanceStateV1 istance rrdCurrentState $ \modificationIndex -> do - -- lookup the instance - getCurrentContractInstanceTicking' imcTo >>= \case - Nothing -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MissingContract imcTo))) Nothing) - Just (InstanceV0 targetInstance) -> do - let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName - runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount rName imcParam - (runSuccess `orElseWith` (return . Left)) >>= \case - Left rr -> -- execution failed. - go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) - Right evs -> do - (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance - let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState - go (resumeEvent True:evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState WasmV1.Success Nothing) - Just (InstanceV1 targetInstance) -> do - let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName - withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstance ownerAccount istance) imcAmount rName imcParam) >>= \case - Left cer -> - go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) - Right (rVal, callEvents) -> do - (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance - let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState - go (resumeEvent True:callEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState WasmV1.Success (Just rVal)) - - -- start contract execution. - -- transfer the amount from the sender to the contract at the start. This is so that the contract may immediately use it - -- for, e.g., forwarding. - withToContractAmount sender istance transferAmount $ - go [] =<< runInterpreter (return . WasmV1.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) + ownerCheck <- getAccount ownerAccountAddress + senderCheck <- checkAndGetSender transferAmount + + case (Set.member receiveName receivefuns, ownerCheck, senderCheck) of + (False, _, _) -> return (Left (WasmV1.EnvFailure (WasmV1.InvalidEntrypoint (GSWasm.miModuleRef . instanceModuleInterface $ iParams) receiveName))) + (_, Nothing, _) -> return (Left (WasmV1.EnvFailure (WasmV1.MissingAccount ownerAccountAddress))) + (_, _, Left err) -> return (Left err) + (True, Just ownerAccount, Right (senderAddr, senderCredentials, sender)) -> do + cm <- getChainMetadata + let receiveCtx = Wasm.ReceiveContext { + invoker = originAddr, + selfAddress = cref, + -- NB: This means that the contract observes the balance without the incoming one + -- It gets the transfer amount as a separate parameter. + selfBalance = _instanceVAmount istance, + sender = senderAddr, + owner = instanceOwner iParams, + rcSenderPolicies = map Wasm.mkSenderPolicy senderCredentials + } + -- Now run the receive function on the message. This ticks energy during execution, failing when running out of energy. + -- FIXME: Once errors can be caught in smart contracts update this to not terminate the transaction. + let iface = instanceModuleInterface iParams + -- charge for looking up the module + tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) + + -- we've covered basic administrative costs now. Now iterate until the end of execution, handling any interrupts. + let go :: [Event] -> Either WasmV1.ContractExecutionReject WasmV1.ReceiveResultData -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) + go _ (Left cer) = return (Left (WasmV1.ExecutionReject cer)) + go events (Right rrData) = + case rrData of + WasmV1.ReceiveSuccess{..} -> do + -- execution terminated, commit the new state + withInstanceStateV1 istance rrdNewState $ \_modifiedIndex -> + let event = Updated{euAddress=instanceAddress istance, + euInstigator=senderAddr, + euAmount=transferAmount, + euMessage=parameter, + euReceiveName=receiveName, + euEvents = rrdLogs + } + in return (Right (rrdReturnValue, event:events)) + WasmV1.ReceiveInterrupt{..} -> do + let interruptEvent = Interrupted{ + iAddress = instanceAddress istance, + iEvents = rrdLogs + } + resumeEvent rSuccess = Resumed{ + rAddress = instanceAddress istance, + .. + } + case rrdMethod of + WasmV1.Transfer{..} -> + runExceptT (transferAccountSync imtTo istance imtAmount) >>= \case + Left errCode -> do + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) + Right transferEvents -> go (resumeEvent True:transferEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing WasmV1.Success Nothing) + WasmV1.Call{..} -> + -- commit the current state of the contract. + withInstanceStateV1 istance rrdCurrentState $ \modificationIndex -> do + -- lookup the instance + getCurrentContractInstanceTicking' imcTo >>= \case + Nothing -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MissingContract imcTo))) Nothing) + Just (InstanceV0 targetInstance) -> do + let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName + runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstanceV0 ownerAccount istance) imcAmount rName imcParam + (runSuccess `orElseWith` (return . Left)) >>= \case + Left rr -> -- execution failed. + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) + Right evs -> do + (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance + let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState + go (resumeEvent True:evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState WasmV1.Success Nothing) + Just (InstanceV1 targetInstance) -> do + let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName + withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstanceV1 ownerAccount istance) imcAmount rName imcParam) >>= \case + Left cer -> + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) + Right (rVal, callEvents) -> do + (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance + let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState + go (resumeEvent True:callEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState WasmV1.Success (Just rVal)) + + -- start contract execution. + -- transfer the amount from the sender to the contract at the start. This is so that the contract may immediately use it + -- for, e.g., forwarding. + withToContractAmount sender istance transferAmount $ + go [] =<< runInterpreter (return . WasmV1.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) where transferAccountSync :: AccountAddress -- ^The target account address. -> InstanceV GSWasm.V1 -- ^The sender of this transfer. @@ -1054,7 +1093,7 @@ foldEvents originAddr istance initEvent = fmap (initEvent:) . go getCurrentContractInstanceTicking erAddr >>= \case InstanceV0 cinstance -> handleContractUpdateV0 originAddr cinstance - (uncurry checkAndGetBalanceInstance istance) + (uncurry checkAndGetBalanceInstanceV0 istance) erAmount erName erParameter @@ -1062,7 +1101,7 @@ foldEvents originAddr istance initEvent = fmap (initEvent:) . go let c = handleContractUpdateV1 originAddr cinstance - (uncurry checkAndGetBalanceInstance istance) + (uncurry checkAndGetBalanceInstanceV1 istance) erAmount erName erParameter diff --git a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs index 1ec42073a1..f25b614502 100644 --- a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -26,7 +26,7 @@ import Concordium.Scheduler.Environment import Concordium.Scheduler.Types import Concordium.Scheduler.EnvironmentImplementation (ContextState(..), maxBlockEnergy, chainMetadata, accountCreationLimit) import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 -import Concordium.Scheduler (handleContractUpdateV0, handleContractUpdateV1, checkAndGetBalanceInstance, checkAndGetBalanceAccount) +import Concordium.Scheduler newtype InvokeContractMonad (pv :: ProtocolVersion) m a = InvokeContractMonad {_runInvokeContract :: ReaderT (ContextState, BlockState m) m a} deriving (Functor, @@ -144,19 +144,19 @@ invokeContract _ ContractContext{..} cm bs = do in return (Right (const (return (AddressAccount zeroAddress, [], Right (maxIndex, zeroAddress))), zeroAddress, maxIndex)) Just (AddressAccount accInvoker) -> getAccount accInvoker >>= \case Nothing -> return (Left (Just (InvalidAccountReference accInvoker))) - Just acc -> return (Right (checkAndGetBalanceAccount accInvoker acc, accInvoker, (fst acc))) + Just acc -> return (Right (checkAndGetBalanceAccountV0 accInvoker acc, accInvoker, (fst acc))) Just (AddressContract contractInvoker) -> getContractInstance contractInvoker >>= \case Nothing -> return (Left (Just (InvalidContractAddress contractInvoker))) Just (Instance.InstanceV0 i@Instance.InstanceV{..}) -> do let ownerAccountAddress = instanceOwner _instanceVParameters getAccount ownerAccountAddress >>= \case Nothing -> return (Left (Just $ InvalidAccountReference ownerAccountAddress)) - Just acc -> return (Right (checkAndGetBalanceInstance acc i, ownerAccountAddress, (fst acc))) + Just acc -> return (Right (checkAndGetBalanceInstanceV0 acc i, ownerAccountAddress, (fst acc))) Just (Instance.InstanceV1 i@Instance.InstanceV{..}) -> do let ownerAccountAddress = instanceOwner _instanceVParameters getAccount ownerAccountAddress >>= \case Nothing -> return (Left (Just $ InvalidAccountReference ownerAccountAddress)) - Just acc -> return (Right (checkAndGetBalanceInstance acc i, ownerAccountAddress, (fst acc))) + Just acc -> return (Right (checkAndGetBalanceInstanceV0 acc i, ownerAccountAddress, (fst acc))) let runContractComp = getInvoker >>= \case Left err -> return (Left err, ccEnergy) @@ -165,7 +165,7 @@ invokeContract _ ContractContext{..} cm bs = do istance <- getContractInstance ccContract `rejectingWith` InvalidContractAddress ccContract case istance of InstanceV0 i -> Left <$> handleContractUpdateV0 addr i invoker ccAmount ccMethod ccParameter - InstanceV1 i -> Right <$> handleContractUpdateV1 addr i invoker ccAmount ccMethod ccParameter + InstanceV1 i -> Right <$> handleContractUpdateV1 addr i (fmap Right . invoker) ccAmount ccMethod ccParameter (r, cs) <- runLocalT @pv comp ccAmount ai ccEnergy ccEnergy return (r, _energyLeft cs) contextState = ContextState{_maxBlockEnergy = ccEnergy, _accountCreationLimit = 0, _chainMetadata = cm} diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 22f6536bc1..ae935e2ab4 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -129,9 +129,9 @@ data EnvFailure = AmountTooLarge !Address !Amount | MissingAccount !AccountAddress | MissingContract !ContractAddress + | InvalidEntrypoint !ModuleRef !ReceiveName -- Attempting to invoke a non-existing entrypoint. | MessageFailed !Exec.RejectReason -- message to a V0 contract failed. No further information is available. deriving (Show) --- TODO: In principle we could extract a more precise reason than MessageFailed. -- |Encode the response into 64 bits. This is necessary since Wasm only allows -- us to pass simple scalars as parameters. Everything else requires passing @@ -149,8 +149,9 @@ invokeResponseToWord64 (Error (EnvFailure e)) = AmountTooLarge _ _ -> 0xffff_ff01_0000_0000 MissingAccount _ -> 0xffff_ff02_0000_0000 MissingContract _ -> 0xffff_ff03_0000_0000 - MessageFailed _ -> 0xffff_ff04_0000_0000 -invokeResponseToWord64 (Error (ExecutionReject Trap)) = 0xffff_ff05_0000_0000 + InvalidEntrypoint _ _ -> 0xffff_ff04_0000_0000 + MessageFailed _ -> 0xffff_ff05_0000_0000 +invokeResponseToWord64 (Error (ExecutionReject Trap)) = 0xffff_ff06_0000_0000 invokeResponseToWord64 (Error (ExecutionReject LogicReject{..})) = -- make the last 32 bits the value of the rejection reason let unsigned = fromIntegral cerRejectReason :: Word32 -- reinterpret the bits @@ -359,10 +360,10 @@ cerToRejectReasonReceive _ _ _ (EnvFailure e) = case e of AmountTooLarge ad am -> Exec.AmountTooLarge ad am MissingAccount aref -> Exec.InvalidAccountReference aref MissingContract cref -> Exec.InvalidContractAddress cref + InvalidEntrypoint mref rn -> Exec.InvalidReceiveMethod mref rn MessageFailed rr -> rr - processReceiveResult :: -- |Serialized output. BS.ByteString diff --git a/concordium-consensus/testdata/contracts/empty.wasm b/concordium-consensus/testdata/contracts/empty.wasm new file mode 100644 index 0000000000000000000000000000000000000000..514a6ca1ed36b192248c82335e42daa3ddbc947a GIT binary patch literal 50 zcmZQbEY4+QU|?WmV@zPIW2|RpVq{=tW@KPw=VRo`%*!l^Pt7eTsbpZ_VrOJ!aAe@; F1^~R|2aW&$ literal 0 HcmV?d00001 diff --git a/concordium-consensus/testdata/contracts/empty.wat b/concordium-consensus/testdata/contracts/empty.wat new file mode 100644 index 0000000000..d2b3babdf2 --- /dev/null +++ b/concordium-consensus/testdata/contracts/empty.wat @@ -0,0 +1,9 @@ +;; An empty contract. It can be initialized, and does nothing else. +(module + + (func $init_empty (export "init_empty") (param i64) (result i32) + (return (i32.const 0)) ;; Successful init + ) + + (memory 1) +) diff --git a/concordium-consensus/testdata/contracts/v1/caller.wasm b/concordium-consensus/testdata/contracts/v1/caller.wasm new file mode 100644 index 0000000000000000000000000000000000000000..dac58be65dd51357f24ed918cd3a5080a8bcfa5f GIT binary patch literal 306 zcmZ9HKWoD<5XIl=Pg0^nO(9Drd+U_7WYpR(VGCCYBDQ4|IfV?-SC32xn7-lOz4yE2 zU@koYph`BBC^aHwW#_ZqpOzZBQ({4ET0gWt{JN?CJlR-}CYatv8|sU@Szy7p|F~_V z^8;vcvU0=KpDoy;d;beA+S*TXoFX`vVwU6tS|5aRgNt=*y3Pg&^<4I|LB7(_xDKmV ziouLnZ+?V?#)mpEmcP;{P%)jGGS7lEz8JK~L7WR#@sgGNo6qnqW4_yIC;{yi2h;-+ C>rV^- literal 0 HcmV?d00001 diff --git a/concordium-consensus/testdata/contracts/v1/caller.wat b/concordium-consensus/testdata/contracts/v1/caller.wat new file mode 100644 index 0000000000..b25d9d9f8a --- /dev/null +++ b/concordium-consensus/testdata/contracts/v1/caller.wat @@ -0,0 +1,45 @@ +;; A trivial contract that simply invokes with whatever information it was given. +;; The return value is written using write_output. + +(module + + ;; Imports + + (import "concordium" "get_parameter_size" (func $get_parameter_size (param $index i32) (result i32))) + (import "concordium" "get_parameter_section" (func $get_parameter_section (param $index i32) (param $write_location i32) (param $length i32) (param $offset i32) (result i32))) + (import "concordium" "invoke" (func $invoke (param $tag i32) (param $start i32) (param $length i32) (result i64))) + (import "concordium" "write_output" (func $write_output (param $start i32) (param $length i32) (param $offset i32) (result i32))) + + ;; The caller contract + + (func $init_caller (export "init_caller") (param i64) (result i32) + (return (i32.const 0)) ;; Successful init + ) + + (func $call (export "caller.call") (param i64) (result i32) + (local $n i32) + (local $size i32) + (local $rv i64) + (local.set $size (call $get_parameter_size (i32.const 0))) + (call $get_parameter_section (i32.const 0) (i32.const 0) (local.get $size) (i32.const 0)) + ;; invoke, interpret the first 4 bytes as the instruction, the remaining bytes as the parameter + (local.set $rv (call $invoke (i32.load (i32.const 0)) (i32.const 4) (i32.sub (local.get $size) (i32.const 4)))) + ;; store the return value + (i64.store (local.get $size) (local.get $rv)) + (call $write_output (local.get $size) (i32.const 8) (i32.const 0)) + (drop) + (drop) + ;; and return success + (i32.const 0) + ) + ;; always fail with error code -17 + (func $fail (export "caller.fail") (param i64) (result i32) + (i32.const -17) + ) + + ;; always unreachable + (func $trap (export "caller.trap") (param i64) (result i32) + unreachable + ) + (memory 1) +) \ No newline at end of file diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs index 3325d851c5..4433914bf7 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs @@ -194,4 +194,4 @@ runCounterTests = do tests :: Spec tests = describe "Invoke contract" $ do - specify "Counter contract" $ runCounterTests + specify "V1: Counter contract" $ runCounterTests diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index 228113098a..b7479d71c2 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -29,6 +29,7 @@ import qualified SchedulerTests.SmartContracts.V1.Counter(tests) import qualified SchedulerTests.SmartContracts.V1.Transfer(tests) import qualified SchedulerTests.SmartContracts.V1.CrossMessaging(tests) import qualified SchedulerTests.SmartContracts.Invoke (tests) +import qualified SchedulerTests.SmartContracts.V1.ErrorCodes (tests) import Test.Hspec @@ -62,3 +63,4 @@ main = hspec $ do SchedulerTests.SmartContracts.V1.Transfer.tests SchedulerTests.SmartContracts.V1.CrossMessaging.tests SchedulerTests.SmartContracts.Invoke.tests + SchedulerTests.SmartContracts.V1.ErrorCodes.tests From 2df594b6a445c9ff943578c3a65d5365fe32d54f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Sun, 16 Jan 2022 08:09:05 +0100 Subject: [PATCH 30/51] Streamline error handling a bit. --- concordium-consensus/src/Concordium/Scheduler.hs | 8 +++++--- .../src/Concordium/Scheduler/WasmIntegration/V1.hs | 9 ++++----- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index c7625aff8e..aeac7d5d58 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -901,7 +901,9 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) -- we've covered basic administrative costs now. Now iterate until the end of execution, handling any interrupts. - let go :: [Event] -> Either WasmV1.ContractExecutionReject WasmV1.ReceiveResultData -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) + let go :: [Event] + -> Either WasmV1.ContractExecutionReject WasmV1.ReceiveResultData + -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) go _ (Left cer) = return (Left (WasmV1.ExecutionReject cer)) go events (Right rrData) = case rrData of @@ -941,8 +943,8 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstanceV0 ownerAccount istance) imcAmount rName imcParam (runSuccess `orElseWith` (return . Left)) >>= \case - Left rr -> -- execution failed. - go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MessageFailed rr))) Nothing) + Left _ -> -- execution failed, ignore the reject reason since V0 contract cannot return useful information + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing WasmV1.MessageSendFailed Nothing) Right evs -> do (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index ae935e2ab4..d2462f9e76 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -104,11 +104,11 @@ withMaybeReturnValue (Just rv) k = withReturnValue rv k withReceiveInterruptedState :: ReceiveInterruptedState -> (Ptr (Ptr ReceiveInterruptedState) -> IO a) -> IO a withReceiveInterruptedState = withForeignPtr . risPtr --- |Possible reasons why a contract call failed. +-- |Possible reasons why a contract call of a V1 contract failed. data ContractCallFailure = -- |The contract call failed because the contract rejected execution for its own reason, or execution trapped. ExecutionReject !ContractExecutionReject - -- |Contract call failed due to other, environment reasons, such as the intended contract not existing. + -- |Contract call of a V1 contract failed due to other, environment reasons, such as the intended contract not existing. | EnvFailure !EnvFailure -- |Convert a contract call failure to a return value. If a contract call fails @@ -123,6 +123,7 @@ ccfToReturnValue (EnvFailure _) = Nothing data InvokeResponseCode = Success | Error !ContractCallFailure + | MessageSendFailed -- |Possible reasons why invocation failed that are not directly logic failure of a V1 call. data EnvFailure = @@ -130,7 +131,6 @@ data EnvFailure = | MissingAccount !AccountAddress | MissingContract !ContractAddress | InvalidEntrypoint !ModuleRef !ReceiveName -- Attempting to invoke a non-existing entrypoint. - | MessageFailed !Exec.RejectReason -- message to a V0 contract failed. No further information is available. deriving (Show) -- |Encode the response into 64 bits. This is necessary since Wasm only allows @@ -150,7 +150,7 @@ invokeResponseToWord64 (Error (EnvFailure e)) = MissingAccount _ -> 0xffff_ff02_0000_0000 MissingContract _ -> 0xffff_ff03_0000_0000 InvalidEntrypoint _ _ -> 0xffff_ff04_0000_0000 - MessageFailed _ -> 0xffff_ff05_0000_0000 +invokeResponseToWord64 MessageSendFailed = 0xffff_ff05_0000_0000 invokeResponseToWord64 (Error (ExecutionReject Trap)) = 0xffff_ff06_0000_0000 invokeResponseToWord64 (Error (ExecutionReject LogicReject{..})) = -- make the last 32 bits the value of the rejection reason @@ -361,7 +361,6 @@ cerToRejectReasonReceive _ _ _ (EnvFailure e) = case e of MissingAccount aref -> Exec.InvalidAccountReference aref MissingContract cref -> Exec.InvalidContractAddress cref InvalidEntrypoint mref rn -> Exec.InvalidReceiveMethod mref rn - MessageFailed rr -> rr processReceiveResult :: From 6e316098ed434c38bd5967953fd328e86f9997d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Sun, 16 Jan 2022 08:52:31 +0100 Subject: [PATCH 31/51] Allow extra exports for V1 contracts, just don't use them. --- concordium-consensus/smart-contracts | 2 +- .../Scheduler/WasmIntegration/V1.hs | 27 +- .../testdata/contracts/v1/extra-exports.wasm | Bin 0 -> 100 bytes .../testdata/contracts/v1/extra-exports.wat | 18 + .../SmartContracts/V1/ErrorCodes.hs | 361 ++++++++++++++++++ .../SmartContracts/V1/ValidInvalidModules.hs | 45 +++ concordium-consensus/tests/scheduler/Spec.hs | 2 + 7 files changed, 442 insertions(+), 13 deletions(-) create mode 100644 concordium-consensus/testdata/contracts/v1/extra-exports.wasm create mode 100644 concordium-consensus/testdata/contracts/v1/extra-exports.wat create mode 100644 concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs create mode 100644 concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index e980394b84..0f5ddf8883 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit e980394b84a305290092d33bd1942ce627f65077 +Subproject commit 0f5ddf8883c35f7b14aa9074000ade24add7dafb diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index d2462f9e76..0c68d8b989 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -135,7 +135,7 @@ data EnvFailure = -- |Encode the response into 64 bits. This is necessary since Wasm only allows -- us to pass simple scalars as parameters. Everything else requires passing --- data in memory, or via host functions, both of which are difficult.. +-- data in memory, or via host functions, both of which are difficult. -- The response is encoded as follows. -- - success is encoded as 0 -- - every failure has all bits of the first 3 bytes set @@ -155,7 +155,7 @@ invokeResponseToWord64 (Error (ExecutionReject Trap)) = 0xffff_ff06_0000_0000 invokeResponseToWord64 (Error (ExecutionReject LogicReject{..})) = -- make the last 32 bits the value of the rejection reason let unsigned = fromIntegral cerRejectReason :: Word32 -- reinterpret the bits - in 0xffff_ff00_0000_0000 .|. fromIntegral unsigned + in 0xffff_ff00_0000_0000 .|. fromIntegral unsigned -- and cut away the upper 32 bits foreign import ccall "call_init_v1" @@ -290,7 +290,8 @@ data ReceiveResultData = rrdInterruptedConfig :: !ReceiveInterruptedState } - +-- |Parse the logs that were produced. This must match serialization of logs on the other end of the ffi, +-- in smart-contracts/wasm-chain-integration/src/v1/ffi.rs getLogs :: Get [ContractEvent] getLogs = do len <- fromIntegral <$> getWord32be @@ -343,7 +344,8 @@ processInitResult result returnValuePtr = case BS.uncons result of Left err -> error $ "Internal error: Could not interpret output from interpreter: " ++ err -- The input was allocated with alloca. We allocate a fresh one with malloc (via 'new') and register --- a finalizer for it. +-- a finalizer for it. The reason for doing this is that we don't want to pre-emptively use malloc +-- when it is very likely that there will be no interrupt of the contract. newReceiveInterruptedState :: Ptr (Ptr ReceiveInterruptedState) -> IO ReceiveInterruptedState newReceiveInterruptedState interruptedStatePtr = do fp <- newForeignPtr finalizerFree =<< new =<< peek interruptedStatePtr -- allocate a new persistent location and register it for freeing. @@ -364,8 +366,7 @@ cerToRejectReasonReceive _ _ _ (EnvFailure e) = case e of processReceiveResult :: - -- |Serialized output. - BS.ByteString + BS.ByteString -- ^Serialized output. -> Ptr ReturnValue -- ^Location where the pointer to the return value is (potentially) stored. -> Either ReceiveInterruptedState (Ptr (Ptr ReceiveInterruptedState)) -- ^Location where the pointer to interrupted config is (potentially) stored. -- |Result, and remaining energy. Returns 'Nothing' if and only if @@ -496,11 +497,10 @@ resumeReceiveFun is cs statusCode rVal remainingEnergy = unsafePerformIO $ do energy = fromIntegral remainingEnergy --- |Process a module as received and make a module interface. This should --- check the module is well-formed, and has the right imports and exports. It --- should also do any pre-processing of the module (such as partial --- compilation or instrumentation) that is needed to apply the exported --- functions from it in an efficient way. +-- |Process a module as received and make a module interface. +-- This +-- - checks the module is well-formed, and has the right imports and exports for a V1 module. +-- - makes a module artifact and allocates it on the Rust side, returning a pointer and a finalizer. {-# NOINLINE processModule #-} processModule :: WasmModule -> Maybe (ModuleInterfaceV V1) processModule modl = do @@ -535,7 +535,10 @@ processModule modl = do | isValidReceiveName nameText -> let cname = "init_" <> Text.takeWhile (/= '.') nameText in return (inits, Map.insertWith Set.union (InitName cname) (Set.singleton (ReceiveName nameText)) receives) - | otherwise -> Nothing + -- ignore any other exported functions. + -- This is different from V0 contracts, which disallow any extra function exports. + -- This feature was requested by some users. + | otherwise -> return (inits, receives) ) (Set.empty, Map.empty) namesByteStrings case names of Nothing -> fail "Incorrect response from FFI call." diff --git a/concordium-consensus/testdata/contracts/v1/extra-exports.wasm b/concordium-consensus/testdata/contracts/v1/extra-exports.wasm new file mode 100644 index 0000000000000000000000000000000000000000..51ff0b91c73eaf5f7a36993a94894be77de71ead GIT binary patch literal 100 zcmXxYK?;B%5JusD93x1qlhmRcbdnO063ifHU02Udn~%qXD<=Vtp3V!J1>C!bMh`FP+zVy$Px2ChExJnH*kXmgV9x^U_KkH6(9fr literal 0 HcmV?d00001 diff --git a/concordium-consensus/testdata/contracts/v1/extra-exports.wat b/concordium-consensus/testdata/contracts/v1/extra-exports.wat new file mode 100644 index 0000000000..b4491e7ffb --- /dev/null +++ b/concordium-consensus/testdata/contracts/v1/extra-exports.wat @@ -0,0 +1,18 @@ +(module + ;; A dummy module that has extra exports that do not belong to any contracts. + ;; valid init method export + (func $init_caller (export "init_contract") (param i64) (result i32) + (return (i32.const 0)) ;; Successful init + ) + + ;; valid receive method export + (func $call (export "contract.call") (param i64) (result i32) + (i32.const 0) + ) + + ;; neither init nor receive method, and some other type + (func $somethingelse (export "something-else") (param i64) + ) + + (memory 1) +) \ No newline at end of file diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs new file mode 100644 index 0000000000..419c6096dc --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} +{-| This module tests invoking a V1 contract which invokes an operation which fails. + The test is to make sure error codes are correctly returned to the contract. +-} +module SchedulerTests.SmartContracts.V1.ErrorCodes (tests) where + +import Test.Hspec +import Test.HUnit(assertFailure, assertEqual, Assertion) + +import Control.Monad.Reader +import Data.Serialize +import qualified Data.ByteString.Short as BSS +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as OrdMap +import qualified Data.Set as Set +import Data.Word + +import qualified Concordium.Scheduler.Types as Types +import qualified Concordium.Crypto.SHA256 as Hash + +import Concordium.Types.SeedState (initialSeedState) +import Concordium.GlobalState.Persistent.BlobStore +import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlockState +import Concordium.GlobalState.Instance +import Concordium.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.Scheduler.InvokeContract as InvokeContract + +import Concordium.Types.DummyData +import Concordium.Crypto.DummyData +import Concordium.GlobalState.DummyData + +import SchedulerTests.TestUtils + +type ContextM = PersistentBlockStateMonad PV4 BlobStore (ReaderT BlobStore IO) + +-- empty state, no accounts, no modules, no instances +initialBlockState :: ContextM (HashedPersistentBlockState PV4) +initialBlockState = initialPersistentState + (initialSeedState (Hash.hash "") 1000) + dummyCryptographicParameters + [mkAccount alesVK alesAccount 1000] + dummyIdentityProviders + dummyArs + dummyKeyCollection + dummyChainParameters + +callerSourceFile :: FilePath +callerSourceFile = "./testdata/contracts/v1/caller.wasm" + +emptyContractSourceFile :: FilePath +emptyContractSourceFile = "./testdata/contracts/empty.wasm" + +wasmModVersion1 :: Word32 +wasmModVersion1 = 1 + +wasmModVersion0 :: Word32 +wasmModVersion0 = 0 + + + +deployModule1 :: PersistentBlockState PV4 -> ContextM ((GSWasm.ModuleInterfaceV GSWasm.V1, WasmModule), PersistentBlockState PV4) +deployModule1 bs = do + wasmSource <- liftIO $ BS.readFile callerSourceFile + let wm = WasmModule wasmModVersion1 (ModuleSource wasmSource) + case WasmV1.processModule wm of + Nothing -> liftIO $ assertFailure "Invalid caller module." + Just miv -> do + let mi = GSWasm.ModuleInterfaceV1 miv + (_, modState) <- bsoPutNewModule bs (mi, wm) + return ((miv, wm), modState) + +initContract1 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V1, WasmModule) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) +initContract1 bs (miv, _) = do + let cm = Types.ChainMetadata 0 + let senderAddress = alesAccount + let initContext = InitContext{ + initOrigin = senderAddress, + icSenderPolicies = [] + } + let initName = InitName "init_caller" + let initParam = emptyParameter + let initAmount = 0 + let initInterpreterEnergy = 1_000_000_000 + case WasmV1.applyInitFun miv cm initContext initName initParam initAmount initInterpreterEnergy of + Nothing -> -- out of energy + liftIO $ assertFailure "Initialization ran out of energy." + Just (Left failure, _) -> + liftIO $ assertFailure $ "Initialization failed: " ++ show failure + Just (Right WasmV1.InitSuccess{..}, _) -> do + let receiveMethods = OrdMap.findWithDefault Set.empty initName (GSWasm.miExposedReceive miv) + let mkInstance = makeInstance initName receiveMethods miv irdNewState initAmount senderAddress + bsoPutNewInstance bs mkInstance + +deployModule0 :: PersistentBlockState PV4 -> ContextM ((GSWasm.ModuleInterfaceV GSWasm.V0, WasmModule), PersistentBlockState PV4) +deployModule0 bs = do + wasmSource <- liftIO $ BS.readFile emptyContractSourceFile + let wm = WasmModule wasmModVersion0 (ModuleSource wasmSource) + case WasmV0.processModule wm of + Nothing -> liftIO $ assertFailure "Invalid caller module." + Just miv -> do + let mi = GSWasm.ModuleInterfaceV0 miv + (_, modState) <- bsoPutNewModule bs (mi, wm) + return ((miv, wm), modState) + +initContract0 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V0, WasmModule) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) +initContract0 bs (miv, _) = do + let cm = Types.ChainMetadata 0 + let senderAddress = alesAccount + let initContext = InitContext{ + initOrigin = senderAddress, + icSenderPolicies = [] + } + let initName = InitName "init_empty" + let initParam = emptyParameter + let initAmount = 0 + let initInterpreterEnergy = 1_000_000_000 + case WasmV0.applyInitFun miv cm initContext initName initParam initAmount initInterpreterEnergy of + Nothing -> -- out of energy + liftIO $ assertFailure "Initialization ran out of energy." + Just (Left failure, _) -> + liftIO $ assertFailure $ "Initialization failed: " ++ show failure + Just (Right SuccessfulResultData{..}, _) -> do + let receiveMethods = OrdMap.findWithDefault Set.empty initName (GSWasm.miExposedReceive miv) + let mkInstance = makeInstance initName receiveMethods miv newState initAmount senderAddress + bsoPutNewInstance bs mkInstance + + +-- |Invoke an entrypoint that calls the "fail" entrypoint. +-- The expected return code is +-- 0x0100_ffff_ffef +-- because +-- - the return value is pushed (hence 01) +-- - the call to "fail" fails with a "logic error" (hence the 00) +-- - the return value is -17 (which when converted with two's complement i32 is ffff_ffef) +invokeContract0 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract0 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord32le 1 -- instruction + putWord64le 0 -- contract index + putWord64le 0 -- contract subindex + putWord16le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "fail")) + putByteString "fail" -- entrypoint name + putWord64le 0 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 0, + ccMethod = ReceiveName "caller.call", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + +-- |Invoke an entrypoint that tries to transfer an amount that it does not have via contract invoke. +-- The expected return code is +-- 0x0001_0000_0000 +-- because +-- - there is no return value (hence 00) +-- - the call fails with "insufficient funds" (hence 01) +-- - the remaining is set to 0 since there is no logic error +invokeContract1 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract1 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord32le 1 -- instruction + putWord64le 0 -- contract index + putWord64le 0 -- contract subindex + putWord16le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "fail")) + putByteString "fail" -- entrypoint name + putWord64le 10000 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 0, + ccMethod = ReceiveName "caller.call", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + +-- |Invoke an entrypoint that tries to invoke a non-existing contract. +-- The expected return code is +-- 0x0003_0000_0000 +-- because +-- - there is no return value (hence 00) +-- - the call fails with "missing contract" (hence 03) +-- - the remaining is set to 0 since there is no logic error +invokeContract3 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract3 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord32le 1 -- instruction + putWord64le 1232 -- contract index, must not exist in the state + putWord64le 0 -- contract subindex + putWord16le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "fail")) + putByteString "fail" -- entrypoint name + putWord64le 0 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 0, + ccMethod = ReceiveName "caller.call", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + +-- |Invoke an entrypoint that tries to invoke a non-existing entrypoint. +-- The expected return code is +-- 0x0004_0000_0000 +-- because +-- - there is no return value (hence 00) +-- - the call fails with "invalid entrypoint" (hence 04) +-- - the remaining is set to 0 since there is no logic error +invokeContract4 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract4 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord32le 1 -- instruction + putWord64le 0 -- contract index + putWord64le 0 -- contract subindex + putWord16le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "nonexisting")) + putByteString "nonexisting" -- entrypoint name + putWord64le 0 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 0, + ccMethod = ReceiveName "caller.call", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + + +-- |Invoke an entrypoint that traps +-- The expected return code is +-- 0x0006_0000_0000 +-- because +-- - there is no return value (hence 00) +-- - the call fails with "trap" (hence 06) +-- - the remaining is set to 0 since there is no logic error +invokeContract6 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract6 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord32le 1 -- instruction + putWord64le 0 -- contract index + putWord64le 0 -- contract subindex + putWord16le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "trap")) + putByteString "trap" -- entrypoint name + putWord64le 0 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 0, + ccMethod = ReceiveName "caller.call", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + + +-- |Invoke an entrypoint that traps +-- The expected return code is +-- 0x0002_0000_0000 +-- because +-- - there is no return value (hence 00) +-- - the call fails with "missing account" (hence 02) +-- - the remaining is set to 0 since there is no logic error +invokeContract2 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract2 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord32le 0 -- instruction + put thomasAccount + putWord64le 0 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 0, + ccMethod = ReceiveName "caller.call", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + + +-- |Invoke a V0 contract such that the invocation fails. +-- The expected return code is +-- 0x0005_0000_0000 +-- because +-- - there is no return value (hence 00) +-- - the call fails with "message failed" (hence 05) +-- - the remaining is set to 0 since there is no logic error +invokeContract5 :: Types.ContractAddress -> Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract5 ccContract targetContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord32le 1 -- instruction + putWord64le (fromIntegral (Types.contractIndex targetContract)) -- contract index + putWord64le (fromIntegral (Types.contractSubindex targetContract)) -- contract subindex + putWord16le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "nonexistent")) + putByteString "nonexistent" -- entrypoint name + putWord64le 0 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 0, + ccMethod = ReceiveName "caller.call", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + + +checkSuccess :: MonadIO m => String -> Word64 -> InvokeContract.InvokeContractResult -> m () +checkSuccess msg targetValue icr = liftIO $ + case icr of + InvokeContract.Failure{..} -> assertFailure $ "Invocation failed ( " ++ show msg ++ "): " ++ show rcrReason + InvokeContract.Success{..} -> + case rcrReturnValue of + Nothing -> assertFailure $ "Invoking a V1 contract must produce a return value." + Just rv -> assertEqual msg + (BS.unpack (runPut (putWord64le targetValue))) + (BS.unpack (WasmV1.returnValueToByteString rv)) + +runCallerTests :: Assertion +runCallerTests = do + runBlobStoreTemp "." . runPersistentBlockStateMonad $ do + initState <- thawBlockState =<< initialBlockState + (mod1, bsWithMod) <- deployModule1 initState + (mod0, bsWithMods) <- deployModule0 bsWithMod + (addr1, stateWithContract1) <- initContract1 bsWithMods mod1 + (addr0, stateWithContracts') <- initContract0 stateWithContract1 mod0 + stateWithContracts <- freezeBlockState stateWithContracts' + let targetValue0 = 0x0100_ffff_ffef + invokeContract0 addr1 stateWithContracts >>= checkSuccess "Invoking a caller with logic error" targetValue0 + let targetValue1 = 0x0001_0000_0000 + invokeContract1 addr1 stateWithContracts >>= checkSuccess "Invoking a caller with insufficient funds" targetValue1 + let targetValue3 = 0x0003_0000_0000 + invokeContract3 addr1 stateWithContracts >>= checkSuccess "Invoking a non-existing contract" targetValue3 + let targetValue4 = 0x0004_0000_0000 + invokeContract4 addr1 stateWithContracts >>= checkSuccess "Invoking non-existing entrypoint" targetValue4 + let targetValue6 = 0x0006_0000_0000 + invokeContract6 addr1 stateWithContracts >>= checkSuccess "Invoking non-existing entrypoint" targetValue6 + let targetValue2 = 0x0002_0000_0000 + invokeContract2 addr1 stateWithContracts >>= checkSuccess "Transferring to missing account" targetValue2 + + let targetValue5 = 0x0005_0000_0000 + invokeContract5 addr1 addr0 stateWithContracts >>= checkSuccess "Invoking a V0 contract that fails." targetValue5 + + +tests :: Spec +tests = describe "V1: Invoke contract" $ do + specify "Caller contract" $ runCallerTests diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs new file mode 100644 index 0000000000..458853c73b --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} +{-| This module tests validating modules of various kinds to test that + they may or may not be deployed. +-} +module SchedulerTests.SmartContracts.V1.ValidInvalidModules (tests) where + +import Test.Hspec +import Test.HUnit(assertFailure, assertEqual, Assertion) + +import qualified Data.ByteString as BS +import Data.Word +import qualified Data.Set as Set +import qualified Data.Map.Strict as Map + +import Concordium.Wasm +import qualified Concordium.GlobalState.Wasm as GSWasm +import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 +import qualified Concordium.Scheduler.WasmIntegration as WasmV0 + +wasmModVersion1 :: Word32 +wasmModVersion1 = 1 + +wasmModVersion0 :: Word32 +wasmModVersion0 = 0 + +-- |A V1 module with extra exports. +testModule1 :: Assertion +testModule1 = do + wasmSource <- BS.readFile "./testdata/contracts/v1/extra-exports.wasm" + let wm1 = WasmModule wasmModVersion1 (ModuleSource wasmSource) + case WasmV1.processModule wm1 of + Nothing -> assertFailure "Invalid caller module." + Just GSWasm.ModuleInterface{..} -> do + assertEqual "Only valid init functions should be exposed" (Set.singleton (InitName "init_contract")) miExposedInit + let expectedReceive = Map.singleton (InitName "init_contract") (Set.singleton (ReceiveName "contract.call")) + assertEqual "Only valid receive functions should be exposed" expectedReceive miExposedReceive + let wm0 = WasmModule wasmModVersion0 (ModuleSource wasmSource) + case WasmV0.processModule wm0 of + Nothing -> return () + Just _ -> assertFailure "Extra exports are not allowed for V0 modules." + +tests :: Spec +tests = describe "V1: Process modules" $ do + specify "Extra exports" testModule1 diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index b7479d71c2..b2b5702a25 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -30,6 +30,7 @@ import qualified SchedulerTests.SmartContracts.V1.Transfer(tests) import qualified SchedulerTests.SmartContracts.V1.CrossMessaging(tests) import qualified SchedulerTests.SmartContracts.Invoke (tests) import qualified SchedulerTests.SmartContracts.V1.ErrorCodes (tests) +import qualified SchedulerTests.SmartContracts.V1.ValidInvalidModules (tests) import Test.Hspec @@ -64,3 +65,4 @@ main = hspec $ do SchedulerTests.SmartContracts.V1.CrossMessaging.tests SchedulerTests.SmartContracts.Invoke.tests SchedulerTests.SmartContracts.V1.ErrorCodes.tests + SchedulerTests.SmartContracts.V1.ValidInvalidModules.tests From 0aa7fb1fe13ba322d129fe397d39acc1fb4f6277 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Sun, 16 Jan 2022 19:08:42 +0100 Subject: [PATCH 32/51] Add some general documentation about contracts. --- docs/contracts.md | 249 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 249 insertions(+) create mode 100644 docs/contracts.md diff --git a/docs/contracts.md b/docs/contracts.md new file mode 100644 index 0000000000..0afcebfa5d --- /dev/null +++ b/docs/contracts.md @@ -0,0 +1,249 @@ +# Smart contracts + +This document describes the smart contracts from the perspective of the node and +the consensus protocol. + +Smart contracts are based on WebAssembly, specifically on the [first standardised +version of Wasm](https://www.w3.org/TR/wasm-core-1/) with additional +restrictions. These restrictions are +- all floating point instructions and types are disallowed +- initial memory size is limited to 32 pages +- maximum number of locals allowed in functions is 1024 +- maximum stack height is 1024 (this means locals + dynamic stack height) +- the number of globals is limited to 1024 +- the maximum number of cases in a switch statement is limited to 4096 +- the list of imports is restricted to allowed ones +- the list of exports is restricted, names and types are restricted + (restrictions differ between V0 and V1 versions, see below) +- Wasm modules cannot have an initialization function. +- The size of the module is restricted. The limit is different for V0 and V1 modules. + +Smart contracts interact with the chain through the exposed **host functions**. This +is a general Wasm concept that allows controlled sandboxing. The host functions +that are allowed are listed for V0 and V1 contracts below. + +There are three operations related to smart contracts +- **deploying** a Wasm module. This registers a new Wasm module on the chain. The + module is validated and processed into an "Artifact" which is ready to + execute. This processing also adds resource accounting, see the [NRG](#nrg) section + below. +- **initializing** a smart contract instance. Given a deployed module and a name of + the contract construct a new contract instance. This has its own state and + balance. +- **updating** an existing smart contract instance. This can affect other smart + contract instances by sending messages, or operation invocation, depending on + the version of the instance. + +These operations are triggered by transactions, and orchestrated by the +scheduler component of the node. The execution of these operations, e.g., +validation, execution of the contract code, is done by a custom validator and +interpreter. These are implemented in Rust in the +[smart-contracts](../concordium-consensus/smart-contracts/) repository. + +## NRG + +Since smart contracts are general programs that are inherently untrusted we must +prevent resource exhaustion by expensive, or even unbounded computations. +The Wasm runtime keeps track of a resource measure called "interpreter energy". +Because NRG is not granular enough, interpreter energy is not the same as NRG, +but there is a conversion factor, currently 1000 interpreter energy is 1 NRG. + +Resource accounting is achieved via a program transformation that adds +additional instructions to the source program. These instructions charge +interpreter energy for each straight-line block of code. This is achieved via +calls to host functions. Hence the final artifact has, in addition to the host +functions listed below, also host functions for keeping track of NRG. + +## Implementation details + +The general design at present is that all the runtime structures are maintained +in the Rust heap and the Haskell runtime maintains pointers to these structures. +It also manages their lifetime and deallocates them when needed. This includes +- module artifacts. This is a processed Wasm module that is easier and quicker + to execute. It is design to be cheap to look up and deserialize from + persistent storage. +- for V1 contracts a suspended state of the execution. When a contract invokes + an operation we must suspend its execution and store the state so it can be + resumed. + +The execution of a contract invocation is initiated by the scheduler which +invokes the relevant functions through FFI. Execution then proceeds as far as +possible. For V0 contracts this means until termination of the initialization +function or contract entrypoint, however for V1 contracts execution can also be +interrupted. Upon this control is handed back to the scheduler which parses the +response and decides what needs to be done next. + +The scheduler also manages the state of the contract, its checkpointing, and +rollbacks. + +# V0 contracts + +TODO: Write information about V0 interface, restrictions. + +# V1 contracts + +V1 contracts differ from V0 contracts in both the way their state is managed, +and in the way they interact with other contracts. + +The following host functions are available to V1 contracts. The host functions +are written as type signature in Rust syntax. The mapping of types is +- `u32`/`i32` in Rust are `i32` in Wasm +- `u64`/`i64` in Rust are `i64` in Wasm +- `*const S`/`*mut S` for a sized S are `i32` in Wasm (since Wasm is a 32-bit platform) + +## Invoke an operation +```rust +/// Invoke a host instruction. The arguments are +/// +/// - `tag`, which instruction to invoke +/// - 0 for transfer to account +/// - 1 for call to a contract +/// - `start`, pointer to the start of the invoke payload +/// - `length`, length of the payload +/// The return value positive indicates success or failure, and additional +/// information in those cases. The complete specification is as follows +/// - if the last 5 bytes are 0 then the call succeeded. In this case the first +/// bit of the response indicates whether our own state has changed (1) or not (0) +/// the remaining 23 bits are the index of the return value that can be used +/// in a call to `get_parameter_section` and `get_parameter_size`. +/// - otherwise +/// - if the fourth byte is 0 the call failed because of a logic error and +/// there is a return value. Bits 1..24 of the response are the index of the +/// return value. Bits 32..64 are to be interpreted in two's complement and +/// will be a negative number indicating the error code. +/// - otherwise only the fourth byte is set. +/// - if it is 1 then call failed due to transfer of non-existent amount +/// - if it is 2 then the account to transfer to did not exist +/// - if it is 3 then the contract to invoke did not exist +/// - if it is 4 then the entrypoint did not exist +/// - if it is 5 then sending a message to V0 contract failed. +/// - if it is 6 then invoking a contract failed with a runtime error +/// - no other values are possible +fn invoke(tag: u32, start: *const u8, length: u32) -> u64; +``` + +## Returning from a contract + +A contract can produce a return value, in addition to the return code. The +return value is modelled as a writable buffer. If nothing is written, it is +empty. + +```rust +/// Write to the return value of the contract. The parameters are +/// +/// - `start` the pointer to the location in memory where the data resides +/// - `length` the size of data (in bytes) +/// - `offset` where in the return value to write the data +/// +/// The return value indicates how many bytes were written. +fn write_output(start: *const u8, length: u32, offset: u32) -> u32; +``` + +## Parameters and observing return values from calls + +Each contract invocation starts with a parameter. If then a contract invokes +another contract, which produces a return value, that return value is added to +the stack of parameters the original contract can observe. + +```rust +/// Get the size of the `i`-th parameter to the call. 0-th parameter is +/// always the original parameter that the method was invoked with, +/// calling invoke adds additional parameters to the stack. Returns `-1` +/// if the given parameter does not exist. +fn get_parameter_size(i: u32) -> i32; +/// Write a section of the `i`-th parameter to the given location. Return +/// the number of bytes written or `-1` if the parameter does not exist. +/// The location is assumed to contain enough memory to +/// write the requested length into. +fn get_parameter_section( + i: u32, + param_bytes: *mut u8, + length: u32, + offset: u32, +) -> i32; +``` + +## Obtaining information about the invoker + +Obtain policies on all credentials of the invoker. If the invoker is a contract +it is the credentials of the owner that are returned. If it is an account, then +the credentials of the account are returned. + +```rust +/// Write a section of the policy to the given location. Return the number +/// of bytes written. The location is assumed to contain enough memory to +/// write the requested length into. +fn get_policy_section(policy_bytes: *mut u8, length: u32, offset: u32) -> u32; +``` + +## Logging + +Contracts can output a small amount of data during execution. This data is +available in a transaction status and can be queried. + +```rust +/// Add a log item. Return values are +/// - -1 if logging failed due to the message being too long +/// - 0 if the log is already full +/// - 1 if data was successfully logged. +fn log_event(start: *const u8, length: u32) -> i32; +``` + +## State operations + +TODO: This will change for P4. + +```rust +/// returns how many bytes were read. +fn load_state(start: *mut u8, length: u32, offset: u32) -> u32; +/// Modify the contract state, and return how many bytes were written +fn write_state(start: *const u8, length: u32, offset: u32) -> u32; +/// Resize state to the new value (truncate if new size is smaller). Return +/// 0 if this was unsuccesful (new state too big), or 1 if successful. +fn resize_state(new_size: u32) -> u32; +/// Get the current state size in bytes. +fn state_size() -> u32; +``` + +## Chain metadata + +Time of the block is available to all methods. This is the only chain metadata +contracts can observe, e.g., block height and similar implementation details are +not available. + +```rust +/// Slot time (in milliseconds) of the block the transaction is being executed in. +fn get_slot_time() -> u64; +``` + +## Caller context available only to init methods + +```rust +/// Address of the sender, 32 bytes. +/// The address is written to the provided location, which must be able to hold +/// 32 bytes. +fn get_init_origin(start: *mut u8); +``` + +## Caller context available only to receive methods + +```rust +/// Invoker of the top-level transaction, AccountAddress. +/// The address is written to the provided location, which must be able to hold +/// 32 bytes. +fn get_receive_invoker(start: *mut u8); +/// Address of the contract itself, ContractAddress. +/// The address is written to the provided location, which must be able to hold +/// 16 bytes. +fn get_receive_self_address(start: *mut u8); +/// Self-balance of the contract, returns the amount in microCCD. +fn get_receive_self_balance() -> u64; +/// Immediate sender of the message (either contract or account). +/// The address is written to the provided location, which must be able to hold +/// 33 bytes. +fn get_receive_sender(start: *mut u8); +/// Owner of the contract, AccountAddress. +/// The address is written to the provided location, which must be able to hold +/// 32 bytes. +fn get_receive_owner(start: *mut u8); +``` From 07da4ed3279a24adf4e07d82653f5d1ab52871ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Sun, 16 Jan 2022 19:49:23 +0100 Subject: [PATCH 33/51] Documentation of invoking a contract. --- .../src/Concordium/Scheduler.hs | 43 ++++++++++++++++--- .../Concordium/Scheduler/InvokeContract.hs | 27 +++++++++--- 2 files changed, 57 insertions(+), 13 deletions(-) diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index aeac7d5d58..c0118e8c6c 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -793,6 +793,7 @@ handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = Left cer -> rejectTransaction (WasmV1.cerToRejectReasonReceive uAddress uReceiveName uMessage cer) Right (_, events) -> return events +-- |Check that the account has sufficient balance, and construct credentials of the account. checkAndGetBalanceAccountV1 :: (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^Used address -> IndexedAccount m @@ -807,6 +808,9 @@ checkAndGetBalanceAccountV1 usedAddress senderAccount transferAmount = do else return (Left (WasmV1.EnvFailure (WasmV1.AmountTooLarge senderAddr transferAmount))) +-- |Check that the account has sufficient balance, and construct credentials of the account. +-- In contrast to the V1 version above this one uses the TransactionMonad's error handling +-- to raise an error, instead of returning it. checkAndGetBalanceAccountV0 :: (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^Used address -> IndexedAccount m @@ -822,6 +826,7 @@ checkAndGetBalanceAccountV0 usedAddress senderAccount transferAmount = do rejectTransaction (AmountTooLarge senderAddr transferAmount) +-- |Check that the instance has sufficient balance, and construct credentials of the owner account. checkAndGetBalanceInstanceV1 :: (TransactionMonad pv m, AccountOperations m) => IndexedAccount m -> InstanceV vOrigin @@ -835,7 +840,9 @@ checkAndGetBalanceInstanceV1 ownerAccount istance transferAmount = do else return (Left (WasmV1.EnvFailure (WasmV1.AmountTooLarge senderAddr transferAmount))) - +-- |Check that the instance has sufficient balance, and construct credentials of the owner account. +-- In contrast to the V1 version above this one uses the TransactionMonad's error handling +-- to raise an error, instead of returning it. checkAndGetBalanceInstanceV0 :: (TransactionMonad pv m, AccountOperations m) => IndexedAccount m -> InstanceV vOrigin @@ -849,7 +856,11 @@ checkAndGetBalanceInstanceV0 ownerAccount istance transferAmount = do else rejectTransaction (AmountTooLarge senderAddr transferAmount) - +-- |Handle updating a V1 contract. +-- In contrast to most other methods in this file this one does not use the +-- error handling facilities of the transaction monad. Instead it explicitly returns an Either type. +-- The reason for this is the possible errors are exposed back to the smart contract in case +-- a contract A invokes contract B's entrypoint. handleContractUpdateV1 :: forall pv m. (TransactionMonad pv m, AccountOperations m) => AccountAddress -- ^The address that was used to send the top-level transaction. @@ -900,11 +911,14 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei -- charge for looking up the module tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) - -- we've covered basic administrative costs now. Now iterate until the end of execution, handling any interrupts. + -- we've covered basic administrative costs now. + -- The @go@ function iterates until the end of execution, handling any interrupts by dispatching + -- to appropriate handlers. let go :: [Event] -> Either WasmV1.ContractExecutionReject WasmV1.ReceiveResultData + -- ^Result of invoking an operation -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) - go _ (Left cer) = return (Left (WasmV1.ExecutionReject cer)) + go _ (Left cer) = return (Left (WasmV1.ExecutionReject cer)) -- contract execution failed. go events (Right rrData) = case rrData of WasmV1.ReceiveSuccess{..} -> do @@ -919,6 +933,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei } in return (Right (rrdReturnValue, event:events)) WasmV1.ReceiveInterrupt{..} -> do + -- execution invoked an operation. Dispatch and continue. let interruptEvent = Interrupted{ iAddress = instanceAddress istance, iEvents = rrdLogs @@ -928,28 +943,44 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei .. } case rrdMethod of + -- the operation is an account transfer, so we handle it. WasmV1.Transfer{..} -> runExceptT (transferAccountSync imtTo istance imtAmount) >>= \case Left errCode -> do go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) Right transferEvents -> go (resumeEvent True:transferEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing WasmV1.Success Nothing) WasmV1.Call{..} -> - -- commit the current state of the contract. + -- the operation is a call to another contract. There is a bit of complication because the contract could be a V0 + -- or V1 one, and the behaviour is different depending on which one it is. + -- First, commit the current state of the contract. + -- TODO: With the new state, only do this if the state has actually changed. withInstanceStateV1 istance rrdCurrentState $ \modificationIndex -> do - -- lookup the instance + -- lookup the instance to invoke getCurrentContractInstanceTicking' imcTo >>= \case + -- we could not find the instance, return this to the caller and continue Nothing -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MissingContract imcTo))) Nothing) Just (InstanceV0 targetInstance) -> do + -- we are invoking a V0 instance. + -- in this case we essentially treat this as a top-level transaction invoking that contract. + -- That is, we execute the entire tree that is potentially generated. let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstanceV0 ownerAccount istance) imcAmount rName imcParam + -- If execution of the contract succeeds resume. + -- Otherwise rollback the state and report that to the caller. (runSuccess `orElseWith` (return . Left)) >>= \case Left _ -> -- execution failed, ignore the reject reason since V0 contract cannot return useful information go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing WasmV1.MessageSendFailed Nothing) Right evs -> do + -- Execution of the contract might have changed our own state. If so, we need to resume in the new state, otherwise + -- we can keep the old one. (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState go (resumeEvent True:evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState WasmV1.Success Nothing) Just (InstanceV1 targetInstance) -> do + -- invoking a V1 instance is easier we recurse on the update function. + -- If this returns Right _ it is successful, and we pass this, and the returned return value + -- to the caller. + -- Otherwise we roll back all the changes and return the return value, and the error code to the caller. let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstanceV1 ownerAccount istance) imcAmount rName imcParam) >>= \case Left cer -> diff --git a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs index f25b614502..401202ea33 100644 --- a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -15,6 +15,7 @@ import Lens.Micro.Platform import Control.Monad.Reader import qualified Data.FixedByteString as FBS +import qualified Concordium.ID.Types as ID import qualified Concordium.Wasm as Wasm import Concordium.Logger import Concordium.GlobalState.Types @@ -130,33 +131,45 @@ instance AE.ToJSON InvokeContractResult where -- |Invoke the contract in the given context. invokeContract :: forall pv m . (IsProtocolVersion pv, BS.BlockStateQuery m) => - SProtocolVersion pv -- An argument to fix the protocol version, to make the type non-ambiguous. + SProtocolVersion pv -- ^An argument to fix the protocol version, to make the type non-ambiguous. -> ContractContext -- ^Context in which to invoke the contract. -> ChainMetadata -- ^Chain metadata corresponding to the block state. -> BlockState m -- ^The block state in which to invoke the contract. -> m InvokeContractResult invokeContract _ ContractContext{..} cm bs = do - let getInvoker = + -- construct an invoker. Since execution of a contract might depend on this + -- it is necessary to provide some value. However since many contract entrypoints will + -- not depend on this it is useful to default to a dummy value if the value is not provided. + let getInvoker :: InvokeContractMonad pv m + (Either + (Maybe RejectReason) -- Invocation failed because the relevant contract/account does not exist. + ( -- Check that the requested account or contract has enough balance. + Amount -> LocalT pv r (InvokeContractMonad pv m) (Address, [ID.AccountCredential], Either ContractAddress IndexedAccountAddress), + AccountAddress, -- Address of the invoker account, or of its owner if the invoker is a contract. + AccountIndex -- And its index. + )) + getInvoker = case ccInvoker of - Nothing -> -- if the invoker is not supplied create a dummy one + Nothing -> -- if the invoker is not supplied create a dummy one with no credentials let zeroAddress = AccountAddress . FBS.pack . replicate 32 $ 0 maxIndex = maxBound in return (Right (const (return (AddressAccount zeroAddress, [], Right (maxIndex, zeroAddress))), zeroAddress, maxIndex)) + -- if the invoker is an address make sure it exists Just (AddressAccount accInvoker) -> getAccount accInvoker >>= \case Nothing -> return (Left (Just (InvalidAccountReference accInvoker))) - Just acc -> return (Right (checkAndGetBalanceAccountV0 accInvoker acc, accInvoker, (fst acc))) + Just acc -> return (Right (checkAndGetBalanceAccountV0 accInvoker acc, accInvoker, fst acc)) Just (AddressContract contractInvoker) -> getContractInstance contractInvoker >>= \case Nothing -> return (Left (Just (InvalidContractAddress contractInvoker))) Just (Instance.InstanceV0 i@Instance.InstanceV{..}) -> do let ownerAccountAddress = instanceOwner _instanceVParameters getAccount ownerAccountAddress >>= \case Nothing -> return (Left (Just $ InvalidAccountReference ownerAccountAddress)) - Just acc -> return (Right (checkAndGetBalanceInstanceV0 acc i, ownerAccountAddress, (fst acc))) + Just acc -> return (Right (checkAndGetBalanceInstanceV0 acc i, ownerAccountAddress, fst acc)) Just (Instance.InstanceV1 i@Instance.InstanceV{..}) -> do let ownerAccountAddress = instanceOwner _instanceVParameters getAccount ownerAccountAddress >>= \case Nothing -> return (Left (Just $ InvalidAccountReference ownerAccountAddress)) - Just acc -> return (Right (checkAndGetBalanceInstanceV0 acc i, ownerAccountAddress, (fst acc))) + Just acc -> return (Right (checkAndGetBalanceInstanceV0 acc i, ownerAccountAddress, fst acc)) let runContractComp = getInvoker >>= \case Left err -> return (Left err, ccEnergy) @@ -170,7 +183,7 @@ invokeContract _ ContractContext{..} cm bs = do return (r, _energyLeft cs) contextState = ContextState{_maxBlockEnergy = ccEnergy, _accountCreationLimit = 0, _chainMetadata = cm} runReaderT (_runInvokeContract runContractComp) (contextState, bs) >>= \case - (Left Nothing, re) -> -- cannot happen, but this is safe to do and not wrong + (Left Nothing, re) -> -- cannot happen (this would mean out of block energy), but this is safe to do and not wrong return Failure{rcrReason = OutOfEnergy, rcrUsedEnergy = ccEnergy - re} (Left (Just rcrReason), re) -> return Failure{rcrUsedEnergy = ccEnergy - re,..} From 8a0ff6bb1c54325371267c90838f45f6530d57cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Sun, 16 Jan 2022 21:57:49 +0100 Subject: [PATCH 34/51] Version module source as well in order to match versions. --- concordium-base | 2 +- .../GlobalState/Basic/BlockState/Modules.hs | 43 ++++++++++--------- .../src/Concordium/GlobalState/BlockState.hs | 3 +- .../GlobalState/Persistent/BlobStore.hs | 1 + .../GlobalState/Persistent/BlockState.hs | 4 +- .../Persistent/BlockState/Modules.hs | 42 ++++++++++-------- .../src/Concordium/GlobalState/Wasm.hs | 18 -------- .../src/Concordium/Scheduler.hs | 28 ++++++------ .../src/Concordium/Scheduler/Environment.hs | 3 +- .../src/Concordium/Scheduler/Runner.hs | 17 ++++---- .../Concordium/Scheduler/WasmIntegration.hs | 7 ++- .../Scheduler/WasmIntegration/V1.hs | 6 +-- .../src/Concordium/Skov/Monad.hs | 1 + .../scheduler/SchedulerTests/ChainMetatest.hs | 5 ++- .../FibonacciSelfMessageTest.hs | 6 +-- .../SchedulerTests/InitContextTest.hs | 4 +- .../SchedulerTests/InitPoliciesTest.hs | 2 +- .../SchedulerTests/ReceiveContextTest.hs | 9 ++-- .../scheduler/SchedulerTests/RejectReasons.hs | 11 ++--- .../RejectReasonsRustContract.hs | 6 +-- .../SchedulerTests/SimpleTransferSpec.hs | 4 +- .../SchedulerTests/SmartContractTests.hs | 9 ++-- .../SchedulerTests/SmartContracts/Invoke.hs | 14 ++---- .../SmartContracts/V1/Counter.hs | 7 ++- .../SmartContracts/V1/CrossMessaging.hs | 9 ++-- .../SmartContracts/V1/ErrorCodes.hs | 26 ++++------- .../SmartContracts/V1/Transfer.hs | 7 ++- .../SmartContracts/V1/ValidInvalidModules.hs | 11 +---- .../scheduler/SchedulerTests/TrySendTest.hs | 4 +- 29 files changed, 142 insertions(+), 167 deletions(-) diff --git a/concordium-base b/concordium-base index 60f6b5bb58..d1f976e29b 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 60f6b5bb58a73c70758aa33accf9635ee47feb62 +Subproject commit d1f976e29b4bed71d187661365ad31bf9a3cf880 diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs index 87a822e004..b0be434709 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module Concordium.GlobalState.Basic.BlockState.Modules ( Module(..), ModuleV(..), @@ -48,7 +50,7 @@ data ModuleV v = ModuleV { -- | The instrumented module, ready to be instantiated. moduleVInterface :: !(GSWasm.ModuleInterfaceV v), -- | The raw module binary source. - moduleVSource :: !WasmModule + moduleVSource :: !(WasmModuleV v) } deriving (Show) -- Create the class HasSource a with functions @@ -70,13 +72,10 @@ fromModule (ModuleV0 v) = GSWasm.ModuleInterfaceV0 (moduleVInterface v) fromModule (ModuleV1 v) = GSWasm.ModuleInterfaceV1 (moduleVInterface v) -- |Helper to convert from an interface to a module. -toModule :: GSWasm.ModuleInterface -> WasmModule -> Module -toModule (GSWasm.ModuleInterfaceV0 moduleVInterface) moduleVSource = ModuleV0 ModuleV{..} -toModule (GSWasm.ModuleInterfaceV1 moduleVInterface) moduleVSource = ModuleV1 ModuleV{..} - -instance HasSource Module WasmModule where - source f (ModuleV0 m) = ModuleV0 <$> source f m - source f (ModuleV1 m) = ModuleV1 <$> source f m +toModule :: forall v . IsWasmVersion v => GSWasm.ModuleInterfaceV v -> WasmModuleV v -> Module +toModule moduleVInterface moduleVSource = case getWasmVersion @v of + SV0 -> ModuleV0 ModuleV{..} + SV1 -> ModuleV1 ModuleV{..} instance GSWasm.HasModuleRef Module where {-# INLINE moduleReference #-} @@ -87,17 +86,19 @@ instance HashableTo Hash Module where getHash = coerce . GSWasm.moduleReference instance Serialize Module where - put = put . (^. source) + put (ModuleV0 ModuleV{..}) = put moduleVSource + put (ModuleV1 ModuleV{..}) = put moduleVSource get = do - moduleVSource <- get - case wasmVersion moduleVSource of - 0 -> case V0.processModule moduleVSource of - Nothing -> fail "Invalid V0 module" - Just moduleVInterface -> return (ModuleV0 ModuleV {..}) - 1 -> case V1.processModule moduleVSource of - Nothing -> fail "Invalid V1 module" - Just moduleVInterface -> return (ModuleV1 ModuleV{..}) - v -> fail $ "Unsupported module version: " ++ show v + wasmModule <- get + case wasmModule of + WasmModuleV0 moduleVSource -> + case V0.processModule moduleVSource of + Nothing -> fail "Invalid V0 module" + Just moduleVInterface -> return (ModuleV0 ModuleV {..}) + WasmModuleV1 moduleVSource -> + case V1.processModule moduleVSource of + Nothing -> fail "Invalid V1 module" + Just moduleVInterface -> return (ModuleV1 ModuleV {..}) -------------------------------------------------------------------------------- @@ -123,7 +124,7 @@ emptyModules = Modules LFMB.empty Map.empty -- |Try to add interfaces to the module table. If a module with the given -- reference exists returns @Nothing@. -putInterface :: (GSWasm.ModuleInterface, WasmModule) -> Modules -> Maybe Modules +putInterface :: IsWasmVersion v => (GSWasm.ModuleInterfaceV v, WasmModuleV v) -> Modules -> Maybe Modules putInterface (iface, mSource) m = if Map.member mref (m ^. modulesMap) then Nothing @@ -142,7 +143,9 @@ getInterface ref mods = fromModule <$> getModule ref mods -- |Get the source of a module by module reference. getSource :: ModuleRef -> Modules -> Maybe WasmModule -getSource ref mods = (^. source) <$> getModule ref mods +getSource ref mods = mp <$> getModule ref mods + where mp (ModuleV0 ModuleV{..}) = WasmModuleV0 moduleVSource + mp (ModuleV1 ModuleV{..}) = WasmModuleV1 moduleVSource moduleRefList :: Modules -> [ModuleRef] moduleRefList mods = Map.keys (mods ^. modulesMap) diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index c873113430..4b0becafbb 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -1,4 +1,5 @@ {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-| Definition of the API of every BlockState implementation. @@ -322,7 +323,7 @@ class (BlockStateQuery m) => BlockStateOperations m where bsoPutNewInstance :: UpdatableBlockState m -> (ContractAddress -> Instance) -> m (ContractAddress, UpdatableBlockState m) -- |Add the module to the global state. If a module with the given address -- already exists return @False@. - bsoPutNewModule :: UpdatableBlockState m -> (GSWasm.ModuleInterface, Wasm.WasmModule) -> m (Bool, UpdatableBlockState m) + bsoPutNewModule :: Wasm.IsWasmVersion v => UpdatableBlockState m -> (GSWasm.ModuleInterfaceV v, Wasm.WasmModuleV v) -> m (Bool, UpdatableBlockState m) -- |Modify an existing account with given data (which includes the address of the account). -- This method is only called when an account exists and can thus assume this. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index a2c25e44ef..2ca9aae058 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -746,6 +746,7 @@ instance MonadBlobStore m => BlobStorable m TransactionFeeDistribution instance MonadBlobStore m => BlobStorable m GASRewards instance MonadBlobStore m => BlobStorable m (Map AccountAddress Timestamp) instance MonadBlobStore m => BlobStorable m WasmModule +instance (IsWasmVersion v, MonadBlobStore m) => BlobStorable m (WasmModuleV v) newtype StoreSerialized a = StoreSerialized { unStoreSerialized :: a } deriving newtype (Serialize) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 5a2b0043a2..357782bf6e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -534,9 +534,9 @@ doGetModuleSource s modRef = do mods <- refLoad (bspModules bsp) Modules.getSource modRef mods -doPutNewModule :: (IsProtocolVersion pv, MonadBlobStore m) +doPutNewModule :: (IsProtocolVersion pv, Wasm.IsWasmVersion v, MonadBlobStore m) => PersistentBlockState pv - -> (GSWasm.ModuleInterface, Wasm.WasmModule) + -> (GSWasm.ModuleInterfaceV v, Wasm.WasmModuleV v) -> m (Bool, PersistentBlockState pv) doPutNewModule pbs (pmInterface, pmSource) = do bsp <- loadPBS pbs diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs index 3b1faadf95..40cec0fcdc 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} module Concordium.GlobalState.Persistent.BlockState.Modules ( Module(..), @@ -30,7 +32,6 @@ import Concordium.Types import Concordium.Types.HashableTo import Concordium.Utils.Serialization.Put import Concordium.Wasm -import Control.Monad import Data.Coerce import Data.Foldable import Data.Map.Strict (Map) @@ -53,7 +54,7 @@ data ModuleV v = ModuleV { moduleVInterface :: !(GSWasm.ModuleInterfaceV v), -- | A plain reference to the raw module binary source. This is generally not needed by consensus, so -- it is almost always simply kept on disk. - moduleVSource :: !(BlobRef WasmModule) + moduleVSource :: !(BlobRef (WasmModuleV v)) } deriving(Show) @@ -63,10 +64,11 @@ data ModuleV v = ModuleV { makeFields ''ModuleV -- |Helper to convert from an interface to a module. -toModule :: GSWasm.ModuleInterface -> BlobRef WasmModule -> Module -toModule (GSWasm.ModuleInterfaceV0 moduleVInterface) moduleVSource = ModuleV0 ModuleV{..} -toModule (GSWasm.ModuleInterfaceV1 moduleVInterface) moduleVSource = ModuleV1 ModuleV{..} - +toModule :: forall v . IsWasmVersion v => GSWasm.ModuleInterfaceV v -> BlobRef (WasmModuleV v) -> Module +toModule moduleVInterface moduleVSource = + case getWasmVersion @v of + SV0 -> ModuleV0 ModuleV{..} + SV1 -> ModuleV1 ModuleV{..} -- |A module, either of version 0 or 1. This is only used when storing a module -- independently, e.g., in the module table. When a module is referenced from a @@ -77,10 +79,6 @@ data Module where ModuleV1 :: ModuleV GSWasm.V1 -> Module deriving (Show) -instance HasSource Module (BlobRef WasmModule) where - source f (ModuleV0 m) = ModuleV0 <$> source f m - source f (ModuleV1 m) = ModuleV1 <$> source f m - getModuleInterface :: Module -> GSWasm.ModuleInterface getModuleInterface (ModuleV0 m) = GSWasm.ModuleInterfaceV0 (moduleVInterface m) getModuleInterface (ModuleV1 m) = GSWasm.ModuleInterfaceV1 (moduleVInterface m) @@ -101,12 +99,18 @@ instance Monad m => MHashableTo m Hash Module instance Serialize Module where get = do -- interface is versioned - moduleVInterface <- get - moduleVSource <- get - return $! toModule moduleVInterface moduleVSource + get >>= \case + GSWasm.ModuleInterfaceV0 moduleVInterface -> do + moduleVSource <- get + return $! toModule moduleVInterface moduleVSource + GSWasm.ModuleInterfaceV1 moduleVInterface -> do + moduleVSource <- get + return $! toModule moduleVInterface moduleVSource put m = do put (getModuleInterface m) - put (m ^. source) + case m of + ModuleV0 ModuleV{..} -> put moduleVSource + ModuleV1 ModuleV{..} -> put moduleVSource -- |This serialization is used for storing the module in the BlobStore. -- It should not be used for other purposes. @@ -137,7 +141,8 @@ instance MonadBlobStore m => Cacheable m Module where -- |Serialize a module in V0 format. -- This only serializes the source. putModuleV0 :: (MonadBlobStore m, MonadPut m) => Module -> m () -putModuleV0 = sPut <=< loadRef . (^. source) +putModuleV0 (ModuleV0 ModuleV{..}) = sPut =<< loadRef moduleVSource +putModuleV0 (ModuleV1 ModuleV{..}) = sPut =<< loadRef moduleVSource -------------------------------------------------------------------------------- @@ -181,8 +186,8 @@ emptyModules = Modules LFMB.empty Map.empty -- |Try to add interfaces to the module table. If a module with the given -- reference exists returns @Nothing@. -putInterface :: MonadBlobStore m - => (GSWasm.ModuleInterface, WasmModule) +putInterface :: (IsWasmVersion v, MonadBlobStore m) + => (GSWasm.ModuleInterfaceV v, WasmModuleV v) -> Modules -> m (Maybe Modules) putInterface (modul, src) m = @@ -236,7 +241,8 @@ getSource ref mods = do m <- getModule ref mods case m of Nothing -> return Nothing - Just modul -> Just <$> loadRef (modul ^. source) + Just (ModuleV0 ModuleV{..}) -> Just . WasmModuleV0 <$> loadRef moduleVSource + Just (ModuleV1 ModuleV{..}) -> Just . WasmModuleV1 <$> loadRef moduleVSource -- |Get the list of all currently deployed modules. -- The order of the list is not specified. diff --git a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs index a25cd2d220..cc18084725 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs @@ -57,24 +57,6 @@ foreign import ccall unsafe "artifact_v1_from_bytes" fromBytesArtifactV1 :: Ptr newtype ModuleArtifact (v :: WasmVersion) = ModuleArtifact { maArtifact :: ForeignPtr (ModuleArtifact v) } deriving(Eq, Show) -- the Eq and Show instances are only for debugging and compare and show pointers. --- |Supported versions of Wasm modules. This version defines available host --- functions, their semantics, and limitations of contracts. -data WasmVersion = V0 | V1 - -instance Serialize WasmVersion where - put V0 = putWord32be 0 - put V1 = putWord32be 1 - - get = getWord32be >>= \case - 0 -> return V0 - 1 -> return V1 - n -> fail $ "Unrecognized Wasm version " ++ show n - --- These type aliases are provided for convenience to avoid having to enable --- DataKinds everywhere we need wasm version. -type V0 = 'V0 -type V1 = 'V1 - type ModuleArtifactV0 = ModuleArtifact V0 type ModuleArtifactV1 = ModuleArtifact V1 diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index c0118e8c6c..d9bd9a18ca 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -99,8 +99,9 @@ import Concordium.Scheduler.WasmIntegration.V1 (ReceiveResultData(rrdCurrentStat -- header and @Just fk@ if any of the checks fails, with the respective 'FailureKind'. -- -- Returns the sender account and the cost to be charged for checking the header. -checkHeader :: (TransactionData msg, SchedulerMonad pv m) => msg -> ExceptT (Maybe FailureKind) m (IndexedAccount m, Energy) +checkHeader :: forall pv msg m . (TransactionData msg, SchedulerMonad pv m) => msg -> ExceptT (Maybe FailureKind) m (IndexedAccount m, Energy) checkHeader meta = do + unless (validatePayloadSize (protocolVersion @pv) (thPayloadSize (transactionHeader meta))) $ throwError $ Just InvalidPayloadSize -- Before even checking the header we calculate the cost that will be charged for this -- and check that at least that much energy is deposited and remaining from the maximum block energy. let cost = Cost.baseCost (getTransactionHeaderPayloadSize $ transactionHeader meta) (getTransactionNumSigs (transactionSignature meta)) @@ -535,35 +536,36 @@ handleDeployModule wtc mod = senderAccount = wtc ^. wtcSenderAccount meta = wtc ^. wtcTransactionHeader - -- Size of the module source - psize = Wasm.moduleSourceLength . Wasm.wasmSource $ mod - c = do - tickEnergy (Cost.deployModuleCost psize) - case Wasm.wasmVersion mod of - 0 -> case WasmV0.processModule mod of + case mod of + Wasm.WasmModuleV0 moduleV0 -> do + tickEnergy (Cost.deployModuleCost (Wasm.moduleSourceLength (Wasm.wmvSource moduleV0))) + case WasmV0.processModule moduleV0 of Nothing -> rejectTransaction ModuleNotWF Just iface -> do let mhash = GSWasm.moduleReference iface exists <- isJust <$> getModuleInterfaces mhash when exists $ rejectTransaction (ModuleHashAlreadyExists mhash) - return (GSWasm.ModuleInterfaceV0 iface, mhash) - 1 | demoteProtocolVersion (protocolVersion @pv) >= P4 -> - case WasmV1.processModule mod of + return (Left (iface, moduleV0), mhash) + Wasm.WasmModuleV1 moduleV1 | demoteProtocolVersion (protocolVersion @pv) >= P4 -> do + tickEnergy (Cost.deployModuleCost (Wasm.moduleSourceLength (Wasm.wmvSource moduleV1))) + case WasmV1.processModule moduleV1 of Nothing -> rejectTransaction ModuleNotWF Just iface -> do let mhash = GSWasm.moduleReference iface exists <- isJust <$> getModuleInterfaces mhash when exists $ rejectTransaction (ModuleHashAlreadyExists mhash) - return (GSWasm.ModuleInterfaceV1 iface, mhash) + return (Right (iface, moduleV1), mhash) _ -> rejectTransaction ModuleNotWF - k ls (iface, mhash) = do + k ls (toCommit, mhash) = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost -- Add the module to the global state (module interface, value interface and module itself). -- We know the module does not exist at this point, so we can ignore the return value. - _ <- commitModule (iface, mod) + case toCommit of + Left v0 -> () <$ commitModule v0 + Right v1 -> () <$ commitModule v1 return (TxSuccess [ModuleDeployed mhash], energyCost, usedEnergy) -- | Tick energy for storing the given contract state. diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 32bad18fe8..6c36971d36 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -42,6 +42,7 @@ import qualified Concordium.GlobalState.Basic.BlockState.AccountReleaseSchedule import Control.Exception(assert) import qualified Concordium.ID.Types as ID +import Concordium.Wasm (IsWasmVersion) -- |An account index togehter with the canonical address. Sometimes it is -- difficult to pass an IndexedAccount and we only need the addresses. That is @@ -108,7 +109,7 @@ class (Monad m, StaticInformation m, CanRecordFootprint (Footprint (ATIStorage m -- |Commit a module interface and module value to global state. Returns @True@ -- if this was successful, and @False@ if a module with the given Hash already -- existed. Also store the code of the module for archival purposes. - commitModule :: (GSWasm.ModuleInterface, Wasm.WasmModule) -> m Bool + commitModule :: IsWasmVersion v => (GSWasm.ModuleInterfaceV v, Wasm.WasmModuleV v) -> m Bool -- |Create new instance in the global state. -- The instance is parametrised by the address, and the return value is the diff --git a/concordium-consensus/src/Concordium/Scheduler/Runner.hs b/concordium-consensus/src/Concordium/Scheduler/Runner.hs index e50595e006..902d44ea4a 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Runner.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Runner.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, TypeApplications #-} module Concordium.Scheduler.Runner where import GHC.Generics(Generic) import Data.Maybe import Data.Text(Text) -import Data.Word import Control.Monad.Except @@ -18,7 +17,6 @@ import qualified Concordium.Crypto.BlsSignature as Bls import Concordium.ID.Types import Concordium.Types -import Concordium.Wasm(WasmModule(..)) import qualified Concordium.Wasm as Wasm import qualified Concordium.Scheduler.Types as Types @@ -43,13 +41,16 @@ transactionHelper t = case t of (TJSON meta (DeployModule version mnameText) keys) -> liftIO $ do BS.readFile mnameText >>= \wasmMod -> - let modl = WasmModule version $ Wasm.ModuleSource wasmMod + let modl = case version of + Wasm.V0 -> Wasm.WasmModuleV0 . Wasm.WasmModuleV . Wasm.ModuleSource $ wasmMod + Wasm.V1 -> Wasm.WasmModuleV1 . Wasm.WasmModuleV . Wasm.ModuleSource $ wasmMod in return $ signTx keys meta . Types.encodePayload . Types.DeployModule $ modl (TJSON meta (InitContract icAmount version mnameText cNameText paramExpr) keys) -> liftIO $ do BS.readFile mnameText >>= \wasmMod -> - let modl = WasmModule version $ Wasm.ModuleSource wasmMod + let icModRef = case version of + Wasm.V0 -> Wasm.getModuleRef @Wasm.V0 . Wasm.WasmModuleV . Wasm.ModuleSource $ wasmMod + Wasm.V1 -> Wasm.getModuleRef @Wasm.V1 . Wasm.WasmModuleV . Wasm.ModuleSource $ wasmMod payload = Types.InitContract{ - icModRef = Wasm.getModuleRef modl, icInitName = Wasm.InitName cNameText, icParam = Wasm.Parameter paramExpr, .. @@ -136,9 +137,9 @@ processGroupedTransactions :: processGroupedTransactions = fmap (Types.fromTransactions . map (map (Types.fromAccountTransaction 0))) . mapM processTransactions -data PayloadJSON = DeployModule { version :: Word32, moduleName :: FilePath } +data PayloadJSON = DeployModule { wasmVersion :: Wasm.WasmVersion, moduleName :: FilePath } | InitContract { amount :: Amount - , version :: Word32 + , version :: Wasm.WasmVersion , moduleName :: FilePath , initFunctionName :: Text , parameter :: BSS.ShortByteString } diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration.hs index c85badef8a..871f9aab6c 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration.hs @@ -177,19 +177,18 @@ applyReceiveFun miface cm receiveCtx rName param amnt cs initialEnergy = process -- compilation or instrumentation) that is needed to apply the exported -- functions from it in an efficient way. {-# NOINLINE processModule #-} -processModule :: WasmModule -> Maybe (ModuleInterfaceV V0) +processModule :: WasmModuleV V0 -> Maybe (ModuleInterfaceV V0) processModule modl = do - guard (wasmVersion modl == 0) (bs, imWasmArtifactV0) <- ffiResult case getExports bs of Left _ -> Nothing Right (miExposedInit, miExposedReceive) -> let miModuleRef = getModuleRef modl miModule = InstrumentedWasmModuleV0{..} - in Just ModuleInterface{miModuleSize = moduleSourceLength $ wasmSource modl,..} + in Just ModuleInterface{miModuleSize = moduleSourceLength (wmvSource modl),..} where ffiResult = unsafePerformIO $ do - unsafeUseModuleSourceAsCStringLen (wasmSource modl) $ \(wasmBytesPtr, wasmBytesLen) -> + unsafeUseModuleSourceAsCStringLen (wmvSource modl) $ \(wasmBytesPtr, wasmBytesLen) -> alloca $ \outputLenPtr -> alloca $ \outputModuleArtifactPtr -> do outPtr <- validate_and_process (castPtr wasmBytesPtr) (fromIntegral wasmBytesLen) outputLenPtr outputModuleArtifactPtr diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 0c68d8b989..38f5e3903b 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -502,7 +502,7 @@ resumeReceiveFun is cs statusCode rVal remainingEnergy = unsafePerformIO $ do -- - checks the module is well-formed, and has the right imports and exports for a V1 module. -- - makes a module artifact and allocates it on the Rust side, returning a pointer and a finalizer. {-# NOINLINE processModule #-} -processModule :: WasmModule -> Maybe (ModuleInterfaceV V1) +processModule :: WasmModuleV V1 -> Maybe (ModuleInterfaceV V1) processModule modl = do (bs, imWasmArtifactV1) <- ffiResult case getExports bs of @@ -510,10 +510,10 @@ processModule modl = do Right (miExposedInit, miExposedReceive) -> let miModuleRef = getModuleRef modl miModule = InstrumentedWasmModuleV1{..} - in Just ModuleInterface{miModuleSize = moduleSourceLength $ wasmSource modl,..} + in Just ModuleInterface{miModuleSize = moduleSourceLength (wmvSource modl),..} where ffiResult = unsafePerformIO $ do - unsafeUseModuleSourceAsCStringLen (wasmSource modl) $ \(wasmBytesPtr, wasmBytesLen) -> + unsafeUseModuleSourceAsCStringLen (wmvSource modl) $ \(wasmBytesPtr, wasmBytesLen) -> alloca $ \outputLenPtr -> alloca $ \outputModuleArtifactPtr -> do outPtr <- validate_and_process (castPtr wasmBytesPtr) (fromIntegral wasmBytesLen) outputLenPtr outputModuleArtifactPtr diff --git a/concordium-consensus/src/Concordium/Skov/Monad.hs b/concordium-consensus/src/Concordium/Skov/Monad.hs index 051fcbecb9..9bb9b83387 100644 --- a/concordium-consensus/src/Concordium/Skov/Monad.hs +++ b/concordium-consensus/src/Concordium/Skov/Monad.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs index 99718aa215..4b2949d022 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs @@ -8,6 +8,7 @@ import qualified Concordium.Scheduler.Types as Types import qualified Concordium.Scheduler.EnvironmentImplementation as Types import qualified Concordium.Scheduler as Sch import Concordium.Scheduler.Runner +import Concordium.Wasm(WasmVersion(..)) import Concordium.GlobalState.Basic.BlockState import Concordium.GlobalState.Basic.BlockState.Invariants @@ -36,12 +37,12 @@ transactionInputs :: [TransactionJSON] transactionInputs = [ TJSON{ metadata = makeDummyHeader alesAccount 1 100000, - payload = DeployModule 0 "./testdata/contracts/chain-meta-test.wasm", + payload = DeployModule V0 "./testdata/contracts/chain-meta-test.wasm", keys = [(0,[(0, alesKP)])] }, TJSON{ metadata = makeDummyHeader alesAccount 2 100000, - payload = InitContract 9 0 "./testdata/contracts/chain-meta-test.wasm" "init_check_slot_time" "", + payload = InitContract 9 V0 "./testdata/contracts/chain-meta-test.wasm" "init_check_slot_time" "", keys = [(0,[(0, alesKP)])] } ] diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs index 9f0b3d7b75..18acf94084 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs @@ -55,13 +55,13 @@ testCases = { tcName = "Error handling in contracts." , tcParameters = defaultParams {tpInitialBlockState=initialBlockState} , tcTransactions = - [ ( TJSON { payload = DeployModule 0 fibSourceFile + [ ( TJSON { payload = DeployModule V0 fibSourceFile , metadata = makeDummyHeader alesAccount 1 100000 , keys = [(0,[(0, alesKP)])] } , (SuccessWithSummary deploymentCostCheck, emptySpec) ) - , ( TJSON { payload = InitContract 0 0 "./testdata/contracts/fib.wasm" "init_fib" "" + , ( TJSON { payload = InitContract 0 V0 "./testdata/contracts/fib.wasm" "init_fib" "" , metadata = makeDummyHeader alesAccount 2 100000 , keys = [(0,[(0, alesKP)])] } @@ -84,7 +84,7 @@ testCases = moduleSource <- BS.readFile fibSourceFile let len = fromIntegral $ BS.length moduleSource -- size of the module deploy payload - payloadSize = Types.payloadSize (Types.encodePayload (Types.DeployModule (WasmModule 0 ModuleSource{..}))) + payloadSize = Types.payloadSize (Types.encodePayload (Types.DeployModule (WasmModuleV0 (WasmModuleV ModuleSource{..})))) -- size of the transaction minus the signatures. txSize = Types.transactionHeaderSize + fromIntegral payloadSize -- transaction is signed with 1 signature diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs index 183bdda2e9..d8eab56cae 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs @@ -48,12 +48,12 @@ transactionInputs :: forall pv . IsProtocolVersion pv => Proxy pv -> [Transactio transactionInputs proxy = [ TJSON{ metadata = makeDummyHeader (senderAccount proxy) 1 100000, - payload = DeployModule 0 "./testdata/contracts/chain-meta-test.wasm", + payload = DeployModule V0 "./testdata/contracts/chain-meta-test.wasm", keys = [(0,[(0, alesKP)])] }, TJSON{ metadata = makeDummyHeader (senderAccount proxy) 2 100000, - payload = InitContract 9 0 "./testdata/contracts/chain-meta-test.wasm" "init_origin" "", + payload = InitContract 9 V0 "./testdata/contracts/chain-meta-test.wasm" "init_origin" "", keys = [(0,[(0, alesKP)])] } ] diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs index e6cb403b44..7d6aee356d 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs @@ -24,7 +24,7 @@ import Concordium.Scheduler.DummyData setup :: String -> IO (ModuleInterfaceV V0) setup errString = do source <- BS.readFile "./testdata/contracts/context_test.wasm" - let wasmMod = WasmModule 0 $ ModuleSource source + let wasmMod = WasmModuleV (ModuleSource source) let miface = processModule wasmMod assertBool ("Module not valid " ++ errString) (isJust miface) return (fromJust miface) diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs index d7f15fe17f..4bbc95e1c2 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs @@ -17,6 +17,7 @@ import qualified Concordium.Scheduler.EnvironmentImplementation as Types import qualified Concordium.Scheduler as Sch import Concordium.Scheduler.Runner import Concordium.Types.ProtocolVersion +import Concordium.Wasm (WasmVersion(..)) import Concordium.GlobalState.Basic.BlockState import Concordium.GlobalState.Basic.BlockState.Invariants @@ -66,22 +67,22 @@ transactionInputs :: [TransactionJSON] transactionInputs = [ TJSON{ metadata = makeDummyHeader alesAccount 1 100000, - payload = DeployModule 0 wasmPath, + payload = DeployModule V0 wasmPath, keys = [(0, [(0, alesKP)])] }, TJSON{ metadata = makeDummyHeader alesAccount 2 100000, - payload = InitContract 0 0 wasmPath "init_c10" "", + payload = InitContract 0 V0 wasmPath "init_c10" "", keys = [(0, [(0, alesKP)])] }, TJSON{ metadata = makeDummyHeader alesAccount 3 100000, - payload = InitContract 42 0 wasmPath "init_c10" "", + payload = InitContract 42 V0 wasmPath "init_c10" "", keys = [(0, [(0, alesKP)])] }, TJSON{ metadata = makeDummyHeader alesAccount 4 100000, - payload = InitContract 0 0 wasmPath "init_c20" "", + payload = InitContract 0 V0 wasmPath "init_c20" "", keys = [(0, [(0, alesKP)])] }, TJSON{ diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs index 951b8c8089..fcfaa98de3 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs @@ -10,6 +10,7 @@ import qualified Concordium.Scheduler.Types as Types import qualified Concordium.Scheduler.EnvironmentImplementation as Types import qualified Concordium.Scheduler as Sch import Concordium.Scheduler.Runner +import Concordium.Wasm (WasmVersion(..)) import Concordium.GlobalState.Basic.BlockState import Concordium.GlobalState.Basic.BlockState.Invariants @@ -39,27 +40,27 @@ transactionInputs :: [TransactionJSON] transactionInputs = [ TJSON{ metadata = makeDummyHeader alesAccount 1 100000, - payload = DeployModule 0 wasmPath, + payload = DeployModule V0 wasmPath, keys = [(0,[(0, alesKP)])] }, TJSON{ metadata = makeDummyHeader alesAccount 2 100000, - payload = InitContract 0 0 wasmPath "init_success" "", + payload = InitContract 0 V0 wasmPath "init_success" "", keys = [(0,[(0, alesKP)])] }, TJSON{ metadata = makeDummyHeader alesAccount 3 100000, - payload = InitContract 0 0 wasmPath "init_error_pos" "", + payload = InitContract 0 V0 wasmPath "init_error_pos" "", keys = [(0,[(0, alesKP)])] }, TJSON{ metadata = makeDummyHeader alesAccount 4 100000, - payload = InitContract 0 0 wasmPath "init_fail_minus2" "", + payload = InitContract 0 V0 wasmPath "init_fail_minus2" "", keys = [(0,[(0, alesKP)])] }, TJSON{ metadata = makeDummyHeader alesAccount 5 100000, - payload = InitContract 0 0 wasmPath "init_fail_big" "", + payload = InitContract 0 V0 wasmPath "init_fail_big" "", keys = [(0,[(0, alesKP)])] }, TJSON{ diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs index 4e8ec1be3a..b1e5b9a7a8 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs @@ -23,7 +23,7 @@ import Concordium.Scheduler.DummyData import Concordium.GlobalState.DummyData import Concordium.Types.DummyData import Concordium.Crypto.DummyData -import Concordium.Wasm (ReceiveName(..)) +import Concordium.Wasm (ReceiveName(..), WasmVersion(..)) import SchedulerTests.Helpers import SchedulerTests.TestUtils @@ -45,7 +45,7 @@ transaction payload n = TJSON { } initWithAmount :: Types.Amount -> Types.Nonce -> TransactionJSON -initWithAmount amount = transaction (InitContract amount 0 wasmPath "init_error_codes" "") +initWithAmount amount = transaction (InitContract amount V0 wasmPath "init_error_codes" "") updateWithAmount :: Types.Amount -> Text -> Types.Nonce -> TransactionJSON updateWithAmount amount fun = transaction (Update amount firstAddress fun "") @@ -55,7 +55,7 @@ firstAddress = Types.ContractAddress 0 0 transactionInputs :: [TransactionJSON] transactionInputs = zipWith ($) transactionFunctionList [1..] - where transactionFunctionList = [ transaction (DeployModule 0 wasmPath), + where transactionFunctionList = [ transaction (DeployModule V0 wasmPath), -- returns InitError::VeryBadError -- error code: -1 diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs index 0051814ebe..612367d45b 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs @@ -34,13 +34,13 @@ testCases = { tcName = "Transfers from a contract to accounts." , tcParameters = defaultParams {tpInitialBlockState=initialBlockState} , tcTransactions = - [ ( TJSON { payload = DeployModule 0 "./testdata/contracts/send-tokens-test.wasm" + [ ( TJSON { payload = DeployModule V0 "./testdata/contracts/send-tokens-test.wasm" , metadata = makeDummyHeader alesAccount 1 100000 , keys = [(0, [(0, alesKP)])] } , (Success emptyExpect, emptySpec) ) - , ( TJSON { payload = InitContract 0 0 "./testdata/contracts/send-tokens-test.wasm" "init_send" "" + , ( TJSON { payload = InitContract 0 V0 "./testdata/contracts/send-tokens-test.wasm" "init_send" "" , metadata = makeDummyHeader alesAccount 2 100000 , keys = [(0, [(0, alesKP)])] } diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContractTests.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContractTests.hs index 3e66168a32..509449385d 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContractTests.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContractTests.hs @@ -32,6 +32,7 @@ import Concordium.Scheduler.Runner (PayloadJSON (..), TransactionJSON (..)) import Concordium.Scheduler.Types (Amount, ContractAddress (..), Event, RejectReason (..)) import qualified Concordium.Scheduler.Types as Types import Concordium.Types.DummyData +import Concordium.Wasm (WasmVersion(..)) import Data.ByteString.Short as BSS import Data.Serialize as S import Data.Text (Text) @@ -51,14 +52,14 @@ runInitTestsFromFile testFile = map f tcParameters = defaultParams {tpInitialBlockState = initialBlockState}, tcTransactions = [ ( TJSON - { payload = DeployModule 0 testFile, + { payload = DeployModule V0 testFile, metadata = makeDummyHeader alesAccount 1 100000, keys = [(0, [(0, alesKP)])] }, (Success emptyExpect, emptySpec) ), ( TJSON - { payload = InitContract 0 0 testFile testName initParam, + { payload = InitContract 0 V0 testFile testName initParam, metadata = makeDummyHeader alesAccount 2 100000, keys = [(0, [(0, alesKP)])] }, @@ -80,14 +81,14 @@ runReceiveTestsFromFile testFile = map f tcParameters = defaultParams {tpInitialBlockState = initialBlockState}, tcTransactions = [ ( TJSON - { payload = DeployModule 0 testFile, + { payload = DeployModule V0 testFile, metadata = makeDummyHeader alesAccount 1 100000, keys = [(0, [(0, alesKP)])] }, (Success emptyExpect, emptySpec) ), ( TJSON - { payload = InitContract 10000 0 testFile "init_test" "", + { payload = InitContract 10000 V0 testFile "init_test" "", metadata = makeDummyHeader alesAccount 2 100000, keys = [(0, [(0, alesKP)])] }, diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs index 4433914bf7..681407a4be 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs @@ -13,7 +13,6 @@ import qualified Data.ByteString.Short as BSS import qualified Data.ByteString as BS import qualified Data.Map.Strict as OrdMap import qualified Data.Set as Set -import Data.Word import qualified Concordium.Scheduler.Types as Types import qualified Concordium.Crypto.SHA256 as Hash @@ -50,22 +49,17 @@ initialBlockState = initialPersistentState counterSourceFile :: FilePath counterSourceFile = "./testdata/contracts/v1/call-counter.wasm" --- Tests in this module use version 1, creating V1 instances. -wasmModVersion :: Word32 -wasmModVersion = 1 - -deployModule :: ContextM (PersistentBlockState PV4, GSWasm.ModuleInterfaceV GSWasm.V1, WasmModule) +deployModule :: ContextM (PersistentBlockState PV4, GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1) deployModule = do wasmSource <- liftIO $ BS.readFile counterSourceFile - let wm = WasmModule wasmModVersion (ModuleSource wasmSource) + let wm = WasmModuleV (ModuleSource wasmSource) case WasmV1.processModule wm of Nothing -> liftIO $ assertFailure "Invalid counter module." Just miv -> do - let mi = GSWasm.ModuleInterfaceV1 miv - (_, modState) <- flip bsoPutNewModule (mi, wm) . hpbsPointers =<< initialBlockState + (_, modState) <- flip bsoPutNewModule (miv, wm) . hpbsPointers =<< initialBlockState return (modState, miv, wm) -initContract :: (PersistentBlockState PV4, GSWasm.ModuleInterfaceV GSWasm.V1, WasmModule) -> ContextM (Types.ContractAddress, HashedPersistentBlockState PV4) +initContract :: (PersistentBlockState PV4, GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1) -> ContextM (Types.ContractAddress, HashedPersistentBlockState PV4) initContract (bs, miv, _) = do let cm = Types.ChainMetadata 0 let senderAddress = alesAccount diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs index 34bc97e2d3..aae3adc503 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs @@ -11,7 +11,6 @@ import Test.HUnit(assertFailure, assertEqual) import qualified Data.ByteString.Short as BSS import qualified Data.ByteString as BS import Data.Serialize(runPut, putWord64le, putByteString, putWord16le) -import Data.Word import Lens.Micro.Platform import Control.Monad @@ -43,8 +42,8 @@ counterSourceFile :: FilePath counterSourceFile = "./testdata/contracts/v1/call-counter.wasm" -- Tests in this module use version 1, creating V1 instances. -wasmModVersion :: Word32 -wasmModVersion = 1 +wasmModVersion :: WasmVersion +wasmModVersion = V1 testCases :: [TestCase PV4] testCases = @@ -100,7 +99,7 @@ testCases = moduleSource <- BS.readFile counterSourceFile let len = fromIntegral $ BS.length moduleSource -- size of the module deploy payload - payloadSize = Types.payloadSize (Types.encodePayload (Types.DeployModule (WasmModule wasmModVersion ModuleSource{..}))) + payloadSize = Types.payloadSize (Types.encodePayload (Types.DeployModule (WasmModuleV0 (WasmModuleV ModuleSource{..})))) -- size of the transaction minus the signatures. txSize = Types.transactionHeaderSize + fromIntegral payloadSize -- transaction is signed with 1 signature diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs index 4eff7fb742..4fc1f6a1db 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs @@ -9,7 +9,6 @@ import Test.HUnit(assertFailure, assertEqual) import qualified Data.ByteString.Short as BSS import qualified Data.ByteString as BS import Data.Serialize(runPut, putWord64le, putByteString, putWord16le) -import Data.Word import Lens.Micro.Platform import qualified Concordium.Scheduler.Types as Types @@ -37,14 +36,14 @@ initialBlockState = blockStateWithAlesAccount counterSourceFile :: FilePath counterSourceFile = "./testdata/contracts/v1/call-counter.wasm" -version1 :: Word32 -version1 = 1 +version1 :: WasmVersion +version1 = V1 proxySourceFile :: FilePath proxySourceFile = "./testdata/contracts/v1/send-message-v1.wasm" -version0 :: Word32 -version0 = 0 +version0 :: WasmVersion +version0 = V0 -- This test sets up two contracts. The counter contract on address 0,0 and the -- proxy contract on address 1,0. Then it invokes a single method on the counter diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs index 419c6096dc..56d3ae8898 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs @@ -55,26 +55,17 @@ callerSourceFile = "./testdata/contracts/v1/caller.wasm" emptyContractSourceFile :: FilePath emptyContractSourceFile = "./testdata/contracts/empty.wasm" -wasmModVersion1 :: Word32 -wasmModVersion1 = 1 - -wasmModVersion0 :: Word32 -wasmModVersion0 = 0 - - - -deployModule1 :: PersistentBlockState PV4 -> ContextM ((GSWasm.ModuleInterfaceV GSWasm.V1, WasmModule), PersistentBlockState PV4) +deployModule1 :: PersistentBlockState PV4 -> ContextM ((GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1), PersistentBlockState PV4) deployModule1 bs = do wasmSource <- liftIO $ BS.readFile callerSourceFile - let wm = WasmModule wasmModVersion1 (ModuleSource wasmSource) + let wm = WasmModuleV (ModuleSource wasmSource) case WasmV1.processModule wm of Nothing -> liftIO $ assertFailure "Invalid caller module." Just miv -> do - let mi = GSWasm.ModuleInterfaceV1 miv - (_, modState) <- bsoPutNewModule bs (mi, wm) + (_, modState) <- bsoPutNewModule bs (miv, wm) return ((miv, wm), modState) -initContract1 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V1, WasmModule) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) +initContract1 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) initContract1 bs (miv, _) = do let cm = Types.ChainMetadata 0 let senderAddress = alesAccount @@ -96,18 +87,17 @@ initContract1 bs (miv, _) = do let mkInstance = makeInstance initName receiveMethods miv irdNewState initAmount senderAddress bsoPutNewInstance bs mkInstance -deployModule0 :: PersistentBlockState PV4 -> ContextM ((GSWasm.ModuleInterfaceV GSWasm.V0, WasmModule), PersistentBlockState PV4) +deployModule0 :: PersistentBlockState PV4 -> ContextM ((GSWasm.ModuleInterfaceV GSWasm.V0, WasmModuleV GSWasm.V0), PersistentBlockState PV4) deployModule0 bs = do wasmSource <- liftIO $ BS.readFile emptyContractSourceFile - let wm = WasmModule wasmModVersion0 (ModuleSource wasmSource) + let wm = WasmModuleV (ModuleSource wasmSource) case WasmV0.processModule wm of Nothing -> liftIO $ assertFailure "Invalid caller module." Just miv -> do - let mi = GSWasm.ModuleInterfaceV0 miv - (_, modState) <- bsoPutNewModule bs (mi, wm) + (_, modState) <- bsoPutNewModule bs (miv, wm) return ((miv, wm), modState) -initContract0 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V0, WasmModule) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) +initContract0 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V0, WasmModuleV GSWasm.V0) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) initContract0 bs (miv, _) = do let cm = Types.ChainMetadata 0 let senderAddress = alesAccount diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs index dd68d817ce..612c7a1689 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs @@ -9,7 +9,6 @@ import Test.HUnit(assertFailure, assertEqual) import qualified Data.ByteString.Short as BSS import qualified Data.ByteString as BS import Data.Serialize(encode) -import Data.Word import Lens.Micro.Platform import Control.Monad @@ -41,8 +40,8 @@ transferSourceFile :: FilePath transferSourceFile = "./testdata/contracts/v1/transfer.wasm" -- Tests in this module use version 1, creating V1 instances. -wasmModVersion :: Word32 -wasmModVersion = 1 +wasmModVersion :: WasmVersion +wasmModVersion = V1 testCases :: [TestCase PV4] testCases = @@ -79,7 +78,7 @@ testCases = moduleSource <- BS.readFile transferSourceFile let len = fromIntegral $ BS.length moduleSource -- size of the module deploy payload - payloadSize = Types.payloadSize (Types.encodePayload (Types.DeployModule (WasmModule wasmModVersion ModuleSource{..}))) + payloadSize = Types.payloadSize (Types.encodePayload (Types.DeployModule (WasmModuleV1 (WasmModuleV ModuleSource{..})))) -- size of the transaction minus the signatures. txSize = Types.transactionHeaderSize + fromIntegral payloadSize -- transaction is signed with 1 signature diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs index 458853c73b..867ba73541 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs @@ -9,7 +9,6 @@ import Test.Hspec import Test.HUnit(assertFailure, assertEqual, Assertion) import qualified Data.ByteString as BS -import Data.Word import qualified Data.Set as Set import qualified Data.Map.Strict as Map @@ -18,24 +17,18 @@ import qualified Concordium.GlobalState.Wasm as GSWasm import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 import qualified Concordium.Scheduler.WasmIntegration as WasmV0 -wasmModVersion1 :: Word32 -wasmModVersion1 = 1 - -wasmModVersion0 :: Word32 -wasmModVersion0 = 0 - -- |A V1 module with extra exports. testModule1 :: Assertion testModule1 = do wasmSource <- BS.readFile "./testdata/contracts/v1/extra-exports.wasm" - let wm1 = WasmModule wasmModVersion1 (ModuleSource wasmSource) + let wm1 = WasmModuleV (ModuleSource wasmSource) case WasmV1.processModule wm1 of Nothing -> assertFailure "Invalid caller module." Just GSWasm.ModuleInterface{..} -> do assertEqual "Only valid init functions should be exposed" (Set.singleton (InitName "init_contract")) miExposedInit let expectedReceive = Map.singleton (InitName "init_contract") (Set.singleton (ReceiveName "contract.call")) assertEqual "Only valid receive functions should be exposed" expectedReceive miExposedReceive - let wm0 = WasmModule wasmModVersion0 (ModuleSource wasmSource) + let wm0 = WasmModuleV (ModuleSource wasmSource) case WasmV0.processModule wm0 of Nothing -> return () Just _ -> assertFailure "Extra exports are not allowed for V0 modules." diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/TrySendTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/TrySendTest.hs index 2713ff4547..e3788155b9 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/TrySendTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/TrySendTest.hs @@ -42,13 +42,13 @@ testCases = { tcName = "Error handling in contracts." , tcParameters = defaultParams {tpInitialBlockState=initialBlockState} , tcTransactions = - [ ( TJSON { payload = DeployModule 0 "./testdata/contracts/try-send-test.wasm" + [ ( TJSON { payload = DeployModule V0 "./testdata/contracts/try-send-test.wasm" , metadata = makeDummyHeader alesAccount 1 100000 , keys = [(0,[(0, alesKP)])] } , (Success emptyExpect, emptySpec) ) - , ( TJSON { payload = InitContract 0 0 "./testdata/contracts/try-send-test.wasm" "init_try" "" + , ( TJSON { payload = InitContract 0 V0 "./testdata/contracts/try-send-test.wasm" "init_try" "" , metadata = makeDummyHeader alesAccount 2 100000 , keys = [(0,[(0, alesKP)])] } From 8c18e07e4b81c33fbbec3e925dbb4d39ea078cdc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Mon, 17 Jan 2022 08:58:58 +0100 Subject: [PATCH 35/51] Bump max transaction size in the network layer. --- concordium-node/src/configuration.rs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/concordium-node/src/configuration.rs b/concordium-node/src/configuration.rs index 5ba8b7ebbc..9fd94cbff7 100644 --- a/concordium-node/src/configuration.rs +++ b/concordium-node/src/configuration.rs @@ -42,7 +42,7 @@ pub(crate) fn is_compatible_wire_version( pub const PROTOCOL_MAX_MESSAGE_SIZE: u32 = 20_971_520; // 20 MIB /// Upper bound on the transaction object size, in bytes. -pub const PROTOCOL_MAX_TRANSACTION_SIZE: usize = 100 * 1024; // 100 kB. +pub const PROTOCOL_MAX_TRANSACTION_SIZE: usize = 600 * 1024; // 600 kB. const APP_PREFERENCES_MAIN: &str = "main.config"; const APP_PREFERENCES_KEY_VERSION: &str = "VERSION"; From 27607a8ede0019c9e579c7b9c38a251ddeafd2a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Mon, 17 Jan 2022 10:47:56 +0100 Subject: [PATCH 36/51] Fix globalstate tests. --- .../tests/globalstate/GlobalStateTests/Instances.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs index 7c97425c94..c7ccbd5ae6 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs @@ -34,22 +34,22 @@ 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.ModuleInterfaceV GSWasm.V0)] +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.WasmModule 0 source) + 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.ModuleInterfaceV GSWasm.V1)] +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.WasmModule 1 source) + 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 ++ ")" From b7f5b6fadf199d859bc7d024c96d7246b27e0cc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Mon, 17 Jan 2022 11:30:12 +0100 Subject: [PATCH 37/51] Improve JSON instances. --- concordium-base | 2 +- concordium-consensus/src/Concordium/GlobalState/Instance.hs | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/concordium-base b/concordium-base index d1f976e29b..30bfdaa6ca 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit d1f976e29b4bed71d187661365ad31bf9a3cf880 +Subproject commit 30bfdaa6ca16f8b102d08b8313f0147e1bda92f4 diff --git a/concordium-consensus/src/Concordium/GlobalState/Instance.hs b/concordium-consensus/src/Concordium/GlobalState/Instance.hs index e7c141db57..0f18952854 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Instance.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Instance.hs @@ -12,7 +12,6 @@ import Concordium.Types import Concordium.Types.HashableTo import qualified Concordium.Wasm as Wasm import qualified Concordium.GlobalState.Wasm as GSWasm -import Data.Word -- |The fixed parameters associated with a smart contract instance data InstanceParameters v = InstanceParameters { @@ -107,7 +106,7 @@ instancePairs (InstanceV0 InstanceV{..}) = "methods" .= instanceReceiveFuns _instanceVParameters, "name" .= instanceInitName _instanceVParameters, "sourceModule" .= GSWasm.miModuleRef (instanceModuleInterface _instanceVParameters), - "version" .= (0 :: Word32) + "version" .= Wasm.V0 ] instancePairs (InstanceV1 InstanceV{..}) = [ "owner" .= instanceOwner _instanceVParameters, @@ -115,7 +114,7 @@ instancePairs (InstanceV1 InstanceV{..}) = "methods" .= instanceReceiveFuns _instanceVParameters, "name" .= instanceInitName _instanceVParameters, "sourceModule" .= GSWasm.miModuleRef (instanceModuleInterface _instanceVParameters), - "version" .= (1 :: Word32) + "version" .= Wasm.V1 ] From 32d4a43c12959799d63ce08a3fb2870d7c3f5df0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Mon, 17 Jan 2022 11:49:51 +0100 Subject: [PATCH 38/51] Improve documentation. --- .../GlobalState/Basic/BlockState/Modules.hs | 6 ------ .../GlobalState/Persistent/BlockState/Modules.hs | 11 ++--------- .../src/Concordium/GlobalState/Wasm.hs | 4 ++-- concordium-consensus/src/Concordium/Scheduler.hs | 1 + 4 files changed, 5 insertions(+), 17 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs index b0be434709..e2621f2959 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs @@ -5,8 +5,6 @@ module Concordium.GlobalState.Basic.BlockState.Modules ( Module(..), ModuleV(..), - interface, - source, Modules, emptyModules, putInterface, @@ -53,10 +51,6 @@ data ModuleV v = ModuleV { moduleVSource :: !(WasmModuleV v) } deriving (Show) --- Create the class HasSource a with functions --- source :: Lens a WasmModule and interface :: Lens (ModuleV v) (GSWasm.ModuleInterfaceV v) -makeFields ''ModuleV - -- |A module, either of version 0 or 1. This is only used when storing a module -- independently, e.g., in the module table. When a module is referenced from a -- contract instance we use the ModuleV type directly so we may tie the version diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs index 40cec0fcdc..ee1301d1f4 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs @@ -7,8 +7,6 @@ module Concordium.GlobalState.Persistent.BlockState.Modules ModuleV(..), Modules, getModuleInterface, - source, - interface, emptyModules, getInterface, getSource, @@ -58,11 +56,6 @@ data ModuleV v = ModuleV { } deriving(Show) --- Create two typeclasses HasInterface a _ and HasSource a _ --- with methods source :: Lens' a (BlobRef WasmModule) and --- interface :: Lens' (ModuleV v) (GSWasm.ModuleInterfaceV v) -makeFields ''ModuleV - -- |Helper to convert from an interface to a module. toModule :: forall v . IsWasmVersion v => GSWasm.ModuleInterfaceV v -> BlobRef (WasmModuleV v) -> Module toModule moduleVInterface moduleVSource = @@ -220,12 +213,12 @@ getModuleReference ref mods = unsafeGetModuleReferenceV0 :: MonadBlobStore m => ModuleRef -> Modules -> m (Maybe (BufferedRef (ModuleV GSWasm.V0))) unsafeGetModuleReferenceV0 ref mods = fmap (unsafeCoerceBufferedRef extract) <$> getModuleReference ref mods where extract (ModuleV0 m) = m - extract _ = error "Precondition violation." + extract _ = error "Precondition violation. Expected module version 0, got 1." -- |Gets the buffered reference to a module as stored in the module table assuming it is version 1. unsafeGetModuleReferenceV1 :: MonadBlobStore m => ModuleRef -> Modules -> m (Maybe (BufferedRef (ModuleV GSWasm.V1))) unsafeGetModuleReferenceV1 ref mods = fmap (unsafeCoerceBufferedRef extract) <$> getModuleReference ref mods where extract (ModuleV1 m) = m - extract _ = error "Precondition violation." + extract _ = error "Precondition violation. Expected module version 1, got 0." -- |Get an interface by module reference. diff --git a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs index cc18084725..9e8ae21a87 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs @@ -128,7 +128,7 @@ instance Serialize (InstrumentedModuleV V0) where get = get >>= \case V0 -> InstrumentedWasmModuleV0 <$> get - _ -> fail "Unsupported Wasm module version." + _ -> fail "Expected Wasm version 0, got 1." instance Serialize (InstrumentedModuleV V1) where @@ -138,7 +138,7 @@ instance Serialize (InstrumentedModuleV V1) where get = get >>= \case V1 -> InstrumentedWasmModuleV1 <$> get - _ -> fail "Unsupported Wasm module version." + _ -> fail "ExpectedWasm version 0, got 1." -------------------------------------------------------------------------------- diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index d9bd9a18ca..4646819dbf 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -590,6 +590,7 @@ getCurrentContractInstanceTicking cref = getCurrentContractInstanceTicking' cref -- | Get the current contract state and charge for its lookup. -- NB: In principle we should look up the state size, then charge, and only then lookup the full state -- But since state size is limited to be small it is acceptable to look it up and then charge for it. +-- TODO: This function will be replaced once the state changes for V1 are in. Then it will only handle V0 instances. getCurrentContractInstanceTicking' :: TransactionMonad pv m => ContractAddress From b15f4d87036a46b878cb532e6de283038a83e38e Mon Sep 17 00:00:00 2001 From: Kasper Dissing Bargsteen Date: Tue, 18 Jan 2022 09:35:46 +0100 Subject: [PATCH 39/51] Move InvokeContract types to Base --- concordium-base | 2 +- .../src/Concordium/External.hs | 2 +- .../src/Concordium/Queries.hs | 1 + .../Concordium/Scheduler/InvokeContract.hs | 69 +------------------ 4 files changed, 5 insertions(+), 69 deletions(-) diff --git a/concordium-base b/concordium-base index 30bfdaa6ca..66965b412a 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 30bfdaa6ca16f8b102d08b8313f0147e1bda92f4 +Subproject commit 66965b412aa3eeef361fa7abc9fc04db7f309e4a diff --git a/concordium-consensus/src/Concordium/External.hs b/concordium-consensus/src/Concordium/External.hs index 755fa93df4..136e53791f 100644 --- a/concordium-consensus/src/Concordium/External.hs +++ b/concordium-consensus/src/Concordium/External.hs @@ -33,7 +33,7 @@ import Concordium.Crypto.ByteStringHelpers import Concordium.GlobalState import Concordium.GlobalState.Persistent.LMDB (addDatabaseVersion) import Concordium.GlobalState.Persistent.TreeState (InitException (..)) -import qualified Concordium.Scheduler.InvokeContract as InvokeContract +import qualified Concordium.Types.InvokeContract as InvokeContract import Concordium.MultiVersion ( Callbacks (..), CatchUpConfiguration (..), diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index 4a1791fc89..5def30e68c 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -33,6 +33,7 @@ import Concordium.Types.SeedState import qualified Concordium.Wasm as Wasm import qualified Concordium.Scheduler.InvokeContract as InvokeContract +import qualified Concordium.Types.InvokeContract as InvokeContract import Concordium.Afgjort.Finalize.Types (FinalizationCommittee (..), PartyInfo (..)) import Concordium.Afgjort.Monad diff --git a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs index 401202ea33..5b4840149e 100644 --- a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,18 +9,17 @@ {-# LANGUAGE UndecidableInstances #-} module Concordium.Scheduler.InvokeContract where -import qualified Data.Aeson as AE import Lens.Micro.Platform import Control.Monad.Reader import qualified Data.FixedByteString as FBS import qualified Concordium.ID.Types as ID -import qualified Concordium.Wasm as Wasm import Concordium.Logger import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Instance as Instance import qualified Concordium.GlobalState.BlockState as BS import Concordium.GlobalState.TreeState (MGSTrans(..)) +import Concordium.Types.InvokeContract (ContractContext(..), InvokeContractResult(..)) import Concordium.Scheduler.Environment import Concordium.Scheduler.Types @@ -66,69 +64,6 @@ instance (Monad m, BS.BlockStateQuery m) => StaticInformation (InvokeContractMon {-# INLINE getAccount #-} getAccount !addr = lift . flip BS.getAccount addr =<< view _2 -data ContractContext = ContractContext { - -- |Invoker of the contract. If this is not supplied then the contract will be - -- invoked, by an account with address 0, no credentials and sufficient amount - -- of CCD to cover the transfer amount. If given, the relevant address must - -- exist in the blockstate. - ccInvoker :: !(Maybe Address), - -- |Contract to invoke. - ccContract :: !ContractAddress, - -- |Amount to invoke the contract with. - ccAmount :: !Amount, - -- |Which entrypoint to invoke. - ccMethod :: !Wasm.ReceiveName, - -- |And with what parameter. - ccParameter :: !Wasm.Parameter, - -- |And what amount of energy to allow for execution. - ccEnergy :: !Energy - } - --- |This FromJSON instance defaults a number of values if they are not given --- - energy defaults to maximum possible --- - amount defaults to 0 --- - parameter defaults to the empty one -instance AE.FromJSON ContractContext where - parseJSON = AE.withObject "ContractContext" $ \obj -> do - ccInvoker <- obj AE..:? "invoker" - ccContract <- obj AE..: "contract" - ccAmount <- obj AE..:? "amount" AE..!= 0 - ccMethod <- obj AE..: "method" - ccParameter <- obj AE..:? "parameter" AE..!= Wasm.emptyParameter - ccEnergy <- obj AE..:? "energy" AE..!= 10_000_000 - return ContractContext{..} - -data InvokeContractResult = - -- |Contract execution failed for the given reason. - Failure { - rcrReason :: !RejectReason, - -- |Energy used by the execution. - rcrUsedEnergy :: !Energy - } - -- |Contract execution succeeded. - | Success { - -- |If invoking a V0 contract this is Nothing, otherwise it is - -- the return value produced by the call. - rcrReturnValue :: !(Maybe WasmV1.ReturnValue), - -- |Events produced by contract execution. - rcrEvents :: ![Event], - -- |Energy used by the execution. - rcrUsedEnergy :: !Energy - } - -instance AE.ToJSON InvokeContractResult where - toJSON Failure{..} = AE.object [ - "tag" AE..= AE.String "failure", - "reason" AE..= rcrReason, - "usedEnergy" AE..= rcrUsedEnergy - ] - toJSON Success{..} = AE.object [ - "tag" AE..= AE.String "success", - "returnValue" AE..= rcrReturnValue, - "events" AE..= rcrEvents, - "usedEnergy" AE..= rcrUsedEnergy - ] - -- |Invoke the contract in the given context. invokeContract :: forall pv m . (IsProtocolVersion pv, BS.BlockStateQuery m) => SProtocolVersion pv -- ^An argument to fix the protocol version, to make the type non-ambiguous. @@ -196,6 +131,6 @@ invokeContract _ ContractContext{..} cm bs = do rcrReason = WasmV1.cerToRejectReasonReceive ccContract ccMethod ccParameter cf, rcrUsedEnergy = ccEnergy - re}) (Right (Right (Right (rv, rcrEvents))), re) -> - return Success{rcrReturnValue=Just rv, + return Success{rcrReturnValue=Just (WasmV1.returnValueToByteString rv), rcrUsedEnergy = ccEnergy - re, ..} From 8ce1614d94ef49773db195577f515de5532fe0d9 Mon Sep 17 00:00:00 2001 From: Kasper Dissing Bargsteen Date: Wed, 19 Jan 2022 10:09:26 +0100 Subject: [PATCH 40/51] Fix tests after moving InvokeContract to Base --- .../SchedulerTests/SmartContracts/Invoke.hs | 17 +++++++++-------- .../SmartContracts/V1/ErrorCodes.hs | 7 ++++--- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs index 681407a4be..15312e687c 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs @@ -25,6 +25,7 @@ import Concordium.GlobalState.Instance import Concordium.Wasm import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 import qualified Concordium.GlobalState.Wasm as GSWasm +import qualified Concordium.Types.InvokeContract as InvokeContract import qualified Concordium.Scheduler.InvokeContract as InvokeContract import Concordium.Types.DummyData @@ -164,28 +165,28 @@ runCounterTests = do InvokeContract.Failure{..} -> liftIO $ assertFailure $ "Invocation failed: " ++ show rcrReason InvokeContract.Success{..} -> case rcrReturnValue of - Nothing -> liftIO $ assertFailure $ "Invoking a V1 contract must produce a return value." - Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return 1" [1,0,0,0,0,0,0,0] (BS.unpack (WasmV1.returnValueToByteString rv)) + Nothing -> liftIO $ assertFailure "Invoking a V1 contract must produce a return value." + Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return 1" [1,0,0,0,0,0,0,0] (BS.unpack rv) invokeContract2 addr stateWithContract >>= \case InvokeContract.Failure{..} -> liftIO $ assertFailure $ "Invocation failed: " ++ show rcrReason InvokeContract.Success{..} -> case rcrReturnValue of - Nothing -> liftIO $ assertFailure $ "Invoking a V1 contract must produce a return value." - Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return nothing" [] (BS.unpack (WasmV1.returnValueToByteString rv)) + Nothing -> liftIO $ assertFailure "Invoking a V1 contract must produce a return value." + Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return nothing" [] (BS.unpack rv) invokeContract3 addr stateWithContract >>= \case InvokeContract.Failure{..} -> liftIO $ assertEqual "Invocation should fail: " Types.RuntimeFailure rcrReason - InvokeContract.Success{} -> liftIO $ assertFailure $ "Invocation succeeded, but should fail." + InvokeContract.Success{} -> liftIO $ assertFailure "Invocation succeeded, but should fail." invokeContract4 addr stateWithContract >>= \case InvokeContract.Failure{..} -> liftIO $ assertFailure $ "Invocation failed: " ++ show rcrReason InvokeContract.Success{..} -> case rcrReturnValue of - Nothing -> liftIO $ assertFailure $ "Invoking a V1 contract must produce a return value." - Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return nothing." [] (BS.unpack (WasmV1.returnValueToByteString rv)) + Nothing -> liftIO $ assertFailure "Invoking a V1 contract must produce a return value." + Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return nothing." [] (BS.unpack rv) tests :: Spec tests = describe "Invoke contract" $ do - specify "V1: Counter contract" $ runCounterTests + specify "V1: Counter contract" runCounterTests diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs index 56d3ae8898..af83601771 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs @@ -28,6 +28,7 @@ import Concordium.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.Types.InvokeContract as InvokeContract import qualified Concordium.Scheduler.InvokeContract as InvokeContract import Concordium.Types.DummyData @@ -315,10 +316,10 @@ checkSuccess msg targetValue icr = liftIO $ InvokeContract.Failure{..} -> assertFailure $ "Invocation failed ( " ++ show msg ++ "): " ++ show rcrReason InvokeContract.Success{..} -> case rcrReturnValue of - Nothing -> assertFailure $ "Invoking a V1 contract must produce a return value." + Nothing -> assertFailure "Invoking a V1 contract must produce a return value." Just rv -> assertEqual msg (BS.unpack (runPut (putWord64le targetValue))) - (BS.unpack (WasmV1.returnValueToByteString rv)) + (BS.unpack rv) runCallerTests :: Assertion runCallerTests = do @@ -348,4 +349,4 @@ runCallerTests = do tests :: Spec tests = describe "V1: Invoke contract" $ do - specify "Caller contract" $ runCallerTests + specify "Caller contract" runCallerTests From c6bc219c69fbdd00e4aab2378f79b9d76c82d86f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Sun, 23 Jan 2022 16:29:57 +0100 Subject: [PATCH 41/51] Return the updated balance to the resumed contract. Add tests for self-transfer. --- concordium-base | 2 +- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/Scheduler.hs | 32 ++-- .../Scheduler/WasmIntegration/V1.hs | 9 +- .../testdata/contracts/v1/self-balance.wasm | Bin 0 -> 401 bytes .../testdata/contracts/v1/self-balance.wat | 51 ++++++ .../SmartContracts/V1/ErrorCodes.hs | 70 +------- .../SmartContracts/V1/InvokeHelpers.hs | 132 +++++++++++++++ .../SmartContracts/V1/SelfBalance.hs | 150 ++++++++++++++++++ .../SmartContracts/V1/Transfer.hs | 2 +- concordium-consensus/tests/scheduler/Spec.hs | 2 + 11 files changed, 370 insertions(+), 82 deletions(-) create mode 100644 concordium-consensus/testdata/contracts/v1/self-balance.wasm create mode 100644 concordium-consensus/testdata/contracts/v1/self-balance.wat create mode 100644 concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/InvokeHelpers.hs create mode 100644 concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/SelfBalance.hs diff --git a/concordium-base b/concordium-base index 66965b412a..a71854e1ff 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 66965b412aa3eeef361fa7abc9fc04db7f309e4a +Subproject commit a71854e1ffd2465942f6fca9f8b8096c3cfb5787 diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 0f5ddf8883..d793485fbe 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 0f5ddf8883c35f7b14aa9074000ade24add7dafb +Subproject commit d793485fbe63a9e3688e062e73e9f6a4ac2b23a4 diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 4646819dbf..008691375a 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -901,15 +901,17 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei let receiveCtx = Wasm.ReceiveContext { invoker = originAddr, selfAddress = cref, - -- NB: This means that the contract observes the balance without the incoming one - -- It gets the transfer amount as a separate parameter. - selfBalance = _instanceVAmount istance, + -- NB: This means that the contract observes the balance **with** the incoming one + -- which is different from the V0 contracts. The reason for this choice is that + -- in V1 contracts, since they execute in one go, it is necessary for some uses to + -- make the incoming amount immediately available. Otherwise the contract cannot, for example, + -- forward the incoming amount. Since that is necessary, the updated semantics is the most natural one. + selfBalance = _instanceVAmount istance + transferAmount, sender = senderAddr, owner = instanceOwner iParams, rcSenderPolicies = map Wasm.mkSenderPolicy senderCredentials } -- Now run the receive function on the message. This ticks energy during execution, failing when running out of energy. - -- FIXME: Once errors can be caught in smart contracts update this to not terminate the transaction. let iface = instanceModuleInterface iParams -- charge for looking up the module tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) @@ -922,7 +924,9 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei -- ^Result of invoking an operation -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) go _ (Left cer) = return (Left (WasmV1.ExecutionReject cer)) -- contract execution failed. - go events (Right rrData) = + go events (Right rrData) = do + -- balance at present before handling out calls or transfers. + entryBalance <- getCurrentContractAmount istance case rrData of WasmV1.ReceiveSuccess{..} -> do -- execution terminated, commit the new state @@ -950,8 +954,10 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei WasmV1.Transfer{..} -> runExceptT (transferAccountSync imtTo istance imtAmount) >>= \case Left errCode -> do - go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) - Right transferEvents -> go (resumeEvent True:transferEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing WasmV1.Success Nothing) + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing entryBalance (WasmV1.Error (WasmV1.EnvFailure errCode)) Nothing) + Right transferEvents -> do + newBalance <- getCurrentContractAmount istance + go (resumeEvent True:transferEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing newBalance WasmV1.Success Nothing) WasmV1.Call{..} -> -- the operation is a call to another contract. There is a bit of complication because the contract could be a V0 -- or V1 one, and the behaviour is different depending on which one it is. @@ -961,7 +967,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei -- lookup the instance to invoke getCurrentContractInstanceTicking' imcTo >>= \case -- we could not find the instance, return this to the caller and continue - Nothing -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MissingContract imcTo))) Nothing) + Nothing -> go events =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing entryBalance (WasmV1.Error (WasmV1.EnvFailure (WasmV1.MissingContract imcTo))) Nothing) Just (InstanceV0 targetInstance) -> do -- we are invoking a V0 instance. -- in this case we essentially treat this as a top-level transaction invoking that contract. @@ -972,13 +978,14 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei -- Otherwise rollback the state and report that to the caller. (runSuccess `orElseWith` (return . Left)) >>= \case Left _ -> -- execution failed, ignore the reject reason since V0 contract cannot return useful information - go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing WasmV1.MessageSendFailed Nothing) + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing entryBalance WasmV1.MessageSendFailed Nothing) Right evs -> do -- Execution of the contract might have changed our own state. If so, we need to resume in the new state, otherwise -- we can keep the old one. (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState - go (resumeEvent True:evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState WasmV1.Success Nothing) + newBalance <- getCurrentContractAmount istance + go (resumeEvent True:evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState newBalance WasmV1.Success Nothing) Just (InstanceV1 targetInstance) -> do -- invoking a V1 instance is easier we recurse on the update function. -- If this returns Right _ it is successful, and we pass this, and the returned return value @@ -987,11 +994,12 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstanceV1 ownerAccount istance) imcAmount rName imcParam) >>= \case Left cer -> - go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) + go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing entryBalance (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) Right (rVal, callEvents) -> do (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState - go (resumeEvent True:callEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState WasmV1.Success (Just rVal)) + newBalance <- getCurrentContractAmount istance + go (resumeEvent True:callEvents ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState newBalance WasmV1.Success (Just rVal)) -- start contract execution. -- transfer the amount from the sender to the contract at the start. This is so that the contract may immediately use it diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 38f5e3903b..63d2a67ccc 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -193,10 +193,11 @@ foreign import ccall "call_receive_v1" foreign import ccall "resume_receive_v1" resume_receive :: Ptr (Ptr ReceiveInterruptedState) -- ^Location where the pointer to interrupted config will be stored. - -> Word8 -- ^Tag of whether the state has been updated or not. If this is 0 then the next two values are not used. + -> Word8 -- ^Tag of whether the state been updated or not. If this is 0 then the next two values are not used. -- If it is non-zero then they are. -> Ptr Word8 -- ^Pointer to the current state of the smart contracts. This will not be modified. -> CSize -- ^Length of the state. + -> Word64 -- ^New balance of the contract. -> Word64 -- ^Return status from the interrupt. -> Ptr ReturnValue -- ^Return value from the call, if any. This will be replaced with an empty vector. -> Word64 -- ^Available energy. @@ -465,13 +466,14 @@ applyReceiveFun miface cm receiveCtx rName param amnt cs initialEnergy = unsafeP resumeReceiveFun :: ReceiveInterruptedState -> Maybe ContractState -- ^State of the contract to start in. + -> Amount -- ^Current balance of the contract, if it changed. -> InvokeResponseCode -> Maybe ReturnValue -> InterpreterEnergy -- ^Amount of energy available for execution. -> Maybe (Either ContractExecutionReject ReceiveResultData, InterpreterEnergy) -- ^Nothing if execution used up all the energy, and otherwise the result -- of execution with the amount of energy remaining. -resumeReceiveFun is cs statusCode rVal remainingEnergy = unsafePerformIO $ do +resumeReceiveFun is cs amnt statusCode rVal remainingEnergy = unsafePerformIO $ do withReceiveInterruptedState is $ \isPtr -> withStateBytes $ \(stateBytesPtr, stateBytesLen) -> withMaybeReturnValue rVal $ \rValPtr -> @@ -479,6 +481,7 @@ resumeReceiveFun is cs statusCode rVal remainingEnergy = unsafePerformIO $ do outPtr <- resume_receive isPtr newStateTag (castPtr stateBytesPtr) (fromIntegral stateBytesLen) + amountWord (invokeResponseToWord64 statusCode) rValPtr energy @@ -495,7 +498,7 @@ resumeReceiveFun is cs statusCode rVal remainingEnergy = unsafePerformIO $ do Just stateBytes -> (BSU.unsafeUseAsCStringLen (contractState stateBytes), 1::Word8) Nothing -> (\f -> f (nullPtr, 0), 0::Word8) energy = fromIntegral remainingEnergy - + amountWord = _amount amnt -- |Process a module as received and make a module interface. -- This diff --git a/concordium-consensus/testdata/contracts/v1/self-balance.wasm b/concordium-consensus/testdata/contracts/v1/self-balance.wasm new file mode 100644 index 0000000000000000000000000000000000000000..778b21509361264421f15471700b4bd53ce22da0 GIT binary patch literal 401 zcmZ9IO-{ow5QWD-ZAt>Fg@lB%Y8ObXSi;)k1f0Mz&IDOa;>dAYiA8fhZiS-&N}0vH z(f8iWVnFu|0RZx_F33p6f{(GHvPsUfj0MDzoXJSPNRk@Y8s|$pG`AlZRHwaeFrZhx z{X~F;fA`Nv6Rc~2EFx>$9^Cye0^k~o?QT13?>Rs2mH3)o> zN^7S})dwB$Vmq7f{uqq2RV+q;B+u-|wl=8Xb=z0yA=& ContextM ((GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1), PersistentBlockState PV4) -deployModule1 bs = do - wasmSource <- liftIO $ BS.readFile callerSourceFile - let wm = WasmModuleV (ModuleSource wasmSource) - case WasmV1.processModule wm of - Nothing -> liftIO $ assertFailure "Invalid caller module." - Just miv -> do - (_, modState) <- bsoPutNewModule bs (miv, wm) - return ((miv, wm), modState) +deployModule1 = InvokeHelpers.deployModuleV1 callerSourceFile initContract1 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) -initContract1 bs (miv, _) = do - let cm = Types.ChainMetadata 0 - let senderAddress = alesAccount - let initContext = InitContext{ - initOrigin = senderAddress, - icSenderPolicies = [] - } - let initName = InitName "init_caller" - let initParam = emptyParameter - let initAmount = 0 - let initInterpreterEnergy = 1_000_000_000 - case WasmV1.applyInitFun miv cm initContext initName initParam initAmount initInterpreterEnergy of - Nothing -> -- out of energy - liftIO $ assertFailure "Initialization ran out of energy." - Just (Left failure, _) -> - liftIO $ assertFailure $ "Initialization failed: " ++ show failure - Just (Right WasmV1.InitSuccess{..}, _) -> do - let receiveMethods = OrdMap.findWithDefault Set.empty initName (GSWasm.miExposedReceive miv) - let mkInstance = makeInstance initName receiveMethods miv irdNewState initAmount senderAddress - bsoPutNewInstance bs mkInstance +initContract1 = InvokeHelpers.initContractV1 alesAccount (InitName "init_caller") emptyParameter 0 deployModule0 :: PersistentBlockState PV4 -> ContextM ((GSWasm.ModuleInterfaceV GSWasm.V0, WasmModuleV GSWasm.V0), PersistentBlockState PV4) -deployModule0 bs = do - wasmSource <- liftIO $ BS.readFile emptyContractSourceFile - let wm = WasmModuleV (ModuleSource wasmSource) - case WasmV0.processModule wm of - Nothing -> liftIO $ assertFailure "Invalid caller module." - Just miv -> do - (_, modState) <- bsoPutNewModule bs (miv, wm) - return ((miv, wm), modState) +deployModule0 = InvokeHelpers.deployModuleV0 emptyContractSourceFile initContract0 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V0, WasmModuleV GSWasm.V0) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) -initContract0 bs (miv, _) = do - let cm = Types.ChainMetadata 0 - let senderAddress = alesAccount - let initContext = InitContext{ - initOrigin = senderAddress, - icSenderPolicies = [] - } - let initName = InitName "init_empty" - let initParam = emptyParameter - let initAmount = 0 - let initInterpreterEnergy = 1_000_000_000 - case WasmV0.applyInitFun miv cm initContext initName initParam initAmount initInterpreterEnergy of - Nothing -> -- out of energy - liftIO $ assertFailure "Initialization ran out of energy." - Just (Left failure, _) -> - liftIO $ assertFailure $ "Initialization failed: " ++ show failure - Just (Right SuccessfulResultData{..}, _) -> do - let receiveMethods = OrdMap.findWithDefault Set.empty initName (GSWasm.miExposedReceive miv) - let mkInstance = makeInstance initName receiveMethods miv newState initAmount senderAddress - bsoPutNewInstance bs mkInstance - +initContract0 = InvokeHelpers.initContractV0 alesAccount (InitName "init_empty") emptyParameter 0 -- |Invoke an entrypoint that calls the "fail" entrypoint. -- The expected return code is diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/InvokeHelpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/InvokeHelpers.hs new file mode 100644 index 0000000000..c956150105 --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/InvokeHelpers.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} +{-| A helper module that defines some scaffolding for running V1 contract tests via invoke. +-} +module SchedulerTests.SmartContracts.V1.InvokeHelpers where + +import Test.HUnit(assertFailure) + +import Control.Monad.Reader +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as OrdMap +import qualified Data.Set as Set + +import qualified Concordium.Scheduler.Types as Types +import qualified Concordium.Crypto.SHA256 as Hash + +import Concordium.Types.SeedState (initialSeedState) +import Concordium.GlobalState.Persistent.BlobStore +import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlockState +import Concordium.GlobalState.Instance +import Concordium.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.DummyData +import Concordium.Crypto.DummyData +import Concordium.GlobalState.DummyData + +import SchedulerTests.TestUtils + +type ContextM = PersistentBlockStateMonad PV4 BlobStore (ReaderT BlobStore IO) + +-- empty state, no accounts, no modules, no instances +initialBlockState :: ContextM (HashedPersistentBlockState PV4) +initialBlockState = initialPersistentState + (initialSeedState (Hash.hash "") 1000) + dummyCryptographicParameters + [mkAccount alesVK alesAccount 1000] + dummyIdentityProviders + dummyArs + dummyKeyCollection + dummyChainParameters + +callerSourceFile :: FilePath +callerSourceFile = "./testdata/contracts/v1/caller.wasm" + +emptyContractSourceFile :: FilePath +emptyContractSourceFile = "./testdata/contracts/empty.wasm" + +-- |Deploy a V1 module in the given state. The source file should be a raw Wasm file. +-- If the module is invalid this will raise an exception. +deployModuleV1 :: FilePath -- ^Source file. + -> PersistentBlockState PV4 -- ^State to add the module to. + -> ContextM ((GSWasm.ModuleInterfaceV V1, WasmModuleV V1), PersistentBlockState PV4) +deployModuleV1 sourceFile bs = do + wasmSource <- liftIO $ BS.readFile sourceFile + let wm = WasmModuleV (ModuleSource wasmSource) + case WasmV1.processModule wm of + Nothing -> liftIO $ assertFailure "Invalid module." + Just miv -> do + (_, modState) <- bsoPutNewModule bs (miv, wm) + return ((miv, wm), modState) + + +-- |Deploy a V0 module in the given state. The source file should be a raw Wasm file. +-- If the module is invalid this will raise an exception. +deployModuleV0 :: FilePath -- ^Source file. + -> PersistentBlockState PV4 -- ^State to add the module to. + -> ContextM ((GSWasm.ModuleInterfaceV V0, WasmModuleV V0), PersistentBlockState PV4) +deployModuleV0 sourceFile bs = do + wasmSource <- liftIO $ BS.readFile sourceFile + let wm = WasmModuleV (ModuleSource wasmSource) + case WasmV0.processModule wm of + Nothing -> liftIO $ assertFailure "Invalid module." + Just miv -> do + (_, modState) <- bsoPutNewModule bs (miv, wm) + return ((miv, wm), modState) + +-- |Initialize a contract from the supplied module in the given state, and return its address. +-- The state is assumed to contain the module. +initContractV1 :: Types.AccountAddress -- ^Sender address + -> InitName -- ^Contract to initialize. + -> Parameter -- ^Parameter to initialize with. + -> Types.Amount -- ^Initial balance. + -> PersistentBlockState PV4 + -> (GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1) + -> ContextM (Types.ContractAddress, PersistentBlockState PV4) +initContractV1 senderAddress initName initParam initAmount bs (miv, _) = do + let cm = Types.ChainMetadata 0 + let initContext = InitContext{ + initOrigin = senderAddress, + icSenderPolicies = [] + } + let initInterpreterEnergy = 1_000_000_000 + case WasmV1.applyInitFun miv cm initContext initName initParam initAmount initInterpreterEnergy of + Nothing -> -- out of energy + liftIO $ assertFailure "Initialization ran out of energy." + Just (Left failure, _) -> + liftIO $ assertFailure $ "Initialization failed: " ++ show failure + Just (Right WasmV1.InitSuccess{..}, _) -> do + let receiveMethods = OrdMap.findWithDefault Set.empty initName (GSWasm.miExposedReceive miv) + let mkInstance = makeInstance initName receiveMethods miv irdNewState initAmount senderAddress + bsoPutNewInstance bs mkInstance + +-- |Initialize a contract from the supplied module in the given state, and return its address. +-- The state is assumed to contain the module. +initContractV0 :: Types.AccountAddress -- ^Sender address + -> InitName -- ^Contract to initialize. + -> Parameter -- ^Parameter to initialize with. + -> Types.Amount -- ^Initial balance. + -> PersistentBlockState PV4 + -> (GSWasm.ModuleInterfaceV GSWasm.V0, WasmModuleV GSWasm.V0) + -> ContextM (Types.ContractAddress, PersistentBlockState PV4) +initContractV0 senderAddress initName initParam initAmount bs (miv, _) = do + let cm = Types.ChainMetadata 0 + let initContext = InitContext{ + initOrigin = senderAddress, + icSenderPolicies = [] + } + let initInterpreterEnergy = 1_000_000_000 + case WasmV0.applyInitFun miv cm initContext initName initParam initAmount initInterpreterEnergy of + Nothing -> -- out of energy + liftIO $ assertFailure "Initialization ran out of energy." + Just (Left failure, _) -> + liftIO $ assertFailure $ "Initialization failed: " ++ show failure + Just (Right SuccessfulResultData{..}, _) -> do + let receiveMethods = OrdMap.findWithDefault Set.empty initName (GSWasm.miExposedReceive miv) + let mkInstance = makeInstance initName receiveMethods miv newState initAmount senderAddress + bsoPutNewInstance bs mkInstance + diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/SelfBalance.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/SelfBalance.hs new file mode 100644 index 0000000000..1b94e7eea5 --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/SelfBalance.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} +{-| This module tests that the correct self-balance is exposed to V1 contracts. + In essence that the self-balance is updated by the invoke. +-} +module SchedulerTests.SmartContracts.V1.SelfBalance (tests) where + +import Test.Hspec +import Test.HUnit(assertFailure, assertEqual, Assertion) + +import Control.Monad.Reader +import Data.Serialize +import qualified Data.ByteString.Short as BSS +import qualified Data.ByteString as BS + +import qualified Concordium.Scheduler.Types as Types +import qualified Concordium.Crypto.SHA256 as Hash + +import Concordium.Types.SeedState (initialSeedState) +import Concordium.GlobalState.Persistent.BlobStore +import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlockState +import Concordium.Wasm +import qualified Concordium.GlobalState.Wasm as GSWasm +import qualified Concordium.Types.InvokeContract as InvokeContract +import qualified Concordium.Scheduler.InvokeContract as InvokeContract + +import Concordium.Types.DummyData +import Concordium.Crypto.DummyData +import Concordium.GlobalState.DummyData + +import SchedulerTests.TestUtils +import SchedulerTests.SmartContracts.V1.InvokeHelpers (ContextM) +import qualified SchedulerTests.SmartContracts.V1.InvokeHelpers as InvokeHelpers + +-- empty state, no accounts, no modules, no instances +initialBlockState :: ContextM (HashedPersistentBlockState PV4) +initialBlockState = initialPersistentState + (initialSeedState (Hash.hash "") 1000) + dummyCryptographicParameters + [mkAccount alesVK alesAccount 1000] + dummyIdentityProviders + dummyArs + dummyKeyCollection + dummyChainParameters + +transferSourceFile :: FilePath +transferSourceFile = "./testdata/contracts/v1/self-balance.wasm" + +deployModule1 :: PersistentBlockState PV4 -> ContextM ((GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1), PersistentBlockState PV4) +deployModule1 = InvokeHelpers.deployModuleV1 transferSourceFile + +-- Initialize a contract with 0 CCD in its balance. +initContract1 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) +initContract1 = InvokeHelpers.initContractV1 alesAccount (InitName "init_transfer") emptyParameter 0 + +-- |Invoke an entrypoint and transfer to ourselves. +-- The before and after self-balances are the same. +invokeContract1 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract1 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord32le 1 -- instruction + putWord64le 0 -- contract index + putWord64le 0 -- contract subindex + putWord16le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "accept")) + putByteString "accept" -- entrypoint name + putWord64le 100 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 123, + ccMethod = ReceiveName "transfer.forward", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + +-- |Invoke an entrypoint and transfer to another instance. +-- The before and after self-balances are different. +invokeContract2 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract2 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord32le 1 -- instruction + putWord64le 1 -- contract index + putWord64le 0 -- contract subindex + putWord16le 0 -- length of parameter + putWord16le (fromIntegral (BSS.length "accept")) + putByteString "accept" -- entrypoint name + putWord64le 100 -- amount + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 123, + ccMethod = ReceiveName "transfer.forward", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + + +-- |Invoke an entrypoint and transfer to an account. +-- The before and after balances are different. +invokeContract3 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult +invokeContract3 ccContract bs = do + let cm = Types.ChainMetadata 0 + let ccParameter = Parameter $ BSS.toShort $ runPut $ do + putWord32le 0 -- instruction + put alesAccount + putWord64le 100 -- amount to transfer + let ctx = InvokeContract.ContractContext{ + ccInvoker = Nothing, + ccAmount = 123, + ccMethod = ReceiveName "transfer.forward", + ccEnergy = 1_000_000_000, + .. + } + InvokeContract.invokeContract Types.SP4 ctx cm bs + + +checkSuccess :: MonadIO m + => String -- ^ Custom error message. + -> Types.Amount -- ^ Expected balance before the transfer. + -> Types.Amount -- ^ Expected balance after the transfer. + -> InvokeContract.InvokeContractResult -> m () +checkSuccess msg expectBefore expectAfter icr = liftIO $ + case icr of + InvokeContract.Failure{..} -> assertFailure $ "Invocation failed ( " ++ show msg ++ "): " ++ show rcrReason + InvokeContract.Success{..} -> + case rcrReturnValue of + Nothing -> assertFailure "Invoking a V1 contract must produce a return value." + Just rv -> assertEqual msg + (BS.unpack (runPut $ (putWord64le . Types._amount $ expectBefore) <> (putWord64le . Types._amount $ expectAfter))) + (BS.unpack rv) + +runTransferTests :: Assertion +runTransferTests = do + runBlobStoreTemp "." . runPersistentBlockStateMonad $ do + initState <- thawBlockState =<< initialBlockState + (mod1, bsWithMod) <- deployModule1 initState + (addr1, stateWithContract1) <- initContract1 bsWithMod mod1 + (_another, stateWithBothContracts') <- initContract1 stateWithContract1 mod1 + stateWithBothContracts <- freezeBlockState stateWithBothContracts' + invokeContract1 addr1 stateWithBothContracts >>= checkSuccess "Self transfer" 123 123 + invokeContract2 addr1 stateWithBothContracts >>= checkSuccess "Transfer to another instance" 123 23 + invokeContract3 addr1 stateWithBothContracts >>= checkSuccess "Transfer to account" 123 23 + +tests :: Spec +tests = describe "V1: Self balance" $ do + specify "Transfer contract" runTransferTests diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs index 612c7a1689..c616c000a8 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs @@ -106,7 +106,7 @@ testCases = -- ensure the transaction is successful ensureSucces :: Types.BlockItem -> Types.TransactionSummary -> Expectation - ensureSucces _ Types.TransactionSummary{..} = checkSuccess "Update failed" tsResult + ensureSucces _ Types.TransactionSummary{..} = checkSuccess "Update failed: " tsResult checkSuccess msg Types.TxReject{..} = assertFailure $ msg ++ show vrRejectReason checkSuccess _ _ = return () diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index b2b5702a25..0942358a6b 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -31,6 +31,7 @@ import qualified SchedulerTests.SmartContracts.V1.CrossMessaging(tests) import qualified SchedulerTests.SmartContracts.Invoke (tests) import qualified SchedulerTests.SmartContracts.V1.ErrorCodes (tests) import qualified SchedulerTests.SmartContracts.V1.ValidInvalidModules (tests) +import qualified SchedulerTests.SmartContracts.V1.SelfBalance (tests) import Test.Hspec @@ -66,3 +67,4 @@ main = hspec $ do SchedulerTests.SmartContracts.Invoke.tests SchedulerTests.SmartContracts.V1.ErrorCodes.tests SchedulerTests.SmartContracts.V1.ValidInvalidModules.tests + SchedulerTests.SmartContracts.V1.SelfBalance.tests From 96eadd5d991d41de823be68af7e5d3303c328f1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Sun, 23 Jan 2022 19:59:32 +0100 Subject: [PATCH 42/51] Documentation of some aspects of resume. --- docs/contracts.md | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/docs/contracts.md b/docs/contracts.md index 0afcebfa5d..745840c5e3 100644 --- a/docs/contracts.md +++ b/docs/contracts.md @@ -122,6 +122,26 @@ are written as type signature in Rust syntax. The mapping of types is fn invoke(tag: u32, start: *const u8, length: u32) -> u64; ``` +When a contract invokes another two things might happen to the contract itself +as a result of the call +- its state can change. This can happen due to reentrancy. +- its own balance can change. This can happen either because the contract is + transferring some of its tokens or, again, because of reentrancy. + +When an invocation fails none of these are changed, and any accrued changes are +rolled back. + +If an invocation succeeds, then in the return value there is an indication on +whether the state might have changed or not. "Might have changed" is currently +defined as any of contract's entrypoints being executed successfully in the +middle of handling the interrupt. + +TODO: The semantics of this will change with new state. + +There is no direct indication of whether the balance has changed. However +**after** the invoke call, the host function `get_receive_self_balance` returns +the **new** self balance. + ## Returning from a contract A contract can produce a return value, in addition to the return code. The From c136bfe478036d6a868a94bebbab843905cccd0c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Mon, 24 Jan 2022 17:43:44 +0100 Subject: [PATCH 43/51] Retain P1-P3 semantics. --- concordium-base | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/concordium-base b/concordium-base index a71854e1ff..00d2b7b2de 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit a71854e1ffd2465942f6fca9f8b8096c3cfb5787 +Subproject commit 00d2b7b2de634f686807e731115dfe7125848367 From 87c279bdc208e16e0c55637a32321483551c0dbd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Tue, 25 Jan 2022 06:42:57 +0100 Subject: [PATCH 44/51] Revise some naming for clarity. --- concordium-consensus/smart-contracts | 2 +- concordium-consensus/src/Concordium/Scheduler.hs | 16 ++++++++-------- .../src/Concordium/Scheduler/Environment.hs | 8 ++++---- .../Scheduler/EnvironmentImplementation.hs | 4 ++-- .../src/Concordium/Scheduler/InvokeContract.hs | 10 +++++----- 5 files changed, 20 insertions(+), 20 deletions(-) diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index d793485fbe..a233c167db 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit d793485fbe63a9e3688e062e73e9f6a4ac2b23a4 +Subproject commit a233c167dbbe2eba3932470179627d42a8d3fa5d diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 008691375a..c3bdb1b073 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -110,7 +110,7 @@ checkHeader meta = do unless (remainingBlockEnergy >= cost) $ throwError Nothing -- Now check whether the specified sender exists, and only then do all remaining checks. - macc <- lift (getAccount (transactionSender meta)) + macc <- lift (getStateAccount (transactionSender meta)) case macc of Nothing -> throwError . Just $ (UnknownAccount (transactionSender meta)) Just iacc@(_, acc) -> do @@ -308,7 +308,7 @@ handleTransferWithSchedule wtc twsTo twsSchedule maybeMemo = withDeposit wtc c k unless (senderAmount >= transferAmount) $! rejectTransaction (AmountTooLarge (AddressAccount senderAddress) transferAmount) -- check the target account - targetAccount <- getAccount twsTo `rejectingWith` InvalidAccountReference twsTo + targetAccount <- getStateAccount twsTo `rejectingWith` InvalidAccountReference twsTo -- In protocol version P3 account addresses are no longer in 1-1 -- correspondence with accounts. Thus to check that a scheduled -- transfer is not a self transfer we need to check canonical @@ -466,7 +466,7 @@ handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransfer -- Look up the receiver account first, and don't charge if it does not exist -- and does not have a valid credential. - targetAccount <- getAccount toAddress `rejectingWith` InvalidAccountReference toAddress + targetAccount <- getStateAccount toAddress `rejectingWith` InvalidAccountReference toAddress -- Check that the account is not transferring to itself since that -- causes technical complications. In protocol versions 1 and 2 -- account addresses and accounts were in 1-1 correspondence. In @@ -759,7 +759,7 @@ handleSimpleTransfer wtc toAddr transferamount maybeMemo = unless (senderamount >= transferamount) $! rejectTransaction (AmountTooLarge (AddressAccount senderAddress) transferamount) -- Check whether target account exists and get it. - targetAccount <- getAccount toAddr `rejectingWith` InvalidAccountReference toAddr + targetAccount <- getStateAccount toAddr `rejectingWith` InvalidAccountReference toAddr -- Add the transfer to the current changeset and return the corresponding event. withAccountToAccountAmount senderAccount targetAccount transferamount $ @@ -889,7 +889,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei let ownerAccountAddress = instanceOwner iParams -- The invariants maintained by global state should ensure that an owner account always exists. -- However we are defensive here and reject the transaction instead of panicking in case it does not. - ownerCheck <- getAccount ownerAccountAddress + ownerCheck <- getStateAccount ownerAccountAddress senderCheck <- checkAndGetSender transferAmount case (Set.member receiveName receivefuns, ownerCheck, senderCheck) of @@ -1020,7 +1020,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei let addr = AddressContract (instanceAddress senderInstance) unless (senderamount >= tAmount) $! throwError (WasmV1.AmountTooLarge addr tAmount) -- Check whether target account exists and get it. - lift (getAccount accAddr) >>= \case + lift (getStateAccount accAddr) >>= \case Nothing -> throwError (WasmV1.MissingAccount accAddr) Just targetAccount -> -- Add the transfer to the current changeset and return the corresponding event. @@ -1070,7 +1070,7 @@ handleContractUpdateV0 originAddr istance checkAndGetSender transferAmount recei let ownerAccountAddress = instanceOwner iParams -- The invariants maintained by global state should ensure that an owner account always exists. -- However we are defensive here and reject the transaction instead of panicking in case it does not. - ownerAccount <- getAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress + ownerAccount <- getStateAccount ownerAccountAddress `rejectingWith` InvalidAccountReference ownerAccountAddress cm <- getChainMetadata -- We have established that the owner account of the receiver instance has at least one valid credential. @@ -1193,7 +1193,7 @@ handleTransferAccount accAddr senderInstance transferamount = do unless (senderamount >= transferamount) $! rejectTransaction (AmountTooLarge addr transferamount) -- Check whether target account exists and get it. - targetAccount <- getAccount accAddr `rejectingWith` InvalidAccountReference accAddr + targetAccount <- getStateAccount accAddr `rejectingWith` InvalidAccountReference accAddr -- Add the transfer to the current changeset and return the corresponding event. withContractToAccountAmount (instanceAddress senderInstance) targetAccount transferamount $ diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 6c36971d36..64ca68087e 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -71,9 +71,9 @@ class (Monad m) => StaticInformation m where -- |Return a contract instance if it exists at the given address. getContractInstance :: ContractAddress -> m (Maybe Instance) - -- |Get the amount of funds at the particular account address. + -- |Get the amount of funds at the particular account address at the start of a transaction. -- To get the amount of funds for a contract instance use getInstance and lookup amount there. - getAccount :: AccountAddress -> m (Maybe (IndexedAccount m)) + getStateAccount :: AccountAddress -> m (Maybe (IndexedAccount m)) -- |Information needed to execute transactions in the form that is easy to use. class (Monad m, StaticInformation m, CanRecordFootprint (Footprint (ATIStorage m)), AccountOperations m, MonadLogger m, IsProtocolVersion pv) @@ -745,8 +745,8 @@ instance StaticInformation m => StaticInformation (LocalT pv r m) where {-# INLINE getContractInstance #-} getContractInstance = liftLocal . getContractInstance - {-# INLINE getAccount #-} - getAccount = liftLocal . getAccount + {-# INLINE getStateAccount #-} + getStateAccount = liftLocal . getStateAccount deriving via (MGSTrans (LocalT pv r) m) instance AccountOperations m => AccountOperations (LocalT pv r m) diff --git a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs index 330818865e..18e8b72084 100644 --- a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs +++ b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs @@ -125,8 +125,8 @@ instance (MonadReader ContextState m, {-# INLINE getContractInstance #-} getContractInstance addr = lift . flip bsoGetInstance addr =<< use schedulerBlockState - {-# INLINE getAccount #-} - getAccount !addr = lift . flip bsoGetAccount addr =<< use schedulerBlockState + {-# INLINE getStateAccount #-} + getStateAccount !addr = lift . flip bsoGetAccount addr =<< use schedulerBlockState instance (MonadReader ContextState m, diff --git a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs index 5b4840149e..a092023a0b 100644 --- a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -61,8 +61,8 @@ instance (Monad m, BS.BlockStateQuery m) => StaticInformation (InvokeContractMon {-# INLINE getContractInstance #-} getContractInstance addr = lift . flip BS.getContractInstance addr =<< view _2 - {-# INLINE getAccount #-} - getAccount !addr = lift . flip BS.getAccount addr =<< view _2 + {-# INLINE getStateAccount #-} + getStateAccount !addr = lift . flip BS.getAccount addr =<< view _2 -- |Invoke the contract in the given context. invokeContract :: forall pv m . (IsProtocolVersion pv, BS.BlockStateQuery m) => @@ -90,19 +90,19 @@ invokeContract _ ContractContext{..} cm bs = do maxIndex = maxBound in return (Right (const (return (AddressAccount zeroAddress, [], Right (maxIndex, zeroAddress))), zeroAddress, maxIndex)) -- if the invoker is an address make sure it exists - Just (AddressAccount accInvoker) -> getAccount accInvoker >>= \case + Just (AddressAccount accInvoker) -> getStateAccount accInvoker >>= \case Nothing -> return (Left (Just (InvalidAccountReference accInvoker))) Just acc -> return (Right (checkAndGetBalanceAccountV0 accInvoker acc, accInvoker, fst acc)) Just (AddressContract contractInvoker) -> getContractInstance contractInvoker >>= \case Nothing -> return (Left (Just (InvalidContractAddress contractInvoker))) Just (Instance.InstanceV0 i@Instance.InstanceV{..}) -> do let ownerAccountAddress = instanceOwner _instanceVParameters - getAccount ownerAccountAddress >>= \case + getStateAccount ownerAccountAddress >>= \case Nothing -> return (Left (Just $ InvalidAccountReference ownerAccountAddress)) Just acc -> return (Right (checkAndGetBalanceInstanceV0 acc i, ownerAccountAddress, fst acc)) Just (Instance.InstanceV1 i@Instance.InstanceV{..}) -> do let ownerAccountAddress = instanceOwner _instanceVParameters - getAccount ownerAccountAddress >>= \case + getStateAccount ownerAccountAddress >>= \case Nothing -> return (Left (Just $ InvalidAccountReference ownerAccountAddress)) Just acc -> return (Right (checkAndGetBalanceInstanceV0 acc i, ownerAccountAddress, fst acc)) let runContractComp = From bb910bc6579cd4eacb61d096cc6bf2b55128ef97 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Tue, 25 Jan 2022 15:38:02 +0100 Subject: [PATCH 45/51] Reverse order of returned events for V1 contracts, and fix bug in tracking deposits. --- concordium-consensus/src/Concordium/Scheduler.hs | 13 +++++++------ .../src/Concordium/Scheduler/InvokeContract.hs | 3 ++- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index c3bdb1b073..817392addd 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -51,7 +51,6 @@ import Concordium.Scheduler.Types import Concordium.Scheduler.Environment import Data.Time import Concordium.TimeMonad - import qualified Data.Serialize as S import qualified Data.ByteString as BS @@ -96,7 +95,7 @@ import Concordium.Scheduler.WasmIntegration.V1 (ReceiveResultData(rrdCurrentStat -- the cost that will be charged for checking the header. -- -- Throws 'Nothing' if the remaining block energy is not sufficient to cover the cost of checking the --- header and @Just fk@ if any of the checks fails, with the respective 'FailureKind'. +-- header and @Just fk@ if any of the checks fail, with the respective 'FailureKind'. -- -- Returns the sender account and the cost to be charged for checking the header. checkHeader :: forall pv msg m . (TransactionData msg, SchedulerMonad pv m) => msg -> ExceptT (Maybe FailureKind) m (IndexedAccount m, Energy) @@ -794,7 +793,7 @@ handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = InstanceV1 ins -> do handleContractUpdateV1 senderAddress ins checkAndGetBalanceV1 uAmount uReceiveName uMessage >>= \case Left cer -> rejectTransaction (WasmV1.cerToRejectReasonReceive uAddress uReceiveName uMessage cer) - Right (_, events) -> return events + Right (_, events) -> return (reverse events) -- |Check that the account has sufficient balance, and construct credentials of the account. checkAndGetBalanceAccountV1 :: (TransactionMonad pv m, AccountOperations m) @@ -804,7 +803,7 @@ checkAndGetBalanceAccountV1 :: (TransactionMonad pv m, AccountOperations m) -> m (Either WasmV1.ContractCallFailure (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress))) checkAndGetBalanceAccountV1 usedAddress senderAccount transferAmount = do (senderAddr, senderCredentials) <- mkSenderAddrCredentials (Right (usedAddress, senderAccount)) - senderamount <- getAccountAvailableAmount (snd senderAccount) + senderamount <- getCurrentAccountAvailableAmount senderAccount if senderamount >= transferAmount then do canonicalAddr <- getAccountCanonicalAddress (snd senderAccount) return (Right (senderAddr, senderCredentials, Right (fst senderAccount, canonicalAddr))) @@ -821,7 +820,7 @@ checkAndGetBalanceAccountV0 :: (TransactionMonad pv m, AccountOperations m) -> m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress)) checkAndGetBalanceAccountV0 usedAddress senderAccount transferAmount = do (senderAddr, senderCredentials) <- mkSenderAddrCredentials (Right (usedAddress, senderAccount)) - senderamount <- getAccountAvailableAmount (snd senderAccount) + senderamount <- getCurrentAccountAvailableAmount senderAccount if senderamount >= transferAmount then do canonicalAddr <- getAccountCanonicalAddress (snd senderAccount) return (senderAddr, senderCredentials, Right (fst senderAccount, canonicalAddr)) @@ -878,7 +877,9 @@ handleContractUpdateV1 :: forall pv m. -> Amount -- ^The amount to be transferred from the sender of the message to the contract upon success. -> Wasm.ReceiveName -- ^Name of the contract to invoke. -> Wasm.Parameter -- ^Message to invoke the receive method with. - -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) -- ^The events resulting from processing the message and all recursively processed messages. + -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) + -- ^The events resulting from processing the message and all recursively processed messages. For efficiency + -- reasons the events are in **reverse order** of the actual effects. handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount receiveName parameter = do -- Cover administrative costs. tickEnergy Cost.updateContractInstanceBaseCost diff --git a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs index a092023a0b..472d0e9b53 100644 --- a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -130,7 +130,8 @@ invokeContract _ ContractContext{..} cm bs = do return (Failure{ rcrReason = WasmV1.cerToRejectReasonReceive ccContract ccMethod ccParameter cf, rcrUsedEnergy = ccEnergy - re}) - (Right (Right (Right (rv, rcrEvents))), re) -> + (Right (Right (Right (rv, reversedEvents))), re) -> -- handleUpdateContractV1 returns events in reverse order return Success{rcrReturnValue=Just (WasmV1.returnValueToByteString rv), rcrUsedEnergy = ccEnergy - re, + rcrEvents = reverse reversedEvents, ..} From 1bf1d68376841e5a6ae28d4fa47b8bb07fdd0f12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Tue, 25 Jan 2022 19:37:10 +0100 Subject: [PATCH 46/51] Bump dependencies. --- concordium-base | 2 +- concordium-consensus/smart-contracts | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/concordium-base b/concordium-base index 00d2b7b2de..e3ec76e4a1 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 00d2b7b2de634f686807e731115dfe7125848367 +Subproject commit e3ec76e4a15ba8009bad49ed82c2ca57ccf0174e diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index a233c167db..0573a5c624 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit a233c167dbbe2eba3932470179627d42a8d3fa5d +Subproject commit 0573a5c6247aaccd020275f0465a0c409739a3ab From 1d8ac05588616c1c09d982363d335c4818b86070 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Tue, 8 Feb 2022 20:40:19 +0100 Subject: [PATCH 47/51] Minor changes stemming from base update. --- concordium-base | 2 +- concordium-consensus/smart-contracts | 2 +- concordium-consensus/src/Concordium/Scheduler.hs | 8 ++++++-- .../tests/scheduler/SchedulerTests/SimpleTransferSpec.hs | 1 + .../SchedulerTests/SmartContracts/V1/InvokeHelpers.hs | 8 ++++---- .../SmartContracts/V1/ValidInvalidModules.hs | 6 +++--- .../tests/scheduler/SchedulerTests/TrySendTest.hs | 2 ++ 7 files changed, 18 insertions(+), 11 deletions(-) diff --git a/concordium-base b/concordium-base index e3ec76e4a1..45fb1b398a 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit e3ec76e4a15ba8009bad49ed82c2ca57ccf0174e +Subproject commit 45fb1b398a6c12d3f66aa4ff8289ced59222ceda diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 0573a5c624..003e298efb 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 0573a5c6247aaccd020275f0465a0c409739a3ab +Subproject commit 003e298efbd02b500fb24162955bef646ad25b22 diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 817392addd..386525d69a 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -712,6 +712,7 @@ handleInitContract wtc initAmount modref initName param = ecAddress=addr, ecAmount=initAmount, ecInitName=initName, + ecContractVersion=Wasm.V0, ecEvents=Wasm.logs result }], energyCost, usedEnergy ) @@ -734,6 +735,7 @@ handleInitContract wtc initAmount modref initName param = ecAddress=addr, ecAmount=initAmount, ecInitName=initName, + ecContractVersion=Wasm.V1, ecEvents=WasmV1.irdLogs result }], energyCost, usedEnergy ) @@ -937,6 +939,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei euAmount=transferAmount, euMessage=parameter, euReceiveName=receiveName, + euContractVersion=Wasm.V1, euEvents = rrdLogs } in return (Right (rrdReturnValue, event:events)) @@ -973,7 +976,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei -- we are invoking a V0 instance. -- in this case we essentially treat this as a top-level transaction invoking that contract. -- That is, we execute the entire tree that is potentially generated. - let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName + let rName = Wasm.uncheckedMakeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstanceV0 ownerAccount istance) imcAmount rName imcParam -- If execution of the contract succeeds resume. -- Otherwise rollback the state and report that to the caller. @@ -992,7 +995,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei -- If this returns Right _ it is successful, and we pass this, and the returned return value -- to the caller. -- Otherwise we roll back all the changes and return the return value, and the error code to the caller. - let rName = Wasm.makeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName + let rName = Wasm.uncheckedMakeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstanceV1 ownerAccount istance) imcAmount rName imcParam) >>= \case Left cer -> go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing entryBalance (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) @@ -1112,6 +1115,7 @@ handleContractUpdateV0 originAddr istance checkAndGetSender transferAmount recei euAmount=transferAmount, euMessage=parameter, euReceiveName=receiveName, + euContractVersion=Wasm.V0, euEvents = Wasm.logs result } foldEvents originAddr (ownerAccount, istance) initEvent txOut diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs index 612367d45b..0c664f5e5e 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs @@ -55,6 +55,7 @@ testCases = , euAmount = 11 , euMessage = Parameter "" , euReceiveName = ReceiveName "send.receive" + , euContractVersion = V0 , euEvents = [] }, Types.Transferred { diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/InvokeHelpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/InvokeHelpers.hs index c956150105..4937ea3c8f 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/InvokeHelpers.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/InvokeHelpers.hs @@ -55,8 +55,8 @@ deployModuleV1 :: FilePath -- ^Source file. -> PersistentBlockState PV4 -- ^State to add the module to. -> ContextM ((GSWasm.ModuleInterfaceV V1, WasmModuleV V1), PersistentBlockState PV4) deployModuleV1 sourceFile bs = do - wasmSource <- liftIO $ BS.readFile sourceFile - let wm = WasmModuleV (ModuleSource wasmSource) + ws <- liftIO $ BS.readFile sourceFile + let wm = WasmModuleV (ModuleSource ws) case WasmV1.processModule wm of Nothing -> liftIO $ assertFailure "Invalid module." Just miv -> do @@ -70,8 +70,8 @@ deployModuleV0 :: FilePath -- ^Source file. -> PersistentBlockState PV4 -- ^State to add the module to. -> ContextM ((GSWasm.ModuleInterfaceV V0, WasmModuleV V0), PersistentBlockState PV4) deployModuleV0 sourceFile bs = do - wasmSource <- liftIO $ BS.readFile sourceFile - let wm = WasmModuleV (ModuleSource wasmSource) + ws <- liftIO $ BS.readFile sourceFile + let wm = WasmModuleV (ModuleSource ws) case WasmV0.processModule wm of Nothing -> liftIO $ assertFailure "Invalid module." Just miv -> do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs index 867ba73541..bd0ba59620 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs @@ -20,15 +20,15 @@ import qualified Concordium.Scheduler.WasmIntegration as WasmV0 -- |A V1 module with extra exports. testModule1 :: Assertion testModule1 = do - wasmSource <- BS.readFile "./testdata/contracts/v1/extra-exports.wasm" - let wm1 = WasmModuleV (ModuleSource wasmSource) + ws <- BS.readFile "./testdata/contracts/v1/extra-exports.wasm" + let wm1 = WasmModuleV (ModuleSource ws) case WasmV1.processModule wm1 of Nothing -> assertFailure "Invalid caller module." Just GSWasm.ModuleInterface{..} -> do assertEqual "Only valid init functions should be exposed" (Set.singleton (InitName "init_contract")) miExposedInit let expectedReceive = Map.singleton (InitName "init_contract") (Set.singleton (ReceiveName "contract.call")) assertEqual "Only valid receive functions should be exposed" expectedReceive miExposedReceive - let wm0 = WasmModuleV (ModuleSource wasmSource) + let wm0 = WasmModuleV (ModuleSource ws) case WasmV0.processModule wm0 of Nothing -> return () Just _ -> assertFailure "Extra exports are not allowed for V0 modules." diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/TrySendTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/TrySendTest.hs index e3788155b9..c0e1445efa 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/TrySendTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/TrySendTest.hs @@ -64,6 +64,7 @@ testCases = , euAmount = 11 , euMessage = Parameter toAddr , euReceiveName = ReceiveName "try.receive" + , euContractVersion = V0 , euEvents = [] }, Types.Transferred { @@ -82,6 +83,7 @@ testCases = , euAmount = 11 , euMessage = Parameter (BSS.pack (replicate 32 0)) , euReceiveName = ReceiveName "try.receive" + , euContractVersion = V0 , euEvents = [] }], emptySpec) ) From 24f76ffe13310a4d37cf1715580d3032c1ee01ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Thu, 10 Feb 2022 21:58:05 +0100 Subject: [PATCH 48/51] Documentation, code style, and other minor fixes. --- concordium-base | 2 +- concordium-consensus/lib.def | 2 +- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/External.hs | 3 +- .../GlobalState/Basic/BlockState/Instances.hs | 14 ++-- .../GlobalState/Basic/BlockState/Modules.hs | 31 ++++----- .../src/Concordium/GlobalState/BlockState.hs | 6 +- .../src/Concordium/GlobalState/Instance.hs | 33 ++++----- .../GlobalState/Persistent/BlockState.hs | 16 ++--- .../GlobalState/Persistent/Instances.hs | 10 ++- .../src/Concordium/GlobalState/Wasm.hs | 13 ++-- .../src/Concordium/Queries.hs | 2 +- .../src/Concordium/Scheduler.hs | 60 ++++++++-------- .../src/Concordium/Scheduler/Environment.hs | 69 +++++++++---------- .../Concordium/Scheduler/InvokeContract.hs | 41 ++++++++++- .../Scheduler/WasmIntegration/V1.hs | 36 +++++++--- .../testdata/contracts/README.md | 12 ++++ .../testdata/contracts/v1/call-counter.wat | 13 ++-- .../testdata/contracts/v1/self-balance.wat | 2 +- .../globalstate/GlobalStateTests/Instances.hs | 2 +- .../scheduler/SchedulerTests/ChainMetatest.hs | 2 +- .../SchedulerTests/InitContextTest.hs | 2 +- .../SchedulerTests/ReceiveContextTest.hs | 2 +- .../scheduler/SchedulerTests/RejectReasons.hs | 2 +- .../RejectReasonsRustContract.hs | 2 +- .../SchedulerTests/SmartContracts/Invoke.hs | 42 +++-------- .../SmartContracts/V1/Counter.hs | 12 ++-- .../SmartContracts/V1/CrossMessaging.hs | 4 +- .../SmartContracts/V1/ErrorCodes.hs | 2 +- .../SmartContracts/V1/SelfBalance.hs | 5 +- .../SmartContracts/V1/Transfer.hs | 10 +-- docs/contracts.md | 7 +- 32 files changed, 253 insertions(+), 208 deletions(-) create mode 100644 concordium-consensus/testdata/contracts/README.md diff --git a/concordium-base b/concordium-base index 45fb1b398a..e6fffb934f 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 45fb1b398a6c12d3f66aa4ff8289ced59222ceda +Subproject commit e6fffb934fba17ea7c5a0f5971ab2e5771c3f0bc diff --git a/concordium-consensus/lib.def b/concordium-consensus/lib.def index d1835ed259..2a2217596f 100644 --- a/concordium-consensus/lib.def +++ b/concordium-consensus/lib.def @@ -22,7 +22,7 @@ EXPORTS getInstances getAccountInfo getInstanceInfo - InvokeContract + invokeContract getRewardStatus getBirkParameters getModuleList diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 003e298efb..8046fb8e98 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 003e298efbd02b500fb24162955bef646ad25b22 +Subproject commit 8046fb8e98ac493bbd17afd6e7268c702fdebf47 diff --git a/concordium-consensus/src/Concordium/External.hs b/concordium-consensus/src/Concordium/External.hs index 1cb8e5eac0..e8281246c6 100644 --- a/concordium-consensus/src/Concordium/External.hs +++ b/concordium-consensus/src/Concordium/External.hs @@ -1090,7 +1090,8 @@ getInstanceInfo cptr blockcstr instcstr = do (Just bh, Just inst) -> jsonQuery cptr (Q.getInstanceInfo bh inst) _ -> jsonCString AE.Null --- |Run the smart contract entrypoint in a given context and the state at the end of the given block. +-- |Run the smart contract entrypoint in a given context and in the state at the +-- end of the given block. -- The block must be given as a null-terminated base16 encoding of the block -- hash and the context (second CString) must be given as a null-terminated -- JSON-encoded value. diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs index d3cb8baed5..0506780ff7 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs @@ -2,9 +2,8 @@ module Concordium.GlobalState.Basic.BlockState.Instances( InstanceParameters(..), Instance(..), InstanceV(..), - HasInstanceParameters(..), + HasInstanceAddress(..), makeInstance, - iaddress, Instances, emptyInstances, getInstance, @@ -39,13 +38,16 @@ emptyInstances = Instances Empty getInstance :: ContractAddress -> Instances -> Maybe Instance getInstance addr (Instances iss) = iss ^? ix addr --- |Update the instance at the specified address with an amount delta and value. --- If there is no instance with the given address, this does nothing. +-- |Update the instance at the specified address with an amount delta and +-- potentially a new state. If new state is not provided the state of the +-- instance is not changed. If there is no instance with the given address, this +-- does nothing. updateInstanceAt :: ContractAddress -> AmountDelta -> Maybe Wasm.ContractState -> Instances -> Instances updateInstanceAt ca amt val (Instances iss) = Instances (iss & ix ca %~ updateInstance amt val) --- |Update the instance at the specified address with a __new amount__ and value. --- If there is no instance with the given address, this does nothing. +-- |Update the instance at the specified address with a __new amount__ and +-- potentially a new state. If new state is not provided the state of the instance is not changed. If +-- there is no instance with the given address, this does nothing. updateInstanceAt' :: ContractAddress -> Amount -> Maybe Wasm.ContractState -> Instances -> Instances updateInstanceAt' ca amt val (Instances iss) = Instances (iss & ix ca %~ updateInstance' amt val) diff --git a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs index e2621f2959..34c754642b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Modules.hs @@ -28,7 +28,6 @@ import qualified Concordium.GlobalState.Wasm as GSWasm import qualified Concordium.Scheduler.WasmIntegration as V0 import qualified Concordium.Scheduler.WasmIntegration.V1 as V1 import Control.Monad -import Data.Coerce import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Serialize @@ -60,24 +59,13 @@ data Module where ModuleV1 :: ModuleV GSWasm.V1 -> Module deriving(Show) --- |Helper (internal to the module) to convert from a module to an interface. -fromModule :: Module -> GSWasm.ModuleInterface -fromModule (ModuleV0 v) = GSWasm.ModuleInterfaceV0 (moduleVInterface v) -fromModule (ModuleV1 v) = GSWasm.ModuleInterfaceV1 (moduleVInterface v) - --- |Helper to convert from an interface to a module. -toModule :: forall v . IsWasmVersion v => GSWasm.ModuleInterfaceV v -> WasmModuleV v -> Module -toModule moduleVInterface moduleVSource = case getWasmVersion @v of - SV0 -> ModuleV0 ModuleV{..} - SV1 -> ModuleV1 ModuleV{..} - instance GSWasm.HasModuleRef Module where {-# INLINE moduleReference #-} moduleReference (ModuleV0 v) = GSWasm.moduleReference . moduleVInterface $ v moduleReference (ModuleV1 v) = GSWasm.moduleReference . moduleVInterface $ v instance HashableTo Hash Module where - getHash = coerce . GSWasm.moduleReference + getHash = moduleRef . GSWasm.moduleReference instance Serialize Module where put (ModuleV0 ModuleV{..}) = put moduleVSource @@ -118,14 +106,19 @@ emptyModules = Modules LFMB.empty Map.empty -- |Try to add interfaces to the module table. If a module with the given -- reference exists returns @Nothing@. -putInterface :: IsWasmVersion v => (GSWasm.ModuleInterfaceV v, WasmModuleV v) -> Modules -> Maybe Modules -putInterface (iface, mSource) m = +putInterface :: forall v . IsWasmVersion v => (GSWasm.ModuleInterfaceV v, WasmModuleV v) -> Modules -> Maybe Modules +putInterface (moduleVInterface, moduleVSource) m = if Map.member mref (m ^. modulesMap) then Nothing else Just $ m & modulesTable .~ modulesTable' & modulesMap %~ Map.insert mref idx - where mref = GSWasm.moduleReference iface - (idx, modulesTable') = LFMB.append (toModule iface mSource) $ m ^. modulesTable + where mref = GSWasm.moduleReference moduleVInterface + (idx, modulesTable') = LFMB.append newModule $ m ^. modulesTable + + newModule = case getWasmVersion @v of + SV0 -> ModuleV0 ModuleV{..} + SV1 -> ModuleV1 ModuleV{..} + getModule :: ModuleRef -> Modules -> Maybe Module getModule ref mods = Map.lookup ref (mods ^. modulesMap) >>= @@ -134,6 +127,10 @@ getModule ref mods = Map.lookup ref (mods ^. modulesMap) >>= -- |Get an interface by module reference. getInterface :: ModuleRef -> Modules -> Maybe GSWasm.ModuleInterface getInterface ref mods = fromModule <$> getModule ref mods + where + fromModule (ModuleV0 v) = GSWasm.ModuleInterfaceV0 (moduleVInterface v) + fromModule (ModuleV1 v) = GSWasm.ModuleInterfaceV1 (moduleVInterface v) + -- |Get the source of a module by module reference. getSource :: ModuleRef -> Modules -> Maybe WasmModule diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 9748f0795c..d497e5f852 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -384,8 +384,10 @@ class (BlockStateQuery m) => BlockStateOperations m where -- ^New account threshold -> m (UpdatableBlockState m) - -- |Replace the instance with given data. The rest of the instance data (instance parameters) stays the same. - -- This method is only called when it is known the instance exists, and can thus assume it. + -- |Replace the instance with given change in owned amount, and potentially + -- new state. The rest of the instance data (instance parameters) stays the + -- same. This method is only called when it is known the instance exists, and + -- can thus assume it. bsoModifyInstance :: UpdatableBlockState m -> ContractAddress -> AmountDelta diff --git a/concordium-consensus/src/Concordium/GlobalState/Instance.hs b/concordium-consensus/src/Concordium/GlobalState/Instance.hs index 0f18952854..26e86209d6 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Instance.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Instance.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} module Concordium.GlobalState.Instance where import Data.Aeson @@ -13,8 +14,9 @@ import Concordium.Types.HashableTo import qualified Concordium.Wasm as Wasm import qualified Concordium.GlobalState.Wasm as GSWasm --- |The fixed parameters associated with a smart contract instance -data InstanceParameters v = InstanceParameters { +-- |The fixed parameters associated with a smart contract instance, parametrized +-- the version of the Wasm module that contains its code. +data InstanceParameters (v :: Wasm.WasmVersion) = InstanceParameters { -- |Address of the instance _instanceAddress :: !ContractAddress, -- |Address of this contract instance owner, i.e., the creator account. @@ -30,10 +32,10 @@ data InstanceParameters v = InstanceParameters { instanceParameterHash :: !H.Hash } -class HasInstanceParameters a where +class HasInstanceAddress a where instanceAddress :: a -> ContractAddress -instance HasInstanceParameters (InstanceParameters v) where +instance HasInstanceAddress (InstanceParameters v) where instanceAddress InstanceParameters{..} = _instanceAddress instance Show (InstanceParameters v) where @@ -44,7 +46,9 @@ instance Show (InstanceParameters v) where instance HashableTo H.Hash (InstanceParameters v) where getHash = instanceParameterHash -data InstanceV v = InstanceV { +-- |A versioned basic in-memory instance, parametrized by the version of the +-- Wasm module that is associated with it. +data InstanceV (v :: Wasm.WasmVersion) = InstanceV { -- |The fixed parameters of the instance _instanceVParameters :: !(InstanceParameters v), -- |The current local state of the instance @@ -77,10 +81,10 @@ instance HasInstanceFields Instance where instanceHash (InstanceV1 i) = instanceHash i -instance HasInstanceParameters (InstanceV v) where +instance HasInstanceAddress (InstanceV v) where instanceAddress = instanceAddress . _instanceVParameters -instance HasInstanceParameters Instance where +instance HasInstanceAddress Instance where instanceAddress (InstanceV0 i) = instanceAddress i instanceAddress (InstanceV1 i) = instanceAddress i @@ -156,9 +160,7 @@ makeInstanceV :: -- ^Address for the instance -> InstanceV v makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress - = case GSWasm.miModule instanceModuleInterface of - GSWasm.InstrumentedWasmModuleV0 {} -> InstanceV{..} - GSWasm.InstrumentedWasmModuleV1 {} -> InstanceV{..} + = InstanceV{..} where instanceContractModule = GSWasm.miModuleRef instanceModuleInterface instanceParameterHash = makeInstanceParameterHash _instanceAddress instanceOwner instanceContractModule instanceInitName @@ -183,16 +185,11 @@ makeInstance :: -> Instance makeInstance instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress = case GSWasm.miModule instanceModuleInterface of - GSWasm.InstrumentedWasmModuleV0 {} -> InstanceV0 (makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress) - GSWasm.InstrumentedWasmModuleV1 {} -> InstanceV1 (makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress) - --- |The address of a smart contract instance. -iaddress :: Instance -> ContractAddress -iaddress (InstanceV0 InstanceV{..}) = _instanceAddress _instanceVParameters -iaddress (InstanceV1 InstanceV{..}) = _instanceAddress _instanceVParameters + GSWasm.InstrumentedWasmModuleV0 {} -> InstanceV0 instanceV + GSWasm.InstrumentedWasmModuleV1 {} -> InstanceV1 instanceV + where instanceV = makeInstanceV instanceInitName instanceReceiveFuns instanceModuleInterface _instanceVModel _instanceVAmount instanceOwner _instanceAddress -- |Update a given smart contract instance. --- FIXME: Updates to the state should be done better in the future, we should not just replace it. updateInstanceV :: AmountDelta -> Maybe Wasm.ContractState -> InstanceV v -> InstanceV v updateInstanceV delta val i = updateInstanceV' amnt val i where amnt = applyAmountDelta delta (_instanceVAmount i) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 294ccae956..e864e9b837 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -993,9 +993,9 @@ doPutNewInstance pbs fnew = do pinstanceInitName = instanceInitName, pinstanceParameterHash = instanceParameterHash } - -- This in an irrefutable pattern because otherwise it would have failed in previous stages - -- as it would be trying to create an instance of a module that doesn't exist. - -- TODO: FIX signature of putnewinstance + -- We use an irrefutable pattern here. This cannot fail since if it failed it would mean we are trying + -- to create an instance of a module that does not exist. The Scheduler should not allow this, and the + -- state implementation relies on this property. ~(Just modRef) <- Modules.unsafeGetModuleReferenceV0 (GSWasm.miModuleRef instanceModuleInterface) mods return (inst, PersistentInstanceV0 Instances.PersistentInstanceV{ pinstanceParameters = params, @@ -1013,9 +1013,9 @@ doPutNewInstance pbs fnew = do pinstanceInitName = instanceInitName, pinstanceParameterHash = instanceParameterHash } - -- This in an irrefutable pattern because otherwise it would have failed in previous stages - -- as it would be trying to create an instance of a module that doesn't exist. - -- TODO: FIX signature of putnewinstance + -- We use an irrefutable pattern here. This cannot fail since if it failed it would mean we are trying + -- to create an instance of a module that does not exist. The Scheduler should not allow this, and the + -- state implementation relies on this property. ~(Just modRef) <- Modules.unsafeGetModuleReferenceV1 (GSWasm.miModuleRef instanceModuleInterface) mods return (inst, PersistentInstanceV1 Instances.PersistentInstanceV{ pinstanceParameters = params, @@ -1038,7 +1038,7 @@ doModifyInstance pbs caddr deltaAmnt val = do (piParams, newParamsRef) <- cacheBufferedRef (pinstanceParameters oldInst) if deltaAmnt == 0 then case val of - Nothing -> return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef})) + Nothing -> return ((), PersistentInstanceV0 $ oldInst {pinstanceParameters = newParamsRef}) Just newVal -> return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef, pinstanceModel = newVal})) else case val of @@ -1048,7 +1048,7 @@ doModifyInstance pbs caddr deltaAmnt val = do (piParams, newParamsRef) <- cacheBufferedRef (pinstanceParameters oldInst) if deltaAmnt == 0 then case val of - Nothing -> return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef})) + Nothing -> return ((), PersistentInstanceV1 $ oldInst {pinstanceParameters = newParamsRef}) Just newVal -> return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef, pinstanceModel = newVal})) else case val of diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs index 08a0e54e92..833995eb20 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs @@ -80,7 +80,7 @@ instance Applicative m => Cacheable m PersistentInstanceParameters -- `v` that is used to tie the instance version to the module version. At -- present the version only appears in the module, but with the state changes it -- will also appear in the contract state. -data PersistentInstanceV v = PersistentInstanceV { +data PersistentInstanceV (v :: Wasm.WasmVersion) = PersistentInstanceV { -- |The fixed parameters of the instance. pinstanceParameters :: !(BufferedRef PersistentInstanceParameters), -- |The interface of 'pinstanceContractModule'. Note this is a BufferedRef to a Module as this @@ -95,6 +95,13 @@ data PersistentInstanceV v = PersistentInstanceV { pinstanceHash :: H.Hash } +-- |Either a V0 or V1 instance. V1 instance is only allowed in protocol versions +-- P4 and up, however this is not explicit here since it needlessly complicates +-- code. The Scheduler ensures that no V1 instances can be constructed prior to +-- P4 version. This type exists since we need to store all versions of instances +-- in the instance table, as opposed to having multiple instance tables for +-- different instance versions. This is necessary because there is a single +-- address space for all contract instances. data PersistentInstance (pv :: ProtocolVersion) where PersistentInstanceV0 :: PersistentInstanceV GSWasm.V0 -> PersistentInstance pv PersistentInstanceV1 :: PersistentInstanceV GSWasm.V1 -> PersistentInstance pv @@ -267,7 +274,6 @@ putV1InstanceV0 PersistentInstanceV {..} = do put pinstanceModel put pinstanceAmount - ---------------------------------------------------------------------------------------------------- makeInstanceParameterHash :: ContractAddress -> AccountAddress -> ModuleRef -> Wasm.InitName -> H.Hash diff --git a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs index 9e8ae21a87..8f2387cfdc 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs @@ -20,7 +20,6 @@ module Concordium.GlobalState.Wasm ( newModuleArtifactV1, withModuleArtifact, InstrumentedModuleV(..), - imWasmVersion, imWasmArtifact, -- *** Module interface ModuleInterface(..), @@ -117,10 +116,6 @@ data InstrumentedModuleV v where deriving instance Eq (InstrumentedModuleV v) deriving instance Show (InstrumentedModuleV v) -imWasmVersion :: InstrumentedModuleV v -> Word32 -imWasmVersion (InstrumentedWasmModuleV0 _) = 0 -imWasmVersion (InstrumentedWasmModuleV1 _) = 1 - instance Serialize (InstrumentedModuleV V0) where put InstrumentedWasmModuleV0{..} = do putWord32be 0 @@ -128,7 +123,7 @@ instance Serialize (InstrumentedModuleV V0) where get = get >>= \case V0 -> InstrumentedWasmModuleV0 <$> get - _ -> fail "Expected Wasm version 0, got 1." + V1 -> fail "Expected Wasm version 0, got 1." instance Serialize (InstrumentedModuleV V1) where @@ -137,8 +132,8 @@ instance Serialize (InstrumentedModuleV V1) where put imWasmArtifactV1 get = get >>= \case + V0 -> fail "Expected Wasm version 1, got 0." V1 -> InstrumentedWasmModuleV1 <$> get - _ -> fail "ExpectedWasm version 0, got 1." -------------------------------------------------------------------------------- @@ -152,8 +147,8 @@ data ModuleInterfaceV v = ModuleInterface { -- |Receive methods exposed by this module, indexed by contract name. -- They should each be exposed with a type Amount -> Word32 miExposedReceive :: !(Map.Map InitName (Set.Set ReceiveName)), - -- |Module source in binary format, instrumented with whatever it needs to be - -- instrumented with to be able to run efficiently. + -- |Module source processed into an efficiently executable format. + -- For details see "Artifact" in smart-contracts/wasm-chain-integration miModule :: !(InstrumentedModuleV v), -- |Size of the module as deployed in the transaction. miModuleSize :: !Word64 diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index 5def30e68c..795f84e67c 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -452,7 +452,7 @@ getAccountList = liftSkovQueryBlock $ BS.getAccountList <=< blockState getInstanceList :: BlockHash -> MVR gsconf finconf (Maybe [ContractAddress]) getInstanceList = liftSkovQueryBlock $ - fmap (fmap iaddress) . BS.getContractInstanceList <=< blockState + fmap (fmap instanceAddress) . BS.getContractInstanceList <=< blockState -- |Get the list of modules present as of a given block. getModuleList :: BlockHash -> MVR gsconf finconf (Maybe [ModuleRef]) diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index b3f3bfbed4..59891c86a3 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -916,13 +916,13 @@ checkAndGetBalanceInstanceV0 ownerAccount istance transferAmount = do -- |Handle updating a V1 contract. -- In contrast to most other methods in this file this one does not use the -- error handling facilities of the transaction monad. Instead it explicitly returns an Either type. --- The reason for this is the possible errors are exposed back to the smart contract in case --- a contract A invokes contract B's entrypoint. -handleContractUpdateV1 :: forall pv m. - (TransactionMonad pv m, AccountOperations m) +-- The reason for this is that the possible errors are exposed back to the smart +-- contract in case a contract A invokes contract B's entrypoint. +handleContractUpdateV1 :: forall pv r m. + (IsProtocolVersion pv, StaticInformation m, AccountOperations m) => AccountAddress -- ^The address that was used to send the top-level transaction. -> InstanceV GSWasm.V1 -- ^The current state of the target contract of the transaction, which must exist. - -> (Amount -> m (Either WasmV1.ContractCallFailure (Address, [ID.AccountCredential], Either ContractAddress IndexedAccountAddress))) + -> (Amount -> LocalT pv r m (Either WasmV1.ContractCallFailure (Address, [ID.AccountCredential], Either ContractAddress IndexedAccountAddress))) -- ^Check that the sender has sufficient amount to cover the given amount and return a triple of -- - used address -- - credentials of the address, either account or owner of the contract @@ -932,7 +932,7 @@ handleContractUpdateV1 :: forall pv m. -> Amount -- ^The amount to be transferred from the sender of the message to the contract upon success. -> Wasm.ReceiveName -- ^Name of the contract to invoke. -> Wasm.Parameter -- ^Message to invoke the receive method with. - -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) + -> LocalT pv r m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) -- ^The events resulting from processing the message and all recursively processed messages. For efficiency -- reasons the events are in **reverse order** of the actual effects. handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount receiveName parameter = do @@ -978,7 +978,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei let go :: [Event] -> Either WasmV1.ContractExecutionReject WasmV1.ReceiveResultData -- ^Result of invoking an operation - -> m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) + -> LocalT pv r m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event])) go _ (Left cer) = return (Left (WasmV1.ExecutionReject cer)) -- contract execution failed. go events (Right rrData) = do -- balance at present before handling out calls or transfers. @@ -1030,11 +1030,11 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei -- in this case we essentially treat this as a top-level transaction invoking that contract. -- That is, we execute the entire tree that is potentially generated. let rName = Wasm.uncheckedMakeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName - runSuccess = Right <$> handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstanceV0 ownerAccount istance) imcAmount rName imcParam + runSuccess = handleContractUpdateV0 originAddr targetInstance (checkAndGetBalanceInstanceV0 ownerAccount istance) imcAmount rName imcParam -- If execution of the contract succeeds resume. -- Otherwise rollback the state and report that to the caller. - (runSuccess `orElseWith` (return . Left)) >>= \case - Left _ -> -- execution failed, ignore the reject reason since V0 contract cannot return useful information + runInnerTransaction runSuccess >>= \case + Left err -> do -- execution failed, ignore the reject reason since V0 contract cannot return useful information go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing entryBalance WasmV1.MessageSendFailed Nothing) Right evs -> do -- Execution of the contract might have changed our own state. If so, we need to resume in the new state, otherwise @@ -1044,13 +1044,13 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei newBalance <- getCurrentContractAmount istance go (resumeEvent True:evs ++ interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig resumeState newBalance WasmV1.Success Nothing) Just (InstanceV1 targetInstance) -> do - -- invoking a V1 instance is easier we recurse on the update function. + -- invoking a V1 instance is easier. We recurse on the update function. -- If this returns Right _ it is successful, and we pass this, and the returned return value -- to the caller. -- Otherwise we roll back all the changes and return the return value, and the error code to the caller. let rName = Wasm.uncheckedMakeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName withRollback (handleContractUpdateV1 originAddr targetInstance (checkAndGetBalanceInstanceV1 ownerAccount istance) imcAmount rName imcParam) >>= \case - Left cer -> + Left cer -> do go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing entryBalance (WasmV1.Error cer) (WasmV1.ccfToReturnValue cer)) Right (rVal, callEvents) -> do (lastModifiedIndex, newState) <- getCurrentContractInstanceState istance @@ -1067,7 +1067,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei where transferAccountSync :: AccountAddress -- ^The target account address. -> InstanceV GSWasm.V1 -- ^The sender of this transfer. -> Amount -- ^The amount to transfer. - -> ExceptT WasmV1.EnvFailure m [Event] -- ^The events resulting from the transfer. + -> ExceptT WasmV1.EnvFailure (LocalT pv r m) [Event] -- ^The events resulting from the transfer. transferAccountSync accAddr senderInstance tAmount = do -- charge at the beginning, successful and failed transfers will have the same cost. -- Check whether the sender has the amount to be transferred and reject the transaction if not. @@ -1085,26 +1085,25 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei return [Transferred addr transferAmount (AddressAccount accAddr)]) --- | Process a message to a contract. +-- | Invoke a V0 contract and process any generated messages. -- This includes the transfer of an amount from the sending account or instance. -- Recursively do the same for new messages created by contracts (from left to right, depth first). -- The target contract must exist, so that its state can be looked up. -handleContractUpdateV0 :: forall pv m. - (TransactionMonad pv m, AccountOperations m) +handleContractUpdateV0 :: forall pv r m. + (IsProtocolVersion pv, StaticInformation m, AccountOperations m) => AccountAddress -- ^The address that was used to send the top-level transaction. -> InstanceV GSWasm.V0 -- ^The current state of the target contract of the transaction, which must exist. - -> (Amount -> m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress))) - -- ^The sender of the message (contract instance or account). In case this is - -- a contract the first parameter is the owner account of the instance. In case this is an account + -> (Amount -> LocalT pv r m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress))) + -- ^Check that the sender has sufficient amount to cover the given amount and return a triple of + -- - used address + -- - credentials of the address, either account or owner of the contract + -- - resolved address. In case this is an account -- (i.e., this is called from a top-level transaction) the value is a pair of the address that was used -- as the sender address of the transaction, and the account to which it points. - -- On the first invocation of this function this will be the sender of the - -- top-level transaction, and in recursive calls the respective contract - -- instance that produced the message. -> Amount -- ^The amount to be transferred from the sender of the message to the receiver. -> Wasm.ReceiveName -- ^Name of the contract to invoke. -> Wasm.Parameter -- ^Message to invoke the receive method with. - -> m [Event] -- ^The events resulting from processing the message and all recursively processed messages. + -> LocalT pv r m [Event] -- ^The events resulting from processing the message and all recursively processed messages. handleContractUpdateV0 originAddr istance checkAndGetSender transferAmount receiveName parameter = do -- Cover administrative costs. tickEnergy Cost.updateContractInstanceBaseCost @@ -1184,12 +1183,12 @@ handleContractUpdateV0 originAddr istance checkAndGetSender transferAmount recei traversalStepCost :: Energy traversalStepCost = 10 -foldEvents :: (TransactionMonad pv m, AccountOperations m) +foldEvents :: (IsProtocolVersion pv, StaticInformation m, AccountOperations m) => AccountAddress -- ^Address that was used in the top-level transaction. -> (IndexedAccount m, InstanceV GSWasm.V0) -- ^Instance that generated the events. -> Event -- ^Event generated by the invocation of the instance. -> Wasm.ActionsTree -- ^Actions to perform - -> m [Event] -- ^List of events in order that transactions were traversed. + -> LocalT pv r m [Event] -- ^List of events in order that transactions were traversed. foldEvents originAddr istance initEvent = fmap (initEvent:) . go where go Wasm.TSend{..} = do getCurrentContractInstanceTicking erAddr >>= \case @@ -1223,7 +1222,14 @@ foldEvents originAddr istance initEvent = fmap (initEvent:) . go go l `orElse` go r go Wasm.Accept = return [] -mkSenderAddrCredentials :: AccountOperations m => Either (IndexedAccount m, ContractAddress) (AccountAddress, IndexedAccount m) -> m (Address, [ID.AccountCredential]) +-- |Construct the address and a list of credentials of the sender. If the sender +-- is an account, this is the address of the account that was used in the +-- transaction, together with the list of credentials of that account, ordered +-- by credential index. If the sender is a smart contract the returned address +-- will be a contract address, and the credentials will be of the owner account. +mkSenderAddrCredentials :: AccountOperations m + => Either (IndexedAccount m, ContractAddress) (AccountAddress, IndexedAccount m) + -> m (Address, [ID.AccountCredential]) mkSenderAddrCredentials sender = case sender of Left (ownerAccount, iaddr) -> do @@ -1237,7 +1243,7 @@ mkSenderAddrCredentials sender = -- | Handle the transfer of an amount from a contract instance to an account. handleTransferAccount :: - (TransactionMonad pv m, HasInstanceParameters a, HasInstanceFields a) + (TransactionMonad pv m, HasInstanceAddress a, HasInstanceFields a) => AccountAddress -- ^The target account address. -> a -- ^The sender of this transfer. -> Amount -- ^The amount to transfer. diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index c7c088fae2..3ee48e5abe 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -46,7 +46,7 @@ import Control.Exception(assert) import qualified Concordium.ID.Types as ID import Concordium.Wasm (IsWasmVersion) --- |An account index togehter with the canonical address. Sometimes it is +-- |An account index together with the canonical address. Sometimes it is -- difficult to pass an IndexedAccount and we only need the addresses. That is -- when this type is useful. type IndexedAccountAddress = (AccountIndex, AccountAddress) @@ -74,7 +74,6 @@ class (Monad m) => StaticInformation m where getContractInstance :: ContractAddress -> m (Maybe Instance) -- |Get the amount of funds at the particular account address at the start of a transaction. - -- To get the amount of funds for a contract instance use getInstance and lookup amount there. getStateAccount :: AccountAddress -> m (Maybe (IndexedAccount m)) -- |Information needed to execute transactions in the form that is easy to use. @@ -305,7 +304,7 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Transfer an amount from the first instance to the second and run the -- computation in the modified environment. - withContractToContractAmount :: ContractAddress -> InstanceV v2 -> Amount -> m a -> m a + withContractToContractAmount :: ContractAddress -> InstanceV v -> Amount -> m a -> m a -- |Transfer a scheduled amount from the first address to the second and run -- the computation in the modified environment. @@ -338,17 +337,12 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- |Transfer an amount from the first given instance or account to the instance in the second -- parameter and run the computation in the modified environment. {-# INLINE withToContractAmount #-} - withToContractAmount :: Either ContractAddress IndexedAccountAddress -> InstanceV v2 -> Amount -> m a -> m a + withToContractAmount :: Either ContractAddress IndexedAccountAddress -> InstanceV v -> Amount -> m a -> m a withToContractAmount (Left i) = withContractToContractAmount i withToContractAmount (Right a) = withAccountToContractAmount a getCurrentContractInstance :: ContractAddress -> m (Maybe Instance) - {-# INLINE getCurrentAvailableAmount #-} - getCurrentAvailableAmount :: Either (IndexedAccount m, InstanceV v) (AccountAddress, IndexedAccount m) -> m Amount - getCurrentAvailableAmount (Left (_, i)) = getCurrentContractAmount i - getCurrentAvailableAmount (Right (_, a)) = getCurrentAccountAvailableAmount a - -- |Get the current total public balance of an account. -- This accounts for any pending changes in the course of execution of the transaction. -- This includes any funds that cannot be spent due to lock-up or baking. @@ -361,11 +355,11 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - getCurrentAccountAvailableAmount :: IndexedAccount m -> m Amount -- |Same as above, but for contracts. - getCurrentContractAmount :: (HasInstanceParameters a, HasInstanceFields a) => a -> m Amount + getCurrentContractAmount :: (HasInstanceAddress a, HasInstanceFields a) => a -> m Amount -- |Get the current contract instance state, together with the modification -- index of the last modification. - getCurrentContractInstanceState :: (HasInstanceParameters a, HasInstanceFields a) => a -> m (ModificationIndex, Wasm.ContractState) + getCurrentContractInstanceState :: (HasInstanceAddress a, HasInstanceFields a) => a -> m (ModificationIndex, Wasm.ContractState) -- |Get the amount of energy remaining for the transaction. getEnergy :: m (Energy, EnergyLimitReason) @@ -386,12 +380,6 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - -- entire computation is aborted. orElse :: m a -> m a -> m a - -- |Try to run the first computation. If it leads to `reject` for a logic - -- reason then try the second computation. If the left computation fails with - -- out of energy then the entire computation is aborted. Compared to 'orElse' - -- above, here the right computation gets access to the rejection reason of the left one. - orElseWith :: m a -> (RejectReason -> m a) -> m a - -- |Try to run the first computation. If it leads to `Left err` then abort and revert all the changes -- apart from consumed energy. withRollback :: m (Either a b) -> m (Either a b) @@ -484,17 +472,13 @@ modifyAmountCS ai !amnt !cs = cs & (accountUpdates . ix ai . auAmount ) %~ -- |Add or update the contract state in the changeset with the given value. --- |NB: If the instance is not yet in the changeset we assume that its balance is --- as listed in the given instance structure. -addContractStatesToCS :: HasInstanceParameters a => a -> ModificationIndex -> Wasm.ContractState -> ChangeSet -> ChangeSet +addContractStatesToCS :: HasInstanceAddress a => a -> ModificationIndex -> Wasm.ContractState -> ChangeSet -> ChangeSet addContractStatesToCS istance curIdx newState = instanceUpdates . at addr %~ \case Just (_, amnt, _) -> Just (curIdx, amnt, Just newState) Nothing -> Just (curIdx, 0, Just newState) where addr = instanceAddress istance -- |Add the given delta to the change set for the given contract instance. --- NB: If the contract is not yet in the changeset it is added, taking the --- model as given in the first argument to be current model (local state) addContractAmountToCS :: ContractAddress -> AmountDelta -> ChangeSet -> ChangeSet addContractAmountToCS addr amnt cs = -- updating amounts does not update the modification index. Only state updates do. @@ -520,7 +504,12 @@ data LocalState = LocalState{ _energyLeft :: !Energy, -- |Changes accumulated thus far. _changeSet :: !ChangeSet, - -- |Maximum number of modified contract instances. + -- |The next available modification index. When a contract state is modified + -- this is used to keep track of "when" it was modified. In the scheduler we + -- then remember the modification index before a contract invokes another + -- contract, and look it up just before contract execution resumes. Comparing + -- them gives information on whether the contract state has definitely not + -- changed, or whether there were writes to the state. _nextContractModificationIndex :: !ModificationIndex, _blockEnergyLeft :: !Energy } @@ -738,6 +727,26 @@ instance StaticInformation m => StaticInformation (LocalT pv r m) where deriving via (MGSTrans (LocalT pv r) m) instance AccountOperations m => AccountOperations (LocalT pv r m) +-- |Execute an inner transaction, reifying it into the return value. This +-- behaves as the given computation in case it does not exit early, and resets +-- the state of execution to the beginning in case of an error. In this case the +-- error is also returned in the return value. +runInnerTransaction :: Monad m => LocalT pv a m a -> LocalT pv r m (Either RejectReason a) +runInnerTransaction (LocalT kOrig) = LocalT $ ContT $ \k -> do + initChangeSet <- use changeSet + initModificationIndex <- use nextContractModificationIndex + -- Run the given computation to the end by giving it a fresh continuation that + -- just returns, as if this was a top-level transaction. + comp <- runContT kOrig (return . Right) + case comp of + Left Nothing -> return (Left Nothing) + Left (Just err) | err == OutOfEnergy -> energyLeft .= 0 >> return (Left (Just OutOfEnergy)) + Left (Just err) -> do + changeSet .= initChangeSet + nextContractModificationIndex .= initModificationIndex + k (Left err) + Right x -> k (Right x) + instance (IsProtocolVersion pv, StaticInformation m, AccountOperations m, Monad m) => TransactionMonad pv (LocalT pv r m) where {-# INLINE withInstanceStateV0 #-} withInstanceStateV0 istance val cont = do @@ -909,20 +918,6 @@ instance (IsProtocolVersion pv, StaticInformation m, AccountOperations m, Monad runContT r k x -> return x - {-# INLINE orElseWith #-} - orElseWith (LocalT l) r = LocalT $ ContT $ \k -> do - initChangeSet <- use changeSet - initModificationIndex <- use nextContractModificationIndex - runContT l k >>= \case - (Left (Just reason)) | reason /= OutOfEnergy -> do - -- reset changeSet, the left computation will have no effect at all other than - -- energy use. - changeSet .= initChangeSet - nextContractModificationIndex .= initModificationIndex - runContT (_runLocalT (r reason)) k - x -> return x - - {-# INLINE withRollback #-} withRollback (LocalT l) = LocalT $ ContT $ \k -> do initChangeSet <- use changeSet diff --git a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs index 472d0e9b53..ef5bb255b5 100644 --- a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -1,3 +1,19 @@ +{-| This module provides a way to invoke contract entrypoints directly, without +going through a transaction and the scheduler. + +The main function is 'invokeContract' which executes the required contract +entrypoint in the desired context. Currently it is only possible to execute a +contract in the state at the end of a given block, this might be relaxed in the +future. + +The main use-case of this functionality are "view-functions", which is a way to +inspect the state of a contract off-chain to enable integrations of off-chain +services with smart contracts. 'invokeContract' is exposed via the +InvokeContract API entrypoint. + +In the future this should be expanded to allow "dry-run" execution of every +transaction, and to allow execution in a more precise state context. +-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -7,7 +23,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -module Concordium.Scheduler.InvokeContract where +module Concordium.Scheduler.InvokeContract (invokeContract) where import Lens.Micro.Platform import Control.Monad.Reader @@ -27,6 +43,17 @@ import Concordium.Scheduler.EnvironmentImplementation (ContextState(..), maxBloc import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 import Concordium.Scheduler +-- |A wrapper that provides enough instances so that transactions can be executed. In particular +-- this is aimed towards execution of `handleContractUpdate`. +-- This type is equipped with (in particular) +-- +-- - BlockStateTypes +-- - AccountOperations +-- - StaticInformation +-- +-- It is then used together with the LocalT transformer to be able to execute +-- transactions without the context of the scheduler. This is achieved via (the +-- only) instance of TransactionMonad for the LocalT transformer. newtype InvokeContractMonad (pv :: ProtocolVersion) m a = InvokeContractMonad {_runInvokeContract :: ReaderT (ContextState, BlockState m) m a} deriving (Functor, Applicative, @@ -98,11 +125,13 @@ invokeContract _ ContractContext{..} cm bs = do Just (Instance.InstanceV0 i@Instance.InstanceV{..}) -> do let ownerAccountAddress = instanceOwner _instanceVParameters getStateAccount ownerAccountAddress >>= \case + -- the first case should really never happen, since a valid instance should always have a valid account. Nothing -> return (Left (Just $ InvalidAccountReference ownerAccountAddress)) Just acc -> return (Right (checkAndGetBalanceInstanceV0 acc i, ownerAccountAddress, fst acc)) Just (Instance.InstanceV1 i@Instance.InstanceV{..}) -> do let ownerAccountAddress = instanceOwner _instanceVParameters getStateAccount ownerAccountAddress >>= \case + -- the first case should really never happen, since a valid instance should always have a valid account. Nothing -> return (Left (Just $ InvalidAccountReference ownerAccountAddress)) Just acc -> return (Right (checkAndGetBalanceInstanceV0 acc i, ownerAccountAddress, fst acc)) let runContractComp = @@ -118,18 +147,24 @@ invokeContract _ ContractContext{..} cm bs = do return (r, _energyLeft cs) contextState = ContextState{_maxBlockEnergy = ccEnergy, _accountCreationLimit = 0, _chainMetadata = cm} runReaderT (_runInvokeContract runContractComp) (contextState, bs) >>= \case - (Left Nothing, re) -> -- cannot happen (this would mean out of block energy), but this is safe to do and not wrong - return Failure{rcrReason = OutOfEnergy, rcrUsedEnergy = ccEnergy - re} + -- cannot happen (this would mean out of block energy, and we set block energy no lower than energy), + -- but this is safe to do and not wrong + (Left Nothing, re) -> + return Failure{rcrReason = OutOfEnergy, rcrUsedEnergy = ccEnergy - re} + -- Contract execution of a V0 contract failed with the given reason. (Left (Just rcrReason), re) -> return Failure{rcrUsedEnergy = ccEnergy - re,..} + -- Contract execution of a V0 contract succeeded with the given list of events (Right (Left rcrEvents), re) -> return Success{rcrReturnValue=Nothing, rcrUsedEnergy = ccEnergy - re, ..} + -- Contract execution of a V1 contract failed with the given reason and potentially a return value (Right (Right (Left cf)), re) -> return (Failure{ rcrReason = WasmV1.cerToRejectReasonReceive ccContract ccMethod ccParameter cf, rcrUsedEnergy = ccEnergy - re}) + -- Contract execution of a V1 contract succeeded with the given return value. (Right (Right (Right (rv, reversedEvents))), re) -> -- handleUpdateContractV1 returns events in reverse order return Success{rcrReturnValue=Just (WasmV1.returnValueToByteString rv), rcrUsedEnergy = ccEnergy - re, diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 63d2a67ccc..41af0facb6 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -34,7 +34,6 @@ import Data.Bits import Data.Int import Data.Word import qualified Data.Aeson as AE -import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Serialize import qualified Data.Map.Strict as Map @@ -138,7 +137,7 @@ data EnvFailure = -- data in memory, or via host functions, both of which are difficult. -- The response is encoded as follows. -- - success is encoded as 0 --- - every failure has all bits of the first 3 bytes set +-- - every failure has all bits of the first (most significant) 3 bytes set -- - in case of failure -- - if the 4th byte is 0 then the remaining 4 bytes encode the rejection reason from the contract -- - otherwise only the 4th byte is used, and encodes the enviroment failure. @@ -207,6 +206,7 @@ foreign import ccall "resume_receive_v1" -- |Apply an init function which is assumed to be a part of the module. +{-# NOINLINE applyInitFun #-} applyInitFun :: ModuleInterfaceV V1 -> ChainMetadata -- ^Chain information available to the contracts. @@ -233,7 +233,8 @@ applyInitFun miface cm initCtx iName param amnt iEnergy = unsafePerformIO $ do energy returnValuePtrPtr outputLenPtr - if outPtr == nullPtr then return (Just (Left Trap, 0)) -- This case should not happen. + -- This case should not happen, it means a mismatch between two sides of FFI. + if outPtr == nullPtr then return (Just (Left Trap, 0)) else do len <- peek outputLenPtr bs <- BSU.unsafePackCStringFinalizer outPtr (fromIntegral len) (rs_free_array_len outPtr (fromIntegral len)) @@ -310,6 +311,10 @@ cerToRejectReasonInit :: ContractExecutionReject -> Exec.RejectReason cerToRejectReasonInit LogicReject{..} = Exec.RejectedInit cerRejectReason cerToRejectReasonInit Trap = Exec.RuntimeFailure +-- |Parse the response from invoking a @call_init_v1@ method. This attempts to +-- parse the returned byte array and depending on its contents it will also +-- update the given pointers. See documentation of the above mentioned imported +-- function for the specification of the return value. processInitResult :: -- |Serialized output. BS.ByteString @@ -322,14 +327,18 @@ processInitResult result returnValuePtr = case BS.uncons result of Just (tag, payload) -> case tag of 0 -> return Nothing - 1 -> let parser = do -- reject + 1 -> let parser = -- runtime failure + label "Init.remainingEnergy" getWord64be + in let remainingEnergy = parseResult parser + in do return (Just (Left Trap, fromIntegral remainingEnergy)) + 2 -> let parser = do -- reject rejectReason <- label "Reject.rejectReason" getInt32be remainingEnergy <- label "Reject.remainingEnergy" getWord64be return (rejectReason, remainingEnergy) in let (cerRejectReason, remainingEnergy) = parseResult parser in do cerReturnValue <- ReturnValue <$> newForeignPtr freeReturnValue returnValuePtr return (Just (Left LogicReject{..}, fromIntegral remainingEnergy)) - 2 -> -- done + 3 -> -- done let parser = do newState <- label "Done.newState" get logs <- label "Done.logs" getLogs @@ -365,7 +374,11 @@ cerToRejectReasonReceive _ _ _ (EnvFailure e) = case e of MissingContract cref -> Exec.InvalidContractAddress cref InvalidEntrypoint mref rn -> Exec.InvalidReceiveMethod mref rn - +-- |Parse the response from invoking either a @call_receive_v1@ or +-- @resume_receive_v1@ method. This attempts to parse the returned byte array +-- and depending on its contents it will also update the given pointers. See +-- documentation of the above mentioned imported functions for the specification +-- of the return value. processReceiveResult :: BS.ByteString -- ^Serialized output. -> Ptr ReturnValue -- ^Location where the pointer to the return value is (potentially) stored. @@ -381,7 +394,7 @@ processReceiveResult result returnValuePtr eitherInterruptedStatePtr = case BS.u 1 -> let parser = -- runtime failure label "Reject.remainingEnergy" getWord64be in let remainingEnergy = parseResult parser - in do return (Just (Left Trap, fromIntegral remainingEnergy)) + in return (Just (Left Trap, fromIntegral remainingEnergy)) 2 -> let parser = do -- reject rejectReason <- label "Reject.rejectReason" getInt32be remainingEnergy <- label "Reject.remainingEnergy" getWord64be @@ -417,6 +430,7 @@ processReceiveResult result returnValuePtr eitherInterruptedStatePtr = case BS.u -- |Apply a receive function which is assumed to be part of the given module. +{-# NOINLINE applyReceiveFun #-} applyReceiveFun :: ModuleInterfaceV V1 -> ChainMetadata -- ^Metadata available to the contract. @@ -463,6 +477,7 @@ applyReceiveFun miface cm receiveCtx rName param amnt cs initialEnergy = unsafeP nameBytes = Text.encodeUtf8 (receiveName rName) -- |Resume execution after processing the interrupt. This can only be called once on a single 'ReceiveInterruptedState'. +{-# NOINLINE resumeReceiveFun #-} resumeReceiveFun :: ReceiveInterruptedState -> Maybe ContractState -- ^State of the contract to start in. @@ -534,10 +549,9 @@ processModule modl = do let names = foldM (\(inits, receives) name -> do case Text.decodeUtf8' name of Left _ -> Nothing - Right nameText | isValidInitName nameText -> return (Set.insert (InitName nameText) inits, receives) - | isValidReceiveName nameText -> - let cname = "init_" <> Text.takeWhile (/= '.') nameText - in return (inits, Map.insertWith Set.union (InitName cname) (Set.singleton (ReceiveName nameText)) receives) + Right nameText | Just initName <- extractInitName nameText -> return (Set.insert initName inits, receives) + | Just (initName, receiveName) <- extractInitReceiveNames nameText -> + return (inits, Map.insertWith Set.union initName (Set.singleton receiveName) receives) -- ignore any other exported functions. -- This is different from V0 contracts, which disallow any extra function exports. -- This feature was requested by some users. diff --git a/concordium-consensus/testdata/contracts/README.md b/concordium-consensus/testdata/contracts/README.md new file mode 100644 index 0000000000..c2ffb13af9 --- /dev/null +++ b/concordium-consensus/testdata/contracts/README.md @@ -0,0 +1,12 @@ +# Example contracts + +This directory and its subdirectories contain a number of wasm modules that are +used to test integration of the smart contract execution engine with the +scheduler. + +These modules are generally written manually in Web Assembly Text format (`.wat`) +and then transformed to `.wasm` files using the `wat2wasm` tool, which is part +of the [web assembly binary toolkit](https://github.com/WebAssembly/wabt). + +Each of the `.wat` files should start with a header briefly explaining the +contents of the module, and what it is designed to test. diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wat b/concordium-consensus/testdata/contracts/v1/call-counter.wat index a44e014034..f46b9feb50 100644 --- a/concordium-consensus/testdata/contracts/v1/call-counter.wat +++ b/concordium-consensus/testdata/contracts/v1/call-counter.wat @@ -1,7 +1,7 @@ ;; Test for one contract calling itself. -;; There are two entrypoints, one which just increments the counter, and another -;; which repeatedly calls the former endpoint to increase the counter by 10. -;; This latter endpoint checks the return value. +;; There are three entrypoints, one which just increments the counter, another +;; which repeatedly calls the former entrypoint to increase the counter by 10, +;; and a version of the latter that does not check the return value. (module @@ -74,7 +74,10 @@ (i32.const 0) ) - ;; call the counter.inc method 10 times. Check returns each time. + ;; Invoke the contract provided as a parameter a given number of times. + ;; The intent is that the provided method is counter.inc, otherwise this will + ;; almost certainly fail. Check returns each time, making sure that they are + ;; consistent with the state. (func $inc_counter_10 (export "counter.inc10") (param i64) (result i32) (local $n i32) (local $size i32) @@ -87,7 +90,7 @@ ;; get the index of the response ;; the numeric value 8388607 is the mask 0b0111_1111_1111_1111_1111_1111 (local.set $index (i32.and (i32.const 8388607) (i32.wrap_i64 (i64.shr_u (local.get $rv) (i64.const 40))))) - ;; and get the parameter size, check it that it is the value of the counter + ;; and get the parameter size, check that it is the value of the counter ;; first check that the size is correct (call $assert_eq (call $get_parameter_size (local.get $index)) (i32.const 8)) ;; next check that the return value is the same as the current contract state (state after the call) diff --git a/concordium-consensus/testdata/contracts/v1/self-balance.wat b/concordium-consensus/testdata/contracts/v1/self-balance.wat index 092757faef..90da7a2eec 100644 --- a/concordium-consensus/testdata/contracts/v1/self-balance.wat +++ b/concordium-consensus/testdata/contracts/v1/self-balance.wat @@ -36,7 +36,7 @@ (local.set $start_balance (call $get_receive_self_balance)) ;; invoke, interpret the first 4 bytes as the instruction, the remaining bytes as the parameter (call $invoke (i32.load (i32.const 0)) (i32.const 4) (i32.sub (local.get $size) (i32.const 4))) - ;; store the return value, balance before and after the call + ;; store the return value and balances before and after the call (i64.store (i32.const 0) (local.get $start_balance)) (i64.store (i32.const 8) (call $get_receive_self_balance)) (call $write_output (i32.const 0) (i32.const 16) (i32.const 0)) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs index c7ccbd5ae6..2cc117d3d4 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs @@ -56,7 +56,7 @@ checkBinary bop x y sbop sx sy = unless (bop x y) $ Left $ "Not satisfied: " ++ invariantIT :: ContractIndex -> IT -> Either String (Word8, Bool, Bool, ContractIndex, H.Hash, Word64) invariantIT offset (Leaf inst) = do - checkBinary (==) (contractIndex $ iaddress inst) offset "==" "account index" "expected value" + 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 diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs index 08eb1b7beb..23df49d9fd 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs @@ -65,7 +65,7 @@ testChainMeta = do case invariantBlockState gs (finState ^. Types.schedulerExecutionCosts) of Left f -> liftIO $ assertFailure $ f ++ " " ++ show gs _ -> return () - return (getResults ftAdded, ftFailed, gs ^.. blockInstances . foldInstances . to (\i -> (iaddress i, i))) + return (getResults ftAdded, ftFailed, gs ^.. blockInstances . foldInstances . to (\i -> (instanceAddress i, i))) checkChainMetaResult :: TestResult -> Assertion checkChainMetaResult (suc, fails, instances) = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs index fd928ea3c5..738f1fc042 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs @@ -76,7 +76,7 @@ testInit proxy = do case invariantBlockState @pv gs (finState ^. Types.schedulerExecutionCosts)of Left f -> liftIO $ assertFailure $ f ++ " " ++ show gs _ -> return () - return (getResults ftAdded, ftFailed, gs ^.. blockInstances . foldInstances . to (\i -> (iaddress i, i))) + return (getResults ftAdded, ftFailed, gs ^.. blockInstances . foldInstances . to (\i -> (instanceAddress i, i))) checkInitResult :: forall pv . IsProtocolVersion pv => Proxy pv -> TestResult -> Assertion checkInitResult proxy (suc, fails, instances) = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs index ab6ae170b3..3b097f5559 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs @@ -110,7 +110,7 @@ testReceive Proxy = do case invariantBlockState gs (finState ^. Types.schedulerExecutionCosts) of Left f -> liftIO $ assertFailure $ f ++ " " ++ show gs _ -> return () - return (getResults ftAdded, ftFailed, gs ^.. blockInstances . foldInstances . to (\i -> (iaddress i, i))) + return (getResults ftAdded, ftFailed, gs ^.. blockInstances . foldInstances . to (\i -> (instanceAddress i, i))) checkReceiveResult :: TestResult -> Assertion checkReceiveResult (suc, fails, instances) = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs index f8023405f9..4c21b329ab 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs @@ -108,7 +108,7 @@ testRejectReasons = do case invariantBlockState gs (finState ^. Types.schedulerExecutionCosts) of Left f -> liftIO $ assertFailure $ f ++ " " ++ show gs _ -> return () - return (getResults ftAdded, ftFailed, gs ^.. blockInstances . foldInstances . to (\i -> (iaddress i, i))) + return (getResults ftAdded, ftFailed, gs ^.. blockInstances . foldInstances . to (\i -> (instanceAddress i, i))) checkTransactionResults :: TestResult -> Assertion checkTransactionResults (suc, fails, instances) = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs index 3ea637e209..58da0c20c8 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs @@ -136,7 +136,7 @@ testRejectReasons = do case invariantBlockState gs (finState ^. Types.schedulerExecutionCosts) of Left f -> liftIO $ assertFailure $ f ++ " " ++ show gs _ -> return () - return (getResults ftAdded, ftFailed, gs ^.. blockInstances . foldInstances . to (\i -> (iaddress i, i))) + return (getResults ftAdded, ftFailed, gs ^.. blockInstances . foldInstances . to (\i -> (instanceAddress i, i))) checkTransactionResults :: TestResult -> Assertion checkTransactionResults (suc, fails, instances) = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs index 42c06486c7..30b37c4878 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs @@ -11,8 +11,6 @@ import Control.Monad.Reader import Data.Serialize import qualified Data.ByteString.Short as BSS import qualified Data.ByteString as BS -import qualified Data.Map.Strict as OrdMap -import qualified Data.Set as Set import qualified Concordium.Scheduler.Types as Types import qualified Concordium.Crypto.SHA256 as Hash @@ -21,9 +19,7 @@ import Concordium.Types.SeedState (initialSeedState) import Concordium.GlobalState.Persistent.BlobStore import Concordium.GlobalState.BlockState import Concordium.GlobalState.Persistent.BlockState -import Concordium.GlobalState.Instance import Concordium.Wasm -import qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 import qualified Concordium.GlobalState.Wasm as GSWasm import qualified Concordium.Types.InvokeContract as InvokeContract import qualified Concordium.Scheduler.InvokeContract as InvokeContract @@ -33,6 +29,7 @@ import Concordium.Crypto.DummyData import Concordium.GlobalState.DummyData import SchedulerTests.TestUtils +import qualified SchedulerTests.SmartContracts.V1.InvokeHelpers as InvokeHelpers type ContextM = PersistentBlockStateMonad PV4 BlobStore (ReaderT BlobStore IO) @@ -52,36 +49,13 @@ counterSourceFile = "./testdata/contracts/v1/call-counter.wasm" deployModule :: ContextM (PersistentBlockState PV4, GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1) deployModule = do - ws <- liftIO $ BS.readFile counterSourceFile - let wm = WasmModuleV (ModuleSource ws) - case WasmV1.processModule wm of - Nothing -> liftIO $ assertFailure "Invalid counter module." - Just miv -> do - (_, modState) <- flip bsoPutNewModule (miv, wm) . hpbsPointers =<< initialBlockState - return (modState, miv, wm) + ((x, y), z) <- InvokeHelpers.deployModuleV1 counterSourceFile . hpbsPointers =<< initialBlockState + return (z, x, y) initContract :: (PersistentBlockState PV4, GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1) -> ContextM (Types.ContractAddress, HashedPersistentBlockState PV4) -initContract (bs, miv, _) = do - let cm = Types.ChainMetadata 0 - let senderAddress = alesAccount - let initContext = InitContext{ - initOrigin = senderAddress, - icSenderPolicies = [] - } - let initName = InitName "init_counter" - let initParam = emptyParameter - let initAmount = 0 - let initInterpreterEnergy = 1_000_000_000 - case WasmV1.applyInitFun miv cm initContext initName initParam initAmount initInterpreterEnergy of - Nothing -> -- out of energy - liftIO $ assertFailure "Initialization ran out of energy." - Just (Left failure, _) -> - liftIO $ assertFailure $ "Initialization failed: " ++ show failure - Just (Right WasmV1.InitSuccess{..}, _) -> do - let receiveMethods = OrdMap.findWithDefault Set.empty initName (GSWasm.miExposedReceive miv) - let mkInstance = makeInstance initName receiveMethods miv irdNewState initAmount senderAddress - (addr, instState) <- bsoPutNewInstance bs mkInstance - (addr,) <$> freezeBlockState instState +initContract (bs, miv, wm) = do + (ca, pbs) <- InvokeHelpers.initContractV1 alesAccount (InitName "init_counter") emptyParameter (0 :: Types.Amount) bs (miv, wm) + (ca,) <$> freezeBlockState pbs -- |Invoke the contract without an invoker expecting success. invokeContract1 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult @@ -173,7 +147,7 @@ runCounterTests = do InvokeContract.Success{..} -> case rcrReturnValue of Nothing -> liftIO $ assertFailure "Invoking a V1 contract must produce a return value." - Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return nothing" [] (BS.unpack rv) + Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return an empty array." [] (BS.unpack rv) invokeContract3 addr stateWithContract >>= \case InvokeContract.Failure{..} -> liftIO $ assertEqual "Invocation should fail: " Types.RuntimeFailure rcrReason @@ -184,7 +158,7 @@ runCounterTests = do InvokeContract.Success{..} -> case rcrReturnValue of Nothing -> liftIO $ assertFailure "Invoking a V1 contract must produce a return value." - Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return nothing." [] (BS.unpack rv) + Just rv -> liftIO $ assertEqual "Invoking a counter in initial state should return an empty array." [] (BS.unpack rv) tests :: Spec diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs index 155010b4f4..891c1b91bf 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-| This module tests calling a contract from a contract and inspecting the return - message. Concretely it invokes a counter countract that maintains a 64-bit + message. Concretely it invokes a counter contract that maintains a 64-bit counter in its state. -} module SchedulerTests.SmartContracts.V1.Counter (tests) where @@ -68,19 +68,19 @@ testCases = , metadata = makeDummyHeader alesAccount 3 700000 , keys = [(0,[(0, alesKP)])] } - , (SuccessWithSummary ensureSucces , counterSpec 1) + , (SuccessWithSummary ensureSuccess , counterSpec 1) ) , ( TJSON { payload = Update 0 (Types.ContractAddress 0 0) "counter.inc" BSS.empty , metadata = makeDummyHeader alesAccount 4 700000 , keys = [(0,[(0, alesKP)])] } - , (SuccessWithSummary ensureSucces , counterSpec 2) + , (SuccessWithSummary ensureSuccess , counterSpec 2) ) , ( TJSON { payload = Update 0 (Types.ContractAddress 0 0) "counter.inc10" callArgs , metadata = makeDummyHeader alesAccount 5 700000 , keys = [(0,[(0, alesKP)])] } - , (SuccessWithSummary ensureSucces , counterSpec 12) + , (SuccessWithSummary ensureSuccess , counterSpec 12) ) ] } @@ -127,8 +127,8 @@ testCases = assertFailure $ "Actual initialization cost " ++ show tsEnergyCost ++ " not more than lower bound " ++ show costLowerBound -- ensure the transaction is successful - ensureSucces :: TVer.BlockItemWithStatus -> Types.TransactionSummary -> Expectation - ensureSucces _ Types.TransactionSummary{..} = checkSuccess "Update failed" tsResult + ensureSuccess :: TVer.BlockItemWithStatus -> Types.TransactionSummary -> Expectation + ensureSuccess _ Types.TransactionSummary{..} = checkSuccess "Update failed" tsResult checkSuccess msg Types.TxReject{..} = assertFailure $ msg ++ show vrRejectReason checkSuccess _ _ = return () diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs index be057c8705..636338dce0 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs @@ -54,7 +54,7 @@ version0 = V0 testCases :: [TestCase PV4] testCases = [ TestCase - { tcName = "" + { tcName = "CrossMessaging via a proxy" , tcParameters = defaultParams {tpInitialBlockState=initialBlockState} , tcTransactions = [ ( TJSON { payload = DeployModule version1 counterSourceFile @@ -81,6 +81,8 @@ testCases = } , (SuccessWithSummary ensureSuccess, emptySpec) ) + -- run the nocheck entrypoint since the @inc10@ one checks the return value, and since + -- we are invoking a V0 contract there is no return value. , ( TJSON { payload = Update 0 (Types.ContractAddress 0 0) "counter.inc10nocheck" callArgs , metadata = makeDummyHeader alesAccount 5 700000 , keys = [(0,[(0, alesKP)])] diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs index 9f01203837..f68ec9be93 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs @@ -281,7 +281,7 @@ runCallerTests = do let targetValue4 = 0x0004_0000_0000 invokeContract4 addr1 stateWithContracts >>= checkSuccess "Invoking non-existing entrypoint" targetValue4 let targetValue6 = 0x0006_0000_0000 - invokeContract6 addr1 stateWithContracts >>= checkSuccess "Invoking non-existing entrypoint" targetValue6 + invokeContract6 addr1 stateWithContracts >>= checkSuccess "Invoking an entrypoint that traps" targetValue6 let targetValue2 = 0x0002_0000_0000 invokeContract2 addr1 stateWithContracts >>= checkSuccess "Transferring to missing account" targetValue2 diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/SelfBalance.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/SelfBalance.hs index 1b94e7eea5..7c8dce2415 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/SelfBalance.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/SelfBalance.hs @@ -76,8 +76,9 @@ invokeContract1 ccContract bs = do } InvokeContract.invokeContract Types.SP4 ctx cm bs --- |Invoke an entrypoint and transfer to another instance. --- The before and after self-balances are different. +-- |Invoke an entrypoint and transfer to another instance. The before and after +-- self-balances are different. The key difference from invokeContract1 test is +-- that the address (the contract index) in the parameter is different. invokeContract2 :: Types.ContractAddress -> HashedPersistentBlockState PV4 -> ContextM InvokeContract.InvokeContractResult invokeContract2 ccContract bs = do let cm = Types.ChainMetadata 0 diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs index efed048589..0a2e9a68e6 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Transfer.hs @@ -66,7 +66,7 @@ testCases = , metadata = makeDummyHeader alesAccount 3 700000 , keys = [(0,[(0, alesKP)])] } - , (SuccessWithSummary ensureSucces , transferSpec) + , (SuccessWithSummary ensureSuccess , transferSpec) ) ] } @@ -106,18 +106,18 @@ testCases = assertFailure $ "Actual initialization cost " ++ show tsEnergyCost ++ " not more than lower bound " ++ show costLowerBound -- ensure the transaction is successful - ensureSucces :: TVer.BlockItemWithStatus -> Types.TransactionSummary -> Expectation - ensureSucces _ Types.TransactionSummary{..} = checkSuccess "Update failed: " tsResult + ensureSuccess :: TVer.BlockItemWithStatus -> Types.TransactionSummary -> Expectation + ensureSuccess _ Types.TransactionSummary{..} = checkSuccess "Update failed: " tsResult checkSuccess msg Types.TxReject{..} = assertFailure $ msg ++ show vrRejectReason checkSuccess _ _ = return () - -- Check that the contract state contains n. + -- Check that the contract state is empty. transferSpec bs = specify "Contract state" $ case getInstance (Types.ContractAddress 0 0) (bs ^. blockInstances) of Nothing -> assertFailure "Instance at <0,0> does not exist." Just istance -> do - assertEqual ("State contains.") (ContractState "") (instanceModel istance) + assertEqual ("State is empty.") (ContractState "") (instanceModel istance) assertEqual ("Contract has 0 CCD.") (Types.Amount 0) (instanceAmount istance) tests :: Spec diff --git a/docs/contracts.md b/docs/contracts.md index 745840c5e3..8d06459c85 100644 --- a/docs/contracts.md +++ b/docs/contracts.md @@ -60,7 +60,7 @@ The general design at present is that all the runtime structures are maintained in the Rust heap and the Haskell runtime maintains pointers to these structures. It also manages their lifetime and deallocates them when needed. This includes - module artifacts. This is a processed Wasm module that is easier and quicker - to execute. It is design to be cheap to look up and deserialize from + to execute. It is designed to be cheap to look up and deserialize from persistent storage. - for V1 contracts a suspended state of the execution. When a contract invokes an operation we must suspend its execution and store the state so it can be @@ -199,7 +199,10 @@ fn get_policy_section(policy_bytes: *mut u8, length: u32, offset: u32) -> u32; ## Logging Contracts can output a small amount of data during execution. This data is -available in a transaction status and can be queried. +available in a transaction status and can be queried. Concretely contracts can +output up to 64 items, each of at most 512 bytes (this is controlled by +constants `MAX_LOG_SIZE` and `MAX_NUM_LOGS` in the `constants.rs` module in the +`wasm-chain-integration` package) ```rust /// Add a log item. Return values are From 7da55e13a27192aaf09256197099bc686436548e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Fri, 11 Feb 2022 08:02:07 +0100 Subject: [PATCH 49/51] Document the new API. --- concordium-base | 2 +- concordium-consensus/smart-contracts | 2 +- .../src/Concordium/Scheduler.hs | 2 +- .../Concordium/Scheduler/InvokeContract.hs | 5 ++- concordium-grpc-api | 2 +- docs/grpc.md | 37 ++++++++++++++++++- 6 files changed, 43 insertions(+), 7 deletions(-) diff --git a/concordium-base b/concordium-base index e6fffb934f..bd83c6b60c 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit e6fffb934fba17ea7c5a0f5971ab2e5771c3f0bc +Subproject commit bd83c6b60c1013eb227a7de4a3da9cc898acf6a9 diff --git a/concordium-consensus/smart-contracts b/concordium-consensus/smart-contracts index 8046fb8e98..6cccd8d9f9 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 8046fb8e98ac493bbd17afd6e7268c702fdebf47 +Subproject commit 6cccd8d9f90d6d70177a879565b3e28ae70b69df diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 59891c86a3..128fc67ffe 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -1034,7 +1034,7 @@ handleContractUpdateV1 originAddr istance checkAndGetSender transferAmount recei -- If execution of the contract succeeds resume. -- Otherwise rollback the state and report that to the caller. runInnerTransaction runSuccess >>= \case - Left err -> do -- execution failed, ignore the reject reason since V0 contract cannot return useful information + Left _ -> -- execution failed, ignore the reject reason since V0 contract cannot return useful information go (resumeEvent False:interruptEvent:events) =<< runInterpreter (return . WasmV1.resumeReceiveFun rrdInterruptedConfig Nothing entryBalance WasmV1.MessageSendFailed Nothing) Right evs -> do -- Execution of the contract might have changed our own state. If so, we need to resume in the new state, otherwise diff --git a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs index ef5bb255b5..37ad619bbf 100644 --- a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -150,10 +150,10 @@ invokeContract _ ContractContext{..} cm bs = do -- cannot happen (this would mean out of block energy, and we set block energy no lower than energy), -- but this is safe to do and not wrong (Left Nothing, re) -> - return Failure{rcrReason = OutOfEnergy, rcrUsedEnergy = ccEnergy - re} + return Failure{rcrReason = OutOfEnergy, rcrReturnValue=Nothing, rcrUsedEnergy = ccEnergy - re} -- Contract execution of a V0 contract failed with the given reason. (Left (Just rcrReason), re) -> - return Failure{rcrUsedEnergy = ccEnergy - re,..} + return Failure{rcrUsedEnergy = ccEnergy - re,rcrReturnValue=Nothing,..} -- Contract execution of a V0 contract succeeded with the given list of events (Right (Left rcrEvents), re) -> return Success{rcrReturnValue=Nothing, @@ -163,6 +163,7 @@ invokeContract _ ContractContext{..} cm bs = do (Right (Right (Left cf)), re) -> return (Failure{ rcrReason = WasmV1.cerToRejectReasonReceive ccContract ccMethod ccParameter cf, + rcrReturnValue = WasmV1.returnValueToByteString <$> WasmV1.ccfToReturnValue cf, rcrUsedEnergy = ccEnergy - re}) -- Contract execution of a V1 contract succeeded with the given return value. (Right (Right (Right (rv, reversedEvents))), re) -> -- handleUpdateContractV1 returns events in reverse order diff --git a/concordium-grpc-api b/concordium-grpc-api index 018edd386c..89eb52e2e8 160000 --- a/concordium-grpc-api +++ b/concordium-grpc-api @@ -1 +1 @@ -Subproject commit 018edd386c03d59db39ee5ab972a17570a8a3fde +Subproject commit 89eb52e2e8f75e1337a2193cc3905ece68da6947 diff --git a/docs/grpc.md b/docs/grpc.md index 357b62a188..290cb7706d 100644 --- a/docs/grpc.md +++ b/docs/grpc.md @@ -117,7 +117,7 @@ Returns a JSON object representing the branches of the tree from the last finali | `BlockHash` | base-16 encoded hash of a block (64 characters) | | `TransactionHash` | base-16 encoded hash of a transaction (64 characters) | | `ModuleRef` | base-16 encoded module reference (64 characters) | -| `Int` | integer | +| `Int` | integer | | `EncryptionKey` | base-16 encoded string (192 characters) | | `EncryptedAmount` | base-16 encoded string (384 characters) | | `UTCTime` | UTC time. `yyyy-mm-ddThh:mm:ss[.sss]Z` (ISO 8601:2004(E) sec. 4.3.2 extended format) | @@ -227,3 +227,38 @@ does not exist. Get the source of the module as it was deployed on the chain. The response is a byte array. + +## InvokeContract : `BlockHash -> ContractContext -> ?InvokeContractResult` + +Invoke a smart contract, returning any results. The contract is invoked in the +state at the end of a given block. + +`ContractContext` is a record with fields +- `invoker: ?Address` — address of the invoker. If not supplied it + defaults to the zero account address +- `contract: ContractAddress` — address of the contract to invoke +- `amount: ?Amount` — an amount to invoke with. Defaults to 0 if not + supplied. +- `method: String` — name of the entrypoint to invoke. This needs to be + fully qualified in the format `contract.method`. +- `parameter: ?String` — parameter to invoke the method with, encoded in + hex. Defaults to empty if not provided. +- `energy: ?Number` — maximum amount of energy allowed for execution. + Defaults to 10_000_000 if not provided. + +The return value is either `null` if either the block does not exist, or parsing +of any of the inputs failed. Otherwise it is a JSON encoded +`InvokeContractResult`. + +This is a record with fields +- `tag: String` — eiether `"success"` or `"failure"`. +- `usedEnergy: Number` — the amount of NRG that was used during + execution +- `returnValue: ?String` — if invoking a V1 contract this is the return + value that was produced, if any (in case of runtime failure or out of energy + there is no return value). If invoking a V0 contract this field is not present. +- if `tag` is `"success"` the following fields are present + - `events: [Event]` — list of events generated as part of execution of + the contract +- if `tag` is `"failure"` then the following fields are present + - `reason: RejectReason` — encoding of a rejection reason From 23632f420c1330b296a340bad929867de9186ab2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Fri, 11 Feb 2022 10:36:14 +0100 Subject: [PATCH 50/51] Bump base dependency after merge. --- concordium-base | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/concordium-base b/concordium-base index bd83c6b60c..39b313c79f 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit bd83c6b60c1013eb227a7de4a3da9cc898acf6a9 +Subproject commit 39b313c79fa55da9a9f861735321e55877f757ac From 1342d1a125c1b7c582891f68a2263663d3bba600 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ale=C5=A1=20Bizjak?= Date: Fri, 11 Feb 2022 16:23:47 +0100 Subject: [PATCH 51/51] Improve documentation. --- docs/grpc.md | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/docs/grpc.md b/docs/grpc.md index 290cb7706d..9d40fe06e3 100644 --- a/docs/grpc.md +++ b/docs/grpc.md @@ -255,8 +255,10 @@ This is a record with fields - `usedEnergy: Number` — the amount of NRG that was used during execution - `returnValue: ?String` — if invoking a V1 contract this is the return - value that was produced, if any (in case of runtime failure or out of energy - there is no return value). If invoking a V0 contract this field is not present. + value that was produced, if any. The return value is only produced if the + contract terminates normally. If it runs out of energy or triggers a runtime + error there is no return value. If invoking a V0 contract this field is not + present. - if `tag` is `"success"` the following fields are present - `events: [Event]` — list of events generated as part of execution of the contract