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

Alpha: lazily deserialize scripts

Browse Source
This commit is contained in:
Benjamin Canou 2018-05-04 15:05:20 +02:00 committed by Grégoire Henry
parent 5f39f2ceec
commit ce668e6afb
18 changed files with 128 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/proto_alpha/lib_client/client_proto_context.ml
View File

@ -49,6 +49,7 @@ let transfer (cctxt : #Proto_alpha.full)
Alpha_services.Contract.counter
cctxt block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
let parameters = Option.map ~f:Script.lazy_expr parameters in
let operations = [Transaction { amount ; parameters ; destination }] in
append_reveal cctxt block ~source ~src_pk operations >>=? fun operations ->
let contents =
@ -221,6 +222,7 @@ let originate_contract
Lwt.return (Michelson_v1_parser.parse_expression initial_storage) >>= fun result ->
Lwt.return (Micheline_parser.no_parsing_error result) >>=?
fun { Michelson_v1_parser.expanded = storage } ->
let code = Script.lazy_expr code and storage = Script.lazy_expr storage in
let origination =
Origination { manager ;
delegate ;

4
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml
View File

@ -248,6 +248,10 @@ let report_errors ~details ~show_source ?parsed ppf errs =
Contract.pp c
print_expr expected
| Apply.Bad_contract_parameter (c, Some expected, Some argument) ->
let argument =
Option.unopt_exn
(Failure "ill-serialized argument")
(Data_encoding.force_decode argument) in
Format.fprintf ppf
"@[<v 0>Contract %a expected an argument of type@, %a@,but received@, %a@]"
Contract.pp c

12
src/proto_alpha/lib_client/operation_result.ml
View File

@ -28,6 +28,10 @@ let pp_manager_operation_content ppf source operation internal pp_result result
begin match parameters with
| None -> ()
| Some expr ->
let expr =
Option.unopt_exn
(Failure "ill-serialized argument")
(Data_encoding.force_decode expr) in
Format.fprintf ppf
"@,Parameter: @[<v 0>%a@]"
Michelson_v1_printer.print_expr expr
@ -47,6 +51,14 @@ let pp_manager_operation_content ppf source operation internal pp_result result
begin match script with
| None -> Format.fprintf ppf "@,No script (accepts all transactions)"
| Some { code ; storage } ->
let code =
Option.unopt_exn
(Failure "ill-serialized code")
(Data_encoding.force_decode code)
and storage =
Option.unopt_exn
(Failure "ill-serialized storage")
(Data_encoding.force_decode storage) in
Format.fprintf ppf
"@,@[<hv 2>Script:@ %a\
@,@[<hv 2>Initial storage:@ %a@]"

13
src/proto_alpha/lib_protocol/src/alpha_context.mli
View File

@ -272,16 +272,23 @@ module Script : sig
type expr = prim Micheline.canonical
type lazy_expr = expr Data_encoding.lazy_t
val force_decode : lazy_expr -> expr tzresult
val force_bytes : lazy_expr -> MBytes.t tzresult
val lazy_expr : expr -> lazy_expr
type node = (location, prim) Micheline.node
type t =
{ code: expr ;
storage: expr }
{ code: lazy_expr ;
storage: lazy_expr }
val location_encoding: location Data_encoding.t
val expr_encoding: expr Data_encoding.t
val prim_encoding: prim Data_encoding.t
val encoding: t Data_encoding.t
val lazy_expr_encoding: lazy_expr Data_encoding.t
end
module Constants : sig
@ -788,7 +795,7 @@ and manager_operation =
| Reveal of Signature.Public_key.t
| Transaction of {
amount: Tez.t ;
parameters: Script.expr option ;
parameters: Script.lazy_expr option ;
destination: Contract.contract ;
}
| Origination of {

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

@ -14,7 +14,7 @@ open Alpha_context
type error += Wrong_voting_period of Voting_period.t * Voting_period.t (* `Temporary *)
type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t (* `Temporary *)
type error += Duplicate_endorsement of int (* `Branch *)
type error += Bad_contract_parameter of Contract.t * Script.expr option * Script.expr option (* `Permanent *)
type error += Bad_contract_parameter of Contract.t * Script.expr option * Script.lazy_expr option (* `Permanent *)
type error += Invalid_endorsement_level
type error += Invalid_commitment of { expected: bool }
@ -79,7 +79,7 @@ let () =
Data_encoding.(obj3
(req "contract" Contract.encoding)
(opt "expectedType" Script.expr_encoding)
(opt "providedArgument" Script.expr_encoding))
(opt "providedArgument" Script.lazy_expr_encoding))
(function Bad_contract_parameter (c, expected, supplied) ->
Some (c, expected, supplied) | _ -> None)
(fun (c, expected, supplied) -> Bad_contract_parameter (c, expected, supplied)) ;
@ -404,6 +404,7 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
match parameters with
| None -> return ()
| Some arg ->
Lwt.return (Script.force_decode arg) >>=? fun arg ->
match Micheline.root arg with
| Prim (_, D_Unit, [], _) ->
return ()
@ -422,16 +423,18 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
storage_size_diff = 0L } in
return (ctxt, result)
| Some script ->
Lwt.return @@ Script_ir_translator.parse_toplevel script.code >>=? fun (arg_type, _, _) ->
Lwt.return (Script.force_decode script.code) >>=? fun code ->
Lwt.return @@ Script_ir_translator.parse_toplevel code >>=? fun (arg_type, _, _) ->
let arg_type = Micheline.strip_locations arg_type in
begin match parameters, Micheline.root arg_type with
| None, Prim (_, T_unit, _, _) ->
return (ctxt, (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))))
| Some parameters, _ ->
Lwt.return (Script.force_decode parameters) >>=? fun arg ->
trace
(Bad_contract_parameter (destination, Some arg_type, Some parameters))
(Script_ir_translator.typecheck_data ctxt ~check_operations:true (parameters, arg_type)) >>=? fun ctxt ->
return (ctxt, parameters)
(Script_ir_translator.typecheck_data ctxt ~check_operations:true (arg, arg_type)) >>=? fun ctxt ->
return (ctxt, arg)
| None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None))
end >>=? fun (ctxt, parameter) ->
Script_interpreter.execute

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

@ -309,7 +309,12 @@ let get_script c contract =
| Some code, Some storage -> return (c, Some { Script_repr.code ; storage })
| None, Some _ | Some _, None -> failwith "get_script"
let get_storage = Storage.Contract.Storage.get_option
let get_storage ctxt contract =
Storage.Contract.Storage.get_option ctxt contract >>=? function
| (ctxt, None) -> return (ctxt, None)
| (ctxt, Some storage) ->
Lwt.return (Script_repr.force_decode storage) >>=? fun storage ->
return (ctxt, Some storage)
let get_counter c contract =
Storage.Contract.Counter.get_option c contract >>=? function
@ -370,6 +375,7 @@ let is_spendable c contract =
Storage.Contract.Spendable.mem c contract >>= return
let update_script_storage c contract storage big_map_diff =
let storage = Script_repr.lazy_expr storage in
update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size_diff) ->
Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) ->
Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size ->

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

@ -158,6 +158,8 @@ let () =
(code, storage, parameter, amount, contract) ->
Lwt.return (Gas.set_limit ctxt (Constants.hard_gas_limit_per_operation ctxt)) >>=? fun ctxt ->
let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
let storage = Script.lazy_expr storage in
let code = Script.lazy_expr code in
Script_interpreter.execute
ctxt
~check_operations:true
@ -172,6 +174,8 @@ let () =
(code, storage, parameter, amount, contract) ->
Lwt.return (Gas.set_limit ctxt (Constants.hard_gas_limit_per_operation ctxt)) >>=? fun ctxt ->
let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
let storage = Script.lazy_expr storage in
let code = Script.lazy_expr code in
Script_interpreter.trace
ctxt
~check_operations:true
@ -328,6 +332,7 @@ module Forge = struct
block ~branch ~source ?sourcePubKey ~counter
~amount ~destination ?parameters
~gas_limit ~storage_limit ~fee ()=
let parameters = Option.map ~f:Script.lazy_expr parameters in
operations ctxt block ~branch ~source ?sourcePubKey ~counter
~fee ~gas_limit ~storage_limit
Alpha_context.[Transaction { amount ; parameters ; destination }]

4
src/proto_alpha/lib_protocol/src/operation_repr.ml
View File

@ -82,7 +82,7 @@ and manager_operation =
| Reveal of Signature.Public_key.t
| Transaction of {
amount: Tez_repr.tez ;
parameters: Script_repr.expr option ;
parameters: Script_repr.lazy_expr option ;
destination: Contract_repr.contract ;
}
| Origination of {
@ -131,7 +131,7 @@ module Encoding = struct
(req "kind" (constant "transaction"))
(req "amount" Tez_repr.encoding)
(req "destination" Contract_repr.encoding)
(opt "parameters" Script_repr.expr_encoding)
(opt "parameters" Script_repr.lazy_expr_encoding)
let transaction_case tag =
case tag ~name:"Transaction" transaction_encoding

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

@ -82,7 +82,7 @@ and manager_operation =
| Reveal of Signature.Public_key.t
| Transaction of {
amount: Tez_repr.tez ;
parameters: Script_repr.expr option ;
parameters: Script_repr.lazy_expr option ;
destination: Contract_repr.contract ;
}
| Origination of {

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

@ -165,7 +165,9 @@ let rec interp
let operation =
Origination
{ credit ; manager ; delegate ; preorigination = Some contract ;
delegatable ; script = Some { code ; storage } ; spendable } in
delegatable ; spendable ;
script = Some { code = Script.lazy_expr code ;
storage = Script.lazy_expr storage } } in
logged_return descr (Item ({ source = self ; operation ; signature = None },
Item (contract, rest)), ctxt) in
let logged_return :
@ -666,7 +668,7 @@ let rec interp
let operation =
Transaction
{ amount ; destination ;
parameters = Some (Micheline.strip_locations p) } in
parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in
logged_return (Item ({ source = self ; operation ; signature = None }, rest), ctxt)
| Create_account,
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
@ -758,8 +760,9 @@ and execute ?log ctxt ~check_operations ~source ~payer ~self script amount arg :
parse_script ctxt ~check_operations script
>>=? fun ((Ex_script { code ; arg_type ; storage ; storage_type }), ctxt) ->
parse_data ctxt ~check_operations arg_type arg >>=? fun (arg, ctxt) ->
Lwt.return (Script.force_decode script.code) >>=? fun script_code ->
trace
(Runtime_contract_error (self, script.code))
(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) ->

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

@ -2267,7 +2267,8 @@ and parse_contract
ok (contract, ctxt))
| Some { code ; _ } ->
Lwt.return
(parse_toplevel code >>? fun (arg_type, _, _) ->
(Script.force_decode code >>? fun code ->
parse_toplevel code >>? fun (arg_type, _, _) ->
parse_ty ~allow_big_map:false arg_type >>? fun (Ex_ty targ, _) ->
ty_eq targ arg >>? fun Eq ->
let contract : arg typed_contract = (arg, contract) in
@ -2318,6 +2319,8 @@ let parse_script
: ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> check_operations:bool -> Script.t -> (ex_script * context) tzresult Lwt.t
= fun ?type_logger ctxt ~check_operations { code ; storage } ->
Lwt.return (Script.force_decode code) >>=? fun code ->
Lwt.return (Script.force_decode storage) >>=? fun storage ->
Lwt.return (parse_toplevel code) >>=? fun (arg_type, storage_type, code_field) ->
trace
(Ill_formed_type (Some "parameter", code, location arg_type))
@ -2348,7 +2351,8 @@ let parse_contract :
| _ -> fail (Invalid_contract (loc, contract))
end
| Some script ->
Lwt.return @@ parse_toplevel script.code >>=? fun (arg_type, _, _) ->
Lwt.return (Script.force_decode script.code) >>=? fun code ->
Lwt.return @@ parse_toplevel code >>=? fun (arg_type, _, _) ->
let arg_type = Micheline.strip_locations arg_type in
Lwt.return (parse_ty ~allow_big_map:false (Micheline.root arg_type)) >>=? fun (Ex_ty arg_type, _) ->
Lwt.return (ty_eq ty arg_type) >>=? fun Eq ->
@ -2468,6 +2472,8 @@ let to_printable_big_map ctxt (Ex_bm { diff ; key_type ; value_type }) =
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 storage) >>=? fun storage ->
Lwt.return @@ parse_toplevel code >>=? fun (_, storage_type, _) ->
Lwt.return @@ parse_ty ~allow_big_map:true storage_type >>=? fun (Ex_ty ty, _) ->
parse_data ctxt ~check_operations:true ty
@ -2479,4 +2485,5 @@ let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) =
return (Some bm, ctxt)
end >>=? fun (bm, ctxt) ->
Lwt.return @@ unparse_data ctxt ty storage >>=? fun (storage, ctxt) ->
return ({ code ; storage = Micheline.strip_locations storage }, bm, ctxt)
return ({ code = Script.lazy_expr code ;
storage = Script.lazy_expr (Micheline.strip_locations storage) }, bm, ctxt)

39
src/proto_alpha/lib_protocol/src/script_repr.ml
View File

@ -13,6 +13,8 @@ let location_encoding = Micheline.canonical_location_encoding
type expr = Michelson_v1_primitives.prim Micheline.canonical
type lazy_expr = expr Data_encoding.lazy_t
type node = (location, Michelson_v1_primitives.prim) Micheline.node
let expr_encoding =
@ -20,11 +22,44 @@ let expr_encoding =
~variant:"michelson_v1"
Michelson_v1_primitives.prim_encoding
type t = { code : expr ; storage : expr }
type error += Lazy_script_decode (* `Permanent *)
let () =
register_error_kind `Permanent
~id:"invalid_binary_format"
~title:"Invalid binary format"
~description:"Could not deserialize some piece of data \
from its binary representation"
Data_encoding.empty
(function Lazy_script_decode -> Some () | _ -> None)
(fun () -> Lazy_script_decode)
let lazy_expr_encoding =
Data_encoding.lazy_encoding expr_encoding
let lazy_expr expr =
Data_encoding.make_lazy expr_encoding expr
let force_decode expr =
match Data_encoding.force_decode expr with
| Some v -> ok v
| None -> error Lazy_script_decode
let force_bytes expr =
match Data_encoding.force_bytes expr with
| bytes -> ok bytes
| exception _ -> error Lazy_script_decode
type t = {
code : lazy_expr ;
storage : lazy_expr
}
let encoding =
let open Data_encoding in
conv
(fun { code ; storage } -> (code, storage))
(fun (code, storage) -> { code ; storage })
(obj2 (req "code" expr_encoding) (req "storage" expr_encoding))
(obj2
(req "code" lazy_expr_encoding)
(req "storage" lazy_expr_encoding))

14
src/proto_alpha/lib_protocol/src/script_repr.mli
View File

@ -11,12 +11,24 @@ type location = Micheline.canonical_location
type expr = Michelson_v1_primitives.prim Micheline.canonical
type error += Lazy_script_decode (* `Permanent *)
type lazy_expr = expr Data_encoding.lazy_t
val force_decode : lazy_expr -> expr tzresult
val force_bytes : lazy_expr -> MBytes.t tzresult
type node = (location, Michelson_v1_primitives.prim) Micheline.node
val location_encoding : location Data_encoding.t
val expr_encoding : expr Data_encoding.t
type t = { code : expr ; storage : expr }
val lazy_expr_encoding : lazy_expr Data_encoding.t
val lazy_expr : expr -> lazy_expr
type t = { code : lazy_expr ; storage : lazy_expr }
val encoding : t Data_encoding.encoding

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

@ -141,16 +141,16 @@ module Contract = struct
Indexed_context.Make_carbonated_map
(struct let name = ["code"] end)
(Make_carbonated_value(struct
type t = Script_repr.expr
let encoding = Script_repr.expr_encoding
type t = Script_repr.lazy_expr
let encoding = Script_repr.lazy_expr_encoding
end))
module Storage =
Indexed_context.Make_carbonated_map
(struct let name = ["storage"] end)
(Make_carbonated_value(struct
type t = Script_repr.expr
let encoding = Script_repr.expr_encoding
type t = Script_repr.lazy_expr
let encoding = Script_repr.lazy_expr_encoding
end))
type bigmap_key = Raw_context.t * Contract_repr.t

4
src/proto_alpha/lib_protocol/src/storage.mli
View File

@ -164,12 +164,12 @@ module Contract : sig
module Code : Indexed_carbonated_data_storage
with type key = Contract_repr.t
and type value = Script_repr.expr
and type value = Script_repr.lazy_expr
and type t := Raw_context.t
module Storage : Indexed_carbonated_data_storage
with type key = Contract_repr.t
and type value = Script_repr.expr
and type value = Script_repr.lazy_expr
and type t := Raw_context.t
(** Current storage space in bytes.

1
src/proto_alpha/lib_protocol/test/helpers/helpers_operation.ml
View File

@ -35,6 +35,7 @@ let manager_full src ?(fee = Tez.zero) ops context gas_limit =
let transaction ?parameters amount destination =
let parameters = Option.map ~f:Script.lazy_expr parameters in
Transaction {
amount ;
parameters ;

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

@ -25,7 +25,9 @@ let parse_expr s : Proto_alpha.Alpha_context.Script.expr tzresult =
let parse_script code_str storage_str : Proto_alpha.Alpha_context.Script.t tzresult =
parse_expr code_str >>? fun code ->
let code = Proto_alpha.Alpha_context.Script.lazy_expr code in
parse_expr storage_str >>? fun storage ->
let storage = Proto_alpha.Alpha_context.Script.lazy_expr storage in
ok { Proto_alpha.Alpha_context.Script.code ; storage }
let code = {|

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

@ -30,8 +30,8 @@ let parse_param s : Proto_alpha.Alpha_context.Script.expr =
let parse_script code_str storage_str : Proto_alpha.Alpha_context.Script.t =
let code = parse_param code_str in
let storage = parse_param storage_str in
let code = Script_repr.lazy_expr (parse_param code_str) in
let storage = Script_repr.lazy_expr (parse_param storage_str) in
let return: Proto_alpha.Alpha_context.Script.t = {code ; storage} in
return