balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Michelson: read some constants in base58 but store them in binary

Browse Source
This commit is contained in:
Benjamin Canou 2018-05-17 17:25:54 +02:00 committed by Grégoire Henry
parent ff4a5fadda
commit 1b91d0929a
18 changed files with 396 additions and 241 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/bin_client/test/test_contracts.sh
View File

@ -314,11 +314,11 @@ assert_storage $contract_dir/map_caddaadr.tz \
# Did the given key sign the string? (key is bootstrap1) # Did the given key sign the string? (key is bootstrap1)
assert_success $client run program $contract_dir/check_signature.tz \ assert_success $client run program $contract_dir/check_signature.tz \
on storage '(Pair "1f19f8f37e80d96797b019f30d23ede6a26a0f698220f942103a3401f047623746e51a9c6e77e269b5df9593994ab96b001aae0f73728a2259187cb640b61e01" "hello")' \ on storage '(Pair 0x011eb640b67c1859228a72730fae1a006bb94a999395dfb569e2776e9c1ae546376247f001343a1042f92082690f6aa2e6ed230df319b09767d9807ef3f8191f "hello")' \
and input '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"' and input '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"'
assert_fails $client run program $contract_dir/check_signature.tz \ assert_fails $client run program $contract_dir/check_signature.tz \
on storage '(Pair "1f19f8f37e80d96797b019f30d23ede6a26a0f698220f942103a3401f047623746e51a9c6e77e269b5df9593994ab96b001aae0f73728a2259187cb640b61e01" "abcd")' \ on storage '(Pair 0x011eb640b67c1859228a72730fae1a006bb94a999395dfb569e2776e9c1ae546376247f001343a1042f92082690f6aa2e6ed230df319b09767d9807ef3f8191f "abcd")' \
and input '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"' and input '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"'

2
src/lib_protocol_environment/sigs/jbuild
View File

@ -14,12 +14,12 @@
v1/format.mli v1/format.mli
;; Part of external libraries ;; Part of external libraries
v1/mBytes.mli
v1/z.mli v1/z.mli
v1/lwt.mli v1/lwt.mli
v1/lwt_list.mli v1/lwt_list.mli
;; Tezos extended stdlib ;; Tezos extended stdlib
v1/mBytes.mli
v1/compare.mli v1/compare.mli
v1/data_encoding.mli v1/data_encoding.mli
v1/error_monad.mli v1/error_monad.mli

3
src/lib_protocol_environment/sigs/v1/z.mli
View File

@ -76,6 +76,9 @@ val to_int: t -> int
val of_int: int -> t val of_int: int -> t
(** Converts from a base integer. *) (** Converts from a base integer. *)
val to_bits: ?pad_to:int -> t -> MBytes.t
val of_bits: MBytes.t -> t
val equal: t -> t -> bool val equal: t -> t -> bool
val compare: t -> t -> int val compare: t -> t -> int

18
src/lib_protocol_environment/tezos_protocol_environment.ml
View File

@ -188,11 +188,25 @@ module Make (Context : CONTEXT) = struct
module Buffer = Buffer module Buffer = Buffer
module Format = Format module Format = Format
module Option = Option module Option = Option
module Z = Z module MBytes = MBytes
module Z = struct
include Z
let to_bits ?(pad_to = 0) z =
let bits = to_bits z in
let len = Pervasives.((numbits z + 7) / 8) in
let full_len = Compare.Int.max pad_to len in
if full_len = 0 then
MBytes.empty
else
let res = MBytes.make full_len '\000' in
MBytes.blit_of_string bits 0 res 0 len ;
res
let of_bits bytes =
of_bits (MBytes.to_string bytes)
end
module Lwt_sequence = Lwt_sequence module Lwt_sequence = Lwt_sequence
module Lwt = Lwt module Lwt = Lwt
module Lwt_list = Lwt_list module Lwt_list = Lwt_list
module MBytes = MBytes
module Uri = Uri module Uri = Uri
module Data_encoding = Data_encoding module Data_encoding = Data_encoding
module Time = Time module Time = Time

3
src/proto_alpha/lib_client/client_proto_programs.ml
View File

