https://gitlab.com/tezos/tezos
Tip revision: 22c75d565d801c6b68247ceeca5408770f388e23 authored by Arvid Jakobsson on 19 October 2023, 09:05:38 UTC
Let the PEZification commence
Let the PEZification commence
Tip revision: 22c75d5
view_helpers.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Development. <contact@tezcore.com> *)
(* Copyright (c) 2021-2022 Nomadic Labs, <contact@nomadic-labs.com> *)
(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Tezos_micheline
type Environment.Error_monad.error += Viewed_contract_has_no_script
type Environment.Error_monad.error += View_callback_origination_failed
type Environment.Error_monad.error +=
| Illformed_view_type of Entrypoint.t * Script.expr
type Environment.Error_monad.error +=
| View_never_returns of Entrypoint.t * Contract_hash.t
type Environment.Error_monad.error +=
| View_unexpected_return of Entrypoint.t * Contract_hash.t
type Environment.Error_monad.error += View_not_found of Contract_hash.t * string
type Environment.Error_monad.error += Viewer_unexpected_storage
let () =
Environment.Error_monad.register_error_kind
`Permanent
~id:"viewedContractHasNoScript"
~title:"Viewed contract has no script"
~description:"A view was called on a contract with no script."
~pp:(fun ppf () ->
Format.fprintf ppf "A view was called on a contract with no script.")
Data_encoding.(unit)
(function Viewed_contract_has_no_script -> Some () | _ -> None)
(fun () -> Viewed_contract_has_no_script) ;
Environment.Error_monad.register_error_kind
`Permanent
~id:"viewCallbackOriginationFailed"
~title:"View callback origination failed"
~description:"View callback origination failed"
~pp:(fun ppf () ->
Format.fprintf ppf "Error during origination of view callback contract.")
Data_encoding.(unit)
(function View_callback_origination_failed -> Some () | _ -> None)
(fun () -> View_callback_origination_failed) ;
Environment.Error_monad.register_error_kind
`Permanent
~id:"illformedViewType"
~title:"An entrypoint type is incompatible with TZIP-4 view type."
~description:"An entrypoint type is incompatible with TZIP-4 view type."
~pp:(fun ppf (entrypoint, typ) ->
Format.fprintf
ppf
"The view %a has type %a, it is not compatible with a TZIP-4 view type."
Entrypoint.pp
entrypoint
Micheline_printer.print_expr
(Micheline_printer.printable
(fun x -> x)
(Michelson_v1_primitives.strings_of_prims typ)))
Data_encoding.(
obj2
(req "entrypoint" Entrypoint.simple_encoding)
(req "type" Script.expr_encoding))
(function Illformed_view_type (etp, exp) -> Some (etp, exp) | _ -> None)
(fun (etp, exp) -> Illformed_view_type (etp, exp)) ;
Environment.Error_monad.register_error_kind
`Permanent
~id:"viewNeverReturns"
~title:"A view never returned a transaction to the given callback contract"
~description:
"A view never initiated a transaction to the given callback contract."
~pp:(fun ppf (entrypoint, callback) ->
Format.fprintf
ppf
"The view %a never initiated a transaction to the given callback \
contract %a."
Entrypoint.pp
entrypoint
Contract_hash.pp
callback)
Data_encoding.(
obj2
(req "entrypoint" Entrypoint.simple_encoding)
(req "callback" Contract.originated_encoding))
(function View_never_returns (e, c) -> Some (e, c) | _ -> None)
(fun (e, c) -> View_never_returns (e, c)) ;
Environment.Error_monad.register_error_kind
`Permanent
~id:"viewUnexpectedReturn"
~title:"A view returned an unexpected list of operations"
~description:
"A view initiated a list of operations while the TZIP-4 standard expects \
only a transaction to the given callback contract."
~pp:(fun ppf (entrypoint, callback) ->
Format.fprintf
ppf
"The view %a initiated a list of operations while the TZIP-4 standard \
expects only a transaction to the given callback contract %a."
Entrypoint.pp
entrypoint
Contract_hash.pp
callback)
Data_encoding.(
obj2
(req "entrypoint" Entrypoint.simple_encoding)
(req "callback" Contract.originated_encoding))
(function View_unexpected_return (e, c) -> Some (e, c) | _ -> None)
(fun (e, c) -> View_unexpected_return (e, c)) ;
Environment.Error_monad.register_error_kind
`Permanent
~id:"viewNotFound"
~title:"A view could not be found"
~description:"The contract does not have a view of the given name."
~pp:(fun ppf (contract, name) ->
Format.fprintf
ppf
"The contract %a does not have a view named `%s`."
Contract_hash.pp
contract
name)
Data_encoding.(
obj2 (req "contract" Contract.originated_encoding) (req "view" string))
(function View_not_found (k, n) -> Some (k, n) | _ -> None)
(fun (k, n) -> View_not_found (k, n)) ;
Environment.Error_monad.register_error_kind
`Permanent
~id:"viewerUnexpectedStorage"
~title:"A VIEW instruction returned an unexpected value"
~description:"A VIEW instruction returned an unexpected value."
~pp:(fun ppf () ->
Format.fprintf ppf "The simulated view returned an unexpected value.")
Data_encoding.unit
(function Viewer_unexpected_storage -> Some () | _ -> None)
(fun () -> Viewer_unexpected_storage)
(* This script is actually never run, its usage is to ensure a
contract that has the type `contract <ty>` is originated, which
will be required as callback of the view. *)
let make_tzip4_viewer_script ty : Script.t =
let loc = 0 in
let ty = Micheline.root ty in
let code =
Micheline.strip_locations
@@ Micheline.Seq
( loc,
[
Micheline.Prim (loc, Script.K_parameter, [ty], []);
Micheline.Prim
( loc,
Script.K_storage,
[Micheline.Prim (loc, Script.T_unit, [], [])],
[] );
Micheline.Prim
( loc,
Script.K_code,
[Micheline.Prim (loc, Script.I_FAILWITH, [], [])],
[] );
] )
in
let storage =
Micheline.strip_locations (Micheline.Prim (loc, Script.D_Unit, [], []))
in
{code = Script.lazy_expr code; storage = Script.lazy_expr storage}
let make_view_parameter input callback =
let loc = 0 in
Micheline.strip_locations
(Micheline.Prim
( loc,
Script.D_Pair,
[
input;
Micheline.Bytes
(loc, Data_encoding.Binary.to_bytes_exn Contract.encoding callback);
],
[] ))
let extract_view_output_type entrypoint ty =
match Micheline.root ty with
| Micheline.Prim
(_, Script.T_pair, [_; Micheline.Prim (_, Script.T_contract, [ty], _)], _)
->
ok (Micheline.strip_locations ty)
| _ -> Environment.Error_monad.error (Illformed_view_type (entrypoint, ty))
(* 'view' entrypoints returns their value by calling a callback contract, thus
the expected result is a unique internal transaction to this callback. *)
let extract_parameter_from_operations entrypoint operations callback =
let unexpected_return =
Environment.Error_monad.error
@@ View_unexpected_return (entrypoint, callback)
in
match operations with
| [
Script_typed_ir.Internal_operation
{
operation =
Transaction_to_smart_contract
{
destination;
unparsed_parameters;
entrypoint = _;
amount = _;
parameters = _;
parameters_ty = _;
location = _;
};
source = _;
nonce = _;
};
]
when Contract_hash.equal destination callback ->
ok unparsed_parameters
| [] ->
Environment.Error_monad.error (View_never_returns (entrypoint, callback))
| _ -> unexpected_return
(* [make_michelson_viewer_script contract view input input_ty output_ty]
generates a script that calls a view from a given contract, and stores the
result in its storage. *)
let make_michelson_viewer_script address view input input_ty output_ty :
Script.t =
let loc = 0 in
let address = Micheline.String (loc, Contract.to_b58check address) in
let push ty value = Micheline.Prim (loc, Script.I_PUSH, [ty; value], []) in
let storage_decl = Micheline.Prim (loc, Script.T_option, [output_ty], []) in
let body =
Micheline.Seq
( loc,
[
Micheline.Prim (loc, Script.I_DROP, [], []);
push (Micheline.Prim (loc, Script.T_address, [], [])) address;
push input_ty (Micheline.root input);
Micheline.Prim
(loc, Script.I_VIEW, [Micheline.String (loc, view); output_ty], []);
Micheline.Prim
( loc,
Script.I_NIL,
[Micheline.Prim (loc, Script.T_operation, [], [])],
[] );
Micheline.Prim (loc, Script.I_PAIR, [], []);
] )
in
let code =
Micheline.strip_locations
@@ Micheline.Seq
( loc,
[
Micheline.Prim
( loc,
Script.K_parameter,
[Micheline.Prim (loc, Script.T_unit, [], [])],
[] );
Micheline.Prim (loc, Script.K_storage, [storage_decl], []);
Micheline.Prim (loc, Script.K_code, [body], []);
] )
in
let storage =
Micheline.strip_locations (Micheline.Prim (loc, Script.D_None, [], []))
in
{code = Script.lazy_expr code; storage = Script.lazy_expr storage}
(* Extracts the value from the mock script generated by
[make_michelson_viewer_script]. *)
let extract_value_from_storage (storage : Script.expr) =
match Micheline.root storage with
| Micheline.Prim (_, Script.D_Some, [value], []) -> ok value
| _ -> Environment.Error_monad.error @@ Viewer_unexpected_storage