diff --git a/concordium-base b/concordium-base index 6f6a74c1d7..39b313c79f 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 6f6a74c1d71c0b5f0f36f57735143a70f5b73be0 +Subproject commit 39b313c79fa55da9a9f861735321e55877f757ac 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/lib.def b/concordium-consensus/lib.def index 801385526c..2a2217596f 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/smart-contracts b/concordium-consensus/smart-contracts index 272186431c..6cccd8d9f9 160000 --- a/concordium-consensus/smart-contracts +++ b/concordium-consensus/smart-contracts @@ -1 +1 @@ -Subproject commit 272186431cc0bcadddbededfa7f5efadcaca9d25 +Subproject commit 6cccd8d9f90d6d70177a879565b3e28ae70b69df diff --git a/concordium-consensus/src/Concordium/External.hs b/concordium-consensus/src/Concordium/External.hs index 3d64bbcf06..e8281246c6 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.Types.InvokeContract as InvokeContract import Concordium.MultiVersion ( Callbacks (..), CatchUpConfiguration (..), @@ -907,6 +908,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 @@ -1085,6 +1090,24 @@ 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 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. +-- 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. @@ -1319,6 +1342,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/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 4152a0d4c1..fda9973b83 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState.hs @@ -33,6 +33,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 @@ -223,6 +224,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 @@ -305,7 +307,7 @@ 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) + return (GSWasm.exposedReceive mi ^. at initName . non Set.empty, mi) _blockInstances <- Instances.getInstancesV0 resolveModule _blockUpdates <- getUpdatesV0 _blockEpochBlocksBaked <- getHashedEpochBlocksV0 @@ -375,6 +377,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)) @@ -551,10 +557,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' @@ -932,6 +937,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/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/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..0506780ff7 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Basic/BlockState/Instances.hs @@ -1,8 +1,9 @@ module Concordium.GlobalState.Basic.BlockState.Instances( InstanceParameters(..), Instance(..), + InstanceV(..), + HasInstanceAddress(..), makeInstance, - iaddress, Instances, emptyInstances, getInstance, @@ -37,14 +38,17 @@ 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. -updateInstanceAt :: ContractAddress -> AmountDelta -> Wasm.ContractState -> Instances -> Instances +-- |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. -updateInstanceAt' :: ContractAddress -> Amount -> Wasm.ContractState -> Instances -> Instances +-- |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) -- |Create a new smart contract instance. @@ -76,8 +80,13 @@ 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 + putV0InstanceV0 i + InstanceV1 i -> do + putWord8 3 + putV1InstanceV0 i -- |Deserialize 'Instances' in V0 format. getInstancesV0 @@ -88,5 +97,6 @@ getInstancesV0 resolve = Instances <$> constructM buildInstance buildInstance idx = getWord8 >>= \case 0 -> return Nothing 1 -> Just . Left <$> get - 2 -> Just . Right <$> getInstanceV0 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/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..34c754642b 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 #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module Concordium.GlobalState.Basic.BlockState.Modules ( Module(..), + ModuleV(..), Modules, emptyModules, putInterface, @@ -11,19 +15,19 @@ 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) import qualified Data.Map.Strict as Map import Data.Serialize @@ -37,24 +41,46 @@ type ModuleIndex = Word64 -------------------------------------------------------------------------------- -- |A module contains both the module interface and the raw source code of the --- module. -data Module = 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. - interface :: !ModuleInterface, + moduleVInterface :: !(GSWasm.ModuleInterfaceV v), -- | The raw module binary source. - source :: !WasmModule + moduleVSource :: !(WasmModuleV v) } deriving (Show) +-- |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) + +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 = moduleRef . GSWasm.moduleReference instance Serialize Module where - put = put . source + put (ModuleV0 ModuleV{..}) = put moduleVSource + put (ModuleV1 ModuleV{..}) = put moduleVSource get = do - source <- get - case processModule source of - Nothing -> fail "Invalid module" - Just interface -> return Module {..} + 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 {..}) -------------------------------------------------------------------------------- @@ -80,26 +106,37 @@ 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 :: 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 = miModuleRef iface - (idx, modulesTable') = LFMB.append (Module iface source) $ 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) >>= 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 + 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 -getSource ref mods = fmap 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) @@ -123,6 +160,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/Block.hs b/concordium-consensus/src/Concordium/GlobalState/Block.hs index af130c1b07..6e39fa5359 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/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 35a48d22e9..d497e5f852 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. @@ -190,6 +191,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)) -- |Check whether an account exists for the given account address. @@ -333,7 +338,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. @@ -379,12 +384,14 @@ 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 - -> Wasm.ContractState + -> Maybe Wasm.ContractState -> m (UpdatableBlockState m) -- |Notify that some amount was transferred from/to encrypted balance of some account. @@ -633,6 +640,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 accountExists s = lift . accountExists s getAccountByCredId s = lift . getAccountByCredId s diff --git a/concordium-consensus/src/Concordium/GlobalState/Instance.hs b/concordium-consensus/src/Concordium/GlobalState/Instance.hs index f83433ffb8..26e86209d6 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 #-} +{-# LANGUAGE DataKinds #-} 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 - import Concordium.Types 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 = 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, + _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 HasInstanceAddress a where + instanceAddress :: a -> ContractAddress + +instance HasInstanceAddress (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 +-- |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 + _instanceVModel :: !Wasm.ContractState, + -- |The current amount of GTU owned by the instance + _instanceVAmount :: !Amount, + -- |Hash of the smart contract instance + _instanceVHash :: H.Hash + } + +class HasInstanceFields a where + instanceAmount :: a -> Amount + instanceModel :: a -> Wasm.ContractState + instanceHash :: a -> H.Hash + +instance HasInstanceFields (InstanceV v) where + {-# INLINE instanceAmount #-} + instanceAmount = _instanceVAmount + {-# INLINE instanceModel #-} + instanceModel = _instanceVModel + {-# INLINE instanceHash #-} + instanceHash = _instanceVHash + +instance HasInstanceFields Instance where + 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 HasInstanceAddress (InstanceV v) where + instanceAddress = instanceAddress . _instanceVParameters + +instance HasInstanceAddress 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) +instancePairs (InstanceV0 InstanceV{..}) = + [ "model" .= _instanceVModel, + "owner" .= instanceOwner _instanceVParameters, + "amount" .= _instanceVAmount, + "methods" .= instanceReceiveFuns _instanceVParameters, + "name" .= instanceInitName _instanceVParameters, + "sourceModule" .= GSWasm.miModuleRef (instanceModuleInterface _instanceVParameters), + "version" .= Wasm.V0 ] - where - params = instanceParameters istance +instancePairs (InstanceV1 InstanceV{..}) = + [ "owner" .= instanceOwner _instanceVParameters, + "amount" .= _instanceVAmount, + "methods" .= instanceReceiveFuns _instanceVParameters, + "name" .= instanceInitName _instanceVParameters, + "sourceModule" .= GSWasm.miModuleRef (instanceModuleInterface _instanceVParameters), + "version" .= Wasm.V1 + ] + -- |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,65 +158,132 @@ 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 + = 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 --- |The address of a smart contract instance. -iaddress :: Instance -> ContractAddress -iaddress = instanceAddress . instanceParameters +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 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. -updateInstance :: AmountDelta -> Wasm.ContractState -> Instance -> Instance -updateInstance delta val i = updateInstance' amnt val i - where amnt = applyAmountDelta delta (instanceAmount i) +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 -> 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. -updateInstance' :: Amount -> Wasm.ContractState -> Instance -> Instance -updateInstance' amnt val i = i { - instanceModel = val, - instanceAmount = amnt, - instanceHash = makeInstanceHash (instanceParameters i) val amnt +updateInstanceV' :: Amount -> Maybe Wasm.ContractState -> InstanceV v -> InstanceV v +updateInstanceV' amnt val i = i { + _instanceVModel = newVal, + _instanceVAmount = amnt, + _instanceVHash = makeInstanceHash ( _instanceVParameters i) newVal amnt } + where newVal = fromMaybe (_instanceVModel i) val + +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 + + +-- |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) + 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 --- |Serialize a smart contract instance in V0 format. -putInstanceV0 :: Putter Instance -putInstanceV0 Instance{instanceParameters = 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) + 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 + + +-- |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) +getV0InstanceV0 resolve idx = do + -- InstanceParameters + subindex <- get + let _instanceAddress = ContractAddress idx subindex + instanceOwner <- get + instanceContractModule <- get + instanceInitName <- get + (instanceReceiveFuns, instanceModuleInterface) <- + case resolve instanceContractModule instanceInitName of + 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. -getInstanceV0 +-- |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 Instance -getInstanceV0 resolve idx = do + -> Get (InstanceV GSWasm.V1) +getV1InstanceV0 resolve idx = do -- InstanceParameters subindex <- get - let instanceAddress = ContractAddress idx subindex + let _instanceAddress = ContractAddress idx subindex instanceOwner <- get instanceContractModule <- get instanceInitName <- get (instanceReceiveFuns, instanceModuleInterface) <- case resolve instanceContractModule instanceInitName of - Just r -> return r + 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" - 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 diff --git a/concordium-consensus/src/Concordium/GlobalState/Paired.hs b/concordium-consensus/src/Concordium/GlobalState/Paired.hs index f9a2bd85b9..9547768847 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/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/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index 1d615cb34c..2ca9aae058 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 @@ -739,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 b549de2e9a..e864e9b837 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', 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), @@ -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 @@ -979,30 +979,53 @@ 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 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 - }) - -doModifyInstance :: (IsProtocolVersion pv, MonadBlobStore m) => PersistentBlockState pv -> ContractAddress -> AmountDelta -> Wasm.ContractState -> m (PersistentBlockState pv) + fnew' mods ca = + case fnew ca of + inst@(InstanceV0 InstanceV{_instanceVParameters = InstanceParameters{..}, ..}) -> do + params <- makeBufferedRef $ PersistentInstanceParameters { + pinstanceAddress = _instanceAddress, + pinstanceOwner = instanceOwner, + pinstanceContractModule = GSWasm.miModuleRef instanceModuleInterface, + pinstanceReceiveFuns = instanceReceiveFuns, + pinstanceInitName = instanceInitName, + pinstanceParameterHash = instanceParameterHash + } + -- 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, + pinstanceModuleInterface = modRef, + pinstanceModel = _instanceVModel, + 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 + } + -- 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, + pinstanceModuleInterface = modRef, + pinstanceModel = _instanceVModel, + pinstanceAmount = _instanceVAmount, + pinstanceHash = _instanceVHash + }) + +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 @@ -1011,13 +1034,27 @@ 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 + case val of + Nothing -> return ((), PersistentInstanceV0 $ oldInst {pinstanceParameters = newParamsRef}) + Just newVal -> return ((), PersistentInstanceV0 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef, pinstanceModel = newVal})) + else + 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 ((), rehash (pinstanceParameterHash piParams) $ oldInst {pinstanceParameters = newParamsRef, pinstanceModel = val}) + case val of + Nothing -> return ((), PersistentInstanceV1 $ oldInst {pinstanceParameters = newParamsRef}) + Just newVal -> return ((), PersistentInstanceV1 $ rehash (pinstanceParameterHash piParams) (oldInst {pinstanceParameters = newParamsRef, pinstanceModel = newVal})) 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} + 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) doGetIdentityProvider pbs ipId = do @@ -1235,6 +1272,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 accountExists = doGetAccountExists . hpbsPointers getAccountByCredId = doGetAccountByCredId . hpbsPointers diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs index 52371d429c..ee1301d1f4 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs @@ -1,11 +1,18 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} module Concordium.GlobalState.Persistent.BlockState.Modules ( Module(..), + ModuleV(..), Modules, + getModuleInterface, emptyModules, getInterface, getSource, getModuleReference, + unsafeGetModuleReferenceV0, + unsafeGetModuleReferenceV1, putInterface, moduleRefList, makePersistentModules, @@ -15,7 +22,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 @@ -23,7 +30,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) @@ -38,37 +44,98 @@ 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 { +-- |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. - interface :: !ModuleInterface, - -- | A plain reference to the raw module binary source. - source :: !(BlobRef WasmModule) + 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 (WasmModuleV v)) } + deriving(Show) +-- |Helper to convert from an interface to a module. +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 +-- 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) + +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) + +-- The module reference already takes versioning into account, so this instance is reasonable. 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 + 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) + 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. +instance Serialize (ModuleV GSWasm.V0) where + get = do + -- interface is versioned + moduleVInterface <- get + moduleVSource <- get + return $! ModuleV {..} + 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. +instance Serialize (ModuleV GSWasm.V1) where + get = do + -- interface is versioned + moduleVInterface <- get + moduleVSource <- get + return $! ModuleV {..} + put ModuleV{..} = put moduleVInterface <> put moduleVSource + + +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 (ModuleV0 ModuleV{..}) = sPut =<< loadRef moduleVSource +putModuleV0 (ModuleV1 ModuleV{..}) = sPut =<< loadRef moduleVSource -------------------------------------------------------------------------------- @@ -91,7 +158,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 @@ -112,8 +179,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 - => (ModuleInterface, WasmModule) +putInterface :: (IsWasmVersion v, MonadBlobStore m) + => (GSWasm.ModuleInterfaceV v, WasmModuleV v) -> Modules -> m (Maybe Modules) putInterface (modul, src) m = @@ -121,10 +188,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 +209,24 @@ 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. 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. Expected module version 1, got 0." + + -- |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 getModuleInterface <$> getModule ref mods -- |Get the source of a module by module reference. getSource :: MonadBlobStore m => ModuleRef -> Modules -> m (Maybe WasmModule) @@ -155,7 +234,8 @@ getSource ref mods = do m <- getModule ref mods case m of Nothing -> return Nothing - Just modul -> Just <$> loadRef (source modul) + 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. @@ -167,9 +247,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..833995eb20 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs @@ -1,8 +1,10 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} {-# 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 @@ -73,14 +76,17 @@ instance Applicative m => Cacheable m PersistentInstanceParameters ---------------------------------------------------------------------------------------------------- --- |An instance of a smart contract. -data PersistentInstance = PersistentInstance { - -- |The fixed parameters of the instance +-- |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 :: 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 -- 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,39 +95,113 @@ data PersistentInstance = PersistentInstance { pinstanceHash :: H.Hash } -instance Show PersistentInstance where - show PersistentInstance{..} = show pinstanceParameters ++ " {balance=" ++ show pinstanceAmount ++ ", model=" ++ show pinstanceModel ++ "}" - -instance HashableTo H.Hash PersistentInstance where - getHash = pinstanceHash - -instance MonadBlobStore m => BlobStorable m PersistentInstance where - storeUpdate PersistentInstance{..} = do - (pparams, newParameters) <- storeUpdate pinstanceParameters - (pinterface, newpInterface) <- storeUpdate pinstanceModuleInterface - let putInst = do - pparams - pinterface - put pinstanceModel - put pinstanceAmount - return (putInst, PersistentInstance{pinstanceParameters = newParameters, pinstanceModuleInterface = newpInterface, ..}) +-- |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 + +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 pv -> m PersistentInstanceParameters +loadInstanceParameters (PersistentInstanceV0 PersistentInstanceV {..}) = loadBufferedRef pinstanceParameters +loadInstanceParameters (PersistentInstanceV1 PersistentInstanceV {..}) = loadBufferedRef pinstanceParameters + +cacheInstanceParameters :: MonadBlobStore m => PersistentInstance pv -> m (PersistentInstanceParameters, BufferedRef PersistentInstanceParameters) +cacheInstanceParameters (PersistentInstanceV0 PersistentInstanceV {..}) = cacheBufferedRef pinstanceParameters +cacheInstanceParameters (PersistentInstanceV1 PersistentInstanceV {..}) = cacheBufferedRef pinstanceParameters + +loadInstanceModule :: MonadBlobStore m => PersistentInstance pv -> m Module +loadInstanceModule (PersistentInstanceV0 PersistentInstanceV {..}) = ModuleV0 <$> loadBufferedRef pinstanceModuleInterface +loadInstanceModule (PersistentInstanceV1 PersistentInstanceV {..}) = ModuleV1 <$> loadBufferedRef pinstanceModuleInterface + +instance HashableTo H.Hash (PersistentInstance pv) where + getHash (PersistentInstanceV0 PersistentInstanceV{..})= pinstanceHash + getHash (PersistentInstanceV1 PersistentInstanceV{..})= pinstanceHash + +-- 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 -> 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 + 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 PersistentInstance{..} + 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 - cache p@PersistentInstance{..} = do +instance MonadBlobStore m => Cacheable (ReaderT Modules m) (PersistentInstance pv) where + cache (PersistentInstanceV0 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.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 @@ -131,32 +211,58 @@ 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 <- Modules.unsafeGetModuleReferenceV1 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} - -fromPersistentInstance :: MonadBlobStore m => PersistentInstance -> m Transient.Instance -fromPersistentInstance PersistentInstance{..} = do - PersistentInstanceParameters{..} <- loadBufferedRef pinstanceParameters - instanceModuleInterface <- interface <$> loadBufferedRef pinstanceModuleInterface - let instanceParameters = Transient.InstanceParameters { - instanceAddress = pinstanceAddress, + 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 pv -> m Transient.Instance +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, - .. - } - --- |Serialize a smart contract instance in V0 format. -putInstanceV0 :: (MonadBlobStore m, MonadPut m) => PersistentInstance -> m () -putInstanceV0 PersistentInstance{..} = do + 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 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 + -- only put the subindex part of the address + put (contractSubindex pinstanceAddress) + put pinstanceOwner + put pinstanceContractModule + put pinstanceInitName + put pinstanceModel + put pinstanceAmount + +-- |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 @@ -193,7 +299,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 @@ -209,31 +315,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 @@ -242,7 +348,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 @@ -272,24 +378,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 @@ -326,21 +432,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 @@ -354,33 +460,33 @@ 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 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 @@ -402,13 +508,13 @@ 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 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 @@ -417,7 +523,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 @@ -426,7 +532,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') @@ -449,27 +555,46 @@ 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 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, + 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.unsafeGetModuleReferenceV0 (GSWasm.miModuleRef instanceModuleInterface) mods + return $ PersistentInstanceV0 PersistentInstanceV { + pinstanceParameters = pIParams, + pinstanceModuleInterface = pIModuleInterface, + pinstanceModel = _instanceVModel, + pinstanceAmount = _instanceVAmount, + pinstanceHash = _instanceVHash + } + convInst (Transient.InstanceV1 Transient.InstanceV {_instanceVParameters=Transient.InstanceParameters{..}, ..}) = do pIParams <- makeBufferedRef $ PersistentInstanceParameters{ - pinstanceAddress = instanceAddress, + pinstanceAddress = _instanceAddress, pinstanceOwner = instanceOwner, pinstanceContractModule = GSWasm.miModuleRef instanceModuleInterface, pinstanceInitName = instanceInitName, @@ -478,17 +603,17 @@ 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) <- Modules.unsafeGetModuleReferenceV1 (GSWasm.miModuleRef instanceModuleInterface) mods + return $ PersistentInstanceV1 PersistentInstanceV { pinstanceParameters = pIParams, pinstanceModuleInterface = pIModuleInterface, - pinstanceModel = instanceModel, - pinstanceAmount = instanceAmount, - pinstanceHash = instanceHash + 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 @@ -497,6 +622,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 + putV0InstanceV0 inst + putOptInstance (Right (PersistentInstanceV1 inst)) = do + liftPut $ putWord8 3 + putV1InstanceV0 inst diff --git a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs index f93002472d..8f2387cfdc 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Wasm.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Wasm.hs @@ -1,16 +1,31 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} {-| 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(..), + imWasmArtifact, -- *** Module interface - ModuleInterface(..) + ModuleInterface(..), + ModuleInterfaceV(..), + HasModuleRef(..), + HasEntrypoints(..) ) where @@ -32,56 +47,98 @@ 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 :: WasmVersion) = ModuleArtifact { maArtifact :: ForeignPtr (ModuleArtifact v) } deriving(Eq, Show) -- the Eq and Show instances are only for debugging and compare and show pointers. +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 +-- 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 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 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 ModuleArtifactV0{..} = - let bs = toBytesHelper toBytesArtifactV0 maArtifactV0 + 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) + +instance Serialize (InstrumentedModuleV V0) where + put InstrumentedWasmModuleV0{..} = do + putWord32be 0 + put imWasmArtifactV0 -instance Serialize InstrumentedModule where - put InstrumentedWasmModule{..} = do - putWord32be imWasmVersion - put imWasmArtifact + get = get >>= \case + V0 -> InstrumentedWasmModuleV0 <$> get + V1 -> fail "Expected Wasm version 0, got 1." - get = InstrumentedWasmModule <$> getWord32be <*> get + +instance Serialize (InstrumentedModuleV V1) where + put InstrumentedWasmModuleV1{..} = do + putWord32be 1 + put imWasmArtifactV1 + + get = get >>= \case + V0 -> fail "Expected Wasm version 1, got 0." + V1 -> InstrumentedWasmModuleV1 <$> get -------------------------------------------------------------------------------- --- |A Wasm module interface with exposed entry-points. -data ModuleInterface = ModuleInterface { +-- |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, -- |Init methods exposed by this module. @@ -90,22 +147,96 @@ data ModuleInterface = 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. - miModule :: !InstrumentedModule, + -- |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 } 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 + -- |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 + exposedInit ModuleInterface{..} = miExposedInit + exposedReceive ModuleInterface{..} = miExposedReceive + +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 + 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 + +-- 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 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) + 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 + 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/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/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index b508f06f2e..795f84e67c 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -32,6 +32,9 @@ import Concordium.Types.Queries 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 import Concordium.Birk.Bake @@ -449,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]) @@ -569,6 +572,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 4002d97aba..128fc67ffe 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -34,16 +34,22 @@ module Concordium.Scheduler (filterTransactions ,runTransactions ,execTransactions + ,handleContractUpdateV1 + ,handleContractUpdateV0 + ,checkAndGetBalanceInstanceV1 + ,checkAndGetBalanceInstanceV0 + ,checkAndGetBalanceAccountV1 + ,checkAndGetBalanceAccountV0 ,FilteredTransactions(..) ) 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 qualified Concordium.Scheduler.WasmIntegration.V1 as WasmV1 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 @@ -74,6 +80,7 @@ import qualified Concordium.TransactionVerification as TVer import Lens.Micro.Platform import Prelude hiding (exp, mod) +import Concordium.Scheduler.WasmIntegration.V1 (ReceiveResultData(rrdCurrentState)) -- |The function asserts the following @@ -86,13 +93,16 @@ import Prelude hiding (exp, mod) -- where currently valid means non-expired. -- -- 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'. -- -- Important! If @mVerRes@ is `Just VerificationResult` then it MUST be the `VerificationResult` matching the provided transaction. -- -- Returns the sender account and the cost to be charged for checking the header. -checkHeader :: (TransactionData msg, SchedulerMonad pv m) => msg -> Maybe TVer.VerificationResult -> ExceptT (Maybe FailureKind) m (IndexedAccount m, Energy) +checkHeader :: forall pv msg m . (TransactionData msg, SchedulerMonad pv m) => msg -> Maybe TVer.VerificationResult -> ExceptT (Maybe FailureKind) m (IndexedAccount m, Energy) checkHeader meta mVerRes = 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)) remainingBlockEnergy <- lift getRemainingEnergy -- check that enough energy is remaining for the block. @@ -103,7 +113,7 @@ checkHeader meta mVerRes = do when (transactionExpired (thExpiry $ transactionHeader meta) $ slotTime cm) $ throwError . Just $ ExpiredTransaction let addr = transactionSender meta - miacc <- lift (getAccount addr) + miacc <- lift (getStateAccount addr) case miacc of -- check if the sender is present on the chain. Nothing -> throwError (Just $ UnknownAccount addr) @@ -169,6 +179,7 @@ checkTransactionVerificationResult (TVer.NotOk TVer.NormalTransactionDepositInsu checkTransactionVerificationResult (TVer.NotOk TVer.NormalTransactionEnergyExceeded) = Left ExceedsMaxBlockEnergy checkTransactionVerificationResult (TVer.NotOk (TVer.NormalTransactionDuplicateNonce nonce)) = Left $ NonSequentialNonce nonce checkTransactionVerificationResult (TVer.NotOk TVer.Expired) = Left ExpiredTransaction +checkTransactionVerificationResult (TVer.NotOk TVer.InvalidPayloadSize) = Left InvalidPayloadSize -- | Execute a transaction on the current block state, charging valid accounts @@ -211,7 +222,7 @@ dispatch (msg, mVerRes) = 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, @@ -366,7 +377,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) @@ -384,7 +395,6 @@ handleTransferToPublic wtc transferData@SecToPubAmountTransferData{..} = do cryptoParams <- TVer.getCryptographicParameters withDeposit wtc (c cryptoParams) k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta c cryptoParams = do @@ -413,7 +423,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{ @@ -439,7 +449,6 @@ handleTransferToEncrypted wtc toEncrypted = do cryptoParams <- TVer.getCryptographicParameters withDeposit wtc (c cryptoParams) k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta @@ -464,7 +473,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) @@ -487,7 +496,6 @@ handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransfer cryptoParams <- TVer.getCryptographicParameters withDeposit wtc (c cryptoParams) k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta @@ -549,7 +557,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, @@ -569,7 +577,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. @@ -578,28 +586,38 @@ handleDeployModule wtc mod = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader - -- Size of the module source - 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) - - k ls (iface, mhash) = do + 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 (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 (Right (iface, moduleV1), mhash) + _ -> rejectTransaction ModuleNotWF + + k ls (toCommit, 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 + 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. @@ -619,12 +637,27 @@ 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. - tickEnergy (Cost.lookupContractState $ Wasm.contractStateSize (Ins.instanceModel inst)) - 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. +-- 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 + -> 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 :: @@ -638,7 +671,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. @@ -654,39 +686,70 @@ 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) - - k ls (iface, result) = do + 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 (Left (iface, result)) + + 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'` WasmV1.cerToRejectReasonInit + + -- Charge for storing the contract state. + tickEnergyStoreState (WasmV1.irdNewState result) + -- And for storing the instance. + tickEnergy Cost.initializeContractInstanceCreateCost + + return (Right (iface, result)) + + 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) @@ -702,9 +765,33 @@ handleInitContract wtc initAmount modref initName param = ecAddress=addr, ecAmount=initAmount, ecInitName=initName, + ecContractVersion=Wasm.V0, ecEvents=Wasm.logs result }], energyCost, usedEnergy ) + k ls (Right (iface, result)) = do + let model = WasmV1.irdNewState result + (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + chargeExecutionCost 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, + ecContractVersion=Wasm.V1, + ecEvents=WasmV1.irdLogs result + }], energyCost, usedEnergy + ) handleSimpleTransfer :: SchedulerMonad pv m @@ -746,54 +833,292 @@ handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = where senderAccount = wtc ^. wtcSenderAccount meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta + checkAndGetBalanceV1 = checkAndGetBalanceAccountV1 senderAddress senderAccount + checkAndGetBalanceV0 = checkAndGetBalanceAccountV0 senderAddress senderAccount c = do - ins <- getCurrentContractInstanceTicking uAddress - -- Now invoke the general handler for contract messages. - handleMessage senderAddress - ins - (Right (senderAddress, senderAccount)) - uAmount - uReceiveName - uMessage - - --- | Process a message to a contract. + getCurrentContractInstanceTicking uAddress >>= \case + InstanceV0 ins -> + -- Now invoke the general handler for contract messages. + handleContractUpdateV0 senderAddress + ins + checkAndGetBalanceV0 + uAmount + 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 (reverse 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 + -> Amount + -> m (Either WasmV1.ContractCallFailure (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress))) +checkAndGetBalanceAccountV1 usedAddress senderAccount transferAmount = do + (senderAddr, senderCredentials) <- mkSenderAddrCredentials (Right (usedAddress, senderAccount)) + senderamount <- getCurrentAccountAvailableAmount 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))) + +-- |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 + -> Amount + -> m (Address, [ID.AccountCredential], (Either ContractAddress IndexedAccountAddress)) +checkAndGetBalanceAccountV0 usedAddress senderAccount transferAmount = do + (senderAddr, senderCredentials) <- mkSenderAddrCredentials (Right (usedAddress, senderAccount)) + senderamount <- getCurrentAccountAvailableAmount senderAccount + if senderamount >= transferAmount then do + canonicalAddr <- getAccountCanonicalAddress (snd senderAccount) + return (senderAddr, senderCredentials, Right (fst senderAccount, canonicalAddr)) + else + 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 + -> Amount + -> 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 + if senderamount >= transferAmount then + return (Right (senderAddr, senderCredentials, (Left (instanceAddress istance)))) + 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 + -> 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) + +-- |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 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 -> 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 + -- - 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. + -> 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. + -> 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 + -- Cover administrative costs. + tickEnergy Cost.updateContractInstanceBaseCost + let model = _instanceVModel istance + let iParams = _instanceVParameters istance + let cref = instanceAddress iParams + let receivefuns = instanceReceiveFuns . _instanceVParameters $ istance + 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 <- getStateAccount 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 **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. + let iface = instanceModuleInterface iParams + -- charge for looking up the module + tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) + + -- 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 + -> 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. + entryBalance <- getCurrentContractAmount istance + 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, + euContractVersion=Wasm.V1, + euEvents = rrdLogs + } + in return (Right (rrdReturnValue, event:events)) + WasmV1.ReceiveInterrupt{..} -> do + -- execution invoked an operation. Dispatch and continue. + let interruptEvent = Interrupted{ + iAddress = instanceAddress istance, + iEvents = rrdLogs + } + resumeEvent rSuccess = Resumed{ + rAddress = instanceAddress istance, + .. + } + 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 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. + -- 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 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 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. + -- That is, we execute the entire tree that is potentially generated. + let rName = Wasm.uncheckedMakeReceiveName (instanceInitName (_instanceVParameters targetInstance)) imcName + 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. + runInnerTransaction runSuccess >>= \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 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 + 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 + -- 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 -> 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 + let resumeState = if lastModifiedIndex == modificationIndex then Nothing else Just newState + 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 + -- 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. + -> Amount -- ^The amount to 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. + 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 (instanceAddress senderInstance) targetAccount tAmount $ + return [Transferred addr transferAmount (AddressAccount accAddr)]) + + +-- | 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. -handleMessage :: 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. - -> Instance -- ^The current state of the target contract of the transaction, which must exist. - -> Either (IndexedAccount m, Instance) (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 + -> InstanceV GSWasm.V0 -- ^The current state of the target contract of the transaction, which must exist. + -> (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. -handleMessage originAddr istance sender transferAmount receiveName parameter = do + -> 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 - let model = instanceModel istance + 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) + (senderAddr, senderCredentials, sender) <- checkAndGetSender transferAmount - let iParams = instanceParameters istance + let iParams = _instanceVParameters istance let cref = instanceAddress iParams - let receivefuns = instanceReceiveFuns . instanceParameters $ istance + 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 @@ -808,7 +1133,7 @@ handleMessage originAddr istance sender transferAmount receiveName parameter = d let receiveCtx = Wasm.ReceiveContext { invoker = originAddr, selfAddress = cref, - selfBalance = instanceAmount istance, + selfBalance = _instanceVAmount istance, sender = senderAddr, owner = instanceOwner iParams, rcSenderPolicies = map Wasm.mkSenderPolicy senderCredentials @@ -819,7 +1144,7 @@ handleMessage originAddr istance sender transferAmount receiveName parameter = d -- charge for looking up the module tickEnergy $ Cost.lookupModule (GSWasm.miModuleSize iface) - result <- runInterpreter (return . Wasm.applyReceiveFun iface cm receiveCtx receiveName parameter transferAmount model) + 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. @@ -836,12 +1161,13 @@ handleMessage originAddr istance sender transferAmount receiveName parameter = d -- 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 + withInstanceStateV0 istance newModel $ do let initEvent = Updated{euAddress=cref, euInstigator=senderAddr, euAmount=transferAmount, euMessage=parameter, euReceiveName=receiveName, + euContractVersion=Wasm.V0, euEvents = Wasm.logs result } foldEvents originAddr (ownerAccount, istance) initEvent txOut @@ -857,21 +1183,30 @@ handleMessage originAddr istance sender transferAmount receiveName parameter = d 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, 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. + -> 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 - cinstance <- getCurrentContractInstanceTicking erAddr - handleMessage originAddr - cinstance - (Left istance) - erAmount - erName - erParameter + getCurrentContractInstanceTicking erAddr >>= \case + InstanceV0 cinstance -> handleContractUpdateV0 originAddr + cinstance + (uncurry checkAndGetBalanceInstanceV0 istance) + erAmount + erName + erParameter + InstanceV1 cinstance -> + let c = handleContractUpdateV1 + originAddr + cinstance + (uncurry checkAndGetBalanceInstanceV1 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 @@ -887,12 +1222,19 @@ 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]) +-- |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, istance) -> do + Left (ownerAccount, iaddr) -> do credentials <- getAccountCredentials (snd ownerAccount) - return (AddressContract (instanceAddress (instanceParameters 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 @@ -901,9 +1243,9 @@ mkSenderAddrCredentials sender = -- | Handle the transfer of an amount from a contract instance to an account. handleTransferAccount :: - TransactionMonad pv m + (TransactionMonad pv m, HasInstanceAddress a, HasInstanceFields a) => AccountAddress -- ^The target account address. - -> Instance -- ^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 @@ -911,14 +1253,14 @@ handleTransferAccount accAddr senderInstance transferamount = do 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)) + 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. - 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 @@ -979,7 +1321,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 @@ -989,7 +1330,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 @@ -1042,13 +1383,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 @@ -1071,7 +1411,6 @@ handleUpdateBakerStake wtc newStake = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta c = do @@ -1081,7 +1420,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) @@ -1109,13 +1448,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 @@ -1150,13 +1488,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 @@ -1276,7 +1613,6 @@ handleUpdateCredentialKeys wtc cid keys sigs = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader c = do @@ -1298,7 +1634,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) @@ -1306,14 +1642,17 @@ handleUpdateCredentialKeys wtc cid keys sigs = -- * Chain updates -- |Handle a chain update message -handleChainUpdate :: +handleChainUpdate :: forall pv m . SchedulerMonad pv m => TVer.ChainUpdateWithStatus -> m TxResult handleChainUpdate (WithMetadata{wmdData = ui@UpdateInstruction{..}, ..}, mVerRes) = do cm <- getChainMetadata + -- check that payload si + if not (validatePayloadSize (protocolVersion @pv) (updatePayloadSize uiHeader)) then + return (TxInvalid InvalidPayloadSize) -- check that the transaction is not expired - if transactionExpired (updateTimeout uiHeader) (slotTime cm) then + else if transactionExpired (updateTimeout uiHeader) (slotTime cm) then return (TxInvalid ExpiredTransaction) else do -- Check that the sequence number is correct @@ -1384,7 +1723,6 @@ handleUpdateCredentials wtc cdis removeRegIds threshold = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - txHash = wtc ^. wtcTransactionHash meta = wtc ^. wtcTransactionHeader senderAddress = thSender meta @@ -1404,7 +1742,7 @@ handleUpdateCredentials wtc cdis removeRegIds threshold = k ls existingCredentials = do (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) - chargeExecutionCost txHash senderAccount energyCost + chargeExecutionCost senderAccount energyCost cryptoParams <- TVer.getCryptographicParameters -- 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 31bfa5ba44..3ee48e5abe 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 #-} @@ -43,6 +44,12 @@ import qualified Concordium.TransactionVerification as TVer import Control.Exception(assert) import qualified Concordium.ID.Types as ID +import Concordium.Wasm (IsWasmVersion) + +-- |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) -- |Whether the current energy limit is block energy or current transaction energy. data EnergyLimitReason = BlockEnergy | TransactionEnergy @@ -63,6 +70,12 @@ 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 at the start of a transaction. + 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, (TVer.TransactionVerifier pv m)) => SchedulerMonad pv m | m -> pv where @@ -72,13 +85,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) @@ -101,7 +107,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 @@ -275,11 +281,18 @@ 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 + + -- |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 -> (ModificationIndex -> 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 + 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. @@ -287,11 +300,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 + 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 :: Instance -> Instance -> 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. @@ -324,20 +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 (IndexedAccount m, Instance) (AccountAddress, IndexedAccount m) -> Instance -> Amount -> m a -> m a - withToContractAmount (Left (_, i)) = withContractToContractAmount i - withToContractAmount (Right (_, a)) = withAccountToContractAmount 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, Instance) (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. - 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. @@ -350,7 +355,11 @@ class (StaticInformation m, IsProtocolVersion pv) => TransactionMonad pv m | m - getCurrentAccountAvailableAmount :: IndexedAccount m -> m Amount -- |Same as above, but for contracts. - getCurrentContractAmount :: Instance -> 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 :: (HasInstanceAddress a, HasInstanceFields a) => a -> m (ModificationIndex, Wasm.ContractState) -- |Get the amount of energy remaining for the transaction. getEnergy :: m (Energy, EnergyLimitReason) @@ -371,6 +380,10 @@ 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 `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 @@ -393,12 +406,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 - {_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 (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. @@ -406,18 +422,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 @@ -426,6 +448,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 @@ -449,23 +472,18 @@ 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 istance newState = - instanceUpdates . at addr %~ \case Just (amnt, _) -> Just (amnt, newState) - Nothing -> Just (0, newState) - where addr = instanceAddress . instanceParameters $ istance +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 :: Instance -> 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 +addContractAmountToCS :: ContractAddress -> AmountDelta -> ChangeSet -> ChangeSet +addContractAmountToCS addr amnt cs = + -- 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, @@ -475,7 +493,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 @@ -486,6 +504,13 @@ data LocalState = LocalState{ _energyLeft :: !Energy, -- |Changes accumulated thus far. _changeSet :: !ChangeSet, + -- |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 } @@ -512,28 +537,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,_nextContractModificationIndex = 0,..} (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 @@ -559,12 +583,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{ @@ -599,7 +623,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. @@ -618,7 +642,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 @@ -627,7 +651,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, @@ -655,11 +679,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) @@ -675,15 +698,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 @@ -696,13 +719,48 @@ 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) - -instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where - {-# INLINE withInstanceState #-} - withInstanceState istance val cont = do - changeSet %= addContractStatesToCS istance val - cont + {-# INLINE getContractInstance #-} + getContractInstance = liftLocal . getContractInstance + + {-# INLINE getStateAccount #-} + getStateAccount = liftLocal . getStateAccount + +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 + nextModificationIndex <- use nextContractModificationIndex + nextContractModificationIndex += 1 + changeSet %= addContractStatesToCS istance nextModificationIndex val + cont + + {-# INLINE withInstanceStateV1 #-} + withInstanceStateV1 istance val cont = do + nextModificationIndex <- use nextContractModificationIndex + nextContractModificationIndex += 1 + changeSet %= addContractStatesToCS istance nextModificationIndex val + cont nextModificationIndex {-# INLINE withAccountToAccountAmount #-} withAccountToAccountAmount fromAcc toAcc amount cont = do @@ -713,8 +771,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 #-} @@ -726,7 +784,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 @@ -763,19 +821,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) - - {-# INLINE getStateAccount #-} - getStateAccount = liftLocal . getAccount + 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 + Just (idx, _, (Just s)) -> return (idx, s) + _ -> return (0, instanceModel istance) getCurrentAccountTotalAmount (ai, acc) = do oldTotal <- getAccountAmount acc @@ -818,9 +878,9 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where {-# INLINE getCurrentContractAmount #-} getCurrentContractAmount inst = do let amnt = instanceAmount inst - let addr = instanceAddress . instanceParameters $ 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 #-} @@ -848,14 +908,28 @@ instance SchedulerMonad pv m => TransactionMonad pv (LocalT r m) where {-# 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 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 + + {-# INLINE outOfBlockEnergy #-} outOfBlockEnergy = LocalT (ContT (\_ -> return (Left Nothing))) diff --git a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs index 3bfb4e2fb9..d6721b77f8 100644 --- a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs +++ b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs @@ -122,6 +122,12 @@ instance (MonadReader ContextState m, {-# INLINE getAccountCreationLimit #-} getAccountCreationLimit = view accountCreationLimit + {-# INLINE getContractInstance #-} + getContractInstance addr = lift . flip bsoGetInstance addr =<< use schedulerBlockState + + {-# INLINE getStateAccount #-} + getStateAccount !addr = lift . flip bsoGetAccount addr =<< use schedulerBlockState + instance (SS state ~ UpdatableBlockState m, HasSchedulerState state, MonadState state m, @@ -200,12 +206,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 @@ -252,7 +252,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/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs new file mode 100644 index 0000000000..37ad619bbf --- /dev/null +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -0,0 +1,173 @@ +{-| 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 #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Concordium.Scheduler.InvokeContract (invokeContract) where + +import Lens.Micro.Platform +import Control.Monad.Reader + +import qualified Data.FixedByteString as FBS +import qualified Concordium.ID.Types as ID +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 +import Concordium.Scheduler.EnvironmentImplementation (ContextState(..), maxBlockEnergy, chainMetadata, accountCreationLimit) +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, + 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 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) => + 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 + -- 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 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) -> 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 + 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 = + 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 (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} + runReaderT (_runInvokeContract runContractComp) (contextState, bs) >>= \case + -- 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, 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,rcrReturnValue=Nothing,..} + -- 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, + 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 + return Success{rcrReturnValue=Just (WasmV1.returnValueToByteString rv), + rcrUsedEnergy = ccEnergy - re, + rcrEvents = reverse reversedEvents, + ..} diff --git a/concordium-consensus/src/Concordium/Scheduler/Runner.hs b/concordium-consensus/src/Concordium/Scheduler/Runner.hs index 0f18a30995..0a6ea3a242 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, .. @@ -138,9 +139,9 @@ processGroupedTransactions :: processGroupedTransactions = fmap (Types.fromTransactions . map (map (\x -> (Types.fromAccountTransaction 0 x, Nothing)))) . 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 a38c9c1742..871f9aab6c 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,21 +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 ModuleInterface +processModule :: WasmModuleV V0 -> Maybe (ModuleInterfaceV V0) processModule modl = do - (bs, imWasmArtifact) <- ffiResult + (bs, imWasmArtifactV0) <- ffiResult case getExports bs of Left _ -> Nothing Right (miExposedInit, miExposedReceive) -> let miModuleRef = getModuleRef modl - miModule = InstrumentedWasmModule{ - imWasmVersion = wasmVersion modl, - .. - } - in Just ModuleInterface{miModuleSize = moduleSourceLength $ wasmSource modl,..} + miModule = InstrumentedWasmModuleV0{..} + 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 new file mode 100644 index 0000000000..41af0facb6 --- /dev/null +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -0,0 +1,563 @@ +{-# 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(..), + ReceiveResultData(..), + applyInitFun, + cerToRejectReasonInit, + cerToRejectReasonReceive, + applyReceiveFun, + resumeReceiveFun, + processModule, + ReturnValue, + ReceiveInterruptedState, + InvokeResponseCode(..), + EnvFailure(..), + ContractExecutionReject(..), + ContractCallFailure(..), + ccfToReturnValue, + returnValueToByteString + ) 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.Aeson as AE +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.Char8 as BS8 +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 +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 "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 ()) + +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. + +-- |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)) + +-- json instance based on hex +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 +-- 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 + +withReceiveInterruptedState :: ReceiveInterruptedState -> (Ptr (Ptr ReceiveInterruptedState) -> IO a) -> IO a +withReceiveInterruptedState = withForeignPtr . risPtr + +-- |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 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 +-- 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 + | MessageSendFailed + +-- |Possible reasons why invocation failed that are not directly logic failure of a V1 call. +data EnvFailure = + AmountTooLarge !Address !Amount + | MissingAccount !AccountAddress + | MissingContract !ContractAddress + | InvalidEntrypoint !ModuleRef !ReceiveName -- Attempting to invoke a non-existing entrypoint. + deriving (Show) + +-- |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. +-- - success is encoded as 0 +-- - 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. +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 + InvalidEntrypoint _ _ -> 0xffff_ff04_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 + let unsigned = fromIntegral cerRejectReason :: Word32 -- reinterpret the bits + in 0xffff_ff00_0000_0000 .|. fromIntegral unsigned -- and cut away the upper 32 bits + + +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. + -> 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. + -> 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, 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. +{-# NOINLINE applyInitFun #-} +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 + -- 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)) + 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) + +-- |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 :: !EntrypointName, + 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 return from the contract in case of successful initialization. +data InitResultData = InitSuccess { + irdReturnValue :: !ReturnValue, + irdNewState :: !ContractState, + irdLogs :: ![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, + rrdLogs :: ![ContractEvent], + 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 + 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. + deriving (Show) + +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 + -> 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 = -- 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)) + 3 -> -- done + let parser = do + 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 + 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 (via 'new') and register +-- 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. + -- 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) + +-- |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 +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 + +-- |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. + -> 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 eitherInterruptedStatePtr = 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 = -- runtime failure + label "Reject.remainingEnergy" getWord64be + in let remainingEnergy = parseResult parser + in 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)) + 4 -> 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, logs, method) + in let (remainingEnergy, rrdCurrentState, rrdLogs, rrdMethod)= parseResult parser + in do rrdInterruptedConfig <- case eitherInterruptedStatePtr of + Left rrid -> return rrid + Right interruptedStatePtr -> newReceiveInterruptedState interruptedStatePtr + return (Just (Right ReceiveInterrupt{..}, fromIntegral remainingEnergy)) + 3 -> -- done + let parser = do + 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 + 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. +{-# NOINLINE applyReceiveFun #-} +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 (Right 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) + +-- |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. + -> 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 amnt statusCode rVal remainingEnergy = unsafePerformIO $ do + withReceiveInterruptedState is $ \isPtr -> + withStateBytes $ \(stateBytesPtr, stateBytesLen) -> + withMaybeReturnValue rVal $ \rValPtr -> + alloca $ \outputLenPtr -> alloca $ \outputReturnValuePtrPtr -> do + outPtr <- resume_receive isPtr + newStateTag + (castPtr stateBytesPtr) (fromIntegral stateBytesLen) + amountWord + (invokeResponseToWord64 statusCode) + rValPtr + energy + outputReturnValuePtrPtr + 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 (Left is) + where + (withStateBytes, newStateTag) = case cs of + 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 +-- - 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 :: WasmModuleV V1 -> 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 (wmvSource modl),..} + + where ffiResult = unsafePerformIO $ do + unsafeUseModuleSourceAsCStringLen (wmvSource 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 | 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. + | otherwise -> return (inits, receives) + ) (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." diff --git a/concordium-consensus/src/Concordium/Skov/Monad.hs b/concordium-consensus/src/Concordium/Skov/Monad.hs index 90d0be7dcf..695864f00d 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/src/Concordium/Skov/Update.hs b/concordium-consensus/src/Concordium/Skov/Update.hs index 7d4261b200..8694562567 100644 --- a/concordium-consensus/src/Concordium/Skov/Update.hs +++ b/concordium-consensus/src/Concordium/Skov/Update.hs @@ -633,4 +633,5 @@ transactionVerificationResultToUpdateResult (TV.NotOk TV.NormalTransactionDeposi transactionVerificationResultToUpdateResult (TV.NotOk TV.NormalTransactionEnergyExceeded) = ResultEnergyExceeded transactionVerificationResultToUpdateResult (TV.NotOk (TV.NormalTransactionDuplicateNonce _)) = ResultDuplicateNonce transactionVerificationResultToUpdateResult (TV.NotOk TV.Expired) = ResultStale +transactionVerificationResultToUpdateResult (TV.NotOk TV.InvalidPayloadSize) = ResultSerializationFail 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, ..} + } diff --git a/concordium-consensus/src/Concordium/TransactionVerification.hs b/concordium-consensus/src/Concordium/TransactionVerification.hs index 6a71b58760..770b505da7 100644 --- a/concordium-consensus/src/Concordium/TransactionVerification.hs +++ b/concordium-consensus/src/Concordium/TransactionVerification.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module Concordium.TransactionVerification where import Control.Monad.Trans @@ -123,6 +125,8 @@ data NotOkResult -- ^The 'NormalTransaction' contained an already used nonce. | Expired -- ^The transaction was expired + | InvalidPayloadSize + -- ^Transaction payload size exceeds protocol limit. deriving (Eq, Show, Ord) -- |Type which can verify transactions in a monadic context. @@ -229,9 +233,11 @@ verifyCredentialDeployment now accountCreation@Tx.AccountCreation{..} = -- * Checks that the effective time is no later than the timeout of the chain update. -- * Checks that provided sequence number is sequential. -- * Checks that the 'ChainUpdate' is correctly signed. -verifyChainUpdate :: TransactionVerifier pv m => Updates.UpdateInstruction -> m VerificationResult +verifyChainUpdate :: forall pv m . TransactionVerifier pv m => Updates.UpdateInstruction -> m VerificationResult verifyChainUpdate ui@Updates.UpdateInstruction{..} = either id id <$> runExceptT (do + unless (Types.validatePayloadSize (Types.protocolVersion @pv) (Updates.updatePayloadSize uiHeader)) $ + throwError $ NotOk InvalidPayloadSize -- Check that the timeout is no later than the effective time, -- or the update is immediate when (Updates.updateTimeout uiHeader >= Updates.updateEffectiveTime uiHeader && Updates.updateEffectiveTime uiHeader /= 0) $ @@ -255,11 +261,13 @@ verifyChainUpdate ui@Updates.UpdateInstruction{..} = -- * Checks that the sender is a valid account. -- * Checks that the nonce is correct. -- * Checks that the 'NormalTransaction' is correctly signed. -verifyNormalTransaction :: (TransactionVerifier pv m, Tx.TransactionData msg) - => msg +verifyNormalTransaction :: forall pv m msg . (TransactionVerifier pv m, Tx.TransactionData msg) + => msg -> m VerificationResult verifyNormalTransaction meta = either id id <$> runExceptT (do + unless (Types.validatePayloadSize (Types.protocolVersion @pv) (Tx.thPayloadSize (Tx.transactionHeader meta))) $ + throwError $ NotOk InvalidPayloadSize -- Check that enough energy is supplied let cost = Cost.baseCost (Tx.getTransactionHeaderPayloadSize $ Tx.transactionHeader meta) (Tx.getTransactionNumSigs (Tx.transactionSignature meta)) unless (Tx.transactionGasAmount meta >= cost) $ throwError $ NotOk NormalTransactionDepositInsufficient 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/empty.wasm b/concordium-consensus/testdata/contracts/empty.wasm new file mode 100644 index 0000000000..514a6ca1ed Binary files /dev/null and b/concordium-consensus/testdata/contracts/empty.wasm differ 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/call-counter.wasm b/concordium-consensus/testdata/contracts/v1/call-counter.wasm new file mode 100644 index 0000000000..4bc04bbaf0 Binary files /dev/null and b/concordium-consensus/testdata/contracts/v1/call-counter.wasm differ diff --git a/concordium-consensus/testdata/contracts/v1/call-counter.wat b/concordium-consensus/testdata/contracts/v1/call-counter.wat new file mode 100644 index 0000000000..f46b9feb50 --- /dev/null +++ b/concordium-consensus/testdata/contracts/v1/call-counter.wat @@ -0,0 +1,128 @@ +;; Test for one contract calling itself. +;; 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 + + ;; 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))) + + ;; state functions + (import "concordium" "load_state" (func $load_state (param $write_location i32) (param $length i32) (param $offset i32) (result i32))) + (import "concordium" "write_state" (func $write_state (param $read_location i32) (param $length i32) (param $offset i32) (result i32))) + + ;; Helper Functions + + (func $assert_eq (param $actual i32) (param $expected i32) + (if (i32.eq (local.get $actual) (local.get $expected)) + (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) + (else unreachable))) + + ;; Gets an address from the parameters and asserts that the size is correct. + ;; The address is saved in memory at location 0. + (func $save_addr_from_param_to_mem_0 + (call $assert_eq + (call $get_parameter_section (i32.const 0) (i32.const 0) (i32.const 32) (i32.const 0)) + (i32.const 32)) + ) + + ;; The counter contract + + (func $init_counter (export "init_counter") (param i64) (result i32) + (i64.store (i32.const 0) (i64.const 0)) + (call $write_state (i32.const 0) (i32.const 8) (i32.const 0)) + (return (i32.const 0)) ;; Successful init + ) + + (func $inc_counter (export "counter.inc") (param i64) (result i32) + (call $load_state (i32.const 0) (i32.const 8) (i32.const 0)) + (drop) + ;; read the integer from the contract state, add 1 to it and store it + (i64.store (i32.const 0) (i64.add (i64.const 1) (i64.load (i32.const 0)))) + ;; update the contract state + (call $write_state (i32.const 0) (i32.const 8) (i32.const 0)) + (drop) + ;; and then write the return value + (call $write_output (i32.const 0) (i32.const 8) (i32.const 0)) + (drop) + ;; and return success + (i32.const 0) + ) + + ;; 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) + ) + + ;; 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) + (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 + (local.set $rv (call $invoke (i32.const 1) (i32.const 0) (local.get $size))) + ;; 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 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) + ) + + ;; 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/caller.wasm b/concordium-consensus/testdata/contracts/v1/caller.wasm new file mode 100644 index 0000000000..dac58be65d Binary files /dev/null and b/concordium-consensus/testdata/contracts/v1/caller.wasm differ 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/testdata/contracts/v1/extra-exports.wasm b/concordium-consensus/testdata/contracts/v1/extra-exports.wasm new file mode 100644 index 0000000000..51ff0b91c7 Binary files /dev/null and b/concordium-consensus/testdata/contracts/v1/extra-exports.wasm differ 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/testdata/contracts/v1/self-balance.wasm b/concordium-consensus/testdata/contracts/v1/self-balance.wasm new file mode 100644 index 0000000000..778b215093 Binary files /dev/null and b/concordium-consensus/testdata/contracts/v1/self-balance.wasm differ diff --git a/concordium-consensus/testdata/contracts/v1/self-balance.wat b/concordium-consensus/testdata/contracts/v1/self-balance.wat new file mode 100644 index 0000000000..90da7a2eec --- /dev/null +++ b/concordium-consensus/testdata/contracts/v1/self-balance.wat @@ -0,0 +1,51 @@ +;; Test checking self-balance when resuming. Both when sending to accounts and contracts. + +(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))) + (import "concordium" "get_receive_self_balance" (func $get_receive_self_balance (result i64))) + + ;; state functions + (import "concordium" "load_state" (func $load_state (param $write_location i32) (param $length i32) (param $offset i32) (result i32))) + (import "concordium" "write_state" (func $write_state (param $read_location i32) (param $length i32) (param $offset i32) (result i32))) + + + ;; just a an empty contract that only holds its balance. + (func $init_transfer(export "init_transfer") (param i64) (result i32) + ;; no state + (return (i32.const 0)) ;; Successful init + ) + + ;; an endpoint that just accepts. + (func $accept (export "transfer.accept") (param i64) (result i32) + (return (i32.const 0)) + ) + + (func $call (export "transfer.forward") (param i64) (result i32) + (local $n i32) + (local $size i32) + (local $start_balance 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)) + ;; store the balance before the call + (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 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)) + ;; and return success + (drop) + (drop) + (drop) + (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 0000000000..5bdb9eeb59 Binary files /dev/null and b/concordium-consensus/testdata/contracts/v1/send-message-v1.wasm differ diff --git a/concordium-consensus/testdata/contracts/v1/send-message-v1.wat b/concordium-consensus/testdata/contracts/v1/send-message-v1.wat new file mode 100644 index 0000000000..628f28614d --- /dev/null +++ b/concordium-consensus/testdata/contracts/v1/send-message-v1.wat @@ -0,0 +1,34 @@ +;; A trivial contract that simply forwards a message. +;; Used to test messaging between v1 and v0 contracts. +;; This is a v0 contract. + +(module + + ;; Imports + + (import "concordium" "get_parameter_size" (func $get_parameter_size (result i32))) + (import "concordium" "get_parameter_section" (func $get_parameter_section (param $write_location i32) (param $length i32) (param $offset i32) (result i32))) + (import "concordium" "send" (func $send (param $addr_index i64) (param $addr_subindex i64) + (param $receive_name i32) (param $receive_name_len i32) + (param $amount i64) (param $parameter i32) (param $parameter_len i32) (result i32))) + + ;; The empty contract + + (func $init_proxy (export "init_proxy") (param i64) (result i32) + (return (i32.const 0)) ;; Successful init + ) + + (func $forward_proxy (export "proxy.forward") (param $amount i64) (result i32) + (local $size i32) + (local.set $size (call $get_parameter_size)) + (call $get_parameter_section (i32.const 0) (local.get $size) (i32.const 0)) + (drop) + (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 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) +) \ No newline at end of file diff --git a/concordium-consensus/testdata/contracts/v1/transfer.wasm b/concordium-consensus/testdata/contracts/v1/transfer.wasm new file mode 100644 index 0000000000..923658e600 Binary files /dev/null and b/concordium-consensus/testdata/contracts/v1/transfer.wasm differ diff --git a/concordium-consensus/testdata/contracts/v1/transfer.wat b/concordium-consensus/testdata/contracts/v1/transfer.wat new file mode 100644 index 0000000000..52732a505a --- /dev/null +++ b/concordium-consensus/testdata/contracts/v1/transfer.wat @@ -0,0 +1,48 @@ +;; test transferring from a contract to an account. +;; We try to transfer twice, checking the first transfer succeeds +;; and the second one fails (since not enough tokens exist). + +(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))) + + ;; state functions + (import "concordium" "load_state" (func $load_state (param $write_location i32) (param $length i32) (param $offset i32) (result i32))) + (import "concordium" "write_state" (func $write_state (param $read_location i32) (param $length i32) (param $offset i32) (result i32))) + + ;; Helper Functions + + (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_64 (param $actual i64) (param $expected i64) + (if (i64.ne (local.get $actual) (local.get $expected)) + (then nop) + (else unreachable))) + + ;; The transfer + + (func $init_transfer(export "init_transfer") (param i64) (result i32) + ;; no state + (return (i32.const 0)) ;; Successful init + ) + + (func $forward (export "transfer.forward") (param $amount i64) (result i32) + ;; assume the parameter is the address to transfer to + (call $get_parameter_section (i32.const 0) (i32.const 0) (i32.const 32) (i32.const 0)) + (drop) + (i64.store (i32.const 32) (local.get $amount)) + (call $assert_eq_64 (call $invoke (i32.const 0) (i32.const 0) (i32.const 40)) (i64.const 0)) ;; ensure success without return value + (call $assert_ne_64 (call $invoke (i32.const 0) (i32.const 0) (i32.const 40)) (i64.const 0)) ;; trying to transfer again fails since we have no tokens + ;; and return success + (i32.const 0) + ) + (memory 1) +) \ No newline at end of file diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs index ec5a03a26e..2cc117d3d4 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Instances.hs @@ -15,11 +15,13 @@ 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 import Concordium.GlobalState.Basic.BlockState.Instances +import Concordium.GlobalState.Instance import qualified Data.FixedByteString as FBS import qualified Data.ByteString as BS @@ -27,24 +29,34 @@ 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. -validContractArtifacts :: [(Wasm.ModuleSource, GSWasm.ModuleInterface)] -validContractArtifacts = mapMaybe packModule contractSources +validContractArtifactsV0 :: [(Wasm.ModuleSource GSWasm.V0, GSWasm.ModuleInterfaceV GSWasm.V0)] +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.WasmModuleV source) +contractSourcesV1 :: [(FilePath, BS.ByteString)] +contractSourcesV1 = $(makeRelativeToProject "testdata/contracts/v1" >>= embedDir) + +-- Read all the files in testdata/contracts/v1 and get any valid contract interfaces. +-- This assumes there is at least one, otherwise the tests will fail. +validContractArtifactsV1 :: [(Wasm.ModuleSource GSWasm.V1, GSWasm.ModuleInterfaceV GSWasm.V1)] +validContractArtifactsV1 = mapMaybe packModule contractSourcesV1 + where packModule (_, sourceBytes) = + let source = Wasm.ModuleSource sourceBytes + in (source,) <$> WasmV1.processModule (Wasm.WasmModuleV source) checkBinary :: Show a => (a -> a -> Bool) -> a -> a -> String -> String -> String -> Either String () checkBinary bop x y sbop sx sy = unless (bop x y) $ Left $ "Not satisfied: " ++ sx ++ " (" ++ show x ++ ") " ++ sbop ++ " " ++ sy ++ " (" ++ show y ++ ")" invariantIT :: ContractIndex -> IT -> Either String (Word8, Bool, Bool, ContractIndex, H.Hash, Word64) invariantIT offset (Leaf inst) = do - checkBinary (==) (contractIndex $ 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 @@ -95,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 validContractArtifacts - 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 @@ -175,7 +193,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 +262,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) @@ -260,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 @@ -269,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 @@ -286,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 @@ -323,7 +341,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/ChainMetatest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs index 9129ec15e2..23df49d9fd 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.TransactionVerification import Concordium.GlobalState.Basic.BlockState @@ -37,12 +38,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)])] } ] @@ -64,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/FibonacciSelfMessageTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs index 877473731c..fd4623e192 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs @@ -22,6 +22,7 @@ import qualified Concordium.Crypto.SHA256 as Hash import Concordium.Scheduler.Runner import Concordium.TransactionVerification +import Concordium.GlobalState.Instance import Concordium.GlobalState.Basic.BlockState.Accounts as Acc import Concordium.GlobalState.Basic.BlockState.Instances import Concordium.GlobalState.Basic.BlockState @@ -55,13 +56,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 +85,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 a05c7973ff..738f1fc042 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs @@ -19,6 +19,7 @@ import qualified Concordium.Scheduler as Sch import Concordium.Scheduler.Runner import Concordium.TransactionVerification +import Concordium.GlobalState.Instance import Concordium.GlobalState.Basic.BlockState import Concordium.GlobalState.Basic.BlockState.Invariants import Concordium.GlobalState.Basic.BlockState.Instances @@ -48,12 +49,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)])] } ] @@ -75,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 @@ -99,3 +100,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/InitPoliciesTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs index c06f5e61f7..7d6aee356d 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitPoliciesTest.hs @@ -21,10 +21,10 @@ 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 + 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 54161d3657..3b097f5559 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.TransactionVerification import Concordium.GlobalState.Basic.BlockState @@ -67,22 +68,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{ @@ -109,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 63d62fe2ed..4c21b329ab 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.TransactionVerification import Concordium.GlobalState.Basic.BlockState @@ -40,27 +41,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{ @@ -107,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 6ebac3bd88..58da0c20c8 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs @@ -24,7 +24,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 @@ -46,7 +46,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 "") @@ -56,7 +56,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 @@ -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/SimpleTransferSpec.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs index 0051814ebe..0c664f5e5e 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)])] } @@ -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/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 new file mode 100644 index 0000000000..30b37c4878 --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/Invoke.hs @@ -0,0 +1,166 @@ +{-# 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 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 qualified SchedulerTests.SmartContracts.V1.InvokeHelpers as InvokeHelpers + +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" + +deployModule :: ContextM (PersistentBlockState PV4, GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1) +deployModule = do + ((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, 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 +invokeContract1 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 + +-- |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 + runBlobStoreTemp "." . runPersistentBlockStateMonad $ do + bsWithMod <- deployModule + (addr, stateWithContract) <- initContract bsWithMod + 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 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 an empty array." [] (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." + + 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 an empty array." [] (BS.unpack rv) + + +tests :: Spec +tests = describe "Invoke contract" $ do + specify "V1: Counter contract" runCounterTests diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs new file mode 100644 index 0000000000..891c1b91bf --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/Counter.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| This module tests calling a contract from a contract and inspecting the return + message. Concretely it invokes a counter contract that maintains a 64-bit + counter in its state. +-} +module SchedulerTests.SmartContracts.V1.Counter (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(runPut, putWord64le, putByteString, putWord16le) +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 qualified Concordium.TransactionVerification as TVer + +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) + +counterSourceFile :: FilePath +counterSourceFile = "./testdata/contracts/v1/call-counter.wasm" + +-- Tests in this module use version 1, creating V1 instances. +wasmModVersion :: WasmVersion +wasmModVersion = V1 + +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 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 ensureSuccess , counterSpec 2) + ) + , ( TJSON { payload = Update 0 (Types.ContractAddress 0 0) "counter.inc10" callArgs + , metadata = makeDummyHeader alesAccount 5 700000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary ensureSuccess , counterSpec 12) + ) + ] + } + ] + + where + callArgs = 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 + deploymentCostCheck :: TVer.BlockItemWithStatus -> 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 (WasmModuleV0 (WasmModuleV 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 :: TVer.BlockItemWithStatus -> 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 + + -- ensure the transaction is successful + 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. + 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))) (instanceModel istance) + +tests :: Spec +tests = describe "V1: Counter counts." $ + mkSpecs testCases diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs new file mode 100644 index 0000000000..636338dce0 --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/CrossMessaging.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| This module tests calling a V0 contract from a V1 contract and sending a message from a V0 to V1 contract. +-} +module SchedulerTests.SmartContracts.V1.CrossMessaging (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(runPut, putWord64le, putByteString, putWord16le) +import Lens.Micro.Platform + +import qualified Concordium.Scheduler.Types as Types +import Concordium.Scheduler.Runner +import qualified Concordium.TransactionVerification as TVer + +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 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) + +counterSourceFile :: FilePath +counterSourceFile = "./testdata/contracts/v1/call-counter.wasm" + +version1 :: WasmVersion +version1 = V1 + +proxySourceFile :: FilePath +proxySourceFile = "./testdata/contracts/v1/send-message-v1.wasm" + +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 +-- contract. That method calls the forward method on the proxy contract which +-- forwards the call to the inc method of the counter contract, which finally +-- increments the counter. +testCases :: [TestCase PV4] +testCases = + [ TestCase + { tcName = "CrossMessaging via a proxy" + , tcParameters = defaultParams {tpInitialBlockState=initialBlockState} + , tcTransactions = + [ ( TJSON { payload = DeployModule version1 counterSourceFile + , metadata = makeDummyHeader alesAccount 1 100000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary ensureSuccess, emptySpec) + ) + , ( TJSON { payload = DeployModule version0 proxySourceFile + , metadata = makeDummyHeader alesAccount 2 100000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary ensureSuccess, emptySpec) + ) + , ( TJSON { payload = InitContract 0 version1 counterSourceFile "init_counter" "" + , metadata = makeDummyHeader alesAccount 3 100000 + , keys = [(0,[(0, alesKP)])] + } + , (SuccessWithSummary ensureSuccess, counterSpec 0) + ) + , ( TJSON { payload = InitContract 0 version0 proxySourceFile "init_proxy" "" + , metadata = makeDummyHeader alesAccount 4 100000 + , keys = [(0,[(0, alesKP)])] + } + , (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)])] + } + , (SuccessWithSummary ensureSuccess, counterSpec 10) + ) + ] + } + ] + + where + forwardParameter = runPut $ do + putWord64le 0 -- index of the counter + putWord64le 0 -- subindex of the counter contract + putWord16le (fromIntegral (BSS.length "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 + putWord64le 1 -- contract index (the proxy contract) + putWord64le 0 -- contract subindex + putWord16le (fromIntegral (BS.length forwardParameter)) -- length of parameter + putByteString forwardParameter + 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 + 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. + 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))) (instanceModel istance) + +tests :: Spec +tests = describe "V1: Counter with cross-messaging." $ + mkSpecs testCases 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..f68ec9be93 --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ErrorCodes.hs @@ -0,0 +1,294 @@ +{-# 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 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.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 + +callerSourceFile :: FilePath +callerSourceFile = "./testdata/contracts/v1/caller.wasm" + +emptyContractSourceFile :: FilePath +emptyContractSourceFile = "./testdata/contracts/empty.wasm" + +deployModule1 :: PersistentBlockState PV4 -> ContextM ((GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1), PersistentBlockState PV4) +deployModule1 = InvokeHelpers.deployModuleV1 callerSourceFile + +initContract1 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V1, WasmModuleV GSWasm.V1) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) +initContract1 = InvokeHelpers.initContractV1 alesAccount (InitName "init_caller") emptyParameter 0 + +deployModule0 :: PersistentBlockState PV4 -> ContextM ((GSWasm.ModuleInterfaceV GSWasm.V0, WasmModuleV GSWasm.V0), PersistentBlockState PV4) +deployModule0 = InvokeHelpers.deployModuleV0 emptyContractSourceFile + +initContract0 :: PersistentBlockState PV4 -> (GSWasm.ModuleInterfaceV GSWasm.V0, WasmModuleV GSWasm.V0) -> ContextM (Types.ContractAddress, PersistentBlockState PV4) +initContract0 = InvokeHelpers.initContractV0 alesAccount (InitName "init_empty") emptyParameter 0 + +-- |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 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 an entrypoint that traps" 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/InvokeHelpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/InvokeHelpers.hs new file mode 100644 index 0000000000..4937ea3c8f --- /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 + ws <- liftIO $ BS.readFile sourceFile + let wm = WasmModuleV (ModuleSource ws) + 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 + ws <- liftIO $ BS.readFile sourceFile + let wm = WasmModuleV (ModuleSource ws) + 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..7c8dce2415 --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/SelfBalance.hs @@ -0,0 +1,151 @@ +{-# 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. 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 + 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 new file mode 100644 index 0000000000..0a2e9a68e6 --- /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 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 qualified Concordium.TransactionVerification as TVer + +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 :: WasmVersion +wasmModVersion = V1 + +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 ensureSuccess , transferSpec) + ) + ] + } + ] + + where + deploymentCostCheck :: TVer.BlockItemWithStatus -> 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 (WasmModuleV1 (WasmModuleV 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 :: TVer.BlockItemWithStatus -> 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 + 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 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 is empty.") (ContractState "") (instanceModel istance) + assertEqual ("Contract has 0 CCD.") (Types.Amount 0) (instanceAmount istance) + +tests :: Spec +tests = describe "V1: Transfer from contract to account." $ + mkSpecs testCases 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..bd0ba59620 --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V1/ValidInvalidModules.hs @@ -0,0 +1,38 @@ +{-# 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 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 + +-- |A V1 module with extra exports. +testModule1 :: Assertion +testModule1 = do + 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 ws) + 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/SchedulerTests/TestUtils.hs b/concordium-consensus/tests/scheduler/SchedulerTests/TestUtils.hs index 816e69ae22..01def6f5e0 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 @@ -36,6 +36,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/SchedulerTests/TrySendTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/TrySendTest.hs index 2713ff4547..c0e1445efa 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)])] } @@ -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) ) diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index 144a54b94d..0942358a6b 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -25,6 +25,14 @@ import qualified SchedulerTests.StakedAmountLocked(tests) 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 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 main :: IO () @@ -53,3 +61,10 @@ main = hspec $ do SchedulerTests.StakedAmountLocked.tests SchedulerTests.RejectReasons.tests SchedulerTests.RejectReasonsRustContract.tests + SchedulerTests.SmartContracts.V1.Counter.tests + SchedulerTests.SmartContracts.V1.Transfer.tests + SchedulerTests.SmartContracts.V1.CrossMessaging.tests + SchedulerTests.SmartContracts.Invoke.tests + SchedulerTests.SmartContracts.V1.ErrorCodes.tests + SchedulerTests.SmartContracts.V1.ValidInvalidModules.tests + SchedulerTests.SmartContracts.V1.SelfBalance.tests diff --git a/concordium-grpc-api b/concordium-grpc-api index 1ea1adde19..89eb52e2e8 160000 --- a/concordium-grpc-api +++ b/concordium-grpc-api @@ -1 +1 @@ -Subproject commit 1ea1adde19bf18dcbb334e505e2ed684addd32d4 +Subproject commit 89eb52e2e8f75e1337a2193cc3905ece68da6947 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"; diff --git a/concordium-node/src/consensus_ffi/ffi.rs b/concordium-node/src/consensus_ffi/ffi.rs index c67f4b267e..7f0612d8d6 100644 --- a/concordium-node/src/consensus_ffi/ffi.rs +++ b/concordium-node/src/consensus_ffi/ffi.rs @@ -360,6 +360,11 @@ extern "C" { block_hash: *const c_char, contract_address: *const c_char, ) -> *const c_char; + pub fn invokeContract( + consensus: *mut consensus_runner, + block_hash: *const c_char, + context: *const c_char, + ) -> *const c_char; pub fn getRewardStatus( consensus: *mut consensus_runner, block_hash: *const c_char, @@ -651,6 +656,16 @@ impl ConsensusContainer { ))) } + pub fn invoke_contract(&self, block_hash: &str, context: &str) -> anyhow::Result { + let block_hash = CString::new(block_hash)?; + let context = CString::new(context)?; + Ok(wrap_c_call_string!(self, consensus, |consensus| invokeContract( + consensus, + block_hash.as_ptr(), + context.as_ptr() + ))) + } + pub fn get_reward_status(&self, block_hash: &str) -> anyhow::Result { let block_hash = CString::new(block_hash)?; Ok(wrap_c_call_string!(self, consensus, |consensus| getRewardStatus( diff --git a/concordium-node/src/rpc.rs b/concordium-node/src/rpc.rs index ac70645308..ba6bdb2d31 100644 --- a/concordium-node/src/rpc.rs +++ b/concordium-node/src/rpc.rs @@ -660,6 +660,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, diff --git a/docs/contracts.md b/docs/contracts.md new file mode 100644 index 0000000000..8d06459c85 --- /dev/null +++ b/docs/contracts.md @@ -0,0 +1,272 @@ +# 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 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 + 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; +``` + +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 +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. 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 +/// - -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); +``` diff --git a/docs/grpc.md b/docs/grpc.md index 357b62a188..9d40fe06e3 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,40 @@ 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. 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 +- if `tag` is `"failure"` then the following fields are present + - `reason: RejectReason` — encoding of a rejection reason