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)
assert_success $client run program $contract_dir/check_signature.tz \
on storage '(Pair "1f19f8f37e80d96797b019f30d23ede6a26a0f698220f942103a3401f047623746e51a9c6e77e269b5df9593994ab96b001aae0f73728a2259187cb640b61e01" "hello")' \
on storage '(Pair 0x011eb640b67c1859228a72730fae1a006bb94a999395dfb569e2776e9c1ae546376247f001343a1042f92082690f6aa2e6ed230df319b09767d9807ef3f8191f "hello")' \
and input '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"'
assert_fails $client run program $contract_dir/check_signature.tz \
on storage '(Pair "1f19f8f37e80d96797b019f30d23ede6a26a0f698220f942103a3401f047623746e51a9c6e77e269b5df9593994ab96b001aae0f73728a2259187cb640b61e01" "abcd")' \
on storage '(Pair 0x011eb640b67c1859228a72730fae1a006bb94a999395dfb569e2776e9c1ae546376247f001343a1042f92082690f6aa2e6ed230df319b09767d9807ef3f8191f "abcd")' \
and input '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"'

2
src/lib_protocol_environment/sigs/jbuild
View File

@ -14,12 +14,12 @@
v1/format.mli
;; Part of external libraries
v1/mBytes.mli
v1/z.mli
v1/lwt.mli
v1/lwt_list.mli
;; Tezos extended stdlib
v1/mBytes.mli
v1/compare.mli
v1/data_encoding.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
(** 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 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 Format = Format
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 = Lwt
module Lwt_list = Lwt_list
module MBytes = MBytes
module Uri = Uri
module Data_encoding = Data_encoding
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 =
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 ->
let `Hex signature = Signature.to_hex signature in
return (hash, signature, gas)
return (hash, Signature.to_b58check signature, gas)
let typecheck_data
?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))
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
Contract.must_exist ctxt source >>=? fun () ->
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))
end >>=? fun (ctxt, parameter) ->
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 } ->
Contract.used_storage_space ctxt destination >>=? fun old_size ->
Contract.update_script_storage
@ -477,7 +477,7 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
| None -> return (None, ctxt)
| Some script ->
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)
end >>=? fun (script, 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 ->
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 =
match worklist with
| [] -> Lwt.return (Ok (ctxt, applied))
@ -514,7 +514,7 @@ let apply_internal_manager_operations ctxt ~payer ops =
fail (Internal_operation_replay op)
else
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
| Error errors ->
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 [] ops
let apply_manager_operations ctxt source ops =
let apply_manager_operations ctxt mode source ops =
let rec apply ctxt applied ops =
match ops with
| [] -> Lwt.return (Ok (ctxt, List.rev applied))
| 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
| Error errors ->
let result = External, Failed errors in
@ -542,7 +542,7 @@ let apply_manager_operations ctxt source ops =
match result with
| Transaction_result { operations = emitted ; _ } -> emitted
| _ -> [] in
apply_internal_manager_operations ctxt ~payer:source emitted
apply_internal_manager_operations ctxt mode ~payer:source emitted
>>= function
| Error (results) ->
let result = (External, Applied result) in
@ -554,7 +554,7 @@ let apply_manager_operations ctxt source ops =
apply ctxt applied rest in
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
| Manager_operations { source ; fee ; counter ; operations ; gas_limit ; storage_limit } ->
let revealed_public_keys =
@ -580,7 +580,7 @@ let apply_sourced_operation ctxt pred_block operation ops =
let ctxt = reset_internal_nonce ctxt in
Lwt.return (Gas.set_limit ctxt gas_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)
| Error operation_results -> return (ctxt (* backtracked *), 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 ->
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
begin match operation.contents with
| Anonymous_operations ops ->
@ -727,7 +727,7 @@ let apply_operation ctxt pred_block hash operation =
>>=? fun (ctxt, results) ->
return (ctxt, Anonymous_operations_result (List.rev results))
| Sourced_operation ops ->
apply_sourced_operation ctxt pred_block operation ops
apply_sourced_operation ctxt mode pred_block operation ops
>>=? fun (ctxt, result) ->
return (ctxt, Sourced_operation_result 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 ;
counter: int32 ;
script: Script.t option ;
storage: Script.expr option ;
}
let info_encoding =
let open Data_encoding in
conv
(fun {manager ; balance ; spendable ; delegate ; script ; counter ; storage } ->
(manager, balance, spendable, delegate, script, storage, counter))
(fun (manager, balance, spendable, delegate, script, storage, counter) ->
{manager ; balance ; spendable ; delegate ; script ; storage ; counter}) @@
obj7
(fun {manager ; balance ; spendable ; delegate ;
script ; counter } ->
(manager, balance, spendable, delegate,
script, counter))
(fun (manager, balance, spendable, delegate,
script, counter) ->
{manager ; balance ; spendable ; delegate ;
script ; counter}) @@
obj6
(req "manager" Signature.Public_key_hash.encoding)
(req "balance" Tez.encoding)
(req "spendable" bool)
@ -37,7 +40,6 @@ let info_encoding =
(req "setable" bool)
(opt "value" Signature.Public_key_hash.encoding))
(opt "script" Script.encoding)
(opt "storage" Script.expr_encoding)
(req "counter" int32)
module S = struct
@ -172,8 +174,17 @@ let () =
register_field S.delegatable Contract.is_delegatable ;
register_opt_field S.script
(fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ;
register_opt_field S.storage
(fun c v -> Contract.get_storage c v >>=? fun (_, v) -> return v) ;
register_opt_field S.storage (fun ctxt contract ->
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 ->
Contract.get_balance ctxt contract >>=? fun balance ->
Contract.get_manager ctxt contract >>=? fun manager ->
@ -182,10 +193,18 @@ let () =
Contract.is_delegatable ctxt contract >>=? fun delegatable ->
Contract.is_spendable ctxt contract >>=? fun spendable ->
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 ;
spendable ; delegate = (delegatable, delegate) ;
script ; counter ; storage})
script ; counter })
let 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 ;
counter: int32 ;
script: Script.t option ;
storage: Script.expr option ;
}
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
| Some (shell, contents) ->
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
end
@ -161,7 +161,7 @@ let () =
let storage = Script.lazy_expr storage in
let code = Script.lazy_expr code in
Script_interpreter.execute
ctxt
ctxt Readable
~source:contract (* transaction initiator *)
~payer:contract (* storage fees payer *)
~self:(contract, { storage ; code }) (* script owner *)
@ -176,7 +176,7 @@ let () =
let storage = Script.lazy_expr storage in
let code = Script.lazy_expr code in
Script_interpreter.trace
ctxt
ctxt Readable
~source:contract (* transaction initiator *)
~payer:contract (* storage fees payer *)
~self:(contract, { storage ; code }) (* script owner *)
@ -205,7 +205,7 @@ let () =
| 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, _) ->
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)
end ;
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 ; _ } ; _ } ; _ }
| Full_construction { predecessor ; _ } ->
predecessor in
Apply.apply_operation ctxt predecessor
Apply.apply_operation ctxt Optimized predecessor
(Alpha_context.Operation.hash operation) operation >>=? fun (ctxt, _) ->
let op_count = op_count + 1 in
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. *)
let ctxt = Gas.set_unlimited ctxt in
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
| Empty, Empty_t -> []
| Empty, Empty_t -> return []
| Item (v, rest), Item_t (ty, rest_ty, _) ->
match unparse_data ctxt ty v with
| Ok (data, _ctxt) -> Micheline.strip_locations data :: unparse_stack (rest, rest_ty)
| Error _ -> assert false in
unparse_data ctxt Readable ty v >>=? fun (data, _ctxt) ->
unparse_stack (rest, rest_ty) >>=? fun rest ->
return (Micheline.strip_locations data :: rest) in
unparse_stack (stack, stack_ty)
module Interp_costs = Michelson_v1_gas.Cost_of
@ -100,7 +100,8 @@ let rec interp
match log with
| None -> return (ret, ctxt)
| 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
let consume_gas_terop : type ret arg1 arg2 arg3 rest.
(_ * (_ * (_ * rest)), ret * rest) descr ->
@ -588,7 +589,7 @@ let rec interp
| Transfer_tokens,
Item (p, Item (amount, Item ((tp, destination), rest))) ->
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 =
Transaction
{ amount ; destination ;
@ -623,7 +624,7 @@ let rec interp
(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_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
Contract.spend_from_script ctxt self credit >>=? fun ctxt ->
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)
| H ty, Item (v, rest) ->
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)
| Steps_to_quota, rest ->
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
let stack = (Item (arg, Empty)) in
begin match log with
| None -> ()
| None -> return ()
| Some log ->
log := (code.loc, Gas.level ctxt, unparse_stack ctxt (stack, code.bef)) :: !log
end ;
unparse_stack ctxt (stack, code.bef) >>=? fun stack ->
log := (code.loc, Gas.level ctxt, stack) :: !log ;
return ()
end >>=? fun () ->
step ctxt code stack >>=? fun (Item (ret, Empty), ctxt) ->
return (ret, ctxt)
(* ---- 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_typed_ir.ex_big_map option) tzresult Lwt.t =
parse_script ctxt script
@ -700,7 +703,7 @@ and execute ?log ctxt ~source ~payer ~self script amount arg :
(Runtime_contract_error (self, script_code))
(interp ?log ctxt ~source ~payer ~self amount code (arg, storage))
>>=? 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,
Script_ir_translator.extract_big_map storage_type sto)
@ -710,26 +713,26 @@ type execution_result =
big_map_diff : Contract.big_map_diff option ;
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
execute ~log ctxt ~source ~payer ~self script amount (Micheline.root parameter)
>>=? fun (storage, operations, ctxt, big_map_diff) ->
begin match big_map_diff with
execute ~log ctxt mode ~source ~payer ~self script amount (Micheline.root parameter)
>>=? fun (storage, operations, ctxt, big_map) ->
begin match big_map with
| None -> return (None, ctxt)
| Some big_map_diff ->
Script_ir_translator.to_serializable_big_map ctxt big_map_diff >>=? fun (big_map_diff, ctxt) ->
| Some big_map ->
Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) ->
return (Some big_map_diff, ctxt)
end >>=? fun (big_map_diff, ctxt) ->
let trace = List.rev !log in
return ({ ctxt ; storage ; big_map_diff ; operations }, trace)
let execute ctxt ~source ~payer ~self:(self, script) ~parameter ~amount =
execute ctxt ~source ~payer ~self script amount (Micheline.root parameter)
>>=? fun (storage, operations, ctxt, big_map_diff) ->
begin match big_map_diff with
let execute ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount =
execute ctxt mode ~source ~payer ~self script amount (Micheline.root parameter)
>>=? fun (storage, operations, ctxt, big_map) ->
begin match big_map with
| None -> return (None, ctxt)
| Some big_map_diff ->
Script_ir_translator.to_serializable_big_map ctxt big_map_diff >>=? fun (big_map_diff, ctxt) ->
| Some big_map ->
Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) ->
return (Some big_map_diff, ctxt)
end >>=? fun (big_map_diff, ctxt) ->
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:
Alpha_context.t ->
Script_ir_translator.unparsing_mode ->
source: Contract.t ->
payer: Contract.t ->
self: (Contract.t * Script.t) ->
@ -33,6 +34,7 @@ type execution_trace =
val trace:
Alpha_context.t ->
Script_ir_translator.unparsing_mode ->
source: Contract.t ->
payer: Contract.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
| Toplevel : { storage_type : 'sto ty ; param_type : 'param ty } -> tc_context
type unparsing_mode = Optimized | Readable
let add_dip ty annot prev =
match prev with
| Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev)
@ -488,7 +490,7 @@ let map_size
fun (module Box) ->
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
: type a. a comparable_ty -> a ty = function
@ -560,120 +562,6 @@ let rec unparse_ty
let tr = unparse_ty None utr in
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 --------------------------------------------------*)
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
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
: type a.
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
@ -1088,6 +986,14 @@ let rec parse_data
fail (error ()))
(None, empty_map key_type, ctxt) items |> traced >>|? fun (_, items, ctxt) ->
(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
(* Unit *)
| Unit_t, Prim (_, D_Unit, [], _) ->
@ -1147,9 +1053,9 @@ let rec parse_data
| Mutez_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* 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)
| Timestamp_t, String (_, s) ->
| Timestamp_t, String (_, s) (* As unparsed with [Redable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) >>=? fun ctxt ->
begin try
match Script_timestamp.of_string s with
@ -1160,7 +1066,14 @@ let rec parse_data
| Timestamp_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ; Int_kind ], kind expr)))
(* 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 ->
begin
try
@ -1169,24 +1082,38 @@ let rec parse_data
end
| Key_t, 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 ->
begin
try
return (Signature.Public_key_hash.of_b58check_exn s, ctxt)
with _ -> fail (error ()) end
with _ -> fail (error ())
end
| Key_hash_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* 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 ->
match Data_encoding.Binary.of_bytes
Signature.encoding
(MBytes.of_hex (`Hex s)) with
| Some s -> return (s, ctxt)
| None -> raise Not_found
with _ ->
fail (error ())
begin
let bytes = Z.to_bits ~pad_to:signature_size z in
match Data_encoding.Binary.of_bytes Signature.encoding bytes with
| Some k -> return (k, ctxt)
| None -> fail (error ())
end
| 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
| Signature_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
@ -1204,20 +1131,35 @@ let rec parse_data
| Operation_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Addresses *)
| Address_t, String (_, s) ->
| Address_t, Int (_, z) (* As unparsed with [O[ptimized]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt ->
traced @@
(Lwt.return (Contract.of_b58check s)) >>=? fun c ->
bytes_of_padded_z z >>=? fun bytes ->
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)
| Address_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* 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 ->
traced @@
(Lwt.return (Contract.of_b58check s)) >>=? fun c ->
parse_contract ctxt loc ty1 c >>=? fun (ctxt, _) ->
return ((ty1, c), ctxt)
Lwt.return (Contract.of_b58check s) >>=? fun c ->
parse_contract ctxt loc ty c >>=? fun (ctxt, _) ->
return ((ty, c), ctxt)
| Contract_t _, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Pairs *)
@ -2340,17 +2282,204 @@ let typecheck_data
(parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun (_, 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 =
unparse_data ctxt typ data >|? fun (data, ctxt) ->
unparse_data ctxt Optimized typ data >>=? fun (data, ctxt) ->
let unparsed = strip_annotations @@ data 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 -------------------------------------------------*)
let big_map_mem ctxt contract key { diff ; key_type ; _ } =
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) ->
return (res, 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
| Some x -> return (x, ctxt)
| 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
ctxt contract hash >>=? begin function
| (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) =
{ 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 ->
let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in
fold_left_s
(fun (acc, ctxt) (key, value) ->
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
match value with
| None -> return (None, ctxt)
| Some x ->
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)
end
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)
| _, _ -> None
let to_serializable_big_map gas (Ex_bm bm) =
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) =
let erase_big_map_initialization ctxt mode ({ code ; storage } : Script.t) =
Lwt.return (Script.force_decode code) >>=? fun code ->
Lwt.return (Script.force_decode storage) >>=? fun storage ->
Lwt.return @@ parse_toplevel code >>=? fun (_, storage_type, _) ->
@ -2424,9 +2537,9 @@ let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) =
begin
match extract_big_map ty storage with
| 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)
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 ;
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_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script
type unparsing_mode = Optimized | Readable
(* ---- Sets and Maps -------------------------------------------------------*)
val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set
@ -60,7 +62,8 @@ val parse_data :
context ->
'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t
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 :
allow_big_map: bool ->
@ -83,23 +86,23 @@ val typecheck_data :
val parse_script :
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
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 :
context -> Script.location -> 'a Script_typed_ir.ty -> Contract.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 :
context -> Script_typed_ir.ex_big_map ->
val diff_of_big_map :
context -> unparsing_mode -> Script_typed_ir.ex_big_map ->
(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 :
context -> Script.t ->
context -> unparsing_mode -> Script.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 ->
let hash = Proto_alpha.Alpha_context.Operation.hash operation in
Proto_alpha.Apply.apply_operation
tc
tc Readable
pred_block_hash
hash
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 ->
let tc = Contract.init_origination_nonce tc hash in
Script_interpreter.execute
tc
tc Readable
~source: op.contract
~payer: op.contract
~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
iter_p
(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) ->
match data, exp with
| 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 }) ->
let payer =
(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 ->
let _, err = extract_result result in
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 _ ->
(* 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 *)
test_output ~location: __LOC__ "hash_key" "None" "\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" "(Some \"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx\")" >>=? fun _ ->