-- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA -- | This module contains various types which are used in @octez-node@ RPC API. -- -- Documentation for RPC API can be found e. g. [here](http://tezos.gitlab.io/010/rpc.html) -- (010 is the protocol, change to the desired one). -- -- Note that errors are reported a bit inconsistently by RPC. -- For more information see -- [this question](https://tezos.stackexchange.com/q/2656/342) -- and [this issue](https://gitlab.com/metastatedev/tezos/-/issues/150). module Morley.Client.RPC.Types ( AppliedResult (..) , BlockConstants (..) , BlockHash (..) , BlockHeaderNoHash (..) , BlockHeader (..) , FeeConstants (..) , BlockId (..) , BlockOperation (..) , CommonOperationData (..) , DelegationOperation (..) , ForgeOperation (..) , GetBigMap (..) , CalcSize(..) , ScriptSize(..) , GetBigMapResult (..) , InternalOperation (..) , InternalOperationData (..) , IntOpEvent (..) , OperationContent (..) , OperationHash (..) , OperationInput , OperationResp (..) , OperationRespWithMeta (..) , OperationMetadata (..) , OperationResult (..) , OriginationOperation (..) , OriginationScript (..) , ParametersInternal (..) , PreApplyOperation (..) , ProtocolParameters (..) , RevealOperation (..) , RunCode (..) , RunCodeResult (..) , RunMetadata (..) , RunOperation (..) , RunOperationInternal (..) , RunOperationResult (..) , RPCInput , TransactionOperation (..) , TransferTicketOperation (..) , WithCommonOperationData (..) , MonitorHeadsStep(..) , GetTicketBalance (..) , GetAllTicketBalancesResponse (..) , mkCommonOperationData -- * Errors , RunError (..) , InternalError (..) -- * Prisms , _RuntimeError , _ScriptRejected , _BadContractParameter , _InvalidConstant , _InconsistentTypes , _InvalidPrimitive , _InvalidSyntacticConstantError , _InvalidExpressionKind , _InvalidContractNotation , _UnexpectedContract , _IllFormedType , _UnexpectedOperation , _REEmptyTransaction , _ScriptOverflow , _PreviouslyRevealedKey , _GasExhaustedOperation , _UnregisteredDelegate -- * Lenses , wcoCommonDataL ) where import Control.Lens (makePrisms) import Data.Aeson (FromJSON(..), Key, Object, ToJSON(..), Value(..), object, omitNothingFields, withObject, (.!=), (.:), (.:?), (.=)) import Data.Aeson.Key qualified as Key (toText) import Data.Aeson.TH (deriveFromJSON, deriveJSON, deriveToJSON) import Data.Default (Default(..)) import Data.Fixed (Milli) import Data.List (isSuffixOf) import Data.Ratio ((%)) import Data.Text qualified as T import Data.Time (UTCTime) import Fmt (Buildable(..), pretty, unwordsF, (+|), (|+)) import Servant.API (ToHttpApiData(..)) import Data.Aeson.Types (Parser) import Morley.Client.RPC.Aeson (morleyClientAesonOptions) import Morley.Client.Types import Morley.Micheline (Expression, MichelinePrimAp(..), MichelinePrimitive(..), StringEncode(..), TezosInt64, TezosMutez(..), TezosNat, expressionPrim) import Morley.Michelson.Text (MText) import Morley.Tezos.Address import Morley.Tezos.Core (Mutez, tz, zeroMutez) import Morley.Tezos.Crypto (KeyHash, PublicKey, Signature, decodeBase58CheckWithPrefix, formatSignature) import Morley.Util.CLI (HasCLReader(..), eitherReader) import Morley.Util.Named import Morley.Util.Text (dquotes) mergeObjects :: HasCallStack => Value -> Value -> Value mergeObjects (Object a) (Object b) = Object (a <> b) mergeObjects (Object _) _ = error "Right part is not an Object" mergeObjects _ _ = error "Left part is not an Object" -- | Designates an input RPC data that we supply to perform an operation. data RPCInput instance OperationInfoDescriptor RPCInput where type TransferInfo RPCInput = TransactionOperation type TransferTicketInfo RPCInput = TransferTicketOperation type OriginationInfo RPCInput = OriginationOperation type RevealInfo RPCInput = RevealOperation type DelegationInfo RPCInput = DelegationOperation type OperationInput = WithCommonOperationData (OperationInfo RPCInput) data ForgeOperation = ForgeOperation { foBranch :: BlockHash , foContents :: NonEmpty OperationInput } data RunOperationInternal = RunOperationInternal { roiBranch :: BlockHash , roiContents :: NonEmpty OperationInput , roiSignature :: Signature } data RunOperation = RunOperation { roOperation :: RunOperationInternal , roChainId :: Text } data PreApplyOperation = PreApplyOperation { paoProtocol :: Text , paoBranch :: BlockHash , paoContents :: NonEmpty OperationInput , paoSignature :: Signature } data RunOperationResult = RunOperationResult { rrOperationContents :: NonEmpty OperationContent } instance FromJSON RunOperationResult where parseJSON = withObject "preApplyRes" $ \o -> RunOperationResult <$> o .: "contents" newtype OperationHash = OperationHash { unOperationHash :: Text } deriving stock (Eq, Show) deriving newtype (FromJSON, Buildable) newtype OperationContent = OperationContent { unOperationContent :: RunMetadata } instance FromJSON OperationContent where parseJSON = withObject "operationCostContent" $ \o -> OperationContent <$> o .: "metadata" data RunMetadata = RunMetadata { rmOperationResult :: OperationResult , rmInternalOperationResults :: [InternalOperation] } instance FromJSON RunMetadata where parseJSON = withObject "metadata" $ \o -> RunMetadata <$> o .: "operation_result" <*> o .:? "internal_operation_results" .!= [] data InternalOperation = InternalOperation { ioData :: InternalOperationData , ioResult :: OperationResult } instance FromJSON InternalOperation where parseJSON json = json & withObject "internal_operation" \o -> InternalOperation <$> parseJSON json <*> o .: "result" data InternalOperationData = IODEvent IntOpEvent | IODIgnored instance FromJSON InternalOperationData where parseJSON json = json & withObject "internal_operation_data" \o -> do (kind :: Text) <- o .: "kind" case kind of "event" -> IODEvent <$> parseJSON json _ -> pure IODIgnored data IntOpEvent = IntOpEvent { ioeSource :: ContractAddress , ioeType :: Expression , ioeTag :: Maybe MText , ioePayload :: Maybe Expression } instance Buildable IntOpEvent where build IntOpEvent{..} = "Contract event with source: " +| ioeSource |+ ", tag: " +| ioeTag |+ ", type: " +| ioeType |+ ", and payload: " +| ioePayload |+ "" instance FromJSON IntOpEvent where parseJSON = withObject "internal_operation_data_event" \o -> do IntOpEvent <$> o .: "source" <*> o .: "type" <*> o .:? "tag" <*> o .:? "payload" data BlockConstants = BlockConstants { bcProtocol :: Text , bcChainId :: Text , bcHeader :: BlockHeaderNoHash , bcHash :: BlockHash } data BlockHeaderNoHash = BlockHeaderNoHash { bhnhTimestamp :: UTCTime , bhnhLevel :: Int64 , bhnhPredecessor :: BlockHash } -- Consider merging this type with 'BlockHeaderNoHash' if it becomes larger (i. e. -- if we need more data from it). -- | The whole block header. data BlockHeader = BlockHeader { bhTimestamp :: UTCTime , bhLevel :: Int64 , bhPredecessor :: BlockHash , bhHash :: BlockHash } newtype BlockHash = BlockHash { unBlockHash :: Text } deriving newtype (Eq, Ord, Show, Buildable, ToJSON, FromJSON, ToHttpApiData) data FeeConstants = FeeConstants { fcBase :: Mutez , fcMutezPerGas :: Milli , fcMutezPerOpByte :: Milli } -- | At the moment of writing, Tezos always uses these constants. instance Default FeeConstants where def = FeeConstants { fcBase = [tz|100u|] , fcMutezPerGas = 0.1 , fcMutezPerOpByte = 1 } -- | A block identifier as submitted to RPC. -- -- A block can be referenced by @head@, @genesis@, level or block hash data BlockId = HeadId -- ^ Identifier referring to the head block. | FinalHeadId -- ^ Identifier of the most recent block guaranteed to have been finalized. -- See: https://web.archive.org/web/20220305165609/https://tezos.gitlab.io/protocols/tenderbake.html#operations | GenesisId -- ^ Identifier referring to the genesis block. | LevelId Natural -- ^ Identifier referring to a block by its level. | BlockHashId BlockHash -- ^ Idenfitier referring to a block by its hash in Base58Check notation. | AtDepthId Natural -- ^ Identifier of a block at specific depth relative to @head@. deriving stock (Show, Eq) instance ToHttpApiData BlockId where toUrlPiece = \case HeadId -> "head" FinalHeadId -> "head~2" GenesisId -> "genesis" LevelId x -> toUrlPiece x BlockHashId hash -> toUrlPiece hash AtDepthId depth -> "head~" <> toUrlPiece depth instance Buildable BlockId where build = \case HeadId -> "head" FinalHeadId -> "head~2" GenesisId -> "genesis" LevelId x -> "block at level " <> build x BlockHashId hash -> "block with hash " <> build hash AtDepthId depth -> "block at depth " <> build depth -- | Parse 'BlockId' in its textual representation in the same format as -- submitted via RPC. parseBlockId :: Text -> Maybe BlockId parseBlockId t | t == "head" = Just HeadId | t == "head~2" = Just FinalHeadId | t == "genesis" = Just GenesisId | Right lvl <- readEither t = Just (LevelId lvl) | Just depthTxt <- "head~" `T.stripPrefix` t , Right depth <- readEither depthTxt = Just (AtDepthId depth) | Right _ <- decodeBase58CheckWithPrefix blockPrefix t = Just (BlockHashId (BlockHash t)) | otherwise = Nothing -- A magic prefix used by Tezos for block hashes -- see https://gitlab.com/tezos/tezos/-/blob/v11-release/src/lib_crypto/base58.ml#L341 blockPrefix :: ByteString blockPrefix = "\001\052" instance HasCLReader BlockId where getReader = eitherReader parseBlockId' where parseBlockId' :: String -> Either String BlockId parseBlockId' = maybeToRight ("failed to parse block ID, try passing block's hash, level or 'head'") . parseBlockId . toText getMetavar = "BLOCK_ID" -- | Protocol-wide constants. -- -- There are more constants, but currently, we are using only these -- in our code. data ProtocolParameters = ProtocolParameters { ppOriginationSize :: Int -- ^ Byte size cost for originating new contract. , ppHardGasLimitPerOperation :: TezosInt64 -- ^ Gas limit for a single operation. , ppHardStorageLimitPerOperation :: TezosInt64 -- ^ Storage limit for a single operation. , ppMinimalBlockDelay :: TezosNat -- ^ Minimal delay between two blocks, this constant is new in V010. , ppCostPerByte :: TezosMutez -- ^ Burn cost per storage byte , ppHardGasLimitPerBlock :: TezosInt64 -- ^ Gas limit for a single block. } -- | Details of a @BadStack@ error. data BadStackInformation = BadStackInformation { bsiLocation :: Int , bsiStackPortion :: Int , bsiPrim :: Text , bsiStack :: Expression } deriving stock (Eq, Show) instance FromJSON BadStackInformation where parseJSON = withObject "BadStack" $ \o -> BadStackInformation <$> o .: "location" <*> o .: "relevant_stack_portion" <*> o .: "primitive_name" <*> o .: "wrong_stack_type" instance Buildable BadStackInformation where build (BadStackInformation loc stack_portion prim stack_type) = "Bad Stack in location " +| loc |+ " stack portion " +| stack_portion |+ " on primitive " +| prim |+ " with (wrong) stack type " +| stack_type |+ "" -- | Errors that are sent as part of operation result in an OK -- response (status 200). They are semi-formally defined as errors -- that can happen when a contract is executed and something goes -- wrong. data RunError = RuntimeError ContractAddress | ScriptRejected Expression | BadContractParameter Address | InvalidConstant Expression Expression | InvalidContract Address | InconsistentTypes Expression Expression | InvalidPrimitive [Text] Text | InvalidSyntacticConstantError Expression Expression | InvalidExpressionKind [Text] Text | InvalidContractNotation Text | UnexpectedContract | IllFormedType Expression | UnexpectedOperation | REEmptyTransaction -- ^ Transfer of 0 to an implicit account. ImplicitAddress -- ^ Receiver address. | ScriptOverflow -- ^ A contract failed due to the detection of an overflow. -- It seems to happen if a too big value is passed to shift instructions -- (as second argument). | GasExhaustedOperation | MutezAdditionOverflow [TezosInt64] | MutezSubtractionUnderflow [TezosInt64] | MutezMultiplicationOverflow TezosInt64 TezosInt64 | CantPayStorageFee | BalanceTooLow ("balance" :! Mutez) ("required" :! Mutez) | PreviouslyRevealedKey ImplicitAddress | NonExistingContract Address | InvalidB58Check Text | UnregisteredDelegate ImplicitAddress | FailedUnDelegation ImplicitAddress | DelegateAlreadyActive | IllTypedContract Expression | IllTypedData Expression Expression | BadStack BadStackInformation | ForbiddenZeroAmountTicket | REEmptyImplicitContract ImplicitAddress deriving stock Show instance FromJSON RunError where parseJSON = withObject "preapply error" $ \o -> do id' <- o .: "id" decode id' [ "runtime_error" ~> RuntimeError <$> o .: "contract_handle" , "script_rejected" ~> ScriptRejected <$> o .: "with" , "bad_contract_parameter" ~> BadContractParameter <$> o .: "contract" , "invalid_constant" ~> InvalidConstant <$> o .: "expected_type" <*> o .: "wrong_expression" , "invalid_contract" ~> InvalidContract <$> o.: "contract" , "inconsistent_types" ~> InconsistentTypes <$> o .: "first_type" <*> o .: "other_type" , "invalid_primitive" ~> InvalidPrimitive <$> o .: "expected_primitive_names" <*> o .: "wrong_primitive_name" , "invalidSyntacticConstantError" ~> InvalidSyntacticConstantError <$> o .: "expectedForm" <*> o .: "wrongExpression" , "invalid_expression_kind" ~> InvalidExpressionKind <$> o .: "expected_kinds" <*> o .: "wrong_kind" , "invalid_contract_notation" ~> InvalidContractNotation <$> o .: "notation" , "unexpected_contract" ~> pure UnexpectedContract , "ill_formed_type" ~> IllFormedType <$> o .: "ill_formed_expression" , "unexpected_operation" ~> pure UnexpectedOperation , "empty_transaction" ~> REEmptyTransaction <$> o .: "contract" , "script_overflow" ~> pure ScriptOverflow , "gas_exhausted.operation" ~> pure GasExhaustedOperation , "tez.addition_overflow" ~> MutezAdditionOverflow <$> o .: "amounts" , "tez.subtraction_underflow" ~> MutezSubtractionUnderflow <$> o .: "amounts" , "tez.multiplication_overflow" ~> MutezMultiplicationOverflow <$> o .: "amount" <*> o .: "multiplicator" , "cannot_pay_storage_fee" ~> pure CantPayStorageFee , "balance_too_low"~> do balance <- unTezosMutez <$> o .: "balance" amount <- unTezosMutez <$> o .: "amount" return $ BalanceTooLow (#balance :! balance) (#required :! amount) , "previously_revealed_key" ~> PreviouslyRevealedKey <$> o .: "contract" , "non_existing_contract" ~> NonExistingContract <$> o .: "contract" , "invalid_b58check" ~> InvalidB58Check <$> o .: "input" , "unregistered_delegate" ~> UnregisteredDelegate <$> o .: "hash" , "no_deletion" ~> FailedUnDelegation <$> o .: "delegate" , "delegate.already_active" ~> pure DelegateAlreadyActive , "empty_implicit_contract" ~> REEmptyImplicitContract <$> o .: "implicit" , "ill_typed_contract" ~> IllTypedContract <$> o .: "ill_typed_code" , "ill_typed_data" ~> IllTypedData <$> o .: "expected_type" <*> o .: "ill_typed_expression" , "bad_stack" ~> BadStack <$> parseJSON (Object o) , "forbidden_zero_amount_ticket" ~> pure ForbiddenZeroAmountTicket ] where infix 0 ~> (~>) = (,) decode x xs = fromMaybe (fail $ "unknown id: " <> x) $ snd <$> find (\(k, _) -> ('.' : k) `isSuffixOf` x) xs instance Buildable RunError where build = \case RuntimeError addr -> "Runtime error for contract: " +| addr |+ "" ScriptRejected expr -> "Script rejected with: " +| expr |+ "" BadContractParameter addr -> "Bad contract parameter for: " +| addr |+ "" InvalidConstant expectedType expr -> "Invalid type: " +| expectedType |+ "\n" +| "For: " +| expr |+ "" InvalidContract addr -> "Invalid contract: " +| addr |+ "" InconsistentTypes type1 type2 -> "Inconsistent types: " +| type1 |+ " and " +| type2 |+ "" InvalidPrimitive expectedPrimitives wrongPrimitive -> "Invalid primitive: " +| wrongPrimitive |+ "\n" +| "Expecting one of: " +| mconcat (intersperse (" " :: Text) $ map pretty expectedPrimitives) |+ "" InvalidSyntacticConstantError expectedForm wrongExpression -> "Invalid syntatic constant error, expecting: " +| expectedForm |+ "\n" +| "But got: " +| wrongExpression |+ "" InvalidExpressionKind expectedKinds wrongKind -> "Invalid expression kind, expecting expression of kind: " +| expectedKinds |+ "\n" +| "But got: " +| wrongKind |+ "" InvalidContractNotation notation -> "Invalid contract notation: " +| notation |+ "" UnexpectedContract -> "When parsing script, a contract type was found in \ \the storage or parameter field." IllFormedType expr -> "Ill formed type: " +| expr |+ "" UnexpectedOperation -> "When parsing script, an operation type was found in \ \the storage or parameter field" REEmptyTransaction addr -> "It's forbidden to send 0ęś© to " +| addr |+ " that has no code" ScriptOverflow -> "A contract failed due to the detection of an overflow" GasExhaustedOperation -> "Contract failed due to gas exhaustion" MutezAdditionOverflow amounts -> "A contract failed due to mutez addition overflow when adding following values:\n" +| unwordsF amounts |+ "" MutezSubtractionUnderflow amounts -> "A contract failed due to mutez subtraction underflow when subtracting following values:\n" +| unwordsF amounts |+ "" MutezMultiplicationOverflow amount multiplicator -> "A contract failed due to mutez multiplication overflow when multiplying" +| amount |+ " by " +| multiplicator |+ "" CantPayStorageFee -> "Balance is too low to pay storage fee" BalanceTooLow (arg #balance -> balance) (arg #required -> required) -> "Balance is too low, \ \current balance: " +| balance |+ ", but required: " +| required |+ "" PreviouslyRevealedKey addr -> "Key for " +| addr |+ " has already been revealed" NonExistingContract addr -> "Contract is not registered: " +| addr |+ "" InvalidB58Check input -> "Failed to read a valid b58check_encoding data from \"" +| input |+ "\"" UnregisteredDelegate addr -> addr |+ " is not registered as delegate" FailedUnDelegation addr -> "Failed to withdraw delegation for: " +| addr |+ "" DelegateAlreadyActive -> "Delegate already active" REEmptyImplicitContract addr -> "Empty implicit contract (" +| addr |+ ")" IllTypedContract expr -> "Ill typed contract: " +| expr |+ "" IllTypedData expected ill_typed -> "Ill typed data: Expected type " +| expected |+ ", ill typed expression: " +| ill_typed |+ "" BadStack info -> build info ForbiddenZeroAmountTicket -> "Forbidden zero amount ticket" -- | Errors that are sent as part of an "Internal Server Error" -- response (HTTP code 500). -- -- We call them internal because of the HTTP code, but we shouldn't -- treat them as internal. They can be easily triggered by making a -- failing operation. data InternalError = CounterInThePast -- ^ An operation assumed a contract counter in the past. ImplicitAddress -- ^ Address whose counter is invalid. ("expected" :! Word) -- ^ Expected counter. ("found" :! Word) -- ^ Found counter. | UnrevealedKey -- ^ One tried to apply a manager operation without revealing -- the manager public key. ImplicitAddress -- ^ Manager address. | Failure Text -- ^ Failure reported without specific id deriving stock Show instance Buildable InternalError where build = \case CounterInThePast addr (arg #expected -> expected) (arg #found -> found) -> "Expected counter " +| expected |+ " for " +| addr |+ "but got: " +| found |+ "" UnrevealedKey addr -> "One tried to apply a manager operation without revealing " <> "the manager public key of " <> build addr Failure msg -> "Contract failed with the following message: " +| msg |+ "" instance FromJSON InternalError where parseJSON = withObject "internal error" $ \o -> o .: "id" >>= \case x | ".counter_in_the_past" `isSuffixOf` x -> CounterInThePast <$> o .: "contract" <*> (#expected <:!> parseCounter o "expected") <*> (#found <:!> parseCounter o "found") x | ".unrevealed_key" `isSuffixOf` x -> UnrevealedKey <$> o .: "contract" "failure" -> Failure <$> o .: "msg" x -> fail ("unknown id: " <> x) where parseCounter :: Object -> Key -> Parser Word parseCounter o fieldName = do fieldValue <- o .: fieldName let mCounter = fromIntegralMaybe fieldValue maybe (fail $ mkErrorMsg (Key.toText fieldName) fieldValue) pure mCounter mkErrorMsg :: Text -> TezosInt64 -> String mkErrorMsg fieldName fieldValue = toString $ unwords ["Invalid", dquotes fieldName, "counter:", show $ unStringEncode fieldValue] data OperationResult = OperationApplied AppliedResult | OperationFailed [RunError] data AppliedResult = AppliedResult { arConsumedMilliGas :: TezosInt64 , arStorageSize :: TezosInt64 , arPaidStorageDiff :: TezosInt64 , arOriginatedContracts :: [ContractAddress] , arAllocatedDestinationContracts :: TezosInt64 -- ^ We need to count number of destination contracts that are new -- to the chain in order to calculate proper storage_limit } deriving stock Show instance Semigroup AppliedResult where (<>) ar1 ar2 = AppliedResult { arConsumedMilliGas = arConsumedMilliGas ar1 + arConsumedMilliGas ar2 , arStorageSize = arStorageSize ar1 + arStorageSize ar2 , arPaidStorageDiff = arPaidStorageDiff ar1 + arPaidStorageDiff ar2 , arOriginatedContracts = arOriginatedContracts ar1 <> arOriginatedContracts ar2 , arAllocatedDestinationContracts = arAllocatedDestinationContracts ar1 + arAllocatedDestinationContracts ar2 } instance Monoid AppliedResult where mempty = AppliedResult 0 0 0 [] 0 instance FromJSON OperationResult where parseJSON = withObject "operation_costs" $ \o -> do status <- o .: "status" case status of "applied" -> OperationApplied <$> do arConsumedMilliGas <- o .: "consumed_milligas" arStorageSize <- o .:? "storage_size" .!= 0 arPaidStorageDiff <- o .:? "paid_storage_size_diff" .!= 0 arOriginatedContracts <- o .:? "originated_contracts" .!= [] allocatedFlag <- o .:? "allocated_destination_contract" .!= False let arAllocatedDestinationContracts = if allocatedFlag then 1 else 0 return AppliedResult{..} "failed" -> OperationFailed <$> o .: "errors" "backtracked" -> OperationFailed <$> o .:? "errors" .!= [] "skipped" -> OperationFailed <$> o .:? "errors" .!= [] _ -> fail ("unexpected status " ++ status) data ParametersInternal = ParametersInternal { piEntrypoint :: Text , piValue :: Expression } -- | 'ParametersInternal' can be missing when default entrypoint is called with -- Unit value. Usually it happens when destination is an implicit account. -- In our structures 'ParametersInternal' is not optional because missing -- case is equivalent to explicit calling of @default@ with @Unit@. defaultParametersInternal :: ParametersInternal defaultParametersInternal = ParametersInternal { piEntrypoint = "default" , piValue = expressionPrim MichelinePrimAp { mpaPrim = MichelinePrimitive "Unit" , mpaArgs = [] , mpaAnnots = [] } } -- | Data that is common for transaction and origination -- operations. data CommonOperationData = CommonOperationData { codSource :: ImplicitAddress , codFee :: TezosMutez , codCounter :: TezosInt64 , codGasLimit :: TezosInt64 , codStorageLimit :: TezosInt64 } -- | Create 'CommonOperationData' based on current blockchain protocol parameters -- and sender info. This data is used for operation simulation. -- -- @num_operations@ parameter can be used for smarter gas limit estimation. If -- 'Nothing', the gas limit is set to 'ppHardGasLimitPerOperation', but that -- puts a hard low limit on the number of operations that will fit into one -- batch. If @num_operations@ is set, then gas limit is estimated as -- -- \[ -- \mathrm{min}\left(\mathbf{hard\_gas\_limit\_per\_operation}, -- \left\lfloor \frac{\mathbf{hard\_gas\_limit\_per\_block}} -- {num\_operations}\right\rfloor\right) -- \] -- -- This works well enough for the case of many small operations, but will break -- when there is one big one and a lot of small ones. That said, specifying -- @num_operations@ will work in all cases where not specifying it would, and -- then some, so it's recommended to specify it whenever possible. -- -- @num_operations@ is assumed to be greater than @0@, otherwise it'll be -- silently ignored. -- -- Fee isn't accounted during operation simulation, so it's safe to use zero amount. -- Real operation fee is calculated later using @octez-client@. mkCommonOperationData :: ProtocolParameters -> "sender" :! ImplicitAddress -> "counter" :! TezosInt64 -> "num_operations" :? Int64 -> CommonOperationData mkCommonOperationData ProtocolParameters{..} source counter mNumOp = CommonOperationData { codSource = arg #sender source , codFee = TezosMutez zeroMutez , codCounter = arg #counter counter , codGasLimit = estGasLimitPerOperation , codStorageLimit = ppHardStorageLimitPerOperation } where estGasLimitPerOperation | Just numOp <- argF #num_operations mNumOp , numOp > 0 = StringEncode $ min (unStringEncode ppHardGasLimitPerOperation) $ floor $ unStringEncode ppHardGasLimitPerBlock % numOp | otherwise = ppHardGasLimitPerOperation instance ToJSON CommonOperationData where toJSON CommonOperationData{..} = object [ "source" .= codSource , "fee" .= codFee , "counter" .= codCounter , "gas_limit" .= codGasLimit , "storage_limit" .= codStorageLimit ] instance FromJSON CommonOperationData where parseJSON = withObject "common operation data" $ \o -> do codSource <- o .: "source" codFee <- o .: "fee" codCounter <- o .: "counter" codGasLimit <- o .: "gas_limit" codStorageLimit <- o .: "storage_limit" pure CommonOperationData {..} -- | Some operation data accompanied with common data. data WithCommonOperationData a = WithCommonOperationData { wcoCommon :: CommonOperationData , wcoCustom :: a } instance ToJSONObject a => ToJSON (WithCommonOperationData a) where toJSON (WithCommonOperationData common custom) = toJSON common `mergeObjects` toJSON custom instance FromJSON a => FromJSON (WithCommonOperationData a) where parseJSON v = WithCommonOperationData <$> parseJSON v <*> parseJSON v -- | All the data needed to perform a transaction through -- Tezos RPC interface. -- For additional information, please refer to RPC documentation -- http://tezos.gitlab.io/api/rpc.html data TransactionOperation = TransactionOperation { toAmount :: TezosMutez , toDestination :: Address , toParameters :: ParametersInternal } data TransferTicketOperation = TransferTicketOperation { ttoTicketContents :: Expression , ttoTicketTy :: Expression , ttoTicketTicketer :: Address , ttoTicketAmount :: TezosNat , ttoDestination :: Address , ttoEntrypoint :: Text } data OriginationScript = OriginationScript { osCode :: Expression , osStorage :: Expression } -- | All the data needed to perform contract origination -- through Tezos RPC interface data OriginationOperation = OriginationOperation { ooBalance :: TezosMutez , ooDelegate :: Maybe KeyHash , ooScript :: OriginationScript } -- | All the data needed to perform key revealing -- through Tezos RPC interface data RevealOperation = RevealOperation { roPublicKey :: PublicKey } instance ToJSON RevealOperation where toJSON RevealOperation{..} = object $ [ "kind" .= String "reveal" , "public_key" .= roPublicKey ] instance ToJSONObject RevealOperation data DelegationOperation = DelegationOperation { doDelegate :: Maybe KeyHash -- ^ 'Nothing' removes delegate, 'Just' sets it } instance ToJSON DelegationOperation where toJSON DelegationOperation{..} = object $ [ "kind" .= String "delegation" ] <> maybeToList (("delegate" .=) <$> doDelegate) instance ToJSONObject DelegationOperation -- | @$operation@ in Tezos docs. data BlockOperation = BlockOperation { boHash :: Text , boContents :: [OperationRespWithMeta] } -- | Contents of an operation that can appear in RPC responses. data OperationResp = TransactionOpResp (WithCommonOperationData TransactionOperation) -- ^ Operation with kind @transaction@. | OtherOpResp -- ^ Operation with kind that we don't support yet (but need to parse to something). data OperationRespWithMeta = OperationRespWithMeta { orwmResponse :: OperationResp , orwmMetadata :: Maybe OperationMetadata } newtype OperationMetadata = OperationMetadata { unOperationMetadata :: Maybe OperationResult } instance FromJSON OperationMetadata where parseJSON = withObject "operationMetadata" $ \o -> OperationMetadata <$> o .:? "operation_result" data GetBigMap = GetBigMap { bmKey :: Expression , bmType :: Expression } data GetBigMapResult = GetBigMapResult Expression | GetBigMapNotFound -- | Data required for calling @run_code@ RPC endpoint. data RunCode = RunCode { rcScript :: Expression , rcStorage :: Expression , rcInput :: Expression , rcAmount :: TezosMutez , rcBalance :: TezosMutez , rcChainId :: Text , rcNow :: Maybe TezosNat , rcLevel :: Maybe TezosNat , rcSource :: Maybe ImplicitAddress , rcPayer :: Maybe ImplicitAddress } data GetTicketBalance = GetTicketBalance { gtbTicketer :: ContractAddress , gtbContentType :: Expression , gtbContent :: Expression } data GetAllTicketBalancesResponse = GetAllTicketBalancesResponse { gatbrTicketer :: ContractAddress , gatbrContentType :: Expression , gatbrContent :: Expression , gatbrAmount :: TezosNat } -- | Result storage of @run_code@ RPC endpoint call. -- -- Actual resulting JSON has more contents, but currently we're interested -- only in resulting storage. data RunCodeResult = RunCodeResult { rcrStorage :: Expression } newtype ScriptSize = ScriptSize { ssScriptSize :: Natural } data CalcSize = CalcSize { csProgram :: Expression , csStorage :: Expression , csGas :: TezosInt64 , csLegacy :: Bool } data MonitorHeadsStep a = MonitorHeadsStop a | MonitorHeadsContinue deriveJSON morleyClientAesonOptions ''ParametersInternal instance ToJSON TransactionOperation where toJSON TransactionOperation{..} = object $ [ "kind" .= String "transaction" , "amount" .= toAmount , "destination" .= toDestination , "parameters" .= toParameters ] instance ToJSONObject TransactionOperation instance ToJSON TransferTicketOperation where toJSON TransferTicketOperation{..} = object $ [ "kind" .= String "transfer_ticket" , "ticket_contents" .= ttoTicketContents , "ticket_ty" .= ttoTicketTy , "ticket_ticketer" .= ttoTicketTicketer , "ticket_amount" .= ttoTicketAmount , "destination" .= ttoDestination , "entrypoint" .= ttoEntrypoint ] instance ToJSONObject TransferTicketOperation instance FromJSON TransactionOperation where parseJSON = withObject "TransactionOperation" $ \obj -> do toAmount <- obj .: "amount" toDestination <- obj .: "destination" toParameters <- fromMaybe defaultParametersInternal <$> obj .:? "parameters" pure TransactionOperation {..} instance FromJSON OperationResp where parseJSON = withObject "OperationResp" $ \obj -> do kind :: Text <- obj .: "kind" case kind of "transaction" -> TransactionOpResp <$> parseJSON (Object obj) _ -> pure OtherOpResp instance FromJSON OperationRespWithMeta where parseJSON = withObject "OperationRespWithMeta" $ \obj -> do OperationRespWithMeta <$> parseJSON (Object obj) <*> obj .:? "metadata" deriveToJSON morleyClientAesonOptions ''OriginationScript instance ToJSON OriginationOperation where toJSON OriginationOperation{..} = object $ [ "kind" .= String "origination" , "balance" .= ooBalance , "script" .= ooScript ] <> maybeToList (("delegate" .=) <$> ooDelegate) instance ToJSONObject OriginationOperation instance ToJSON ForgeOperation where toJSON ForgeOperation{..} = object [ "branch" .= unBlockHash foBranch , "contents" .= foContents ] instance ToJSON RunOperationInternal where toJSON RunOperationInternal{..} = object [ "branch" .= unBlockHash roiBranch , "contents" .= roiContents , "signature" .= roiSignature ] instance ToJSON PreApplyOperation where toJSON PreApplyOperation{..} = object [ "branch" .= unBlockHash paoBranch , "contents" .= paoContents , "protocol" .= paoProtocol , "signature" .= formatSignature paoSignature ] deriveToJSON morleyClientAesonOptions ''RunOperation deriveToJSON morleyClientAesonOptions ''GetBigMap deriveToJSON morleyClientAesonOptions ''GetTicketBalance deriveToJSON morleyClientAesonOptions ''CalcSize deriveToJSON morleyClientAesonOptions{omitNothingFields = True} ''RunCode deriveFromJSON morleyClientAesonOptions ''GetAllTicketBalancesResponse deriveFromJSON morleyClientAesonOptions ''BlockHeaderNoHash deriveFromJSON morleyClientAesonOptions ''ScriptSize deriveFromJSON morleyClientAesonOptions ''BlockConstants deriveJSON morleyClientAesonOptions ''BlockHeader deriveFromJSON morleyClientAesonOptions ''ProtocolParameters deriveFromJSON morleyClientAesonOptions ''BlockOperation deriveFromJSON morleyClientAesonOptions ''OriginationScript deriveFromJSON morleyClientAesonOptions ''RunCodeResult instance FromJSON GetBigMapResult where parseJSON v = maybe GetBigMapNotFound GetBigMapResult <$> parseJSON v makePrisms ''RunError wcoCommonDataL :: Lens' (WithCommonOperationData a) CommonOperationData wcoCommonDataL = \f (WithCommonOperationData com cust) -> (`WithCommonOperationData` cust) <$> f com