diff --git a/CHANGELOG.md b/CHANGELOG.md index 3d61af929b..8cd31b365f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ ## Unreleased changes +- New `DryRun` endpoint that allows simulating the execution of transactions. + ## 6.1.7 - Add load-shedding to the V2 GRPC API. In particular, if at the time of the diff --git a/concordium-base b/concordium-base index c38bceece3..fe3994ba63 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit c38bceece366cfad0475b9bd39496ec7bab01d29 +Subproject commit fe3994ba637045ab62fe76152eb9e29ba67ccc28 diff --git a/concordium-consensus/lib.def b/concordium-consensus/lib.def index 9aded2beba..e9076831c2 100644 --- a/concordium-consensus/lib.def +++ b/concordium-consensus/lib.def @@ -88,3 +88,13 @@ EXPORTS getBakersRewardPeriodV2 getBlockCertificatesV2 getBakerEarliestWinTimeV2 + + dryRunStart + dryRunEnd + dryRunGetAccountInfo + dryRunGetInstanceInfo + dryRunLoadBlockState + dryRunInvokeInstance + dryRunSetTimestamp + dryRunMintToAccount + dryRunTransaction \ No newline at end of file diff --git a/concordium-consensus/src/Concordium/External/DryRun.hs b/concordium-consensus/src/Concordium/External/DryRun.hs new file mode 100644 index 0000000000..b03d8ada31 --- /dev/null +++ b/concordium-consensus/src/Concordium/External/DryRun.hs @@ -0,0 +1,882 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module provides the interface for supporting the transaction dry-run facility in the +-- node API. A dry run is initiated by a call to 'dryRunStart', which returns a stable pointer to a +-- 'DryRunHandle'. This handle should be passed to the various dry run operations before ultimately +-- being released with a call to 'dryRunEnd', which frees the resources associated with the handle. +-- +-- Note, the operations on a single dry run handle are not thread safe, and must be serialised. +-- That is, you must wait for each dry run operation to return before invoking another operation +-- on the same handle. However, it is safe to concurrently invoke operations on different dry +-- run handles. +module Concordium.External.DryRun () where + +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Cont (ContT (..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString.Unsafe as BS +import Data.IORef +import qualified Data.Map.Strict as Map +import qualified Data.ProtoLens as Proto +import Foreign +import GHC.Stack +import Lens.Micro.Platform + +import qualified Concordium.Crypto.SignatureScheme as Sig +import Concordium.GRPC2 +import Concordium.Logger +import Concordium.Types +import Concordium.Types.Execution +import qualified Concordium.Types.InvokeContract as InvokeContract +import Concordium.Types.Parameters +import Concordium.Types.Queries +import Concordium.Types.Transactions +import Concordium.Utils +import qualified Proto.V2.Concordium.Types as Proto + +import qualified Concordium.Cost as Cost +import qualified Concordium.External as Ext +import Concordium.External.Helpers +import Concordium.GlobalState.BlockMonads +import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlockState +import qualified Concordium.GlobalState.TreeState as SkovV0 +import Concordium.GlobalState.Types (BlockStateTypes (..)) +import Concordium.ID.Types +import qualified Concordium.KonsensusV1.SkovMonad as SkovV1 +import qualified Concordium.KonsensusV1.Types as SkovV1 +import qualified Concordium.Kontrol as SkovV0 +import Concordium.MultiVersion +import Concordium.Queries +import qualified Concordium.Scheduler as Scheduler +import qualified Concordium.Scheduler.Environment as Scheduler +import qualified Concordium.Scheduler.EnvironmentImplementation as Scheduler +import qualified Concordium.Scheduler.InvokeContract as InvokeContract +import qualified Concordium.Skov as SkovV0 +import qualified Concordium.TransactionVerification as TVer + +-- | The charge to the energy quota for loading a block state. +costLoadBlockState :: Energy +costLoadBlockState = 2000 + +-- | The charge to the energy quota for getting account info. +costGetAccountInfo :: Energy +costGetAccountInfo = 200 + +-- | The charge to the energy quota for getting contract instance info. +costGetInstanceInfo :: Energy +costGetInstanceInfo = 200 + +-- | The base charge to the energy quota for running invoke instance on a contract. +-- In addition, the energy cost of the execution will be charged. +costInvokeInstanceBase :: Energy +costInvokeInstanceBase = 200 + +-- | The charge to the energy quota for setting the block timestamp. +costSetTimestamp :: Energy +costSetTimestamp = 50 + +-- | The charge to the energy quota for minting to an account. +costMintToAccount :: Energy +costMintToAccount = 400 + +-- | The base cost for dry-running a transaction. +-- In addition, the energy cost of the execution will be charged. +costTransactionBase :: Energy +costTransactionBase = 400 + +-- | An opaque rust vector. +data ForeignVec + +-- | A function that copies bytes to a rust vector. +type CopyToForeignVec = Ptr ForeignVec -> Ptr Word8 -> Int64 -> IO () + +-- | Boilerplate wrapper to invoke C callbacks. +foreign import ccall "dynamic" callCopyToForeignVecCallback :: FunPtr CopyToForeignVec -> CopyToForeignVec + +-- | Write a value that represents a dry-run response. +writeProtoResponse :: + ( ToProto (DryRunResponse a), + Output (DryRunResponse a) ~ Proto.DryRunResponse + ) => + -- | Writer function. + (Ptr Word8 -> Int64 -> IO ()) -> + -- | Remaining energy quota. + Energy -> + -- | Value to write. + a -> + IO () +writeProtoResponse writer quotaRem response = + BS.unsafeUseAsCStringLen encoded (\(ptr, len) -> writer (castPtr ptr) (fromIntegral len)) + where + encoded = + Proto.encodeMessage . toProto $ + DryRunResponse + { drrResponse = response, + drrQuotaRemaining = quotaRem + } + +-- | Write a value that represents a dry-run response, but could fail in the conversion. +writeProtoResponseEither :: + ( ToProto (DryRunResponse a), + Output (DryRunResponse a) ~ Either e Proto.DryRunResponse + ) => + -- | Writer function. + (Ptr Word8 -> Int64 -> IO ()) -> + -- | Remaining energy quota. + Energy -> + -- | Value to write. + a -> + IO (Either e ()) +writeProtoResponseEither writer quotaRem response = case toProto resp of + Left e -> return $ Left e + Right msg -> do + BS.unsafeUseAsCStringLen + (Proto.encodeMessage msg) + (\(ptr, len) -> writer (castPtr ptr) (fromIntegral len)) + return $ Right () + where + resp = + DryRunResponse + { drrResponse = response, + drrQuotaRemaining = quotaRem + } + +-- | Return codes for the dry run FFI. +data DryRunReturnCode + = -- | The operation was successful. + OK + | -- | An internal error occurred. + InternalError + | -- | The operation could not be completed within the remaining energy quota. + OutOfEnergyQuota + deriving (Enum) + +-- | Convert a 'DryRunReturnCode' to an 'Int64' that is actually sent across the FFI boundary. +returnCode :: DryRunReturnCode -> Int64 +returnCode = fromIntegral . fromEnum + +-- | The set of constraints that apply to the monad used for dry-run operations. +type StateConstraints m pv = + ( BlockStateOperations m, + BlockState m ~ HashedPersistentBlockState pv, + UpdatableBlockState m ~ PersistentBlockState pv, + MonadProtocolVersion m, + MPV m ~ pv, + MonadLogger m, + MonadIO m + ) + +-- | The current state of a dry-run session. +data DryRunState (pv :: ProtocolVersion) = DryRunState + { -- | The current block state. + drsBlockState :: !(PersistentBlockState pv), + -- | The current timestamp. + drsTimestamp :: !Timestamp + } + +-- | The block state context. +-- Implementation note: Storing the 'PersistentBlockState' under an 'IORef' is not necessary in +-- principle, as the state is implemented with an 'IORef' and is updated in-place. However, the +-- 'BlockStateOperations' interface does not strictly guarantee that operations are performed +-- in-place, so we use the 'IORef' to allow for that possibility. +data EBlockStateContext finconf + = forall (pv :: ProtocolVersion). + (StateConstraints (VersionedSkovV0M finconf pv) pv, IsConsensusV0 pv) => + EBlockStateContextV0 + { bsc0Config :: !(VersionedConfigurationV0 finconf pv), + bscState :: !(IORef (DryRunState pv)) + } + | forall (pv :: ProtocolVersion). + (StateConstraints (VersionedSkovV1M finconf pv) pv, IsConsensusV1 pv) => + EBlockStateContextV1 + { bsc1Config :: !(VersionedConfigurationV1 finconf pv), + bscState :: !(IORef (DryRunState pv)) + } + +-- | Extract the protocol version from a block state context. +bscProtocolVersion :: EBlockStateContext finconf -> ProtocolVersion +bscProtocolVersion (EBlockStateContextV0 @_ @pv _ _) = demoteProtocolVersion $ protocolVersion @pv +bscProtocolVersion (EBlockStateContextV1 @_ @pv _ _) = demoteProtocolVersion $ protocolVersion @pv + +-- | Run an operation on the dry-run state in a block state context. +-- The operation runs in a monad that is abstracted by 'StateConstraints', and can thus run on any +-- consensus version. +runWithEBlockStateContext :: + MultiVersionRunner finconf -> + EBlockStateContext finconf -> + (forall m pv. (StateConstraints m pv) => IORef (DryRunState pv) -> m a) -> + IO a +runWithEBlockStateContext mvr (EBlockStateContextV0 vc0 drs) operation = do + st <- readIORef (vc0State vc0) + runMVR + ( SkovV0.evalSkovT + (operation drs) + (mvrSkovHandlers vc0 mvr) + (vc0Context vc0) + st + ) + mvr +runWithEBlockStateContext mvr (EBlockStateContextV1 vc1 drs) operation = do + st <- readIORef (vc1State vc1) + runMVR + ( SkovV1.evalSkovT + (operation drs) + (vc1Context vc1) + st + ) + mvr + +-- | Handle that identifies a particular dry-run session. +data DryRunHandle = forall finconf. + DryRunHandle + { -- | Wrap the multi-version runner from the consensus runner. + drhMVR :: !(MultiVersionRunner finconf), + -- | Callback for writing to a Rust vector. + drhWriteToVector :: !CopyToForeignVec, + -- | Reference to the current block state context. + drhBlockStateContext :: !(IORef (Maybe (EBlockStateContext finconf))), + -- | An 'IORef' that records the remaining energy quota for this dry run. + drhEnergyQuota :: !(IORef Energy) + } + +-- | Start a dry-run session, creating a new dry-run handle. +-- Once completed, the handle must be disposed by calling 'dryRunEnd'. +dryRunStart :: + -- | Pointer to the consensus runner. + StablePtr Ext.ConsensusRunner -> + -- | Callback to use for writing data to a vector. + FunPtr CopyToForeignVec -> + -- | The total energy quota to use for the dry-run session. + Word64 -> + IO (StablePtr DryRunHandle) +dryRunStart consensusPtr vecCallback energyQuota = do + Ext.ConsensusRunner mvr <- deRefStablePtr consensusPtr + initialBSC <- newIORef Nothing + quotaRef <- newIORef $ Energy energyQuota + dryRunPtr <- + newStablePtr $! + DryRunHandle + { drhMVR = mvr, + drhWriteToVector = callCopyToForeignVecCallback vecCallback, + drhBlockStateContext = initialBSC, + drhEnergyQuota = quotaRef + } + mvLog mvr External LLTrace $ "Dry run start " ++ show (castStablePtrToPtr dryRunPtr) + return dryRunPtr + +-- | Finish a dry-run session, allowing the resources associated with it to be freed. +-- The handle must not be used after calling 'dryRunEnd'. +dryRunEnd :: + -- | The dry-run handle. + StablePtr DryRunHandle -> + IO () +dryRunEnd dryRunPtr = do + DryRunHandle{drhMVR = mvr} <- deRefStablePtr dryRunPtr + mvLog mvr External LLTrace $ "Dry run end " ++ show (castStablePtrToPtr dryRunPtr) + freeStablePtr dryRunPtr + +-- | Deduct the specified amount from the energy quota if sufficient quota is remaining. +-- If it is sufficient, the supplied continuation is executed. Otherwise, 'OutOfEnergyQuota' +-- is returned. +tryTickQuota :: IORef Energy -> Energy -> (Energy -> IO DryRunReturnCode) -> IO DryRunReturnCode +tryTickQuota quotaRef amount cont = do + (inQuota, remQuota) <- atomicModifyIORef' quotaRef $ \q -> + if q >= amount then (q - amount, (True, q - amount)) else (q, (False, q)) + if inQuota then cont remQuota else return OutOfEnergyQuota + +-- | Load the state of a particular block in the dry-run session, and use its timestamp as the +-- current timestamp for the session. +dryRunLoadBlockState :: + -- | The dry-run handle. + StablePtr DryRunHandle -> + -- | Tag identifying the type of block hash input. + Word8 -> + -- | Payload data for the block hash input. + Ptr Word8 -> + -- | Vector in which to write the response. + Ptr ForeignVec -> + IO Int64 +dryRunLoadBlockState dryRunPtr bhiTag hashPtr outVec = + returnCode <$> do + DryRunHandle{..} <- deRefStablePtr dryRunPtr + tryTickQuota drhEnergyQuota costLoadBlockState $ \quotaRem -> do + input <- decodeBlockHashInput bhiTag hashPtr + res <- + runMVR + ( liftSkovQueryBHIAndVersion + ( \vc0 bp -> do + drsTimestamp <- SkovV0.getSlotTimestamp $ SkovV0.blockSlot bp + drsBlockState <- thawBlockState =<< blockState bp + drs <- liftIO . newIORef $ DryRunState{..} + return (drsTimestamp, EBlockStateContextV0 vc0 drs) + ) + ( \vc1 bp _ -> do + let drsTimestamp = SkovV1.blockTimestamp bp + drsBlockState <- thawBlockState =<< blockState bp + drs <- liftIO . newIORef $ DryRunState{..} + return (drsTimestamp, EBlockStateContextV1 vc1 drs) + ) + input + ) + drhMVR + case res of + BQRNoBlock -> do + writeProtoResponse (drhWriteToVector outVec) quotaRem DryRunErrorBlockNotFound + BQRBlock blkHash (ts, newBSC) -> do + oldBlockStateContext <- atomicModifyIORef' drhBlockStateContext (Just newBSC,) + forM_ oldBlockStateContext $ \oldBSC -> + runWithEBlockStateContext drhMVR oldBSC $ \drs -> + liftIO $ writeIORef drs (error "Dry run state dropped") + writeProtoResponse + (drhWriteToVector outVec) + quotaRem + ( DryRunSuccessBlockStateLoaded + { drsBlockHash = blkHash, + drsCurrentTimestamp = ts, + drsProtocolVersion = bscProtocolVersion newBSC + } + ) + return OK + +-- | A dummy 'StateHash' value that can be used to create a 'HashedPersistentBlockState' where the +-- actual hash does not matter. +-- This is used to invoke query operations that require a 'HashedPersistentBlockState'. +dummyStateHash :: StateHash +{-# NOINLINE dummyStateHash #-} +dummyStateHash = read "0000000000000000000000000000000000000000000000000000000000000000" + +-- | Wrapper for the data passed to the continuation of 'dryRunStateHelper'. +data StateHelperInfo finconf = StateHelperInfo + { -- | The multi-version runner from the dry run handle. + shiMVR :: MultiVersionRunner finconf, + -- | Write bytes at the specified pointer into the output vector. + shiWriteOut :: Ptr Word8 -> Int64 -> IO (), + -- | The block state context obtained from the dry run handle. + shiBSC :: EBlockStateContext finconf, + -- | Reference used to store the remaining energy quota. + shiQuotaRef :: IORef Energy, + -- | The remaining energy quota after charging the base cost. + shiQuotaRem :: Energy + } + +-- | Helper function for getting the dry run state context and charging the base cost to the +-- energy quota. This first attempts to charge the specified energy cost to the quota. If that +-- fails, the function returns signalling 'OutOfEnergyQuota'. It then attempts to read the current +-- block state context. If that fails, it writes out a 'DryRunErrorNoState' response to the output +-- vector and returns signalling 'OK'. Otherwise, it executes the continuation with the +-- 'StateHelperInfo'. If an exception occurs in doing so, it is caught and logged, and the function +-- returns signalling 'InternalError'. Otherwise, the function returns with the return code of the +-- continuation. +dryRunStateHelper :: + (HasCallStack) => + -- | Pointer to the dry run handle. + StablePtr DryRunHandle -> + -- | Pointer to the output vector. + Ptr ForeignVec -> + -- | Base energy to charge for this operation. + Energy -> + -- | Continuation for executing the operation. + ( forall finconf. + (HasCallStack) => + StateHelperInfo finconf -> + IO DryRunReturnCode + ) -> + -- | The return code (see 'DryRunReturnCode'). + IO Int64 +dryRunStateHelper dryRunPtr outVec baseCost cont = + returnCode <$> do + DryRunHandle{..} <- deRefStablePtr dryRunPtr + let writeOut = drhWriteToVector outVec + tryTickQuota drhEnergyQuota baseCost $ \quotaRem -> + readIORef drhBlockStateContext >>= \case + Nothing -> do + writeProtoResponse writeOut quotaRem DryRunErrorNoState + return OK + Just bsc -> do + let onExcept :: SomeException -> IO DryRunReturnCode + onExcept e = do + mvLog drhMVR External LLError $ + "Error occurred in dry run operation: " + ++ displayException e + ++ "\n" + ++ prettyCallStack callStack + return InternalError + let shi = + StateHelperInfo + { shiMVR = drhMVR, + shiWriteOut = writeOut, + shiBSC = bsc, + shiQuotaRef = drhEnergyQuota, + shiQuotaRem = quotaRem + } + cont shi `catch` onExcept + +-- | Look up information on a particular account in the current dry-run state. +dryRunGetAccountInfo :: + -- | Dry-run handle. + StablePtr DryRunHandle -> + -- | Account identifier tag. + Word8 -> + -- | Account identifier data. + Ptr Word8 -> + -- | Output vector. + Ptr ForeignVec -> + -- | The return code (see 'DryRunReturnCode'). + IO Int64 +dryRunGetAccountInfo dryRunPtr acctTag acctPtr outVec = dryRunStateHelper dryRunPtr outVec costGetAccountInfo $ + \StateHelperInfo{..} -> do + account <- decodeAccountIdentifierInput acctTag acctPtr + macctInfo <- case shiBSC of + EBlockStateContextV0{..} -> do + DryRunState{..} <- liftIO $ readIORef bscState + let fbs = HashedPersistentBlockState drsBlockState dummyStateHash + st <- readIORef $ vc0State bsc0Config + runMVR + ( SkovV0.evalSkovT + (getAccountInfoV0 account fbs) + (mvrSkovHandlers bsc0Config shiMVR) + (vc0Context bsc0Config) + st + ) + shiMVR + EBlockStateContextV1{..} -> do + DryRunState{..} <- liftIO $ readIORef bscState + let fbs = HashedPersistentBlockState drsBlockState dummyStateHash + st <- readIORef $ vc1State bsc1Config + runMVR + ( SkovV1.evalSkovT + (getAccountInfoV1 account fbs) + (vc1Context bsc1Config) + st + ) + shiMVR + case macctInfo of + Nothing -> do + writeProtoResponse shiWriteOut shiQuotaRem DryRunErrorAccountNotFound + Just acctInfo -> + writeProtoResponse shiWriteOut shiQuotaRem (DryRunSuccessAccountInfo acctInfo) + return OK + +-- | Look up information on a particular smart contract instance in the current dry-run state. +dryRunGetInstanceInfo :: + -- | Dry-run handle. + StablePtr DryRunHandle -> + -- | Contract index. + Word64 -> + -- | Contract subindex. + Word64 -> + -- | Output vector. + Ptr ForeignVec -> + IO Int64 +dryRunGetInstanceInfo dryRunPtr contractIndex contractSubindex outVec = + dryRunStateHelper dryRunPtr outVec costGetInstanceInfo $ \StateHelperInfo{..} -> do + res <- runWithEBlockStateContext shiMVR shiBSC $ \drsRef -> do + DryRunState{..} <- liftIO $ readIORef drsRef + let fbs = HashedPersistentBlockState drsBlockState dummyStateHash + getInstanceInfoHelper ca fbs + case res of + Nothing -> writeProtoResponse shiWriteOut shiQuotaRem DryRunErrorInstanceNotFound + Just instInfo -> writeProtoResponse shiWriteOut shiQuotaRem (DryRunSuccessInstanceInfo instInfo) + return OK + where + ca = ContractAddress (ContractIndex contractIndex) (ContractSubindex contractSubindex) + +-- | Invoke an entrypoint on a smart contract instance in the current dry-run state. +-- No changes to the state are retained at the completion of this operation. +dryRunInvokeInstance :: + StablePtr DryRunHandle -> + -- | Contract index. + Word64 -> + -- | Contract subindex. + Word64 -> + -- | Invoker address tag. + Word8 -> + -- | Invoker account address pointer. + Ptr Word8 -> + -- | Invoker contract index. + Word64 -> + -- | Invoker contract subindex. + Word64 -> + -- | Amount. + Word64 -> + -- | ReceiveName pointer. + Ptr Word8 -> + -- | ReceiveName length. + Word32 -> + -- | Parameter pointer. + Ptr Word8 -> + -- | Parameter length. + Word32 -> + -- | Energy + Word64 -> + -- | Output vector. + Ptr ForeignVec -> + -- | The return code (see 'DryRunReturnCode'). + IO Int64 +dryRunInvokeInstance + dryRunPtr + contractIndex + contractSubindex + invokerAddressType + invokerAccountAddressPtr + invokerContractIndex + invokerContractSubindex + amount + receiveNamePtr + receiveNameLen + parameterPtr + parameterLen + energy + outVec = dryRunStateHelper dryRunPtr outVec costInvokeInstanceBase $ \StateHelperInfo{..} -> do + maybeInvoker <- case invokerAddressType of + 0 -> return Nothing + 1 -> Just . AddressAccount <$> decodeAccountAddress invokerAccountAddressPtr + _ -> + return $ + Just $ + AddressContract $ + ContractAddress + (ContractIndex invokerContractIndex) + (ContractSubindex invokerContractSubindex) + method <- decodeReceiveName receiveNamePtr receiveNameLen + parameter <- decodeParameter parameterPtr parameterLen + + let (energyLimit, quotaLimiting) + | Energy energy > shiQuotaRem = (shiQuotaRem, True) + | otherwise = (Energy energy, False) + let context = + InvokeContract.ContractContext + { ccInvoker = maybeInvoker, + ccContract = + ContractAddress + (ContractIndex contractIndex) + (ContractSubindex contractSubindex), + ccAmount = Amount amount, + ccMethod = method, + ccParameter = parameter, + ccEnergy = energyLimit + } + res <- runWithEBlockStateContext shiMVR shiBSC $ \drsRef -> do + -- We "freeze" the block state using a dummy hash so that we do not recompute the + -- state hash, since it is not required by invokeContract. + DryRunState{..} <- liftIO $ readIORef drsRef + let chainMeta = ChainMetadata drsTimestamp + let fbs = HashedPersistentBlockState drsBlockState dummyStateHash + InvokeContract.invokeContract context chainMeta fbs + -- Charge the energy used to the quota. + let newQuotaRem = shiQuotaRem - InvokeContract.rcrUsedEnergy res + writeIORef shiQuotaRef newQuotaRem + case res of + -- If we ran out of energy and hit the quota, then we return an error code and + -- do not produce a result. + InvokeContract.Failure{rcrReason = OutOfEnergy} + | quotaLimiting -> return OutOfEnergyQuota + _ -> + writeProtoResponseEither shiWriteOut newQuotaRem res >>= \case + Left e -> do + mvLog shiMVR External LLError $ + "An error occurred converting the result of a dry run invoke \ + \instance to protobuf: " + ++ show e + return InternalError + Right () -> return OK + +-- | Set the current block time for the dry-run session. +dryRunSetTimestamp :: + -- | Dry-run handle. + StablePtr DryRunHandle -> + -- | The new timestamp (in ms since the epoch). + Word64 -> + -- | Output vector. + Ptr ForeignVec -> + -- | The return code (see 'DryRunReturnCode'). + IO Int64 +dryRunSetTimestamp dryRunPtr newTimestamp outVec = dryRunStateHelper dryRunPtr outVec costSetTimestamp $ + \StateHelperInfo{..} -> do + runWithEBlockStateContext shiMVR shiBSC $ \st -> + liftIO $ + atomicModifyIORef' st $ + \drs -> (drs{drsTimestamp = Timestamp newTimestamp}, ()) + writeProtoResponse shiWriteOut shiQuotaRem DryRunSuccessTimestampSet + return OK + +-- | Mint a specified amount and credit it to the specified account. +dryRunMintToAccount :: + -- | Dry-run handle. + StablePtr DryRunHandle -> + -- | Account address to mint to. + Ptr Word8 -> + -- | Amount to mint. + Word64 -> + -- | Output vector. + Ptr ForeignVec -> + -- | The return code (see 'DryRunReturnCode'). + IO Int64 +dryRunMintToAccount dryRunPtr senderPtr mintAmt outVec = dryRunStateHelper dryRunPtr outVec costMintToAccount $ + \StateHelperInfo{..} -> do + sender <- decodeAccountAddress senderPtr + runWithEBlockStateContext shiMVR shiBSC $ \drsRef -> do + drs@DryRunState{..} <- liftIO $ readIORef drsRef + bsoGetAccountIndex drsBlockState sender >>= \case + Nothing -> do + liftIO $ + writeProtoResponse + shiWriteOut + shiQuotaRem + DryRunErrorAccountNotFound + return OK + Just account -> do + bsoMintToAccount drsBlockState account (Amount mintAmt) + >>= liftIO . \case + Left safeMintAmount -> do + writeProtoResponse shiWriteOut shiQuotaRem $ + DryRunErrorAmountOverLimit safeMintAmount + return OK + Right newState -> do + writeIORef drsRef drs{drsBlockState = newState} + writeProtoResponse + shiWriteOut + shiQuotaRem + DryRunSuccessMintedToAccount + return OK + +-- | Run a transaction in the current dry-run state, updating the state if it succeeds. +dryRunTransaction :: + -- | Dry run handle. + StablePtr DryRunHandle -> + -- | Sender account address. + Ptr Word8 -> + -- | Energy limit for executing the payload + Word64 -> + -- | Payload. + Ptr Word8 -> + -- | Payload length. + Word64 -> + -- | Array of (credential, key) pairs. + Ptr Word8 -> + -- | Number of signatures. + Word64 -> + -- | Output vector. + Ptr ForeignVec -> + -- | The return code (see 'DryRunReturnCode'). + IO Int64 +dryRunTransaction dryRunPtr senderPtr energyLimit payloadPtr payloadLen sigPairs sigCount outVec = + dryRunStateHelper dryRunPtr outVec costTransactionBase $ \StateHelperInfo{..} -> do + sender <- decodeAccountAddress senderPtr + payloadBytes <- BS.packCStringLen (castPtr payloadPtr, fromIntegral payloadLen) + let payload = EncodedPayload (SBS.toShort payloadBytes) + sigMap <- + if sigCount == 0 + then return (Map.singleton 0 (Map.singleton 0 Sig.dummySignatureEd25519)) + else do + let addSigs i m + | i < fromIntegral sigCount = do + cred <- CredentialIndex <$> peekByteOff sigPairs (2 * i) + key <- KeyIndex <$> peekByteOff sigPairs (2 * i + 1) + addSigs (i + 1) $! + m + & at' cred . nonEmpty . at' key + ?~ Sig.dummySignatureEd25519 + | otherwise = return m + addSigs 0 Map.empty + let dummySignature = TransactionSignature sigMap + let signatureCount = getTransactionNumSigs dummySignature + + res <- runWithEBlockStateContext shiMVR shiBSC $ \drsRef -> do + drs@DryRunState{..} <- liftIO $ readIORef drsRef + let context = + Scheduler.ContextState + { _chainMetadata = ChainMetadata drsTimestamp, + _maxBlockEnergy = shiQuotaRem, + _accountCreationLimit = 0 + } + let schedulerState = + Scheduler.SchedulerState + { _ssNextIndex = 0, + _ssExecutionCosts = 0, + _ssEnergyUsed = 0, + _ssBlockState = drsBlockState + } + let exec = flip runContT return $ do + let exit = ContT . const . return . Right . toProto + srcAccount <- lift $ Scheduler.getStateAccount sender + case srcAccount of + Nothing -> + return . Right . toProto $ + DryRunResponse + DryRunErrorAccountNotFound + shiQuotaRem + Just src@(_, acc) -> do + nextNonce <- lift $ TVer.getNextAccountNonce acc + let header = + TransactionHeader + { thSender = sender, + thNonce = nextNonce, + thEnergyAmount = Energy energyLimit, + thPayloadSize = payloadSize payload, + thExpiry = fromIntegral $ drsTimestamp `div` 1000 + 1 + } + let transaction = makeAccountTransaction dummySignature header payload + let cost = + Cost.baseCost + (getTransactionHeaderPayloadSize header) + signatureCount + -- Check that the energy amount covers the base cost of checking + -- the transaction header. + when (thEnergyAmount header < cost) $ + exit $ + DryRunResponse + (DryRunErrorEnergyInsufficient cost) + shiQuotaRem + -- Check that the sender account has sufficient funds to cover the + -- deposit amount. + accBalance <- lift $ TVer.getAccountAvailableAmount acc + depositAmount <- lift $ TVer.energyToCcd (thEnergyAmount header) + when (accBalance < depositAmount) $ + exit $ + DryRunResponse + DryRunErrorBalanceInsufficient + { dreRequiredAmount = depositAmount, + dreAvailableAmount = accBalance + } + shiQuotaRem + + lift (Scheduler.dispatchTransactionBody transaction src cost) >>= \case + Nothing -> do + lift . lift . liftIO $ writeIORef shiQuotaRef 0 + return $ Left OutOfEnergyQuota + Just (res :: TransactionSummary' ValidResultWithReturn) -> do + let newQuotaRem = shiQuotaRem - tsEnergyCost res + lift . lift . liftIO $ + writeIORef shiQuotaRef newQuotaRem + + return $! case toProto (DryRunResponse res newQuotaRem) of + Left _ -> Left InternalError + Right r -> Right r + (res, ss) <- Scheduler.runSchedulerT exec context schedulerState + liftIO $ writeIORef drsRef (drs{drsBlockState = ss ^. Scheduler.ssBlockState}) + return res + case res of + Left code -> return code + Right message -> do + let encoded = Proto.encodeMessage message + BS.unsafeUseAsCStringLen + encoded + (\(ptr, len) -> shiWriteOut (castPtr ptr) (fromIntegral len)) + return OK + +foreign export ccall + dryRunStart :: + StablePtr Ext.ConsensusRunner -> + FunPtr CopyToForeignVec -> + Word64 -> + IO (StablePtr DryRunHandle) + +foreign export ccall + dryRunEnd :: StablePtr DryRunHandle -> IO () + +foreign export ccall + dryRunLoadBlockState :: StablePtr DryRunHandle -> Word8 -> Ptr Word8 -> Ptr ForeignVec -> IO Int64 + +foreign export ccall + dryRunGetAccountInfo :: + StablePtr DryRunHandle -> + -- | Account identifier tag. + Word8 -> + -- | Account identifier data. + Ptr Word8 -> + -- | Output vector. + Ptr ForeignVec -> + IO Int64 + +foreign export ccall + dryRunGetInstanceInfo :: + StablePtr DryRunHandle -> + -- | Contract index. + Word64 -> + -- | Contract subindex. + Word64 -> + -- | Output vector. + Ptr ForeignVec -> + IO Int64 + +foreign export ccall + dryRunInvokeInstance :: + StablePtr DryRunHandle -> + -- | Contract index. + Word64 -> + -- | Contract subindex. + Word64 -> + -- | Invoker address tag. + Word8 -> + -- | Invoker account address pointer. + Ptr Word8 -> + -- | Invoker contract index. + Word64 -> + -- | Invoker contract subindex. + Word64 -> + -- | Amount. + Word64 -> + -- | ReceiveName pointer. + Ptr Word8 -> + -- | ReceiveName length. + Word32 -> + -- | Parameter pointer. + Ptr Word8 -> + -- | Parameter length. + Word32 -> + -- | Energy + Word64 -> + -- | Output vector. + Ptr ForeignVec -> + IO Int64 + +foreign export ccall + dryRunSetTimestamp :: + StablePtr DryRunHandle -> + -- | The new timestamp. + Word64 -> + -- | Output vector. + Ptr ForeignVec -> + IO Int64 + +foreign export ccall + dryRunMintToAccount :: + StablePtr DryRunHandle -> + -- | Account address to mint to. + Ptr Word8 -> + -- | Amount to mint. + Word64 -> + -- | Output vector. + Ptr ForeignVec -> + IO Int64 + +foreign export ccall + dryRunTransaction :: + StablePtr DryRunHandle -> + -- | Sender account address (32 bytes) + Ptr Word8 -> + -- | Energy limit for executing the payload + Word64 -> + -- | Payload. + Ptr Word8 -> + -- | Payload length. + Word64 -> + -- | Array of (credential, key) pairs. + Ptr Word8 -> + -- | Number of signatures. + Word64 -> + -- | Output vector + Ptr ForeignVec -> + IO Int64 diff --git a/concordium-consensus/src/Concordium/External/GRPC2.hs b/concordium-consensus/src/Concordium/External/GRPC2.hs index 200c300601..93005b2984 100644 --- a/concordium-consensus/src/Concordium/External/GRPC2.hs +++ b/concordium-consensus/src/Concordium/External/GRPC2.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | Part of the implementation of the GRPC2 interface. This module constructs @@ -13,16 +12,12 @@ module Concordium.External.GRPC2 () where import Concordium.GRPC2 import Control.Concurrent -import qualified Data.ByteString as BS -import qualified Data.ByteString.Short as BSS import qualified Data.ByteString.Unsafe as BS -import Data.Coerce import qualified Data.FixedByteString as FBS import Data.Foldable (toList) import Data.Int import qualified Data.ProtoLens as Proto import qualified Data.ProtoLens.Combinators as Proto -import qualified Data.Serialize as S import qualified Data.Vector as Vec import Data.Word import Foreign @@ -31,10 +26,8 @@ import qualified Proto.V2.Concordium.Types as Proto import qualified Proto.V2.Concordium.Types_Fields as ProtoFields import qualified Concordium.GlobalState.ContractStateV1 as StateV1 -import Concordium.ID.Types import qualified Concordium.Queries as Q import Concordium.Types -import qualified Concordium.Types.Queries as Queries import qualified Concordium.External as Ext import qualified Concordium.Logger as Logger @@ -43,13 +36,12 @@ import Concordium.MultiVersion ( mvLog, ) -import Concordium.Crypto.SHA256 (DigestSize, Hash (Hash)) +import Concordium.Crypto.SHA256 (Hash (Hash)) +import Concordium.External.Helpers import Concordium.GlobalState.Parameters (CryptographicParameters) import Concordium.ID.Parameters (withGlobalContext) import qualified Concordium.Types.InvokeContract as InvokeContract import qualified Concordium.Wasm as Wasm -import Data.Text (Text) -import qualified Data.Text.Encoding as Text -- | An opaque representation of a Rust vector. This is used by callbacks to copy -- the message generated by a query to Rust, so it can be forwarded back to the @@ -90,70 +82,6 @@ foreign import ccall "dynamic" callCopyToVecCallback :: FunPtr CopyToVecCallback -- | Boilerplate wrapper to invoke C callbacks. foreign import ccall "dynamic" callCopyCryptographicParametersCallback :: FunPtr CopyCryptographicParametersCallback -> CopyCryptographicParametersCallback --- | NB: Assumes the data is at least 32 bytes -decodeBlockHashInput :: Word8 -> Ptr Word8 -> IO Queries.BlockHashInput -decodeBlockHashInput 0 _ = return Queries.Best -decodeBlockHashInput 1 _ = return Queries.LastFinal -decodeBlockHashInput 2 hsh = Queries.Given . coerce <$> FBS.create @DigestSize (\p -> copyBytes p hsh 32) -decodeBlockHashInput n dt = - Queries.AtHeight - <$> case n of - 3 -> do - inputData <- BS.unsafePackCStringLen (castPtr dt, 8) -- 8 bytes for the block height. - case S.decode inputData of - Left err -> error $ "Precondition violation in FFI call: " ++ err - Right aBlockHeight -> return $ Queries.Absolute{..} - 4 -> do - inputData <- BS.unsafePackCStringLen (castPtr dt, 13) -- 8 bytes for the block height, 4 bytes for the genesis index and 1 byte for encoding 'restrict'. - case S.decode inputData of - Left err -> error $ "Precondition violation in FFI call: " ++ err - Right (rBlockHeight, rGenesisIndex, rRestrict) -> return $ Queries.Relative{..} - _ -> error "Precondition violation in FFI call: Unknown block hash input type" - --- | Decode an 'Queries.EpochRequest' given the tag byte and data. --- The tags supported by 'decodeBlockHashInput' are also supported here (0-4), corresponding to --- a 'Queries.EpochOfBlock'. The tag 5 is used for 'Queries.SpecifiedEpoch'. -decodeEpochRequest :: Word8 -> Ptr Word8 -> IO Queries.EpochRequest -decodeEpochRequest 5 dt = do - -- 8 bytes for epoch, 4 bytes for genesis index - inputData <- BS.unsafePackCStringLen (castPtr dt, 12) - case S.decode inputData of - Left err -> error $ "Precondition violation in FFI call: " ++ err - Right (erEpoch, erGenesisIndex) -> return $! Queries.SpecifiedEpoch{..} -decodeEpochRequest n dt = Queries.EpochOfBlock <$> decodeBlockHashInput n dt - --- | Decode an account address from a foreign ptr. Assumes 32 bytes are available. -decodeAccountAddress :: Ptr Word8 -> IO AccountAddress -decodeAccountAddress accPtr = coerce <$> FBS.create @AccountAddressSize (\p -> copyBytes p accPtr 32) - --- | NB: Assumes the data is at least 32 bytes. -decodeTransactionHashInput :: Ptr Word8 -> IO TransactionHash -decodeTransactionHashInput hsh = coerce <$> FBS.create @DigestSize (\p -> copyBytes p hsh 32) - --- | Decode an account address from a foreign ptr. -decodeAccountIdentifierInput :: Word8 -> Ptr Word8 -> IO AccountIdentifier -decodeAccountIdentifierInput 0 dta = AccAddress <$> decodeAccountAddress dta -decodeAccountIdentifierInput 1 dta = do - bs <- BS.unsafePackCStringLen (castPtr dta, 48) - case S.decode bs of - Left err -> error $ "Precondition violation in FFI call: " ++ err - Right cid -> return (CredRegID cid) -decodeAccountIdentifierInput 2 dta = AccIndex . AccountIndex <$> peek (castPtr dta) -decodeAccountIdentifierInput n _ = error $ "Unknown account identifier tag: " ++ show n - -decodeModuleRefInput :: Ptr Word8 -> IO ModuleRef -decodeModuleRefInput modRef = coerce <$> FBS.create @DigestSize (\p -> copyBytes p modRef 32) - --- | NB: Assumes the data is valid utf8. The caller is expected to guarantee --- this. -decodeText :: Ptr Word8 -> Word32 -> IO Text -decodeText ptr len = Text.decodeUtf8 <$> BS.packCStringLen (castPtr ptr, fromIntegral len) - --- | NB: Assumes the data is valid utf8. Protobuf guarantees this, and Rust/tonic --- does actually implement the validation, so this is safe. -decodeReceiveName :: Ptr Word8 -> Word32 -> IO Wasm.ReceiveName -decodeReceiveName ptr len = Wasm.ReceiveName <$> decodeText ptr len - -- | The result type of a gRPC2 query. data QueryResult = -- | An invalid argument was provided by the client. @@ -545,7 +473,7 @@ invokeInstanceV2 cptr blockIdType blockIdPtr contractIndex contractSubindex invo 1 -> Just . AddressAccount <$> decodeAccountAddress invokerAccountAddressPtr _ -> return $ Just $ AddressContract $ ContractAddress (ContractIndex invokerContractIndex) (ContractSubindex invokerContractSubindex) method <- decodeReceiveName receiveNamePtr receiveNameLen - parameter <- Wasm.Parameter . BSS.toShort <$> BS.packCStringLen (castPtr parameterPtr, fromIntegral parameterLen) + parameter <- decodeParameter parameterPtr parameterLen let context = InvokeContract.ContractContext { ccInvoker = maybeInvoker, diff --git a/concordium-consensus/src/Concordium/External/Helpers.hs b/concordium-consensus/src/Concordium/External/Helpers.hs new file mode 100644 index 0000000000..4f87351600 --- /dev/null +++ b/concordium-consensus/src/Concordium/External/Helpers.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TypeApplications #-} + +-- | This module provides helper functions for marshalling types across the FFI boundary. +module Concordium.External.Helpers where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as BSS +import qualified Data.ByteString.Unsafe as BS +import Data.Coerce +import qualified Data.Serialize as S +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Data.Word +import Foreign + +import Concordium.Crypto.SHA256 +import Concordium.ID.Types +import Concordium.Types +import qualified Concordium.Types.Queries as Queries +import qualified Concordium.Wasm as Wasm +import qualified Data.FixedByteString as FBS + +-- | Decode a 'Queries.BlockHashInput' from a tag and a pointer to the payload data. +-- The tags (and corresponding payloads) are as follows: +-- +-- * 0 (no payload): best block +-- * 1 (no payload): last finalized block +-- * 2 (block hash): specified block by hash +-- * 3 (64-bit big-endian absolute block height): specified block by absolute height +-- * 4 (64-bit BE relative height, 32-bit BE genesis index, bool (1 byte) flag to restrict to +-- specified genesis index): specified block by relative height +decodeBlockHashInput :: Word8 -> Ptr Word8 -> IO Queries.BlockHashInput +decodeBlockHashInput 0 _ = return Queries.Best +decodeBlockHashInput 1 _ = return Queries.LastFinal +decodeBlockHashInput 2 hsh = Queries.Given . coerce <$> FBS.create @DigestSize (\p -> copyBytes p hsh 32) +decodeBlockHashInput n dt = + Queries.AtHeight + <$> case n of + 3 -> do + inputData <- BS.unsafePackCStringLen (castPtr dt, 8) -- 8 bytes for the block height. + case S.decode inputData of + Left err -> error $ "Precondition violation in FFI call: " ++ err + Right aBlockHeight -> return $ Queries.Absolute{..} + 4 -> do + inputData <- BS.unsafePackCStringLen (castPtr dt, 13) -- 8 bytes for the block height, 4 bytes for the genesis index and 1 byte for encoding 'restrict'. + case S.decode inputData of + Left err -> error $ "Precondition violation in FFI call: " ++ err + Right (rBlockHeight, rGenesisIndex, rRestrict) -> return $ Queries.Relative{..} + _ -> error "Precondition violation in FFI call: Unknown block hash input type" + +-- | Decode an 'Queries.EpochRequest' given the tag byte and data. +-- The tags supported by 'decodeBlockHashInput' are also supported here (0-4), corresponding to +-- a 'Queries.EpochOfBlock'. The tag 5 is used for 'Queries.SpecifiedEpoch'. +decodeEpochRequest :: Word8 -> Ptr Word8 -> IO Queries.EpochRequest +decodeEpochRequest 5 dt = do + -- 8 bytes for epoch, 4 bytes for genesis index + inputData <- BS.unsafePackCStringLen (castPtr dt, 12) + case S.decode inputData of + Left err -> error $ "Precondition violation in FFI call: " ++ err + Right (erEpoch, erGenesisIndex) -> return $! Queries.SpecifiedEpoch{..} +decodeEpochRequest n dt = Queries.EpochOfBlock <$> decodeBlockHashInput n dt + +-- | Decode an account address from a foreign ptr. Assumes 32 bytes are available. +decodeAccountAddress :: Ptr Word8 -> IO AccountAddress +decodeAccountAddress accPtr = coerce <$> FBS.create @AccountAddressSize (\p -> copyBytes p accPtr 32) + +-- | NB: Assumes the data is at least 32 bytes. +decodeTransactionHashInput :: Ptr Word8 -> IO TransactionHash +decodeTransactionHashInput hsh = coerce <$> FBS.create @DigestSize (\p -> copyBytes p hsh 32) + +-- | Decode an account address from a foreign ptr. +decodeAccountIdentifierInput :: Word8 -> Ptr Word8 -> IO AccountIdentifier +decodeAccountIdentifierInput 0 dta = AccAddress <$> decodeAccountAddress dta +decodeAccountIdentifierInput 1 dta = do + bs <- BS.unsafePackCStringLen (castPtr dta, 48) + case S.decode bs of + Left err -> error $ "Precondition violation in FFI call: " ++ err + Right cid -> return (CredRegID cid) +decodeAccountIdentifierInput 2 dta = AccIndex . AccountIndex <$> peek (castPtr dta) +decodeAccountIdentifierInput n _ = error $ "Unknown account identifier tag: " ++ show n + +decodeModuleRefInput :: Ptr Word8 -> IO ModuleRef +decodeModuleRefInput modRef = coerce <$> FBS.create @DigestSize (\p -> copyBytes p modRef 32) + +-- | NB: Assumes the data is valid utf8. The caller is expected to guarantee +-- this. +decodeText :: Ptr Word8 -> Word32 -> IO Text +decodeText ptr len = Text.decodeUtf8 <$> BS.packCStringLen (castPtr ptr, fromIntegral len) + +-- | NB: Assumes the data is valid utf8. Protobuf guarantees this, and Rust/tonic +-- does actually implement the validation, so this is safe. +decodeReceiveName :: Ptr Word8 -> Word32 -> IO Wasm.ReceiveName +decodeReceiveName ptr len = Wasm.ReceiveName <$> decodeText ptr len + +-- | Decode a smart contract parameter from the given pointer and length. +decodeParameter :: Ptr Word8 -> Word32 -> IO Wasm.Parameter +decodeParameter ptr len = + Wasm.Parameter . BSS.toShort <$> BS.packCStringLen (castPtr ptr, fromIntegral len) diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index a6b639438c..0878270817 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -1231,6 +1231,15 @@ class (BlockStateQuery m) => BlockStateOperations m where -- This increases the total GTU in circulation. bsoMint :: UpdatableBlockState m -> MintAmounts -> m (UpdatableBlockState m) + -- | Mint an amount directly to an account, increasing the total supply by the minted amount. + -- If minting to the account would overflow the total supply, then the minting does not + -- occur and the maximum amount that could be minted without overflowing is returned. + -- (The operation is "safe" in so far as it does not cause an overflow in the supply.) + -- If minting to the account is successful, the updated state is returned. + -- The caller must ensure that the account exists. If it does not, the behaviour is + -- unspecified. (For instance, the amount may be minted, but not credited to any account.) + bsoMintToAccount :: UpdatableBlockState m -> AccountIndex -> Amount -> m (Either Amount (UpdatableBlockState m)) + -- | Get the identity provider data for the given identity provider, or Nothing if -- the identity provider with given ID does not exist. bsoGetIdentityProvider :: UpdatableBlockState m -> ID.IdentityProviderIdentity -> m (Maybe IpInfo) @@ -1354,7 +1363,7 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc -- change, and thus a variant of copy-on-write should be used. thawBlockState :: BlockState m -> m (UpdatableBlockState m) - -- | Freeze a mutable block state instance. The mutable state instance will + -- | Freeze a mutable block state instance. The mutable state instance should -- not be used afterwards and the implementation can thus avoid copying -- data. freezeBlockState :: UpdatableBlockState m -> m (BlockState m) @@ -1570,6 +1579,7 @@ instance (Monad (t m), MonadTrans t, BlockStateOperations m) => BlockStateOperat bsoRewardFoundationAccount s = lift . bsoRewardFoundationAccount s bsoGetFoundationAccount = lift . bsoGetFoundationAccount bsoMint s = lift . bsoMint s + bsoMintToAccount s acc amt = lift $ bsoMintToAccount s acc amt bsoGetIdentityProvider s ipId = lift $ bsoGetIdentityProvider s ipId bsoGetAnonymityRevokers s arId = lift $ bsoGetAnonymityRevokers s arId bsoGetCryptoParams s = lift $ bsoGetCryptoParams s @@ -1630,6 +1640,7 @@ instance (Monad (t m), MonadTrans t, BlockStateOperations m) => BlockStateOperat {-# INLINE bsoGetFoundationAccount #-} {-# INLINE bsoRewardFoundationAccount #-} {-# INLINE bsoMint #-} + {-# INLINE bsoMintToAccount #-} {-# INLINE bsoGetIdentityProvider #-} {-# INLINE bsoGetAnonymityRevokers #-} {-# INLINE bsoGetCryptoParams #-} diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 42adf57205..d8e7e141ac 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -1680,7 +1680,8 @@ doConfigureBaker pbs ai BakerConfigureUpdate{..} = do liftBSO $ refMake $ activeBkrs - & totalActiveCapital %~ addActiveCapital (capital - _stakedAmount oldBkr) + & totalActiveCapital + %~ addActiveCapital (capital - _stakedAmount oldBkr) MTL.modify' $ \bsp -> bsp{bspBirkParameters = birkParams & birkActiveBakers .~ newActiveBkrs} MTL.tell [BakerConfigureStakeIncreased capital] return $ setAccountStake capital @@ -2192,6 +2193,19 @@ doMint pbs mint = do newAccounts <- Accounts.updateAccountsAtIndex' updAcc foundationAccount (bspAccounts bsp) storePBS pbs (bsp{bspBank = newBank, bspAccounts = newAccounts}) +doSafeMintToAccount :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountIndex -> Amount -> m (Either Amount (PersistentBlockState pv)) +doSafeMintToAccount pbs acctIdx mintAmt = do + bsp <- loadPBS pbs + let currentSupply = bspBank bsp ^. unhashed . Rewards.totalGTU + let maxMintAmount = maxBound - currentSupply + if maxMintAmount >= mintAmt + then do + let newBank = bspBank bsp & unhashed . Rewards.totalGTU +~ mintAmt + let updAcc = addAccountAmount mintAmt + newAccounts <- Accounts.updateAccountsAtIndex' updAcc acctIdx (bspAccounts bsp) + Right <$> storePBS pbs (bsp{bspBank = newBank, bspAccounts = newAccounts}) + else return $ Left maxMintAmount + doGetAccount :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountAddress -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) doGetAccount pbs addr = do bsp <- loadPBS pbs @@ -3494,6 +3508,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperatio bsoRewardFoundationAccount = doRewardFoundationAccount bsoGetFoundationAccount = doGetFoundationAccount bsoMint = doMint + bsoMintToAccount = doSafeMintToAccount bsoGetIdentityProvider = doGetIdentityProvider bsoGetAnonymityRevokers = doGetAnonymityRevokers bsoGetCryptoParams = doGetCryptoParams diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index 41a078eac4..ed0b93df2d 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -101,12 +101,34 @@ liftSkovQuery :: -- | Query to run at version 1 consensus. QueryV1M finconf a -> IO a -liftSkovQuery mvr (EVersionedConfigurationV0 vc) av0 _ = do +liftSkovQuery mvr evc av0 av1 = liftSkovQueryWithVersion mvr evc (const av0) (const av1) + +-- | Run a query against a specific skov version, passing in the versioned configuration as a +-- parameter. +liftSkovQueryWithVersion :: + MultiVersionRunner finconf -> + EVersionedConfiguration finconf -> + -- | Query to run at version 0 consensus. + ( forall (pv :: ProtocolVersion). + ( SkovMonad (VersionedSkovV0M finconf pv), + FinalizationMonad (VersionedSkovV0M finconf pv) + ) => + VersionedConfigurationV0 finconf pv -> + VersionedSkovV0M finconf pv a + ) -> + -- | Query to run at version 1 consensus. + ( forall (pv :: ProtocolVersion). + (IsConsensusV1 pv, IsProtocolVersion pv) => + VersionedConfigurationV1 finconf pv -> + VersionedSkovV1M finconf pv a + ) -> + IO a +liftSkovQueryWithVersion mvr (EVersionedConfigurationV0 vc) av0 _ = do st <- readIORef (vc0State vc) - runMVR (evalSkovT av0 (mvrSkovHandlers vc mvr) (vc0Context vc) st) mvr -liftSkovQuery mvr (EVersionedConfigurationV1 vc) _ av1 = do + runMVR (evalSkovT (av0 vc) (mvrSkovHandlers vc mvr) (vc0Context vc) st) mvr +liftSkovQueryWithVersion mvr (EVersionedConfigurationV1 vc) _ av1 = do st <- readIORef (vc1State vc) - runMVR (SkovV1.evalSkovT av1 (vc1Context vc) st) mvr + runMVR (SkovV1.evalSkovT (av1 vc) (vc1Context vc) st) mvr -- | Run a query against the latest skov version. liftSkovQueryLatest :: @@ -279,7 +301,7 @@ liftSkovQueryBHIAndVersion :: FinalizationMonad (VersionedSkovV0M finconf pv), IsProtocolVersion pv ) => - EVersionedConfiguration finconf -> + VersionedConfigurationV0 finconf pv -> BlockPointerType (VersionedSkovV0M finconf pv) -> VersionedSkovV0M finconf pv a ) -> @@ -288,7 +310,7 @@ liftSkovQueryBHIAndVersion :: -- if the block is finalized. ( forall (pv :: ProtocolVersion). (IsConsensusV1 pv, IsProtocolVersion pv) => - EVersionedConfiguration finconf -> + VersionedConfigurationV1 finconf pv -> SkovV1.BlockPointer pv -> Bool -> VersionedSkovV1M finconf pv a @@ -302,17 +324,17 @@ liftSkovQueryBHIAndVersion av0 av1 bhi = do maybeValue <- atLatestSuccessfulVersion ( \vc -> - liftSkovQuery + liftSkovQueryWithVersion mvr vc -- consensus version 0 - (mapM (av0 vc) =<< resolveBlock bh) + (\theVC -> mapM (av0 theVC) =<< resolveBlock bh) -- consensus version 1 - ( do + ( \theVC -> do status <- SkovV1.getBlockStatus bh =<< get case status of - SkovV1.BlockAlive bp -> Just <$> av1 vc bp False - SkovV1.BlockFinalized bp -> Just <$> av1 vc bp True + SkovV1.BlockAlive bp -> Just <$> av1 theVC bp False + SkovV1.BlockFinalized bp -> Just <$> av1 theVC bp True _ -> return Nothing ) ) @@ -328,17 +350,17 @@ liftSkovQueryBHIAndVersion av0 av1 bhi = do (Just ([bh], evc)) -> MVR $ \mvr -> do maybeValue <- - liftSkovQuery + liftSkovQueryWithVersion mvr evc -- consensus version 0 - (mapM (av0 evc) =<< resolveBlock bh) + (\theVC -> mapM (av0 theVC) =<< resolveBlock bh) -- consensus version 1 - ( do + ( \theVC -> do status <- SkovV1.getBlockStatus bh =<< get case status of - SkovV1.BlockAlive bp -> Just <$> av1 evc bp False - SkovV1.BlockFinalized bp -> Just <$> av1 evc bp True + SkovV1.BlockAlive bp -> Just <$> av1 theVC bp False + SkovV1.BlockFinalized bp -> Just <$> av1 theVC bp True _ -> return Nothing ) return $ case maybeValue of @@ -349,21 +371,24 @@ liftSkovQueryBHIAndVersion av0 av1 bhi = do versions <- liftIO . readIORef =<< asks mvVersions let evc = Vec.last versions (bh, maybeValue) <- - liftSkovQueryLatest - ( do - -- consensus version 0 - bp <- case other of - Best -> bestBlock - LastFinal -> lastFinalizedBlock - (bpHash bp,) . Just <$> av0 evc bp - ) - ( do - -- consensus version 1 - (bp, finalized) <- case other of - Best -> (,False) <$> bestBlockConsensusV1 - LastFinal -> (,True) <$> use SkovV1.lastFinalized - (getHash bp,) . Just <$> av1 evc bp finalized - ) + MVR $ \mvr -> + liftSkovQueryWithVersion + mvr + evc + ( \theVC -> do + -- consensus version 0 + bp <- case other of + Best -> bestBlock + LastFinal -> lastFinalizedBlock + (bpHash bp,) . Just <$> av0 theVC bp + ) + ( \theVC -> do + -- consensus version 1 + (bp, finalized) <- case other of + Best -> (,False) <$> bestBlockConsensusV1 + LastFinal -> (,True) <$> use SkovV1.lastFinalized + (getHash bp,) . Just <$> av1 theVC bp finalized + ) return $ case maybeValue of Just v -> BQRBlock bh v Nothing -> BQRNoBlock @@ -647,9 +672,9 @@ getNextAccountNonce accountAddress = getBlockInfo :: BlockHashInput -> MVR finconf (BHIQueryResponse BlockInfo) getBlockInfo = liftSkovQueryBHIAndVersion - ( \evc bp -> do + ( \(vc :: VersionedConfigurationV0 finconf pv) bp -> do let biBlockHash = getHash bp - let biGenesisIndex = evcIndex evc + let biGenesisIndex = vc0Index vc biBlockParent <- if blockSlot bp == 0 && biGenesisIndex /= 0 then do @@ -665,7 +690,7 @@ getBlockInfo = (use (SkovV1.lastFinalized . to getHash)) else getHash <$> bpParent bp biBlockLastFinalized <- getHash <$> bpLastFinalized bp - let biBlockHeight = localToAbsoluteBlockHeight (evcGenesisHeight evc) (bpHeight bp) + let biBlockHeight = localToAbsoluteBlockHeight (vc0GenesisHeight vc) (bpHeight bp) let biEraBlockHeight = bpHeight bp let biBlockReceiveTime = bpReceiveTime bp let biBlockArriveTime = bpArriveTime bp @@ -677,14 +702,14 @@ getBlockInfo = let biTransactionEnergyCost = bpTransactionsEnergyCost bp let biTransactionsSize = bpTransactionsSize bp let biBlockStateHash = bpBlockStateHash bp - let biProtocolVersion = evcProtocolVersion evc + let biProtocolVersion = demoteProtocolVersion (protocolVersion @pv) let biRound = Nothing let biEpoch = Nothing return BlockInfo{..} ) - ( \evc bp biFinalized -> do + ( \(vc :: VersionedConfigurationV1 finconf pv) bp biFinalized -> do let biBlockHash = getHash bp - let biGenesisIndex = evcIndex evc + let biGenesisIndex = vc1Index vc biBlockParent <- if SkovV1.blockRound bp == 0 && biGenesisIndex /= 0 then do @@ -700,7 +725,7 @@ getBlockInfo = (use (SkovV1.lastFinalized . to getHash)) else getHash <$> bpParent bp biBlockLastFinalized <- getHash <$> bpLastFinalized bp - let biBlockHeight = localToAbsoluteBlockHeight (evcGenesisHeight evc) (SkovV1.blockHeight bp) + let biBlockHeight = localToAbsoluteBlockHeight (vc1GenesisHeight vc) (SkovV1.blockHeight bp) let biEraBlockHeight = SkovV1.blockHeight bp let biBlockReceiveTime = SkovV1.blockReceiveTime bp let biBlockArriveTime = SkovV1.blockArriveTime bp @@ -711,7 +736,7 @@ getBlockInfo = let biTransactionEnergyCost = SkovV1.blockEnergyCost bp let biTransactionsSize = fromIntegral $ SkovV1.blockTransactionsSize bp let biBlockStateHash = SkovV1.blockStateHash bp - let biProtocolVersion = evcProtocolVersion evc + let biProtocolVersion = demoteProtocolVersion (protocolVersion @pv) let biRound = Just $ SkovV1.blockRound bp let biEpoch = Just $ SkovV1.blockEpoch bp return BlockInfo{..} @@ -1033,32 +1058,14 @@ getAccountInfo :: MVR finconf (BHIQueryResponse (Maybe AccountInfo)) getAccountInfo blockHashInput acct = do liftSkovQueryBHI - (getAI getASIv0 <=< blockState) - (getAI getASIv1 <=< blockState) + (getAccountInfoV0 acct <=< blockState) + (getAccountInfoV1 acct <=< blockState) blockHashInput + +-- | Get the details of an account, for the V0 consensus. +getAccountInfoV0 :: (SkovQueryMonad m) => AccountIdentifier -> BlockState m -> m (Maybe AccountInfo) +getAccountInfoV0 = getAccountInfoHelper getASIv0 where - getAI :: - forall m. - (BS.BlockStateQuery m) => - (Account m -> m AccountStakingInfo) -> - BlockState m -> - m (Maybe AccountInfo) - getAI getASI bs = do - macc <- case acct of - AccAddress addr -> BS.getAccount bs addr - AccIndex idx -> BS.getAccountByIndex bs idx - CredRegID crid -> BS.getAccountByCredId bs crid - forM macc $ \(aiAccountIndex, acc) -> do - aiAccountNonce <- BS.getAccountNonce acc - aiAccountAmount <- BS.getAccountAmount acc - aiAccountReleaseSchedule <- BS.getAccountReleaseSummary acc - aiAccountCredentials <- fmap (Versioned 0) <$> BS.getAccountCredentials acc - aiAccountThreshold <- aiThreshold <$> BS.getAccountVerificationKeys acc - aiAccountEncryptedAmount <- BS.getAccountEncryptedAmount acc - aiAccountEncryptionKey <- BS.getAccountEncryptionKey acc - aiStakingInfo <- getASI acc - aiAccountAddress <- BS.getAccountCanonicalAddress acc - return AccountInfo{..} getASIv0 acc = do gd <- getGenesisData let convEpoch e = @@ -1067,21 +1074,65 @@ getAccountInfo blockHashInput acct = do (gdGenesisTime gd) (fromIntegral e * fromIntegral (gdEpochLength gd) * gdSlotDuration gd) toAccountStakingInfo convEpoch <$> BS.getAccountStake acc + +-- | Get the details of an account, for the V1 consensus. +getAccountInfoV1 :: + ( BS.BlockStateQuery m, + MonadProtocolVersion m, + IsConsensusV1 (MPV m) + ) => + AccountIdentifier -> + BlockState m -> + m (Maybe AccountInfo) +getAccountInfoV1 = getAccountInfoHelper getASIv1 + where getASIv1 acc = toAccountStakingInfoP4 <$> BS.getAccountStake acc +-- | Helper for getting the details of an account, given a function for getting the staking +-- information. +getAccountInfoHelper :: + (BS.BlockStateQuery m) => + (Account m -> m AccountStakingInfo) -> + AccountIdentifier -> + BlockState m -> + m (Maybe AccountInfo) +getAccountInfoHelper getASI acct bs = do + macc <- case acct of + AccAddress addr -> BS.getAccount bs addr + AccIndex idx -> BS.getAccountByIndex bs idx + CredRegID crid -> BS.getAccountByCredId bs crid + forM macc $ \(aiAccountIndex, acc) -> do + aiAccountNonce <- BS.getAccountNonce acc + aiAccountAmount <- BS.getAccountAmount acc + aiAccountReleaseSchedule <- BS.getAccountReleaseSummary acc + aiAccountCredentials <- fmap (Versioned 0) <$> BS.getAccountCredentials acc + aiAccountThreshold <- aiThreshold <$> BS.getAccountVerificationKeys acc + aiAccountEncryptedAmount <- BS.getAccountEncryptedAmount acc + aiAccountEncryptionKey <- BS.getAccountEncryptionKey acc + aiStakingInfo <- getASI acc + aiAccountAddress <- BS.getAccountCanonicalAddress acc + return AccountInfo{..} + -- | Get the details of a smart contract instance in the block state. getInstanceInfo :: BlockHashInput -> ContractAddress -> MVR finconf (BHIQueryResponse (Maybe Wasm.InstanceInfo)) getInstanceInfo bhi caddr = do liftSkovQueryStateBHI - (\bs -> mkII =<< BS.getContractInstance bs caddr) + (getInstanceInfoHelper caddr) bhi - where - mkII Nothing = return Nothing - mkII (Just (BS.InstanceInfoV0 BS.InstanceInfoV{..})) = do - iiModel <- BS.externalContractState iiState - return - ( Just - ( Wasm.InstanceInfoV0 + +-- | Helper function for getting the 'Wasm.InstanceInfo' for a contract instance. +getInstanceInfoHelper :: + (BS.BlockStateQuery m) => + ContractAddress -> + BlockState m -> + m (Maybe Wasm.InstanceInfo) +getInstanceInfoHelper caddr bs = do + mInstance <- BS.getContractInstance bs caddr + forM mInstance $ \case + BS.InstanceInfoV0 BS.InstanceInfoV{..} -> do + iiModel <- BS.externalContractState iiState + return $ + Wasm.InstanceInfoV0 { Wasm.iiOwner = instanceOwner iiParameters, Wasm.iiAmount = iiBalance, Wasm.iiMethods = instanceReceiveFuns iiParameters, @@ -1089,20 +1140,15 @@ getInstanceInfo bhi caddr = do Wasm.iiSourceModule = GSWasm.miModuleRef (instanceModuleInterface iiParameters), .. } - ) - ) - mkII (Just (BS.InstanceInfoV1 BS.InstanceInfoV{..})) = do - return - ( Just - ( Wasm.InstanceInfoV1 + BS.InstanceInfoV1 BS.InstanceInfoV{..} -> do + return $ + Wasm.InstanceInfoV1 { Wasm.iiOwner = instanceOwner iiParameters, Wasm.iiAmount = iiBalance, Wasm.iiMethods = instanceReceiveFuns iiParameters, Wasm.iiName = instanceInitName iiParameters, Wasm.iiSourceModule = GSWasm.miModuleRef (instanceModuleInterface iiParameters) } - ) - ) -- | Get the exact state of a smart contract instance in the block state. The -- return value is 'Nothing' if the instance cannot be found (either the @@ -1266,17 +1312,17 @@ getFirstBlockEpoch (EpochOfBlock blockInput) = do where unBHIResponse BQRNoBlock = Left EQEBlockNotFound unBHIResponse (BQRBlock _ res) = res - epochOfBlockV0 curVersionIndex evc b = + epochOfBlockV0 curVersionIndex vc b = getFirstFinalizedOfEpoch (Right b) <&> \case Left FutureEpoch - | evcIndex evc == curVersionIndex -> Left EQEFutureEpoch + | vc0Index vc == curVersionIndex -> Left EQEFutureEpoch | otherwise -> Left EQEInvalidEpoch Left EmptyEpoch -> Left EQEBlockNotFound Right epochBlock -> Right (getHash epochBlock) - epochOfBlockV1 curVersionIndex evc b _ = + epochOfBlockV1 curVersionIndex vc b _ = (SkovV1.getFirstFinalizedBlockOfEpoch (Right b) =<< get) <&> \case Nothing - | evcIndex evc == curVersionIndex -> Left EQEFutureEpoch + | vc1Index vc == curVersionIndex -> Left EQEFutureEpoch | otherwise -> Left EQEInvalidEpoch Just epochBlock -> Right (getHash epochBlock) @@ -1324,11 +1370,11 @@ getWinningBakersEpoch (EpochOfBlock blockInput) = do res <- liftSkovQueryBHIAndVersion (\_ _ -> return (Left EQEInvalidGenesisIndex)) - ( \evc b _ -> do + ( \vc b _ -> do mwbs <- ConsensusV1.getWinningBakersForEpoch (SkovV1.blockEpoch b) =<< get return $! case mwbs of Nothing - | evcIndex evc == curVersionIndex -> Left EQEFutureEpoch + | vc1Index vc == curVersionIndex -> Left EQEFutureEpoch | otherwise -> Left EQEInvalidEpoch Just wbs -> Right wbs ) diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 8cbee1c27b..38e8ed852f 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -36,6 +36,7 @@ module Concordium.Scheduler ( filterTransactions, runTransactions, execTransactions, + dispatchTransactionBody, handleContractUpdateV1, handleContractUpdateV0, checkAndGetBalanceInstanceV1, @@ -222,73 +223,110 @@ checkTransactionVerificationResult (TVer.NotOk TVer.InvalidPayloadSize) = Left I -- ('TxValid', with either 'TxSuccess' or 'TxReject'). dispatch :: forall msg m. (TransactionData msg, SchedulerMonad m) => (msg, Maybe TVer.VerificationResult) -> m (Maybe TxResult) dispatch (msg, mVerRes) = do - let meta = transactionHeader msg validMeta <- runExceptT (checkHeader msg mVerRes) case validMeta of Left (Just fk) -> return $ Just (TxInvalid fk) Left Nothing -> return Nothing Right (senderAccount, checkHeaderCost) -> do - -- At this point the transaction is going to be committed to the block. - -- It could be that the execution exceeds maximum block energy allowed, but in that case - -- the whole block state will be removed, and thus this operation will have no effect anyhow. - -- Hence we can increase the account nonce of the sender account. - increaseAccountNonce senderAccount - - let psize = payloadSize (transactionPayload msg) - - tsIndex <- bumpTransactionIndex - -- Payload is not parametrised by the protocol version, but decodePayload only returns - -- payloads appropriate to the protocol version. - case decodePayload (protocolVersion @(MPV m)) psize (transactionPayload msg) of - Left _ -> do - -- In case of serialization failure we charge the sender for checking - -- the header and reject the transaction; we have checked that the amount - -- exists on the account with 'checkHeader'. - payment <- energyToGtu checkHeaderCost - chargeExecutionCost senderAccount payment - return $ - Just $ - TxValid $ - TransactionSummary - { tsEnergyCost = checkHeaderCost, - tsCost = payment, - tsSender = Just (thSender meta), -- the sender of the transaction is as specified in the transaction. - tsResult = TxReject SerializationFailure, - tsHash = transactionHash msg, - tsType = TSTAccountTransaction Nothing, - .. - } - Right payload -> do - usedBlockEnergy <- getUsedEnergy - let mkWTC _wtcTransactionType = - WithDepositContext - { _wtcSenderAccount = senderAccount, - _wtcTransactionHash = transactionHash msg, - _wtcTransactionHeader = meta, - _wtcTransactionCheckHeaderCost = checkHeaderCost, - -- NB: We already account for the cost we used here. - _wtcCurrentlyUsedBlockEnergy = usedBlockEnergy + checkHeaderCost, - _wtcTransactionIndex = tsIndex, - .. - } - -- Now pass the decoded payload to the respective transaction handler which contains - -- the main transaction logic. - -- During processing of transactions the amount on the sender account is decreased by the - -- amount corresponding to the deposited energy, i.e., the maximum amount that can be charged - -- for execution. The amount corresponding to the unused energy is refunded at the end of - -- processing; see `withDeposit`. - -- Note, for transactions that require specific constraints on the protocol version, - -- those constraints are asserted. 'decodePayload' ensures that those assertions - -- will not fail. - res <- case payload of + res <- dispatchTransactionBody msg senderAccount checkHeaderCost + case res of + -- The remaining block energy is not sufficient for the handler to execute the transaction. + Nothing -> return Nothing + Just summary -> return $ Just $ TxValid summary + +-- | Execute a transaction on the current block state, charging the sender account for the +-- resulting energy cost. It is assumed that the transaction header has been checked for validity +-- and the provided 'IndexedAccount' is the sender account. +-- +-- This is parametric in the type of the transaction result @res@. This is instantiated as +-- @ValidResult@ for block execution (in 'dispatch'), which ignores the return value of contract +-- calls. It is instantiated as @ValidResultWithReturn@ for transaction dry-run, where we want +-- the return value to be available. +-- +-- Returns +-- +-- * @Nothing@ if the transaction would exceed the remaining block energy. +-- * @Just result@ if the transaction failed ('TxInvalid') or was successfully committed +-- ('TxValid', with either 'TxSuccess' or 'TxReject'). +dispatchTransactionBody :: + forall msg m res. + (TransactionData msg, SchedulerMonad m, TransactionResult res) => + -- | Transaction to execute. + msg -> + -- | Sender account. + IndexedAccount m -> + -- | Energy cost to be charged for checking the transaction header. + Energy -> + m (Maybe (TransactionSummary' res)) +dispatchTransactionBody msg senderAccount checkHeaderCost = do + let meta = transactionHeader msg + -- At this point the transaction is going to be committed to the block. + -- It could be that the execution exceeds maximum block energy allowed, but in that case + -- the whole block state will be removed, and thus this operation will have no effect anyhow. + -- Hence we can increase the account nonce of the sender account. + increaseAccountNonce senderAccount + + let psize = payloadSize (transactionPayload msg) + + tsIndex <- bumpTransactionIndex + -- Payload is not parametrised by the protocol version, but decodePayload only returns + -- payloads appropriate to the protocol version. + case decodePayload (protocolVersion @(MPV m)) psize (transactionPayload msg) of + Left _ -> do + -- In case of serialization failure we charge the sender for checking + -- the header and reject the transaction; we have checked that the amount + -- exists on the account with 'checkHeader'. + payment <- energyToGtu checkHeaderCost + chargeExecutionCost senderAccount payment + return $ + Just $ + TransactionSummary + { tsEnergyCost = checkHeaderCost, + tsCost = payment, + tsSender = Just (thSender meta), -- the sender of the transaction is as specified in the transaction. + tsResult = transactionReject SerializationFailure, + tsHash = transactionHash msg, + tsType = TSTAccountTransaction Nothing, + .. + } + Right payload -> do + usedBlockEnergy <- getUsedEnergy + let mkWTC _wtcTransactionType = + WithDepositContext + { _wtcSenderAccount = senderAccount, + _wtcTransactionHash = transactionHash msg, + _wtcSenderAddress = thSender meta, + _wtcEnergyAmount = thEnergyAmount meta, + _wtcTransactionCheckHeaderCost = checkHeaderCost, + -- NB: We already account for the cost we used here. + _wtcCurrentlyUsedBlockEnergy = usedBlockEnergy + checkHeaderCost, + _wtcTransactionIndex = tsIndex, + .. + } + -- Now pass the decoded payload to the respective transaction handler which contains + -- the main transaction logic. + -- During processing of transactions the amount on the sender account is decreased by the + -- amount corresponding to the deposited energy, i.e., the maximum amount that can be charged + -- for execution. The amount corresponding to the unused energy is refunded at the end of + -- processing; see `withDeposit`. + -- Note, for transactions that require specific constraints on the protocol version, + -- those constraints are asserted. 'decodePayload' ensures that those assertions + -- will not fail. + case payload of + -- Update and InitContract are the only operations that can produce a return value, + -- so the handlers are polymorphic in the return type. + Update{..} -> + handleUpdateContract (mkWTC TTUpdate) uAmount uAddress uReceiveName uMessage + InitContract{..} -> + handleInitContract (mkWTC TTInitContract) icAmount icModRef icInitName icParam + -- For the remaining operations, we map 'fromValidResult' on the result, to + -- avoid the handlers being needlessly polymorphic. + _ -> + fmap (summaryResult %~ fromValidResult) <$> case payload of DeployModule mod -> handleDeployModule (mkWTC TTDeployModule) mod - InitContract{..} -> - handleInitContract (mkWTC TTInitContract) icAmount icModRef icInitName icParam Transfer toaddr amount -> handleSimpleTransfer (mkWTC TTTransfer) toaddr amount Nothing - Update{..} -> - handleUpdateContract (mkWTC TTUpdate) uAmount uAddress uReceiveName uMessage AddBaker{..} -> onlyWithoutDelegation $ handleAddBaker (mkWTC TTAddBaker) abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyKey abProofSig abProofElection abProofAggregation abBakingStake abRestakeEarnings @@ -330,11 +368,6 @@ dispatch (msg, mVerRes) = do ConfigureDelegation{..} -> onlyWithDelegation $ handleConfigureDelegation (mkWTC TTConfigureDelegation) cdCapital cdRestakeEarnings cdDelegationTarget - - case res of - -- The remaining block energy is not sufficient for the handler to execute the transaction. - Nothing -> return Nothing - Just summary -> return $ Just $ TxValid summary where -- Function @onlyWithoutDelegation k@ fails if the protocol version @MPV m@ supports -- delegation. Otherwise, it continues with @k@, which may assume the chain parameters version @@ -371,8 +404,7 @@ handleTransferWithSchedule wtc twsTo twsSchedule maybeMemo = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount txHash = wtc ^. wtcTransactionHash - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c = do -- After we've checked all of that, we charge. tickEnergy (Cost.scheduledTransferCost $ length twsSchedule) @@ -434,7 +466,7 @@ handleTransferWithSchedule wtc twsTo twsSchedule maybeMemo = withDeposit wtc c k withScheduledAmount senderAccount targetAccount transferAmount twsSchedule txHash $ return () k ls () = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost commitChanges (ls ^. changeSet) let eventList = @@ -456,8 +488,7 @@ handleTransferToPublic wtc transferData@SecToPubAmountTransferData{..} = do withDeposit wtc (c cryptoParams) k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c cryptoParams = do -- the expensive operations start now, so we charge. tickEnergy Cost.transferToPublicCost @@ -483,7 +514,7 @@ handleTransferToPublic wtc transferData@SecToPubAmountTransferData{..} = do return senderAmount k ls senderAmount = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost notifyEncryptedBalanceChange $ amountDiff 0 stpatdTransferAmount commitChanges (ls ^. changeSet) @@ -514,8 +545,7 @@ handleTransferToEncrypted wtc toEncrypted = do withDeposit wtc (c cryptoParams) k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c cryptoParams = do tickEnergy Cost.transferToEncryptedCost @@ -536,7 +566,7 @@ handleTransferToEncrypted wtc toEncrypted = do return encryptedAmount k ls encryptedAmount = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost notifyEncryptedBalanceChange $ amountToDelta toEncrypted commitChanges (ls ^. changeSet) @@ -568,8 +598,7 @@ handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransfer withDeposit wtc (c cryptoParams) k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c cryptoParams = do -- We charge as soon as we can even if we could in principle do some @@ -627,7 +656,7 @@ handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransfer return (targetAccountEncryptedAmountIndex, senderAmount) k ls (targetAccountEncryptedAmountIndex, senderAmount) = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost commitChanges (ls ^. changeSet) let eventList = @@ -663,7 +692,6 @@ handleDeployModule wtc mod = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader currentProtocolVersion = demoteProtocolVersion (protocolVersion @(MPV m)) c = do @@ -689,7 +717,7 @@ handleDeployModule wtc mod = _ -> rejectTransaction ModuleNotWF k ls (toCommit, mhash) = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost -- Add the module to the global state (module interface, value interface and module itself). -- We know the module does not exist at this point, so we can ignore the return value. @@ -744,8 +772,8 @@ getCurrentContractInstanceTicking' cref = do -- | Handle the initialization of a contract instance. handleInitContract :: - forall m. - (SchedulerMonad m) => + forall m res. + (SchedulerMonad m, TransactionResult res) => WithDepositContext m -> -- | The amount to initialize the contract instance with. Amount -> @@ -755,15 +783,14 @@ handleInitContract :: Wasm.InitName -> -- | Parameter expression to initialize with. Wasm.Parameter -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary' res)) handleInitContract wtc initAmount modref initName param = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader -- The contract gets the address that was used when signing the -- transactions, as opposed to the canonical one. - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c = do -- charge for base administrative cost tickEnergy Cost.initializeContractInstanceBaseCost @@ -775,7 +802,7 @@ handleInitContract wtc initAmount modref initName param = -- Check whether the number of logs and the size of return values are limited in the current protocol version. let limitLogsAndRvs = Wasm.limitLogsAndReturnValues $ protocolVersion @(MPV m) - unless (senderAmount >= initAmount) $! rejectTransaction (AmountTooLarge (AddressAccount (thSender meta)) initAmount) + unless (senderAmount >= initAmount) $! rejectTransaction (AmountTooLarge (AddressAccount (wtc ^. wtcSenderAddress)) initAmount) -- First try to get the module interface of the parent module of the contract. (viface :: (GSWasm.ModuleInterface (InstrumentedModuleRef m))) <- liftLocal (getModuleInterfaces modref) `rejectingWith` InvalidModuleReference modref @@ -833,8 +860,14 @@ handleInitContract wtc initAmount modref initName param = } stateContext <- getV1StateContext artifact <- liftLocal $ getModuleArtifact (GSWasm.miModule iface) + interpreterResult <- runInterpreter (return . WasmV1.applyInitFun stateContext artifact cm initCtx initName param limitLogsAndRvs initAmount) + -- If the result includes a return value, set it. + case interpreterResult of + Left WasmV1.LogicReject{..} -> transactionReturnValue ?= cerReturnValue + Left WasmV1.Trap -> return () + Right WasmV1.InitSuccess{..} -> transactionReturnValue ?= irdReturnValue result <- - runInterpreter (return . WasmV1.applyInitFun stateContext artifact cm initCtx initName param limitLogsAndRvs initAmount) + return interpreterResult `rejectingWith'` WasmV1.cerToRejectReasonInit -- Charge for storing the contract state. @@ -846,7 +879,7 @@ handleInitContract wtc initAmount modref initName param = k ls (Left (iface, result)) = do let model = Wasm.newState result - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost -- Withdraw the amount the contract is initialized with from the sender account. @@ -868,7 +901,7 @@ handleInitContract wtc initAmount modref initName param = commitChanges $ addContractInitToCS (Proxy @m) newInstanceAddr cs' return - ( TxSuccess + ( transactionSuccess [ ContractInitialized { ecRef = modref, ecAddress = newInstanceAddr, @@ -883,7 +916,7 @@ handleInitContract wtc initAmount modref initName param = ) k ls (Right (iface, result)) = do let model = WasmV1.irdNewState result - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost -- Withdraw the amount the contract is initialized with from the sender account. @@ -905,7 +938,7 @@ handleInitContract wtc initAmount modref initName param = commitChanges $ addContractInitToCS (Proxy @m) newInstanceAddr cs' return - ( TxSuccess + ( transactionSuccess [ ContractInitialized { ecRef = modref, ecAddress = newInstanceAddr, @@ -933,8 +966,7 @@ handleSimpleTransfer wtc toAddr transferamount maybeMemo = withDeposit wtc c (defaultSuccess wtc) where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c = do -- charge at the beginning, successful and failed transfers will have the same cost. tickEnergy Cost.simpleTransferCost @@ -952,7 +984,7 @@ handleSimpleTransfer wtc toAddr transferamount maybeMemo = -- | Handle a top-level update transaction to a contract. handleUpdateContract :: - (SchedulerMonad m) => + (SchedulerMonad m, TransactionResult res) => WithDepositContext m -> -- | Amount to invoke the contract's receive method with. Amount -> @@ -962,13 +994,12 @@ handleUpdateContract :: Wasm.ReceiveName -> -- | Message to send to the receive method. Wasm.Parameter -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary' res)) handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = withDeposit wtc computeAndCharge (defaultSuccess wtc) where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress checkAndGetBalanceV1 = checkAndGetBalanceAccountV1 senderAddress senderAccount checkAndGetBalanceV0 = checkAndGetBalanceAccountV0 senderAddress senderAccount c = do @@ -984,8 +1015,12 @@ handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = uMessage InstanceInfoV1 ins -> do handleContractUpdateV1 senderAddress ins checkAndGetBalanceV1 uAmount uReceiveName uMessage >>= \case - Left cer -> rejectTransaction (WasmV1.cerToRejectReasonReceive uAddress uReceiveName uMessage cer) - Right (_, events) -> return (reverse events) + Left cer -> do + transactionReturnValue .= WasmV1.ccfToReturnValue cer + rejectTransaction (WasmV1.cerToRejectReasonReceive uAddress uReceiveName uMessage cer) + Right (ret, events) -> do + transactionReturnValue ?= ret + return $ reverse events computeAndCharge = do r <- c chargeV1Storage -- charge for storing the new state of all V1 contracts. V0 state is already charged. @@ -1831,15 +1866,14 @@ handleAddBaker wtc abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyK withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c = do tickEnergy Cost.addBakerCost -- Get the total amount on the account, including locked amounts, -- less the deposit. getCurrentAccountTotalAmount senderAccount k ls accountBalance = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost let challenge = addBakerChallenge senderAddress abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyKey @@ -1947,8 +1981,7 @@ handleConfigureBaker withDeposit wtc tickGetArgAndBalance chargeAndExecute where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress configureAddBakerArg = case ( cbCapital, cbRestakeEarnings, @@ -1992,7 +2025,7 @@ handleConfigureBaker configureUpdateBakerArg (arg,) <$> getCurrentAccountTotalAmount senderAccount chargeAndExecute ls argAndBalance = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost executeConfigure energyCost usedEnergy argAndBalance executeConfigure energyCost usedEnergy (ConfigureAddBakerCont{..}, accountBalance) = do @@ -2128,8 +2161,7 @@ handleConfigureDelegation wtc cdCapital cdRestakeEarnings cdDelegationTarget = withDeposit wtc tickAndGetAccountBalance kWithAccountBalance where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress configureAddDelegationArg = case (cdCapital, cdRestakeEarnings, cdDelegationTarget) of @@ -2156,7 +2188,7 @@ handleConfigureDelegation wtc cdCapital cdRestakeEarnings cdDelegationTarget = configureUpdateDelegationArg (arg,) <$> getCurrentAccountTotalAmount senderAccount kWithAccountBalance ls (ConfigureAddDelegationCont{..}, accountBalance) = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost if accountBalance < cdcCapital then -- The balance is insufficient. @@ -2173,7 +2205,7 @@ handleConfigureDelegation wtc cdCapital cdRestakeEarnings cdDelegationTarget = res <- configureDelegation (fst senderAccount) dca kResult energyCost usedEnergy dca res kWithAccountBalance ls (ConfigureUpdateDelegationCont, accountBalance) = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost if maybe False (accountBalance <) cdCapital then return (TxReject InsufficientBalanceForDelegationStake, energyCost, usedEnergy) @@ -2237,11 +2269,10 @@ handleRemoveBaker wtc = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c = tickEnergy Cost.removeBakerCost k ls () = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost res <- removeBaker (fst senderAccount) @@ -2266,15 +2297,14 @@ handleUpdateBakerStake wtc newStake = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c = do tickEnergy Cost.updateBakerStakeCost -- Get the total amount on the account, including locked amounts, -- less the deposit. getCurrentAccountTotalAmount senderAccount k ls accountBalance = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost if accountBalance < newStake then -- The balance is insufficient. @@ -2304,11 +2334,10 @@ handleUpdateBakerRestakeEarnings :: handleUpdateBakerRestakeEarnings wtc newRestakeEarnings = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c = tickEnergy Cost.updateBakerRestakeCost k ls () = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost res <- updateBakerRestakeEarnings (fst senderAccount) newRestakeEarnings @@ -2346,11 +2375,10 @@ handleUpdateBakerKeys wtc bkuElectionKey bkuSignKey bkuAggregationKey bkuProofSi withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c = tickEnergy Cost.updateBakerKeysCost k ls _ = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost let challenge = updateBakerKeyChallenge senderAddress bkuElectionKey bkuSignKey bkuAggregationKey @@ -2478,7 +2506,6 @@ handleUpdateCredentialKeys wtc cid keys sigs = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader c = do existingCredentials <- getAccountCredentials (snd senderAccount) @@ -2498,7 +2525,7 @@ handleUpdateCredentialKeys wtc cid keys sigs = unless ownerCheck $ rejectTransaction CredentialHolderDidNotSign return index k ls index = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost updateCredentialKeys (fst senderAccount) index keys return (TxSuccess [CredentialKeysUpdated cid], energyCost, usedEnergy) @@ -2646,8 +2673,7 @@ handleUpdateCredentials wtc cdis removeRegIds threshold = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount - meta = wtc ^. wtcTransactionHeader - senderAddress = thSender meta + senderAddress = wtc ^. wtcSenderAddress c = do tickEnergy Cost.updateCredentialsBaseCost @@ -2664,7 +2690,7 @@ handleUpdateCredentials wtc cdis removeRegIds threshold = return creds k ls existingCredentials = do - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost cryptoParams <- TVer.getCryptographicParameters diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 35ca9706c6..6c7401ae08 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -44,6 +44,7 @@ import Control.Exception (assert) import qualified Concordium.GlobalState.ContractStateV1 as StateV1 import qualified Concordium.ID.Types as ID +import qualified Concordium.Scheduler.WasmIntegration.V1 as V1 import Concordium.Wasm (IsWasmVersion) import qualified Concordium.Wasm as GSWasm import Data.Proxy @@ -747,7 +748,12 @@ data LocalState m = LocalState -- modification of smart contract instance state by the scheduler. It is -- unaffected by updates to the balance of the contract. _nextContractModificationIndex :: !ModificationIndex, - _blockEnergyLeft :: !Energy + _blockEnergyLeft :: !Energy, + -- | When executing a smart contract update or init transaction, this records the return + -- value, if any. This is used to support transaction dry run functionality, where the return + -- value is exposed in the API. Under normal block execution, the return value is + -- discarded. + _transactionReturnValue :: !(Maybe V1.ReturnValue) } makeLenses ''LocalState @@ -788,7 +794,13 @@ runLocalT :: runLocalT (LocalT st) _tcDepositedAmount _tcTxSender _energyLeft _blockEnergyLeft = do -- The initial contract modification index must start at 1 since 0 is the -- "initial state" of all contracts (as recorded in the changeset). - let s = LocalState{_changeSet = emptyCS (Proxy @m), _nextContractModificationIndex = 1, ..} + let s = + LocalState + { _changeSet = emptyCS (Proxy @m), + _nextContractModificationIndex = 1, + _transactionReturnValue = Nothing, + .. + } (a, s') <- runRST (runContT st (return . Right)) ctx s return (a, s') where @@ -805,20 +817,19 @@ instance BlockStateTypes (LocalT r m) where type BakerInfoRef (LocalT r m) = BakerInfoRef m type InstrumentedModuleRef (LocalT r m) = InstrumentedModuleRef m -{-# INLINE energyUsed #-} - --- | Compute how much energy was used from the upper bound in the header of a --- transaction and the amount left. -energyUsed :: TransactionHeader -> Energy -> Energy -energyUsed meta energy = thEnergyAmount meta - energy - -- | Given the deposited amount and the remaining amount of gas compute how much -- the sender of the transaction should be charged, as well as how much energy was used -- for execution. -- This function assumes that the deposited energy is not less than the used energy. -computeExecutionCharge :: (SchedulerMonad m) => TransactionHeader -> Energy -> m (Energy, Amount) -computeExecutionCharge meta energy = - let used = energyUsed meta energy +computeExecutionCharge :: + (SchedulerMonad m) => + -- | Energy allocated. + Energy -> + -- | Energy remaining unused. + Energy -> + m (Energy, Amount) +computeExecutionCharge allocated unused = + let used = allocated - unused in (used,) <$> energyToGtu used -- | Reduce the public balance on the account to charge for execution cost. The @@ -839,14 +850,17 @@ chargeExecutionCost (ai, acc) amnt = do notifyExecutionCost amnt data WithDepositContext m = WithDepositContext - { -- | Address of the account initiating the transaction. + { -- | The account initiating the transaction. _wtcSenderAccount :: !(IndexedAccount m), -- | Type of the top-level transaction. _wtcTransactionType :: !TransactionType, -- | Hash of the top-level transaction. _wtcTransactionHash :: !TransactionHash, - -- | Header of the transaction we are running. - _wtcTransactionHeader :: !TransactionHeader, + -- | Address of the sender of the transaction. + -- This should correspond to '_wtcSenderAccount', but need not be the canonical address. + _wtcSenderAddress :: !AccountAddress, + -- | The amount of energy dedicated for the execution of this transaction. + _wtcEnergyAmount :: !Energy, -- | Cost to be charged for checking the transaction header. _wtcTransactionCheckHeaderCost :: !Energy, -- | Energy currently used by the block. @@ -868,7 +882,7 @@ makeLenses ''WithDepositContext -- * The deposited amount exists in the public account value. -- * The deposited amount is __at least__ Cost.checkHeader applied to the respective parameters (i.e., minimum transaction cost). withDeposit :: - (SchedulerMonad m) => + (SchedulerMonad m, TransactionResult res) => WithDepositContext m -> -- | The computation to run in the modified environment with reduced amount on the initial account. LocalT a m a -> @@ -876,12 +890,11 @@ withDeposit :: -- It gets the result of the previous computation as input, in particular the -- remaining energy and the ChangeSet. It should return the result, and the amount that was charged -- for the execution. - (LocalState m -> a -> m (ValidResult, Amount, Energy)) -> - m (Maybe TransactionSummary) + (LocalState m -> a -> m (res, Amount, Energy)) -> + m (Maybe (TransactionSummary' res)) withDeposit wtc comp k = do - let txHeader = wtc ^. wtcTransactionHeader let tsHash = wtc ^. wtcTransactionHash - let totalEnergyToUse = thEnergyAmount txHeader + let totalEnergyToUse = wtc ^. wtcEnergyAmount maxEnergy <- getMaxBlockEnergy -- - here is safe due to precondition that currently used energy is less than the maximum block energy let beLeft = maxEnergy - wtc ^. wtcCurrentlyUsedBlockEnergy @@ -890,6 +903,11 @@ withDeposit wtc comp k = do -- record how much we have deposited. This cannot be touched during execution. depositedAmount <- energyToGtu totalEnergyToUse (res, ls) <- runLocalT comp depositedAmount (wtc ^. wtcSenderAccount . _1) energy beLeft + let addReturn result = + foldr + (setTransactionReturnValue . V1.returnValueToByteString) + result + (ls ^. transactionReturnValue) case res of -- Failure: maximum block energy exceeded Left Nothing -> return Nothing @@ -897,15 +915,15 @@ withDeposit wtc comp k = do Left (Just reason) -> 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) + (usedEnergy, payment) <- computeExecutionCharge totalEnergyToUse (ls ^. energyLeft) chargeExecutionCost (wtc ^. wtcSenderAccount) payment return $! Just $! TransactionSummary - { tsSender = Just (thSender txHeader), + { tsSender = Just (wtc ^. wtcSenderAddress), tsCost = payment, tsEnergyCost = usedEnergy, - tsResult = TxReject reason, + tsResult = addReturn $ transactionReject reason, tsType = TSTAccountTransaction $ Just $ wtc ^. wtcTransactionType, tsIndex = wtc ^. wtcTransactionIndex, .. @@ -913,13 +931,14 @@ withDeposit wtc comp k = do -- Computation successful Right a -> do -- In this case we invoke the continuation, which should charge for the used energy. - (tsResult, tsCost, tsEnergyCost) <- k ls a + (tsResult0, tsCost, tsEnergyCost) <- k ls a return $! Just $! TransactionSummary - { tsSender = Just (thSender txHeader), + { tsSender = Just (wtc ^. wtcSenderAddress), tsType = TSTAccountTransaction $ Just $ wtc ^. wtcTransactionType, tsIndex = wtc ^. wtcTransactionIndex, + tsResult = addReturn tsResult0, .. } @@ -929,14 +948,18 @@ withDeposit wtc comp k = do -- from the current changeset and returns the recorded events, the amount corresponding to the -- used energy and the used energy. defaultSuccess :: - (SchedulerMonad m) => WithDepositContext m -> LocalState m -> [Event] -> m (ValidResult, Amount, Energy) -defaultSuccess wtc = \ls events -> do - let meta = wtc ^. wtcTransactionHeader + (SchedulerMonad m, TransactionResult res) => + WithDepositContext m -> + LocalState m -> + [Event] -> + m (res, Amount, Energy) +defaultSuccess wtc = \ls res -> do + let energyAllocated = wtc ^. wtcEnergyAmount senderAccount = wtc ^. wtcSenderAccount - (usedEnergy, energyCost) <- computeExecutionCharge meta (ls ^. energyLeft) + (usedEnergy, energyCost) <- computeExecutionCharge energyAllocated (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost commitChanges (ls ^. changeSet) - return (TxSuccess events, energyCost, usedEnergy) + return (transactionSuccess res, energyCost, usedEnergy) {-# INLINE liftLocal #-} liftLocal :: (Monad m) => m a -> LocalT r m a diff --git a/concordium-node/Cargo.lock b/concordium-node/Cargo.lock index 209cfe0f7f..8d015acdde 100644 --- a/concordium-node/Cargo.lock +++ b/concordium-node/Cargo.lock @@ -565,7 +565,7 @@ dependencies = [ [[package]] name = "concordium-contracts-common" -version = "8.0.0" +version = "8.1.1" dependencies = [ "base64", "bs58", @@ -585,7 +585,7 @@ dependencies = [ [[package]] name = "concordium-contracts-common-derive" -version = "4.0.0" +version = "4.0.1" dependencies = [ "proc-macro2", "quote", @@ -594,7 +594,7 @@ dependencies = [ [[package]] name = "concordium-smart-contract-engine" -version = "3.0.0" +version = "3.1.0" dependencies = [ "anyhow", "byteorder", @@ -627,7 +627,7 @@ dependencies = [ [[package]] name = "concordium_base" -version = "3.0.1" +version = "3.1.1" dependencies = [ "aes", "anyhow", diff --git a/concordium-node/build.rs b/concordium-node/build.rs index 669a2fdc59..f149ab947b 100644 --- a/concordium-node/build.rs +++ b/concordium-node/build.rs @@ -673,6 +673,17 @@ fn build_grpc2(proto_root_input: &str) -> std::io::Result<()> { .server_streaming() .build(), ) + .method( + tonic_build::manual::Method::builder() + .name("dry_run") + .route_name("DryRun") + .input_type("crate::grpc2::types::DryRunRequest") + .client_streaming() + .output_type("Vec") + .codec_path("crate::grpc2::RawCodec") + .server_streaming() + .build(), + ) .build(); // Due to the slightly hacky nature of the RawCodec (i.e., it does not support // deserialization) we cannot build the client. But we also don't need it in the diff --git a/concordium-node/src/configuration.rs b/concordium-node/src/configuration.rs index a28594e8c7..a152a94a45 100644 --- a/concordium-node/src/configuration.rs +++ b/concordium-node/src/configuration.rs @@ -406,12 +406,28 @@ pub struct GRPC2Config { pub endpoint_config: Option, #[structopt( long = "grpc2-invoke-max-energy", - help = "Maximum amount of energy allowed for the InvokeInstance and InvokeContract (V1 \ - API) endpoints.", + help = "Maximum amount of energy allowed for the InvokeInstance, InvokeContract and \ + DryRun endpoints.", env = "CONCORDIUM_NODE_GRPC2_INVOKE_MAX_ENERGY", default_value = "1000000" )] pub invoke_max_energy: u64, + #[structopt( + long = "grpc2-dry-run-timeout", + help = "Maximum duration in seconds for a DryRun session. If it is not completed in this \ + time, the server cancels the request with DEADLINE_EXCEEDED.", + env = "CONCORDIUM_NODE_GRPC2_DRY_RUN_TIMEOUT", + default_value = "30" + )] + pub dry_run_timeout: u64, + #[structopt( + long = "grpc2-dry-run-concurrency", + help = "Maximum number of concurrent invocations of the DryRun endpoint. If this is \ + exceeded, the server responds to DryRun invocations with RESOURCE_EXHAUSTED. If \ + it is not set, there is no explicit limit.", + env = "CONCORDIUM_NODE_GRPC2_DRY_RUN_CONCURRENCY" + )] + pub dry_run_concurrency: Option, #[structopt( long = "grpc2-health-max-finalized-delay", help = "Maximum amount of seconds that the time of the last finalized block can be behind \ diff --git a/concordium-node/src/consensus_ffi/ffi.rs b/concordium-node/src/consensus_ffi/ffi.rs index bce03882e0..555ce3284e 100644 --- a/concordium-node/src/consensus_ffi/ffi.rs +++ b/concordium-node/src/consensus_ffi/ffi.rs @@ -257,6 +257,12 @@ pub struct execute_block { private: [u8; 0], } +/// An opaque reference to a dry-run handle, which is managed in Haskell. +#[repr(C)] +pub struct dry_run_handle { + private: [u8; 0], +} + /// Abstracts the reference required to execute a block that has been received. /// This wrapper type exists so we make sure that the same '*mut execute_block' /// is not called twice as we pass ownership of 'ExecuteBlockCallback' to @@ -1472,6 +1478,140 @@ extern "C" { out: *mut Vec, copier: CopyToVecCallback, ) -> i64; + + /// Start a dry-run sequence. The returned handle must be freed with a call + /// to `dryRunEnd` once it is no longer required. (Failure to do so will + /// leak memory.) + /// + /// * `consensus` - Pointer to the consensus. + /// * `copier` - Callback for appending a bytestring to a vector. + /// * `energy_quota` - Limit on total energy cost for operations in this + /// dry-run sequence. + pub fn dryRunStart( + consensus: *mut consensus_runner, + copier: CopyToVecCallback, + energy_quota: u64, + ) -> *mut dry_run_handle; + + /// Terminate a dry-run sequence, freeing up the resources associated with + /// the handle. + pub fn dryRunEnd(dry_run_handle: *mut dry_run_handle); + + /// Load state from a specified block as part of a dry-run sequence. + /// The return value is 0 on success, 1 on an internal error, and 2 + /// on out-of-energy. + pub fn dryRunLoadBlockState( + dry_run_handle: *mut dry_run_handle, + block_id_type: u8, + block_id: *const u8, + out: *mut Vec, + ) -> i64; + + /// Get info about a specified account as part of a dry-run sequence. + /// The return value is 0 on success, 1 on an internal error, and 2 + /// on out-of-energy. + pub fn dryRunGetAccountInfo( + dry_run_handle: *mut dry_run_handle, + account_identifier_tag: u8, + account_identifier_data: *const u8, + out: *mut Vec, + ) -> i64; + + /// Get info about a specified smart contract instance as part of a dry-run + /// sequence. + /// The return value is 0 on success, 1 on an internal error, and 2 + /// on out-of-energy. + pub fn dryRunGetInstanceInfo( + dry_run_handle: *mut dry_run_handle, + contract_index: u64, + contract_subindex: u64, + out: *mut Vec, + ) -> i64; + + /// Run the smart contract entrypoint in a given context as part of a + /// dry-run sequence. + /// + /// * `dry_run_handle` - Handle created with `dryRunStart`. + /// * `contract_index` - The contact index to invoke. + /// * `contract_subindex` - The contact subindex to invoke. + /// * `invoker_address_type` - Tag for whether an account or a contract + /// address is provided. If 0 no address is provided, if 1 the + /// `invoker_account_address_ptr` is 32 bytes for an account address, if 2 + /// the `invoker_contract_index` and `invoker_contract_subindex` is used + /// for the contract address. + /// * `invoker_account_address_ptr` - Pointer to the address if this is + /// provided. The length will depend on the value of + /// `invoker_address_type`. + /// * `invoker_contract_index` - The invoker contact index. Only used if + /// `invoker_address_type` is 2. + /// * `invoker_contract_subindex` - The invoker contact subindex. Only used + /// if `invoker_address_type` is 2. + /// * `amount` - The amount to use for the invocation. + /// * `receive_name_ptr` - Pointer to the entrypoint to invoke. + /// * `receive_name_len` - Length of the bytes for the entrypoint. + /// * `parameter_ptr` - Pointer to the parameter to invoke with. + /// * `parameter_len` - Length of the bytes for the parameter. + /// * `energy` - The energy to use for the invocation. + /// * `out` - Location to write the output of the query. + /// + /// The return value is 0 on success, 1 on an internal error, and 2 + /// on out-of-energy. + pub fn dryRunInvokeInstance( + dry_run_handle: *mut dry_run_handle, + contract_index: u64, + contract_subindex: u64, + invoker_address_type: u8, + invoker_account_address_ptr: *const u8, + invoker_contract_index: u64, + invoker_contract_subindex: u64, + amount: u64, + receive_name_ptr: *const u8, + receive_name_len: u32, + parameter_ptr: *const u8, + parameter_len: u32, + energy: u64, + out: *mut Vec, + ) -> i64; + + /// Set the current timestamp to use as part of a dry-run sequence. + pub fn dryRunSetTimestamp( + dry_run_handle: *mut dry_run_handle, + new_timestamp: u64, + out: *mut Vec, + ) -> i64; + + /// Mint an amount to an account as part of a dry-run sequence. + pub fn dryRunMintToAccount( + dry_run_handle: *mut dry_run_handle, + account_address: *const u8, + amount: u64, + out: *mut Vec, + ) -> i64; + + /// Execute a transaction as part of a dry-run sequence. + /// + /// * `dry_run_handle` - Handle created with `dryRunStart`. + /// * `sender_address_ptr` - Pointer to the encoded account address of the + /// transaction sender. + /// * `energy` - Limit on the energy to be used by the transaction. + /// * `payload` - Pointer to the encoded transaction payload. + /// * `payload_length` - Length in bytes of the encoded transaction payload. + /// * `signatures` - An array of pairs of credential ID (u8) and key ID (u8) + /// that are deemed to have signed the transaction. + /// * `signature_count` - The number of signatures deemed to have signed the + /// transaction. The length of `signatures` in bytes must be `2 * + /// signature_count`. + /// * `out` - Vector to write the output of the query. + pub fn dryRunTransaction( + dry_run_handle: *mut dry_run_handle, + sender_address_ptr: *const u8, + energy: u64, + payload: *const u8, + payload_length: u64, + signatures: *const u8, + signature_count: u64, + out: *mut Vec, + ) -> i64; } /// This is the callback invoked by consensus on newly arrived, and newly @@ -1665,6 +1805,233 @@ pub fn get_consensus_ptr( } } +/// A dry-run session. This wraps the FFI operations on a dry-run handle, and +/// ensures that `dryRunEnd` is called when the `DryRun` object is dropped. +pub struct DryRun { + handle: *mut dry_run_handle, +} + +/// A dry-run handle is not bound to a particular thread, and therefore it is +/// safe for it to be `Send`. +unsafe impl Send for DryRun {} + +impl Drop for DryRun { + fn drop(&mut self) { unsafe { dryRunEnd(self.handle) } } +} + +impl DryRun { + /// Load the state of a particular block in the dry-run session, and use its + /// timestamp as the current timestamp for the session. + pub fn load_block_state( + &mut self, + request: &crate::grpc2::types::BlockHashInput, + ) -> Result, tonic::Status> { + use crate::grpc2::Require; + let mut out_data: Vec = Vec::new(); + let bhi = crate::grpc2::types::block_hash_input_to_ffi(request).require()?; + let (block_id_type, block_id) = bhi.to_ptr(); + let res = unsafe { + dryRunLoadBlockState(self.handle, block_id_type, block_id.as_ptr(), &mut out_data) + }; + DryRun::check_result(res, "load block state")?; + Ok(out_data) + } + + /// Look up information on a particular account in the current dry-run + /// state. + pub fn get_account_info( + &mut self, + target: &crate::grpc2::types::AccountIdentifierInput, + ) -> Result, tonic::Status> { + use crate::grpc2::Require; + let mut out_data: Vec = Vec::new(); + let (acc_type, acc_id) = + crate::grpc2::types::account_identifier_to_ffi(target).require()?; + let res = unsafe { dryRunGetAccountInfo(self.handle, acc_type, acc_id, &mut out_data) }; + DryRun::check_result(res, "get account info")?; + Ok(out_data) + } + + /// Look up information on a particular smart contract instance in the + /// current dry-run state. + pub fn get_instance_info( + &mut self, + target: &crate::grpc2::types::ContractAddress, + ) -> Result, tonic::Status> { + let mut out_data: Vec = Vec::new(); + let res = unsafe { + dryRunGetInstanceInfo(self.handle, target.index, target.subindex, &mut out_data) + }; + DryRun::check_result(res, "get instance info")?; + Ok(out_data) + } + + /// Invoke an entrypoint on a smart contract instance in the current dry-run + /// state. No changes to the state are retained at the completion of + /// this operation. + pub fn invoke_instance( + &mut self, + request: &crate::grpc2::types::DryRunInvokeInstance, + ) -> Result, tonic::Status> { + use crate::grpc2::Require; + let mut out_data: Vec = Vec::new(); + + // Optional Address to ffi + let ( + invoker_address_type, + invoker_account_address_ptr, + invoker_contract_index, + invoker_contract_subindex, + ) = if let Some(address) = &request.invoker { + match address.r#type.as_ref().require()? { + crate::grpc2::types::address::Type::Account(account) => { + (1, crate::grpc2::types::account_address_to_ffi(account).require()?, 0, 0) + } + crate::grpc2::types::address::Type::Contract(contract) => { + (2, std::ptr::null(), contract.index, contract.subindex) + } + } + } else { + (0, std::ptr::null(), 0, 0) + }; + + let amount = request.amount.as_ref().require()?.value; + + let (receive_name_ptr, receive_name_len) = + crate::grpc2::types::receive_name_to_ffi(request.entrypoint.as_ref().require()?) + .require()?; + + // Parameter to ffi + let (parameter_ptr, parameter_len) = { + let bytes = &request.parameter.as_ref().require()?.value; + ( + bytes.as_ptr(), + bytes.len().try_into().map_err(|_| { + tonic::Status::invalid_argument("Parameter exceeds maximum supported size.") + })?, + ) + }; + + let energy = request.energy.as_ref().require()?.value; + + let contract = request.instance.as_ref().require()?; + + let res = unsafe { + dryRunInvokeInstance( + self.handle, + contract.index, + contract.subindex, + invoker_address_type, + invoker_account_address_ptr, + invoker_contract_index, + invoker_contract_subindex, + amount, + receive_name_ptr, + receive_name_len, + parameter_ptr, + parameter_len, + energy, + &mut out_data, + ) + }; + DryRun::check_result(res, "invoke instance")?; + Ok(out_data) + } + + /// Set the current block time for the dry-run session. + pub fn set_timestamp( + &mut self, + new_timestamp: crate::grpc2::types::Timestamp, + ) -> Result, tonic::Status> { + let mut out_data: Vec = Vec::new(); + + let res = unsafe { dryRunSetTimestamp(self.handle, new_timestamp.value, &mut out_data) }; + DryRun::check_result(res, "set timestamp")?; + Ok(out_data) + } + + /// Mint a specified amount and credit it to the specified account. + pub fn mint_to_account( + &mut self, + mint: crate::grpc2::types::DryRunMintToAccount, + ) -> Result, tonic::Status> { + use crate::grpc2::Require; + let mut out_data: Vec = Vec::new(); + let account_address = + crate::grpc2::types::account_address_to_ffi(mint.account.as_ref().require()?) + .require()?; + + let amount = mint.amount.require()?; + let res = unsafe { + dryRunMintToAccount(self.handle, account_address, amount.value, &mut out_data) + }; + DryRun::check_result(res, "mint to account")?; + Ok(out_data) + } + + /// Run a transaction in the current dry-run state, updating the state if it + /// succeeds. + pub fn transaction( + &mut self, + request: crate::grpc2::types::DryRunTransaction, + ) -> Result, tonic::Status> { + use crate::grpc2::Require; + let mut out_data: Vec = Vec::new(); + let energy = request.energy_amount.as_ref().require()?.value; + + let sender_address = + crate::grpc2::types::account_address_to_ffi(request.sender.as_ref().require()?) + .require()?; + let encoded_payload = + concordium_base::transactions::EncodedPayload::try_from(request.payload.require()?)?; + let payload_bytes: Vec = encoded_payload.into(); + let signature_count = request.signatures.len(); + let mut signature_vec: Vec = Vec::with_capacity(signature_count * 2); + for sig in request.signatures { + signature_vec.push( + sig.credential.try_into().map_err(|_| { + tonic::Status::invalid_argument("Credential index out of bounds") + })?, + ); + signature_vec.push( + sig.key + .try_into() + .map_err(|_| tonic::Status::invalid_argument("Key index out of bounds"))?, + ); + } + + let res = unsafe { + dryRunTransaction( + self.handle, + sender_address, + energy, + payload_bytes.as_ptr(), + payload_bytes.len() as u64, + signature_vec.as_ptr(), + signature_count as u64, + &mut out_data, + ) + }; + DryRun::check_result(res, "run transaction")?; + Ok(out_data) + } + + /// Convert a result code returned by a dry-run FFI into an appropriate + /// [`tonic::Status`]. + fn check_result(result: i64, origin: &str) -> Result<(), tonic::Status> { + match result { + 0 => Ok(()), + 1 => Err(tonic::Status::internal(format!( + "Internal error: {origin} could not be completed" + ))), + 2 => Err(tonic::Status::resource_exhausted("Energy quota exceeded")), + _ => Err(tonic::Status::internal(format!( + "Internal error: unexpected error code in {origin}" + ))), + } + } +} + impl ConsensusContainer { pub fn receive_block( &self, @@ -3238,6 +3605,15 @@ impl ConsensusContainer { response.ensure_ok("baker")?; Ok(out_data) } + + /// Start a dry-run operation sequence. + pub fn dry_run(&self, energy_quota: u64) -> DryRun { + let consensus = self.consensus.load(Ordering::SeqCst); + let handle = unsafe { dryRunStart(consensus, copy_to_vec_callback, energy_quota) }; + DryRun { + handle, + } + } } pub enum CallbackType { diff --git a/concordium-node/src/grpc2.rs b/concordium-node/src/grpc2.rs index 2284ce2312..890582a8a6 100644 --- a/concordium-node/src/grpc2.rs +++ b/concordium-node/src/grpc2.rs @@ -713,6 +713,8 @@ struct ServiceConfig { get_first_block_epoch: bool, #[serde(default)] get_winning_bakers_epoch: bool, + #[serde(default)] + dry_run: bool, } impl ServiceConfig { @@ -773,6 +775,7 @@ impl ServiceConfig { get_baker_earliest_win_time: true, get_first_block_epoch: true, get_winning_bakers_epoch: true, + dry_run: true, } } @@ -874,7 +877,7 @@ pub mod server { }; use anyhow::Context; use byteorder::WriteBytesExt; - use futures::{FutureExt, StreamExt}; + use futures::{Future, FutureExt, StreamExt}; use std::{ io::Write, net::SocketAddr, @@ -909,6 +912,12 @@ pub mod server { blocks_channels: Clients, /// The list of active clients listening for new finalized blocks. finalized_blocks_channels: Clients, + /// The maximum energy allowed to be used in a dry run invocation. + dry_run_max_energy: u64, + /// The timeout for a dry run invocation to complete. + dry_run_timeout: tokio::time::Duration, + /// Semaphore limiting the concurrent dry run sessions allowed. + dry_run_semaphore: Option>, } /// An administrative structure that collects objects needed to manage the @@ -978,6 +987,11 @@ pub mod server { consensus: consensus.clone(), blocks_channels: Arc::new(Mutex::new(Vec::new())), finalized_blocks_channels: Arc::new(Mutex::new(Vec::new())), + dry_run_max_energy: config.invoke_max_energy, + dry_run_timeout: tokio::time::Duration::from_secs(config.dry_run_timeout), + dry_run_semaphore: config + .dry_run_concurrency + .map(|n| Arc::new(tokio::sync::Semaphore::new(n))), }; let NotificationHandlers { @@ -1195,6 +1209,8 @@ pub mod server { #[async_trait] impl service::queries_server::Queries for RpcServerImpl { + /// Return type for the 'DryRun' method. + type DryRunStream = std::pin::Pin>; /// Return type for the 'GetAccountList' method. type GetAccountListStream = futures::channel::mpsc::Receiver, tonic::Status>>; @@ -1252,7 +1268,7 @@ pub mod server { /// Return type for the 'GetPoolDelegators' method. type GetPoolDelegatorsStream = futures::channel::mpsc::Receiver, tonic::Status>>; - /// Return type for the 'GetWinningBakersEpoch' mehtod. + /// Return type for the 'GetWinningBakersEpoch' method. type GetWinningBakersEpochStream = futures::channel::mpsc::Receiver, tonic::Status>>; @@ -2476,6 +2492,125 @@ pub mod server { self.consensus.get_winning_bakers_epoch_v2(request.get_ref(), sender)?; Ok(tonic::Response::new(receiver)) } + + async fn dry_run( + &self, + request: tonic::Request>, + ) -> Result, tonic::Status> { + if !self.service_config.dry_run { + return Err(tonic::Status::unimplemented("`DryRun` is not enabled.")); + } + // If the number of concurrent dry run sessions is limited, we try to get a + // permit from the semaphore. + let permit = match self.dry_run_semaphore.as_ref() { + None => None, + Some(semaphore) => { + let permit = semaphore.clone().try_acquire_owned().map_err(|_| { + tonic::Status::resource_exhausted("Too many concurrent `DryRun` requests") + })?; + Some(permit) + } + }; + + let energy_quota = self.dry_run_max_energy; + let dry_run = self.consensus.dry_run(energy_quota); + let input = request.into_inner(); + let timeout = self.dry_run_timeout; + let output = DryRunStream::new(dry_run, input, timeout, permit); + let mut response = tonic::Response::new(Box::pin(output)); + response.metadata_mut().insert("quota", energy_quota.into()); + // u64::MAX milliseconds is already hundreds of millions of years, so even if + // this is an underestimate of the actual timeout, it doesn't + // matter. + response + .metadata_mut() + .insert("timeout", u64::try_from(timeout.as_millis()).unwrap_or(u64::MAX).into()); + Ok(response) + } + } + + struct DryRunStream { + dry_run: crate::consensus_ffi::ffi::DryRun, + input: tonic::Streaming, + timeout: std::pin::Pin>, + _permit: Option, + done: bool, + } + + impl DryRunStream { + pub fn new( + dry_run: crate::consensus_ffi::ffi::DryRun, + input: tonic::Streaming, + timeout: tokio::time::Duration, + permit: Option, + ) -> Self { + DryRunStream { + dry_run, + input, + timeout: Box::pin(tokio::time::sleep(timeout)), + _permit: permit, + done: false, + } + } + } + + impl futures::Stream for DryRunStream { + type Item = tonic::Result>; + + fn poll_next( + mut self: std::pin::Pin<&mut Self>, + cx: &mut std::task::Context<'_>, + ) -> std::task::Poll> { + use std::task::Poll::Ready; + if self.done { + return Ready(None); + } + let timeout = std::pin::pin!(&mut self.timeout); + if timeout.poll(cx).is_ready() { + self.done = true; + return Ready(Some(Err(tonic::Status::deadline_exceeded( + "dry run deadline elapsed", + )))); + } + let input = std::pin::pin!(&mut self.input); + let Some(dry_run_request) = futures::ready!(input.poll_next(cx)) else { + self.done = true; + return Ready(None); + }; + let Ok(request) = dry_run_request else { + self.done = true; + return Ready(Some(Err(tonic::Status::invalid_argument("invalid dry run request")))); + }; + + use crate::grpc2::types::dry_run_request::Request::*; + let result = match request.request.require()? { + LoadBlockState(block_hash_input) => { + self.dry_run.load_block_state(&block_hash_input) + } + StateQuery(query) => { + use crate::grpc2::types::dry_run_state_query::Query::*; + match query.query.require()? { + GetAccountInfo(account) => self.dry_run.get_account_info(&account), + GetInstanceInfo(instance) => self.dry_run.get_instance_info(&instance), + InvokeInstance(invoke_instance_input) => { + self.dry_run.invoke_instance(&invoke_instance_input) + } + } + } + StateOperation(operation) => { + use crate::grpc2::types::dry_run_state_operation::Operation::*; + match operation.operation.require()? { + SetTimestamp(timestamp) => self.dry_run.set_timestamp(timestamp), + MintToAccount(mint) => self.dry_run.mint_to_account(mint), + RunTransaction(run_transaction_input) => { + self.dry_run.transaction(run_transaction_input) + } + } + } + }; + self.done = result.is_err(); + Ready(Some(result)) + } } } diff --git a/docs/grpc2.md b/docs/grpc2.md index 56ca10c078..26d412ef9b 100644 --- a/docs/grpc2.md +++ b/docs/grpc2.md @@ -103,6 +103,12 @@ If these are enabled then the following options become available send_block_item = true get_account_transaction_sign_hash = true get_block_items = true + get_bakers_reward_period = true + get_block_certificates = true + get_baker_earliest_win_time = true + get_first_block_epoch = true + get_winning_bakers_epoch = true + dry_run = true ``` ### Configuration options for checking client liveness @@ -154,3 +160,19 @@ connected clients are alive and responding in desired time. to 30s. Note that as for `grpc2-max-concurrent-requests`, for streaming responses, this does not mean that the stream must be consumed in 30s. It only means that the time until the initial response must be less than 30s. + +- `--grpc2-invoke-max-energy` (`CONCORDIUM_NODE_GRPC2_INVOKE_MAX_ENERGY`) + Maximum amount of energy allowed for a call to InvokeInstance/InvokeContract + or a dry-run session. Defaults to 1000000. For a dry-run session, each + request in the session uses a certain amount of energy, and once the limit is + reached, the session will be terminated with a `RESOURCE_EXHAUSTED` status. + +- `--grpc2-dry-run-timeout` (`CONCORDIUM_NODE_GRPC2_DRY_RUN_TIMEOUT`) + Maximum duration in milliseconds for a dry-run session to complete. Defaults + to 30000 (30s). If the timeout is reached before the session completes, it + will be terminated with a `DEADLINE_EXCEEDED` status. + +- `--grpc2-dry-run-concurrency` (`CONCORDIUM_NODE_GRPC2_DRY_RUN_CONCURRENCY`) + Maximum number of concurrent invocations of the `DryRun` endpoint. There is no + limit by default. If this limit is reached, the node will respond to further + `DryRun` requests with `RESOURCE_EXHAUSTED` until existing invocations complete. \ No newline at end of file