@ -120,8 +120,7 @@ let trace
let hash_and_sign ?gas (data : Michelson_v1_parser.parsed) (typ : Michelson_v1_parser.parsed) sk block cctxt = let hash_and_sign ?gas (data : Michelson_v1_parser.parsed) (typ : Michelson_v1_parser.parsed) sk block cctxt =
Alpha_services.Helpers.hash_data cctxt block (data.expanded, typ.expanded, gas) >>=? fun (hash, gas) -> Alpha_services.Helpers.hash_data cctxt block (data.expanded, typ.expanded, gas) >>=? fun (hash, gas) ->
Client_keys.sign sk (MBytes.of_string hash) >>=? fun signature -> Client_keys.sign sk (MBytes.of_string hash) >>=? fun signature ->
let `Hex signature = Signature.to_hex signature in return (hash, Signature.to_b58check signature, gas)
return (hash, signature, gas)
let typecheck_data let typecheck_data
?gas ?gas

24
src/proto_alpha/lib_protocol/src/apply.ml
View File

@ -398,7 +398,7 @@ let cleanup_balance_updates balance_updates =
not (Tez.equal update Tez.zero)) not (Tez.equal update Tez.zero))
balance_updates balance_updates
let apply_manager_operation_content ctxt ~payer ~source ~internal operation = let apply_manager_operation_content ctxt mode ~payer ~source ~internal operation =
let before_operation = ctxt in let before_operation = ctxt in
Contract.must_exist ctxt source >>=? fun () -> Contract.must_exist ctxt source >>=? fun () ->
let spend = let spend =
@ -449,7 +449,7 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
| None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None)) | None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None))
end >>=? fun (ctxt, parameter) -> end >>=? fun (ctxt, parameter) ->
Script_interpreter.execute Script_interpreter.execute
ctxt ~source ~payer ~self:(destination, script) ~amount ~parameter ctxt mode ~source ~payer ~self:(destination, script) ~amount ~parameter
>>=? fun { ctxt ; storage ; big_map_diff ; operations } -> >>=? fun { ctxt ; storage ; big_map_diff ; operations } ->
Contract.used_storage_space ctxt destination >>=? fun old_size -> Contract.used_storage_space ctxt destination >>=? fun old_size ->
Contract.update_script_storage Contract.update_script_storage
@ -477,7 +477,7 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
| None -> return (None, ctxt) | None -> return (None, ctxt)
| Some script -> | Some script ->
Script_ir_translator.parse_script ctxt script >>=? fun (_, ctxt) -> Script_ir_translator.parse_script ctxt script >>=? fun (_, ctxt) ->
Script_ir_translator.erase_big_map_initialization ctxt script >>=? fun (script, big_map_diff, ctxt) -> Script_ir_translator.erase_big_map_initialization ctxt Optimized script >>=? fun (script, big_map_diff, ctxt) ->
return (Some (script, big_map_diff), ctxt) return (Some (script, big_map_diff), ctxt)
end >>=? fun (script, ctxt) -> end >>=? fun (script, ctxt) ->
spend ctxt source credit >>=? fun ctxt -> spend ctxt source credit >>=? fun ctxt ->
@ -505,7 +505,7 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
set_delegate ctxt source delegate >>=? fun ctxt -> set_delegate ctxt source delegate >>=? fun ctxt ->
return (ctxt, Delegation_result) return (ctxt, Delegation_result)
let apply_internal_manager_operations ctxt ~payer ops = let apply_internal_manager_operations ctxt mode ~payer ops =
let rec apply ctxt applied worklist = let rec apply ctxt applied worklist =
match worklist with match worklist with
| [] -> Lwt.return (Ok (ctxt, applied)) | [] -> Lwt.return (Ok (ctxt, applied))
@ -514,7 +514,7 @@ let apply_internal_manager_operations ctxt ~payer ops =
fail (Internal_operation_replay op) fail (Internal_operation_replay op)
else else
let ctxt = record_internal_nonce ctxt nonce in let ctxt = record_internal_nonce ctxt nonce in
apply_manager_operation_content ctxt ~source ~payer ~internal:true operation apply_manager_operation_content ctxt mode ~source ~payer ~internal:true operation
end >>= function end >>= function
| Error errors -> | Error errors ->
let result = Internal op, Failed errors in let result = Internal op, Failed errors in
@ -526,12 +526,12 @@ let apply_internal_manager_operations ctxt ~payer ops =
apply ctxt ((Internal op, Applied result) :: applied) rest in apply ctxt ((Internal op, Applied result) :: applied) rest in
apply ctxt [] ops apply ctxt [] ops
let apply_manager_operations ctxt source ops = let apply_manager_operations ctxt mode source ops =
let rec apply ctxt applied ops = let rec apply ctxt applied ops =
match ops with match ops with
| [] -> Lwt.return (Ok (ctxt, List.rev applied)) | [] -> Lwt.return (Ok (ctxt, List.rev applied))
| operation :: rest -> | operation :: rest ->
apply_manager_operation_content ctxt ~source ~payer:source ~internal:false operation apply_manager_operation_content ctxt mode ~source ~payer:source ~internal:false operation
>>= function >>= function
| Error errors -> | Error errors ->
let result = External, Failed errors in let result = External, Failed errors in
@ -542,7 +542,7 @@ let apply_manager_operations ctxt source ops =
match result with match result with
| Transaction_result { operations = emitted ; _ } -> emitted | Transaction_result { operations = emitted ; _ } -> emitted
| _ -> [] in | _ -> [] in
apply_internal_manager_operations ctxt ~payer:source emitted apply_internal_manager_operations ctxt mode ~payer:source emitted
>>= function >>= function
| Error (results) -> | Error (results) ->
let result = (External, Applied result) in let result = (External, Applied result) in
@ -554,7 +554,7 @@ let apply_manager_operations ctxt source ops =
apply ctxt applied rest in apply ctxt applied rest in
apply ctxt [] ops apply ctxt [] ops
let apply_sourced_operation ctxt pred_block operation ops = let apply_sourced_operation ctxt mode pred_block operation ops =
match ops with match ops with
| Manager_operations { source ; fee ; counter ; operations ; gas_limit ; storage_limit } -> | Manager_operations { source ; fee ; counter ; operations ; gas_limit ; storage_limit } ->
let revealed_public_keys = let revealed_public_keys =
@ -580,7 +580,7 @@ let apply_sourced_operation ctxt pred_block operation ops =
let ctxt = reset_internal_nonce ctxt in let ctxt = reset_internal_nonce ctxt in
Lwt.return (Gas.set_limit ctxt gas_limit) >>=? fun ctxt -> Lwt.return (Gas.set_limit ctxt gas_limit) >>=? fun ctxt ->
Lwt.return (Contract.set_storage_limit ctxt storage_limit) >>=? fun ctxt -> Lwt.return (Contract.set_storage_limit ctxt storage_limit) >>=? fun ctxt ->
apply_manager_operations ctxt source operations >>= begin function apply_manager_operations ctxt mode source operations >>= begin function
| Ok (ctxt, operation_results) -> return (ctxt, operation_results) | Ok (ctxt, operation_results) -> return (ctxt, operation_results)
| Error operation_results -> return (ctxt (* backtracked *), operation_results) | Error operation_results -> return (ctxt (* backtracked *), operation_results)
end >>=? fun (ctxt, operation_results) -> end >>=? fun (ctxt, operation_results) ->
@ -715,7 +715,7 @@ let apply_anonymous_operation ctxt kind =
Contract.(credit ctxt (implicit_contract (Signature.Ed25519 pkh)) amount) >>=? fun ctxt -> Contract.(credit ctxt (implicit_contract (Signature.Ed25519 pkh)) amount) >>=? fun ctxt ->
return (ctxt, Activation_result [(* FIXME *)]) return (ctxt, Activation_result [(* FIXME *)])
let apply_operation ctxt pred_block hash operation = let apply_operation ctxt mode pred_block hash operation =
let ctxt = Contract.init_origination_nonce ctxt hash in let ctxt = Contract.init_origination_nonce ctxt hash in
begin match operation.contents with begin match operation.contents with
| Anonymous_operations ops -> | Anonymous_operations ops ->
@ -727,7 +727,7 @@ let apply_operation ctxt pred_block hash operation =
>>=? fun (ctxt, results) -> >>=? fun (ctxt, results) ->
return (ctxt, Anonymous_operations_result (List.rev results)) return (ctxt, Anonymous_operations_result (List.rev results))
| Sourced_operation ops -> | Sourced_operation ops ->
apply_sourced_operation ctxt pred_block operation ops apply_sourced_operation ctxt mode pred_block operation ops
>>=? fun (ctxt, result) -> >>=? fun (ctxt, result) ->
return (ctxt, Sourced_operation_result result) return (ctxt, Sourced_operation_result result)
end >>=? fun (ctxt, result) -> end >>=? fun (ctxt, result) ->

41
src/proto_alpha/lib_protocol/src/contract_services.ml
View File

@ -19,17 +19,20 @@ type info = {
delegate: bool * public_key_hash option ; delegate: bool * public_key_hash option ;
counter: int32 ; counter: int32 ;
script: Script.t option ; script: Script.t option ;
storage: Script.expr option ;
} }
let info_encoding = let info_encoding =
let open Data_encoding in let open Data_encoding in
conv conv
(fun {manager ; balance ; spendable ; delegate ; script ; counter ; storage } -> (fun {manager ; balance ; spendable ; delegate ;
(manager, balance, spendable, delegate, script, storage, counter)) script ; counter } ->
(fun (manager, balance, spendable, delegate, script, storage, counter) -> (manager, balance, spendable, delegate,
{manager ; balance ; spendable ; delegate ; script ; storage ; counter}) @@ script, counter))
obj7 (fun (manager, balance, spendable, delegate,
script, counter) ->
{manager ; balance ; spendable ; delegate ;
script ; counter}) @@
obj6
(req "manager" Signature.Public_key_hash.encoding) (req "manager" Signature.Public_key_hash.encoding)
(req "balance" Tez.encoding) (req "balance" Tez.encoding)
(req "spendable" bool) (req "spendable" bool)
@ -37,7 +40,6 @@ let info_encoding =
(req "setable" bool) (req "setable" bool)
(opt "value" Signature.Public_key_hash.encoding)) (opt "value" Signature.Public_key_hash.encoding))
(opt "script" Script.encoding) (opt "script" Script.encoding)
(opt "storage" Script.expr_encoding)
(req "counter" int32) (req "counter" int32)
module S = struct module S = struct
@ -172,8 +174,17 @@ let () =
register_field S.delegatable Contract.is_delegatable ; register_field S.delegatable Contract.is_delegatable ;
register_opt_field S.script register_opt_field S.script
(fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ; (fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ;
register_opt_field S.storage register_opt_field S.storage (fun ctxt contract ->
(fun c v -> Contract.get_storage c v >>=? fun (_, v) -> return v) ; Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
match script with
| None -> return None
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt script >>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script >>=? fun (script, _ctxt) ->
Lwt.return (Script.force_decode script.storage) >>=? fun storage ->
return (Some storage)) ;
register_field S.info (fun ctxt contract -> register_field S.info (fun ctxt contract ->
Contract.get_balance ctxt contract >>=? fun balance -> Contract.get_balance ctxt contract >>=? fun balance ->
Contract.get_manager ctxt contract >>=? fun manager -> Contract.get_manager ctxt contract >>=? fun manager ->
@ -182,10 +193,18 @@ let () =
Contract.is_delegatable ctxt contract >>=? fun delegatable -> Contract.is_delegatable ctxt contract >>=? fun delegatable ->
Contract.is_spendable ctxt contract >>=? fun spendable -> Contract.is_spendable ctxt contract >>=? fun spendable ->
Contract.get_script ctxt contract >>=? fun (ctxt, script) -> Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
Contract.get_storage ctxt contract >>=? fun (_ctxt, storage) -> begin match script with
| None -> return (None, ctxt)
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt script >>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
return (Some script, ctxt)
end >>=? fun (script, _ctxt) ->
return { manager ; balance ; return { manager ; balance ;
spendable ; delegate = (delegatable, delegate) ; spendable ; delegate = (delegatable, delegate) ;
script ; counter ; storage}) script ; counter })
let list ctxt block = let list ctxt block =
RPC_context.make_call0 S.list ctxt block () () RPC_context.make_call0 S.list ctxt block () ()

1
src/proto_alpha/lib_protocol/src/contract_services.mli
View File

@ -19,7 +19,6 @@ type info = {
delegate: bool * public_key_hash option ; delegate: bool * public_key_hash option ;
counter: int32 ; counter: int32 ;
script: Script.t option ; script: Script.t option ;
storage: Script.expr option ;
} }
val info_encoding: info Data_encoding.t val info_encoding: info Data_encoding.t

8
src/proto_alpha/lib_protocol/src/helpers_services.ml
View File

@ -141,7 +141,7 @@ module I = struct
| None -> Error_monad.fail Operation.Cannot_parse_operation | None -> Error_monad.fail Operation.Cannot_parse_operation
| Some (shell, contents) -> | Some (shell, contents) ->
let operation = { shell ; contents ; signature } in let operation = { shell ; contents ; signature } in
Apply.apply_operation ctxt pred_block hash operation Apply.apply_operation ctxt Readable pred_block hash operation
>>=? fun (_, result) -> return result >>=? fun (_, result) -> return result
end end
@ -161,7 +161,7 @@ let () =
let storage = Script.lazy_expr storage in let storage = Script.lazy_expr storage in
let code = Script.lazy_expr code in let code = Script.lazy_expr code in
Script_interpreter.execute Script_interpreter.execute
ctxt ctxt Readable
~source:contract (* transaction initiator *) ~source:contract (* transaction initiator *)
~payer:contract (* storage fees payer *) ~payer:contract (* storage fees payer *)
~self:(contract, { storage ; code }) (* script owner *) ~self:(contract, { storage ; code }) (* script owner *)
@ -176,7 +176,7 @@ let () =
let storage = Script.lazy_expr storage in let storage = Script.lazy_expr storage in
let code = Script.lazy_expr code in let code = Script.lazy_expr code in
Script_interpreter.trace Script_interpreter.trace
ctxt ctxt Readable
~source:contract (* transaction initiator *) ~source:contract (* transaction initiator *)
~payer:contract (* storage fees payer *) ~payer:contract (* storage fees payer *)
~self:(contract, { storage ; code }) (* script owner *) ~self:(contract, { storage ; code }) (* script owner *)
@ -205,7 +205,7 @@ let () =
| Some gas -> Lwt.return (Gas.set_limit ctxt gas) end >>=? fun ctxt -> | Some gas -> Lwt.return (Gas.set_limit ctxt gas) end >>=? fun ctxt ->
Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ, _) -> Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ, _) ->
parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) -> parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) ->
Lwt.return (Script_ir_translator.hash_data ctxt typ data) >>=? fun (hash, ctxt) -> Script_ir_translator.hash_data ctxt typ data >>=? fun (hash, ctxt) ->
return (hash, Gas.level ctxt) return (hash, Gas.level ctxt)
end ; end ;
register1 S.level begin fun ctxt raw () offset -> register1 S.level begin fun ctxt raw () offset ->

2
src/proto_alpha/lib_protocol/src/main.ml
View File

@ -110,7 +110,7 @@ let apply_operation ({ mode ; ctxt ; op_count ; _ } as data) operation =
{ block_header = { shell = { predecessor ; _ } ; _ } ; _ } { block_header = { shell = { predecessor ; _ } ; _ } ; _ }
| Full_construction { predecessor ; _ } -> | Full_construction { predecessor ; _ } ->
predecessor in predecessor in
Apply.apply_operation ctxt predecessor Apply.apply_operation ctxt Optimized predecessor
(Alpha_context.Operation.hash operation) operation >>=? fun (ctxt, _) -> (Alpha_context.Operation.hash operation) operation >>=? fun (ctxt, _) ->
let op_count = op_count + 1 in let op_count = op_count + 1 in
return { data with ctxt ; op_count } return { data with ctxt ; op_count }

55
src/proto_alpha/lib_protocol/src/script_interpreter.ml
View File

@ -64,13 +64,13 @@ let unparse_stack ctxt (stack, stack_ty) =
(* We drop the gas limit as this function is only used for debugging/errors. *) (* We drop the gas limit as this function is only used for debugging/errors. *)
let ctxt = Gas.set_unlimited ctxt in let ctxt = Gas.set_unlimited ctxt in
let rec unparse_stack let rec unparse_stack
: type a. a stack * a stack_ty -> Script.expr list : type a. a stack * a stack_ty -> Script.expr list tzresult Lwt.t
= function = function
| Empty, Empty_t -> [] | Empty, Empty_t -> return []
| Item (v, rest), Item_t (ty, rest_ty, _) -> | Item (v, rest), Item_t (ty, rest_ty, _) ->
match unparse_data ctxt ty v with unparse_data ctxt Readable ty v >>=? fun (data, _ctxt) ->
| Ok (data, _ctxt) -> Micheline.strip_locations data :: unparse_stack (rest, rest_ty) unparse_stack (rest, rest_ty) >>=? fun rest ->
| Error _ -> assert false in return (Micheline.strip_locations data :: rest) in
unparse_stack (stack, stack_ty) unparse_stack (stack, stack_ty)
module Interp_costs = Michelson_v1_gas.Cost_of module Interp_costs = Michelson_v1_gas.Cost_of
@ -100,7 +100,8 @@ let rec interp
match log with match log with
| None -> return (ret, ctxt) | None -> return (ret, ctxt)
| Some log -> | Some log ->
log := (descr.loc, Gas.level ctxt, unparse_stack ctxt (ret, descr.aft)) :: !log ; unparse_stack ctxt (ret, descr.aft) >>=? fun stack ->
log := (descr.loc, Gas.level ctxt, stack) :: !log ;
return (ret, ctxt) in return (ret, ctxt) in
let consume_gas_terop : type ret arg1 arg2 arg3 rest. let consume_gas_terop : type ret arg1 arg2 arg3 rest.
(_ * (_ * (_ * rest)), ret * rest) descr -> (_ * (_ * (_ * rest)), ret * rest) descr ->
@ -588,7 +589,7 @@ let rec interp
| Transfer_tokens, | Transfer_tokens,
Item (p, Item (amount, Item ((tp, destination), rest))) -> Item (p, Item (amount, Item ((tp, destination), rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->
Lwt.return @@ unparse_data ctxt tp p >>=? fun (p, ctxt) -> unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) ->
let operation = let operation =
Transaction Transaction
{ amount ; destination ; { amount ; destination ;
@ -623,7 +624,7 @@ let rec interp
(Seq (0, [ Prim (0, K_parameter, [ unparse_ty None param_type ], None) ; (Seq (0, [ Prim (0, K_parameter, [ unparse_ty None param_type ], None) ;
Prim (0, K_storage, [ unparse_ty None storage_type ], None) ; Prim (0, K_storage, [ unparse_ty None storage_type ], None) ;
Prim (0, K_code, [ Micheline.root code ], None) ], None)) in Prim (0, K_code, [ Micheline.root code ], None) ], None)) in
Lwt.return @@ unparse_data ctxt storage_type init >>=? fun (storage, ctxt) -> unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) ->
let storage = Micheline.strip_locations storage in let storage = Micheline.strip_locations storage in
Contract.spend_from_script ctxt self credit >>=? fun ctxt -> Contract.spend_from_script ctxt self credit >>=? fun ctxt ->
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
@ -661,7 +662,7 @@ let rec interp
logged_return (Item (Signature.Public_key.hash key, rest), ctxt) logged_return (Item (Signature.Public_key.hash key, rest), ctxt)
| H ty, Item (v, rest) -> | H ty, Item (v, rest) ->
Lwt.return (Gas.consume ctxt (Interp_costs.hash v)) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt (Interp_costs.hash v)) >>=? fun ctxt ->
Lwt.return @@ hash_data ctxt ty v >>=? fun (hash, ctxt) -> hash_data ctxt ty v >>=? fun (hash, ctxt) ->
logged_return (Item (hash, rest), ctxt) logged_return (Item (hash, rest), ctxt)
| Steps_to_quota, rest -> | Steps_to_quota, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt ->
@ -680,16 +681,18 @@ let rec interp
logged_return (Item (amount, rest), ctxt) in logged_return (Item (amount, rest), ctxt) in
let stack = (Item (arg, Empty)) in let stack = (Item (arg, Empty)) in
begin match log with begin match log with
| None -> () | None -> return ()
| Some log -> | Some log ->
log := (code.loc, Gas.level ctxt, unparse_stack ctxt (stack, code.bef)) :: !log unparse_stack ctxt (stack, code.bef) >>=? fun stack ->
end ; log := (code.loc, Gas.level ctxt, stack) :: !log ;
return ()
end >>=? fun () ->
step ctxt code stack >>=? fun (Item (ret, Empty), ctxt) -> step ctxt code stack >>=? fun (Item (ret, Empty), ctxt) ->
return (ret, ctxt) return (ret, ctxt)
(* ---- contract handling ---------------------------------------------------*) (* ---- contract handling ---------------------------------------------------*)
and execute ?log ctxt ~source ~payer ~self script amount arg : and execute ?log ctxt mode ~source ~payer ~self script amount arg :
(Script.expr * internal_operation list * context * (Script.expr * internal_operation list * context *
Script_typed_ir.ex_big_map option) tzresult Lwt.t = Script_typed_ir.ex_big_map option) tzresult Lwt.t =
parse_script ctxt script parse_script ctxt script
@ -700,7 +703,7 @@ and execute ?log ctxt ~source ~payer ~self script amount arg :
(Runtime_contract_error (self, script_code)) (Runtime_contract_error (self, script_code))
(interp ?log ctxt ~source ~payer ~self amount code (arg, storage)) (interp ?log ctxt ~source ~payer ~self amount code (arg, storage))
>>=? fun ((ops, sto), ctxt) -> >>=? fun ((ops, sto), ctxt) ->
Lwt.return @@ unparse_data ctxt storage_type sto >>=? fun (storage, ctxt) -> unparse_data ctxt mode storage_type sto >>=? fun (storage, ctxt) ->
return (Micheline.strip_locations storage, ops, ctxt, return (Micheline.strip_locations storage, ops, ctxt,
Script_ir_translator.extract_big_map storage_type sto) Script_ir_translator.extract_big_map storage_type sto)
@ -710,26 +713,26 @@ type execution_result =
big_map_diff : Contract.big_map_diff option ; big_map_diff : Contract.big_map_diff option ;
operations : internal_operation list } operations : internal_operation list }
let trace ctxt ~source ~payer ~self:(self, script) ~parameter ~amount = let trace ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount =
let log = ref [] in let log = ref [] in
execute ~log ctxt ~source ~payer ~self script amount (Micheline.root parameter) execute ~log ctxt mode ~source ~payer ~self script amount (Micheline.root parameter)
>>=? fun (storage, operations, ctxt, big_map_diff) -> >>=? fun (storage, operations, ctxt, big_map) ->
begin match big_map_diff with begin match big_map with
| None -> return (None, ctxt) | None -> return (None, ctxt)
| Some big_map_diff -> | Some big_map ->
Script_ir_translator.to_serializable_big_map ctxt big_map_diff >>=? fun (big_map_diff, ctxt) -> Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) ->
return (Some big_map_diff, ctxt) return (Some big_map_diff, ctxt)
end >>=? fun (big_map_diff, ctxt) -> end >>=? fun (big_map_diff, ctxt) ->
let trace = List.rev !log in let trace = List.rev !log in
return ({ ctxt ; storage ; big_map_diff ; operations }, trace) return ({ ctxt ; storage ; big_map_diff ; operations }, trace)
let execute ctxt ~source ~payer ~self:(self, script) ~parameter ~amount = let execute ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount =
execute ctxt ~source ~payer ~self script amount (Micheline.root parameter) execute ctxt mode ~source ~payer ~self script amount (Micheline.root parameter)
>>=? fun (storage, operations, ctxt, big_map_diff) -> >>=? fun (storage, operations, ctxt, big_map) ->
begin match big_map_diff with begin match big_map with
| None -> return (None, ctxt) | None -> return (None, ctxt)
| Some big_map_diff -> | Some big_map ->
Script_ir_translator.to_serializable_big_map ctxt big_map_diff >>=? fun (big_map_diff, ctxt) -> Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) ->
return (Some big_map_diff, ctxt) return (Some big_map_diff, ctxt)
end >>=? fun (big_map_diff, ctxt) -> end >>=? fun (big_map_diff, ctxt) ->
return { ctxt ; storage ; big_map_diff ; operations } return { ctxt ; storage ; big_map_diff ; operations }

2
src/proto_alpha/lib_protocol/src/script_interpreter.mli
View File

@ -21,6 +21,7 @@ type execution_result =
val execute: val execute:
Alpha_context.t -> Alpha_context.t ->
Script_ir_translator.unparsing_mode ->
source: Contract.t -> source: Contract.t ->
payer: Contract.t -> payer: Contract.t ->
self: (Contract.t * Script.t) -> self: (Contract.t * Script.t) ->
@ -33,6 +34,7 @@ type execution_trace =
val trace: val trace:
Alpha_context.t -> Alpha_context.t ->
Script_ir_translator.unparsing_mode ->
source: Contract.t -> source: Contract.t ->
payer: Contract.t -> payer: Contract.t ->
self: (Contract.t * Script.t) -> self: (Contract.t * Script.t) ->

435
src/proto_alpha/lib_protocol/src/script_ir_translator.ml
View File

@ -22,6 +22,8 @@ type tc_context =
| Dip : 'a stack_ty * tc_context -> tc_context | Dip : 'a stack_ty * tc_context -> tc_context
| Toplevel : { storage_type : 'sto ty ; param_type : 'param ty } -> tc_context | Toplevel : { storage_type : 'sto ty ; param_type : 'param ty } -> tc_context
type unparsing_mode = Optimized | Readable
let add_dip ty annot prev = let add_dip ty annot prev =
match prev with match prev with
| Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev) | Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev)
@ -488,7 +490,7 @@ let map_size
fun (module Box) -> fun (module Box) ->
Script_int.(abs (of_int (snd Box.boxed))) Script_int.(abs (of_int (snd Box.boxed)))
(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) (* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*)
let ty_of_comparable_ty let ty_of_comparable_ty
: type a. a comparable_ty -> a ty = function : type a. a comparable_ty -> a ty = function
@ -560,120 +562,6 @@ let rec unparse_ty
let tr = unparse_ty None utr in let tr = unparse_ty None utr in
Prim (-1, T_big_map, [ ta; tr ], None) Prim (-1, T_big_map, [ ta; tr ], None)
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse
let rec unparse_data
: type a. context -> a ty -> a -> (Script.node * context) tzresult
= fun ctxt ty a ->
Gas.consume ctxt Unparse_costs.cycle >>? fun gas ->
match ty, a with
| Unit_t, () ->
Gas.consume ctxt Unparse_costs.unit >|? fun gas ->
(Prim (-1, D_Unit, [], None), gas)
| Int_t, v ->
Gas.consume ctxt (Unparse_costs.int v) >|? fun gas ->
(Int (-1, Script_int.to_zint v), gas)
| Nat_t, v ->
Gas.consume ctxt (Unparse_costs.int v) >|? fun gas ->
(Int (-1, Script_int.to_zint v), gas)
| String_t, s ->
Gas.consume ctxt (Unparse_costs.string s) >|? fun gas ->
(String (-1, s), gas)
| Bool_t, true ->
Gas.consume ctxt Unparse_costs.bool >|? fun gas ->
(Prim (-1, D_True, [], None), gas)
| Bool_t, false ->
Gas.consume ctxt Unparse_costs.bool >|? fun gas ->
(Prim (-1, D_False, [], None), gas)
| Timestamp_t, t ->
Gas.consume ctxt (Unparse_costs.timestamp t) >>? fun gas ->
begin
match Script_timestamp.to_notation t with
| None -> ok @@ (Int (-1, Script_timestamp.to_zint t), gas)
| Some s -> ok @@ (String (-1, s), gas)
end
| Address_t, c ->
Gas.consume ctxt Unparse_costs.contract >|? fun gas ->
(String (-1, Contract.to_b58check c), gas)
| Contract_t _, (_, c) ->
Gas.consume ctxt Unparse_costs.contract >|? fun gas ->
(String (-1, Contract.to_b58check c), gas)
| Signature_t, s ->
Gas.consume ctxt Unparse_costs.signature >|? fun gas ->
let `Hex text =
MBytes.to_hex
(Data_encoding.Binary.to_bytes_exn Signature.encoding s) in
(String (-1, text), gas)
| Mutez_t, v ->
Gas.consume ctxt Unparse_costs.tez >|? fun gas ->
(Int (-1, Z.of_int64 (Tez.to_mutez v)), gas)
| Key_t, k ->
Gas.consume ctxt Unparse_costs.key >|? fun gas ->
(String (-1, Signature.Public_key.to_b58check k), gas)
| Key_hash_t, k ->
Gas.consume ctxt Unparse_costs.key_hash >|? fun gas ->
(String (-1, Signature.Public_key_hash.to_b58check k), gas)
| Operation_t, op ->
let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in
let `Hex text = MBytes.to_hex bytes in
Gas.consume ctxt (Unparse_costs.operation bytes) >>? fun ctxt ->
ok (String (-1, text), ctxt)
| Pair_t ((tl, _), (tr, _)), (l, r) ->
Gas.consume ctxt Unparse_costs.pair >>? fun gas ->
unparse_data gas tl l >>? fun (l, gas) ->
unparse_data gas tr r >|? fun (r, gas) ->
(Prim (-1, D_Pair, [ l; r ], None), gas)
| Union_t ((tl, _), _), L l ->
Gas.consume ctxt Unparse_costs.union >>? fun gas ->
unparse_data gas tl l >|? fun (l, gas) ->
(Prim (-1, D_Left, [ l ], None), gas)
| Union_t (_, (tr, _)), R r ->
Gas.consume ctxt Unparse_costs.union >>? fun gas ->
unparse_data gas tr r >|? fun (r, gas) ->
(Prim (-1, D_Right, [ r ], None), gas)
| Option_t t, Some v ->
Gas.consume ctxt Unparse_costs.some >>? fun gas ->
unparse_data gas t v >|? fun (v, gas) ->
(Prim (-1, D_Some, [ v ], None), gas)
| Option_t _, None ->
Gas.consume ctxt Unparse_costs.none >|? fun gas ->
(Prim (-1, D_None, [], None), gas)
| List_t t, items ->
List.fold_right
(fun element acc ->
acc >>? fun (l, ctxt) ->
Gas.consume ctxt Unparse_costs.list_element >>? fun ctxt ->
unparse_data ctxt t element >>? fun (unparsed, ctxt) ->
ok (unparsed :: l, ctxt))
items
(ok ([], ctxt)) >|? fun (items, gas) ->
(Micheline.Seq (-1, items, None), gas)
| Set_t t, set ->
let t = ty_of_comparable_ty t in
set_fold
(fun item acc ->
acc >>? fun (l, ctxt) ->
Gas.consume ctxt Unparse_costs.set_element >>? fun ctxt ->
unparse_data ctxt t item >>? fun (item, ctxt) ->
ok (item :: l, ctxt))
set (ok ([], ctxt)) >|? fun (items, gas) ->
(Micheline.Seq (-1, List.rev items, None), gas)
| Map_t (kt, vt), map ->
let kt = ty_of_comparable_ty kt in
map_fold
(fun k v acc ->
acc >>? fun (l, ctxt) ->
Gas.consume ctxt Unparse_costs.map_element >>? fun ctxt ->
unparse_data ctxt kt k >>? fun (key, ctxt) ->
unparse_data ctxt vt v >>? fun (value, ctxt) ->
ok (Prim (-1, D_Elt, [ key ; value ], None) :: l, ctxt))
map (ok ([], ctxt)) >|? fun (items, gas) ->
(Micheline.Seq (-1, List.rev items, None), gas)
| Big_map_t (_kt, _kv), _map ->
ok (Micheline.Seq (-1, [], None), gas)
| Lambda_t _, Lam (_, original_code) ->
ok (root original_code, gas)
(* ---- Equality witnesses --------------------------------------------------*) (* ---- Equality witnesses --------------------------------------------------*)
type ('ta, 'tb) eq = Eq : ('same, 'same) eq type ('ta, 'tb) eq = Eq : ('same, 'same) eq
@ -1051,6 +939,16 @@ let rec unparse_stack
type ex_script = Ex_script : ('a, 'c) script -> ex_script type ex_script = Ex_script : ('a, 'c) script -> ex_script
let public_key_hash_size =
match Data_encoding.Binary.fixed_length Signature.Public_key_hash.encoding with
| None -> assert false
| Some size -> size
let signature_size =
match Data_encoding.Binary.fixed_length Signature.encoding with
| None -> assert false
| Some size -> size
let rec parse_data let rec parse_data
: type a. : type a.
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
@ -1088,6 +986,14 @@ let rec parse_data
fail (error ())) fail (error ()))
(None, empty_map key_type, ctxt) items |> traced >>|? fun (_, items, ctxt) -> (None, empty_map key_type, ctxt) items |> traced >>|? fun (_, items, ctxt) ->
(items, ctxt) in (items, ctxt) in
let bytes_of_padded_z z =
let bytes = Z.to_bits z in
let len = MBytes.length bytes in
if Compare.Int.(MBytes.length bytes = 0)
|| Compare.Char.(MBytes.get_char bytes (MBytes.length bytes - 1) <> '\xFF') then
fail (error ())
else
return (MBytes.sub bytes 0 (len - 1)) in
match ty, script_data with match ty, script_data with
(* Unit *) (* Unit *)
| Unit_t, Prim (_, D_Unit, [], _) -> | Unit_t, Prim (_, D_Unit, [], _) ->
@ -1147,9 +1053,9 @@ let rec parse_data
| Mutez_t, expr -> | Mutez_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Timestamps *) (* Timestamps *)
| Timestamp_t, (Int (_, v)) -> | Timestamp_t, (Int (_, v)) (* As unparsed with [Optimized] or out of bounds [Readable]. *) ->
return (Script_timestamp.of_zint v, ctxt) return (Script_timestamp.of_zint v, ctxt)
| Timestamp_t, String (_, s) -> | Timestamp_t, String (_, s) (* As unparsed with [Redable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) >>=? fun ctxt ->
begin try begin try
match Script_timestamp.of_string s with match Script_timestamp.of_string s with
@ -1160,7 +1066,14 @@ let rec parse_data
| Timestamp_t, expr -> | Timestamp_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ; Int_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ String_kind ; Int_kind ], kind expr)))
(* IDs *) (* IDs *)
| Key_t, String (_, s) -> | Key_t, Int (_, z) -> (* As unparsed with [Optimized]. *)
Lwt.return (Gas.consume ctxt Typecheck_costs.key) >>=? fun ctxt ->
bytes_of_padded_z z >>=? fun bytes ->
begin match Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes with
| Some k -> return (k, ctxt)
| None -> fail (error ())
end
| Key_t, String (_, s) -> (* As unparsed with [Readable]. *)
Lwt.return (Gas.consume ctxt Typecheck_costs.key) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Typecheck_costs.key) >>=? fun ctxt ->
begin begin
try try
@ -1169,24 +1082,38 @@ let rec parse_data
end end
| Key_t, expr -> | Key_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
| Key_hash_t, String (_, s) -> | Key_hash_t, Int (_, z) -> (* As unparsed with [Optimized]. *)
Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) >>=? fun ctxt ->
begin
let bytes = Z.to_bits ~pad_to:public_key_hash_size z in
match Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes with
| Some k -> return (k, ctxt)
| None -> fail (error ())
end
| Key_hash_t, String (_, s) (* As unparsed with [Readable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) >>=? fun ctxt ->
begin begin
try try
return (Signature.Public_key_hash.of_b58check_exn s, ctxt) return (Signature.Public_key_hash.of_b58check_exn s, ctxt)
with _ -> fail (error ()) end with _ -> fail (error ())
end
| Key_hash_t, expr -> | Key_hash_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Signatures *) (* Signatures *)
| Signature_t, String (_, s) -> begin try | Signature_t, Int (_, z) (* As unparsed with [Optimized]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.signature) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Typecheck_costs.signature) >>=? fun ctxt ->
match Data_encoding.Binary.of_bytes begin
Signature.encoding let bytes = Z.to_bits ~pad_to:signature_size z in
(MBytes.of_hex (`Hex s)) with match Data_encoding.Binary.of_bytes Signature.encoding bytes with
| Some s -> return (s, ctxt) | Some k -> return (k, ctxt)
| None -> raise Not_found | None -> fail (error ())
with _ -> end
fail (error ()) | Signature_t, String (_, s) (* As unparsed with [Readable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.signature) >>=? fun ctxt ->
begin
try
return (Signature.of_b58check_exn s, ctxt)
with _ -> fail (error ())
end end
| Signature_t, expr -> | Signature_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
@ -1204,20 +1131,35 @@ let rec parse_data
| Operation_t, expr -> | Operation_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Addresses *) (* Addresses *)
| Address_t, String (_, s) -> | Address_t, Int (_, z) (* As unparsed with [O[ptimized]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt ->
traced @@ bytes_of_padded_z z >>=? fun bytes ->
(Lwt.return (Contract.of_b58check s)) >>=? fun c -> begin match Data_encoding.Binary.of_bytes Contract.encoding bytes with
| Some c -> return (c, ctxt)
| None -> fail (error ())
end
| Address_t, String (_, s) (* As unparsed with [Readable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt ->
traced (Lwt.return (Contract.of_b58check s)) >>=? fun c ->
return (c, ctxt) return (c, ctxt)
| Address_t, expr -> | Address_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Contracts *) (* Contracts *)
| Contract_t ty1, String (loc, s) -> | Contract_t ty, Int (loc, z) (* As unparsed with [Optimized]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt ->
bytes_of_padded_z z >>=? fun bytes ->
begin match Data_encoding.Binary.of_bytes Contract.encoding bytes with
| Some c ->
traced (parse_contract ctxt loc ty c) >>=? fun (ctxt, _) ->
return ((ty, c), ctxt)
| None -> fail (error ())
end
| Contract_t ty, String (loc, s) (* As unparsed with [Readable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt ->
traced @@ traced @@
(Lwt.return (Contract.of_b58check s)) >>=? fun c -> Lwt.return (Contract.of_b58check s) >>=? fun c ->
parse_contract ctxt loc ty1 c >>=? fun (ctxt, _) -> parse_contract ctxt loc ty c >>=? fun (ctxt, _) ->
return ((ty1, c), ctxt) return ((ty, c), ctxt)
| Contract_t _, expr -> | Contract_t _, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Pairs *) (* Pairs *)
@ -2340,17 +2282,204 @@ let typecheck_data
(parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun (_, ctxt) -> (parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun (_, ctxt) ->
return ctxt return ctxt
(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*)
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse
let rec unparse_data
: type a. context -> unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t
= fun ctxt mode ty a ->
let padded_z_of_bytes bytes =
let bytes = MBytes.concat "" [ bytes ; MBytes.of_string "\xFF" ] in
Z.of_bits bytes in
Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt ->
match ty, a with
| Unit_t, () ->
Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt ->
return (Prim (-1, D_Unit, [], None), ctxt)
| Int_t, v ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
return (Int (-1, Script_int.to_zint v), ctxt)
| Nat_t, v ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
return (Int (-1, Script_int.to_zint v), ctxt)
| String_t, s ->
Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt ->
return (String (-1, s), ctxt)
| Bool_t, true ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
return (Prim (-1, D_True, [], None), ctxt)
| Bool_t, false ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
return (Prim (-1, D_False, [], None), ctxt)
| Timestamp_t, t ->
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt ->
begin
match mode with
| Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
| Readable ->
match Script_timestamp.to_notation t with
| None -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
| Some s -> return (String (-1, s), ctxt)
end
| Address_t, c ->
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
return (Int (-1, padded_z_of_bytes bytes), ctxt)
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
end
| Contract_t _, (_, c) ->
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
return (Int (-1, padded_z_of_bytes bytes), ctxt)
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
end
| Signature_t, s ->
Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
return (Int (-1, Z.of_bits bytes), ctxt)
| Readable ->
return (String (-1, Signature.to_b58check s), ctxt)
end
| Mutez_t, v ->
Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt ->
return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
| Key_t, k ->
Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in
return (Int (-1, padded_z_of_bytes bytes), ctxt)
| Readable ->
return (String (-1, Signature.Public_key.to_b58check k), ctxt)
end
| Key_hash_t, k ->
Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in
return (Int (-1, Z.of_bits bytes), ctxt)
| Readable ->
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt)
end
| Operation_t, op ->
let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in
let `Hex text = MBytes.to_hex bytes in
Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt ->
return (String (-1, text), ctxt)
| Pair_t ((tl, _), (tr, _)), (l, r) ->
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
unparse_data ctxt mode tl l >>=? fun (l, ctxt) ->
unparse_data ctxt mode tr r >>=? fun (r, ctxt) ->
return (Prim (-1, D_Pair, [ l; r ], None), ctxt)
| Union_t ((tl, _), _), L l ->
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
unparse_data ctxt mode tl l >>=? fun (l, ctxt) ->
return (Prim (-1, D_Left, [ l ], None), ctxt)
| Union_t (_, (tr, _)), R r ->
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
unparse_data ctxt mode tr r >>=? fun (r, ctxt) ->
return (Prim (-1, D_Right, [ r ], None), ctxt)
| Option_t t, Some v ->
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
unparse_data ctxt mode t v >>=? fun (v, ctxt) ->
return (Prim (-1, D_Some, [ v ], None), ctxt)
| Option_t _, None ->
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt ->
return (Prim (-1, D_None, [], None), ctxt)
| List_t t, items ->
fold_left_s
(fun (l, ctxt) element ->
Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt ->
unparse_data ctxt mode t element >>=? fun (unparsed, ctxt) ->
return (unparsed :: l, ctxt))
([], ctxt)
items >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, List.rev items, None), ctxt)
| Set_t t, set ->
let t = ty_of_comparable_ty t in
fold_left_s
(fun (l, ctxt) item ->
Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt ->
unparse_data ctxt mode t item >>=? fun (item, ctxt) ->
return (item :: l, ctxt))
([], ctxt)
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, items, None), ctxt)
| Map_t (kt, vt), map ->
let kt = ty_of_comparable_ty kt in
fold_left_s
(fun (l, ctxt) (k, v) ->
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
unparse_data ctxt mode kt k >>=? fun (key, ctxt) ->
unparse_data ctxt mode vt v >>=? fun (value, ctxt) ->
return (Prim (-1, D_Elt, [ key ; value ], None) :: l, ctxt))
([], ctxt)
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, items, None), ctxt)
| Big_map_t (_kt, _kv), _map ->
return (Micheline.Seq (-1, [], None), ctxt)
| Lambda_t _, Lam (_, original_code) ->
unparse_code ctxt mode (root original_code)
and unparse_code ctxt mode = function
| Prim (loc, I_PUSH, [ ty ; data ], annot) ->
Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, _) ->
parse_data ctxt t data >>=? fun (data, ctxt) ->
unparse_data ctxt mode t data >>=? fun (data, ctxt) ->
return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt)
| Seq (loc, items, annot) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code ctxt mode item >>=? fun (item, ctxt) ->
return (item :: l, ctxt))
([], ctxt) items >>=? fun (items, ctxt) ->
return (Micheline.Seq (loc, List.rev items, annot), ctxt)
| Prim (loc, prim, items, annot) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code ctxt mode item >>=? fun (item, ctxt) ->
return (item :: l, ctxt))
([], ctxt) items >>=? fun (items, ctxt) ->
return (Prim (loc, prim, List.rev items, annot), ctxt)
| Int _ | String _ as atom -> return (atom, ctxt)
let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } =
let Lam (_, original_code) = code in
unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) ->
unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) ->
let arg_type = unparse_ty None arg_type in
let storage_type = unparse_ty None storage_type in
let open Micheline in
let code =
Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], None) ;
Prim (-1, K_storage, [ storage_type ], None) ;
Prim (-1, K_code, [ code ], None) ], None) in
return ({ code = lazy_expr (strip_locations code) ;
storage = lazy_expr (strip_locations storage) }, ctxt)
let hash_data ctxt typ data = let hash_data ctxt typ data =
unparse_data ctxt typ data >|? fun (data, ctxt) -> unparse_data ctxt Optimized typ data >>=? fun (data, ctxt) ->
let unparsed = strip_annotations @@ data in let unparsed = strip_annotations @@ data in
let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in
(Script_expr_hash.(hash_bytes [ bytes ] |> to_b58check), ctxt) return (Script_expr_hash.(hash_bytes [ bytes ] |> to_b58check), ctxt)
(* ---------------- Big map -------------------------------------------------*) (* ---------------- Big map -------------------------------------------------*)
let big_map_mem ctxt contract key { diff ; key_type ; _ } = let big_map_mem ctxt contract key { diff ; key_type ; _ } =
match map_get key diff with match map_get key diff with
| None -> Lwt.return @@ hash_data ctxt key_type key >>=? fun (hash, ctxt) -> | None -> hash_data ctxt key_type key >>=? fun (hash, ctxt) ->
Alpha_context.Contract.Big_map.mem ctxt contract hash >>=? fun (ctxt, res) -> Alpha_context.Contract.Big_map.mem ctxt contract hash >>=? fun (ctxt, res) ->
return (res, ctxt) return (res, ctxt)
| Some None -> return (false, ctxt) | Some None -> return (false, ctxt)
@ -2360,7 +2489,7 @@ let big_map_get ctxt contract key { diff ; key_type ; value_type } =
match map_get key diff with match map_get key diff with
| Some x -> return (x, ctxt) | Some x -> return (x, ctxt)
| None -> | None ->
Lwt.return @@ hash_data ctxt key_type key >>=? fun (hash, ctxt) -> hash_data ctxt key_type key >>=? fun (hash, ctxt) ->
Alpha_context.Contract.Big_map.get_opt Alpha_context.Contract.Big_map.get_opt
ctxt contract hash >>=? begin function ctxt contract hash >>=? begin function
| (ctxt, None) -> return (None, ctxt) | (ctxt, None) -> return (None, ctxt)
@ -2373,19 +2502,19 @@ let big_map_get ctxt contract key { diff ; key_type ; value_type } =
let big_map_update key value ({ diff ; _ } as map) = let big_map_update key value ({ diff ; _ } as map) =
{ map with diff = map_set key value diff } { map with diff = map_set key value diff }
let to_big_map_diff_list ctxt { key_type ; value_type ; diff } = let diff_of_big_map ctxt mode (Ex_bm { key_type ; value_type ; diff }) =
Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.map_to_list diff)) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.map_to_list diff)) >>=? fun ctxt ->
let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in
fold_left_s fold_left_s
(fun (acc, ctxt) (key, value) -> (fun (acc, ctxt) (key, value) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt ->
Lwt.return @@ hash_data ctxt key_type key >>=? fun (hash, ctxt) -> hash_data ctxt key_type key >>=? fun (hash, ctxt) ->
begin begin
match value with match value with
| None -> return (None, ctxt) | None -> return (None, ctxt)
| Some x -> | Some x ->
begin begin
Lwt.return @@ unparse_data ctxt value_type x >>=? fun (node, ctxt) -> unparse_data ctxt mode value_type x >>=? fun (node, ctxt) ->
return (Some (Micheline.strip_locations node), ctxt) return (Some (Micheline.strip_locations node), ctxt)
end end
end >>=? fun (value, ctxt) -> end >>=? fun (value, ctxt) ->
@ -2398,23 +2527,7 @@ let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x ->
| Pair_t ((Big_map_t (_, _), _), _), (map, _) -> Some (Ex_bm map) | Pair_t ((Big_map_t (_, _), _), _), (map, _) -> Some (Ex_bm map)
| _, _ -> None | _, _ -> None
let to_serializable_big_map gas (Ex_bm bm) = let erase_big_map_initialization ctxt mode ({ code ; storage } : Script.t) =
to_big_map_diff_list gas bm
let to_printable_big_map ctxt (Ex_bm { diff ; key_type ; value_type }) =
let un_error = function
| Ok x -> x
| Error _ -> Pervasives.failwith "Raise to_printiable_big_map gas limit" in
let ctxt = Gas.set_unlimited ctxt in
let unparse ty value =
fst @@ un_error @@ unparse_data ctxt ty value in
let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in
List.fold_left
(fun acc (key, value) ->
((Micheline.strip_locations @@ unparse key_type key,
Option.map ~f:(fun x -> Micheline.strip_locations @@ unparse value_type x) value) :: acc)) [] pairs
let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) =
Lwt.return (Script.force_decode code) >>=? fun code -> Lwt.return (Script.force_decode code) >>=? fun code ->
Lwt.return (Script.force_decode storage) >>=? fun storage -> Lwt.return (Script.force_decode storage) >>=? fun storage ->
Lwt.return @@ parse_toplevel code >>=? fun (_, storage_type, _) -> Lwt.return @@ parse_toplevel code >>=? fun (_, storage_type, _) ->
@ -2424,9 +2537,9 @@ let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) =
begin begin
match extract_big_map ty storage with match extract_big_map ty storage with
| None -> return (None, ctxt) | None -> return (None, ctxt)
| Some bm -> to_serializable_big_map ctxt bm >>=? fun (bm, ctxt) -> | Some bm -> diff_of_big_map ctxt mode bm >>=? fun (bm, ctxt) ->
return (Some bm, ctxt) return (Some bm, ctxt)
end >>=? fun (bm, ctxt) -> end >>=? fun (bm, ctxt) ->
Lwt.return @@ unparse_data ctxt ty storage >>=? fun (storage, ctxt) -> unparse_data ctxt mode ty storage >>=? fun (storage, ctxt) ->
return ({ code = Script.lazy_expr code ; return ({ code = Script.lazy_expr code ;
storage = Script.lazy_expr (Micheline.strip_locations storage) }, bm, ctxt) storage = Script.lazy_expr (Micheline.strip_locations storage) }, bm, ctxt)

23
src/proto_alpha/lib_protocol/src/script_ir_translator.mli
View File

@ -17,6 +17,8 @@ type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty
type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty
type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script
type unparsing_mode = Optimized | Readable
(* ---- Sets and Maps -------------------------------------------------------*) (* ---- Sets and Maps -------------------------------------------------------*)
val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set
@ -60,7 +62,8 @@ val parse_data :
context -> context ->
'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t 'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t
val unparse_data : val unparse_data :
context -> 'a Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult context -> unparsing_mode ->
'a Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult Lwt.t
val parse_ty : val parse_ty :
allow_big_map: bool -> allow_big_map: bool ->
@ -83,23 +86,23 @@ val typecheck_data :
val parse_script : val parse_script :
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> Script.t -> (ex_script * context) tzresult Lwt.t context -> Script.t -> (ex_script * context) tzresult Lwt.t
val unparse_script :
context -> unparsing_mode ->
('a, 'b) Script_typed_ir.script -> (Script.t * context) tzresult Lwt.t
val parse_contract : val parse_contract :
context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->
(context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t
val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (string * context) tzresult val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (string * context) tzresult Lwt.t
val extract_big_map : 'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option val extract_big_map :
'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option
val to_serializable_big_map : val diff_of_big_map :
context -> Script_typed_ir.ex_big_map -> context -> unparsing_mode -> Script_typed_ir.ex_big_map ->
(Contract.big_map_diff * context) tzresult Lwt.t (Contract.big_map_diff * context) tzresult Lwt.t
val to_printable_big_map :
context -> Script_typed_ir.ex_big_map ->
(Script.expr * Script.expr option) list
val erase_big_map_initialization : val erase_big_map_initialization :
context -> Script.t -> context -> unparsing_mode -> Script.t ->
(Script.t * Contract.big_map_diff option * context) tzresult Lwt.t (Script.t * Contract.big_map_diff option * context) tzresult Lwt.t

2
src/proto_alpha/lib_protocol/test/helpers/helpers_apply.ml
View File

@ -38,7 +38,7 @@ let operation
return @@ Helpers_operation.apply_of_proto src op_sh proto_op >>=? fun operation -> return @@ Helpers_operation.apply_of_proto src op_sh proto_op >>=? fun operation ->
let hash = Proto_alpha.Alpha_context.Operation.hash operation in let hash = Proto_alpha.Alpha_context.Operation.hash operation in
Proto_alpha.Apply.apply_operation Proto_alpha.Apply.apply_operation
tc tc Readable
pred_block_hash pred_block_hash
hash hash
operation operation

2
src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml
View File

@ -32,7 +32,7 @@ let execute_code_pred
Lwt.return (Proto_alpha.Alpha_context.Gas.set_limit tc gas) >>=? fun tc -> Lwt.return (Proto_alpha.Alpha_context.Gas.set_limit tc gas) >>=? fun tc ->
let tc = Contract.init_origination_nonce tc hash in let tc = Contract.init_origination_nonce tc hash in
Script_interpreter.execute Script_interpreter.execute
tc tc Readable
~source: op.contract ~source: op.contract
~payer: op.contract ~payer: op.contract
~self: (dst, script) ~self: (dst, script)

2
src/proto_alpha/lib_protocol/test/test_big_maps.ml
View File

@ -47,7 +47,7 @@ let expect_big_map tc contract print_key key_type print_data data_type contents
let open Proto_alpha.Error_monad in let open Proto_alpha.Error_monad in
iter_p iter_p
(fun (n, exp) -> (fun (n, exp) ->
Lwt.return @@ Proto_alpha.Script_ir_translator.hash_data tc key_type n >>=? fun (key, tc) -> Proto_alpha.Script_ir_translator.hash_data tc key_type n >>=? fun (key, tc) ->
Proto_alpha.Alpha_context.Contract.Big_map.get_opt tc contract key >>=? fun (_tc, data) -> Proto_alpha.Alpha_context.Contract.Big_map.get_opt tc contract key >>=? fun (_tc, data) ->
match data, exp with match data, exp with
| None, None -> | None, None ->

6
src/proto_alpha/lib_protocol/test/test_michelson.ml
View File

@ -65,7 +65,7 @@ let parse_execute sb ?tc code_str param_str storage_str =
>>=?? fun (dst, { ctxt = tc ; operations = ops ; big_map_diff = bgm }) -> >>=?? fun (dst, { ctxt = tc ; operations = ops ; big_map_diff = bgm }) ->
let payer = let payer =
(List.hd Account.bootstrap_accounts).contract in (List.hd Account.bootstrap_accounts).contract in
Proto_alpha.Apply.apply_internal_manager_operations tc ~payer ops >>= function Proto_alpha.Apply.apply_internal_manager_operations tc Readable ~payer ops >>= function
| Error result -> | Error result ->
let _, err = extract_result result in let _, err = extract_result result in
Lwt.return (Alpha_environment.wrap_error (Error_monad.error (List.hd err))) Lwt.return (Alpha_environment.wrap_error (Error_monad.error (List.hd err)))
@ -409,9 +409,9 @@ let test_example () =
test_storage ~location: __LOC__ "map_caddaadr" "(Pair (Pair 1 (Pair 2 (Pair (Pair (Pair 3 0) 4) 5))) 6)" "Unit" "(Pair (Pair 1 (Pair 2 (Pair (Pair (Pair 3 1000000) 4) 5))) 6)" >>=? fun _ -> test_storage ~location: __LOC__ "map_caddaadr" "(Pair (Pair 1 (Pair 2 (Pair (Pair (Pair 3 0) 4) 5))) 6)" "Unit" "(Pair (Pair 1 (Pair 2 (Pair (Pair (Pair 3 1000000) 4) 5))) 6)" >>=? fun _ ->
(* Did the given key sign the string? (key is bootstrap1) *) (* Did the given key sign the string? (key is bootstrap1) *)
test_success ~location: __LOC__ "check_signature" "(Pair \"1f19f8f37e80d96797b019f30d23ede6a26a0f698220f942103a3401f047623746e51a9c6e77e269b5df9593994ab96b001aae0f73728a2259187cb640b61e01\" \"hello\")" "\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" >>=? fun _ -> test_success ~location: __LOC__ "check_signature" "(Pair \"edsigtbsm9RwhfQuJWSmZrvbDqDR9t1TJs34KrX4wkt9uUJ4PJG1aT6uLDiCqKz6vcGZAbNpoW7PvXUzdXo1E3c6ap6GoUU366J\" \"hello\")" "\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" >>=? fun _ ->
test_fails ~location: __LOC__ "check_signature" "(Pair \"1f19f8f37e80d96797b019f30d23ede6a26a0f698220f942103a3401f047623746e51a9c6e77e269b5df9593994ab96b001aae0f73728a2259187cb640b61e01\" \"abcd\")" "\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" >>=? fun _ -> test_fails ~location: __LOC__ "check_signature" "(Pair \"edsigtbsm9RwhfQuJWSmZrvbDqDR9t1TJs34KrX4wkt9uUJ4PJG1aT6uLDiCqKz6vcGZAbNpoW7PvXUzdXo1E3c6ap6GoUU366J\" \"abcd\")" "\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" >>=? fun _ ->
(* Convert a public key to a public key hash *) (* Convert a public key to a public key hash *)
test_output ~location: __LOC__ "hash_key" "None" "\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" "(Some \"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx\")" >>=? fun _ -> test_output ~location: __LOC__ "hash_key" "None" "\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" "(Some \"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx\")" >>=? fun _ ->