533 lines
26 KiB
OCaml
533 lines
26 KiB
OCaml
(*****************************************************************************)
|
|
(* *)
|
|
(* Open Source License *)
|
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
|
|
(* Copyright (c) 2019 Cryptium Labs <contact@cryptium-labs.com> *)
|
|
(* *)
|
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
|
(* copy of this software and associated documentation files (the "Software"),*)
|
|
(* to deal in the Software without restriction, including without limitation *)
|
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
|
(* Software is furnished to do so, subject to the following conditions: *)
|
|
(* *)
|
|
(* The above copyright notice and this permission notice shall be included *)
|
|
(* in all copies or substantial portions of the Software. *)
|
|
(* *)
|
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
|
(* DEALINGS IN THE SOFTWARE. *)
|
|
(* *)
|
|
(*****************************************************************************)
|
|
|
|
let manager_script_code: Script_repr.lazy_expr =
|
|
let open Micheline in
|
|
let open Michelson_v1_primitives in
|
|
Script_repr.lazy_expr @@ strip_locations @@
|
|
Seq (0, [
|
|
Prim (0, K_parameter, [
|
|
Prim (0, T_or, [
|
|
Prim (0, T_lambda, [
|
|
Prim (0, T_unit, [], []);
|
|
Prim (0, T_list, [
|
|
Prim (0, T_operation, [], [])
|
|
], [])
|
|
], ["%do"]);
|
|
Prim (0, T_unit, [], ["%default"])
|
|
], [])
|
|
], []);
|
|
Prim (0, K_storage, [
|
|
Prim (0, T_key_hash, [], [])
|
|
], []);
|
|
Prim (0, K_code, [
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_DUP, [], []);
|
|
Prim (0, I_CAR, [], []);
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_CDR, [], [])
|
|
])
|
|
], [])
|
|
])
|
|
]);
|
|
Prim (0, I_IF_LEFT, [
|
|
Seq (0, [
|
|
Prim (0, I_PUSH, [
|
|
Prim (0, T_mutez, [], []);
|
|
Int (0, Z.zero)
|
|
], []);
|
|
Prim (0, I_AMOUNT, [], []);
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_COMPARE, [], []);
|
|
Prim (0, I_EQ, [], [])
|
|
]);
|
|
Prim (0, I_IF, [
|
|
Seq (0, []);
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_UNIT, [], []);
|
|
Prim (0, I_FAILWITH, [], [])
|
|
])
|
|
])
|
|
], [])
|
|
]);
|
|
Seq (0, [
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_DUP, [], [])
|
|
])
|
|
], []);
|
|
Prim (0, I_SWAP, [], [])
|
|
]);
|
|
Prim (0, I_IMPLICIT_ACCOUNT, [], []);
|
|
Prim (0, I_ADDRESS, [], []);
|
|
Prim (0, I_SENDER, [], []);
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_COMPARE, [], []);
|
|
Prim (0, I_EQ, [], [])
|
|
]);
|
|
Prim (0, I_IF, [
|
|
Seq (0, []);
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_UNIT, [], []);
|
|
Prim (0, I_FAILWITH, [], [])
|
|
])
|
|
])
|
|
], [])
|
|
]);
|
|
Prim (0, I_UNIT, [], []);
|
|
Prim (0, I_EXEC, [], []);
|
|
Prim (0, I_PAIR, [], [])
|
|
]);
|
|
Seq (0, [
|
|
Prim (0, I_DROP, [], []);
|
|
Prim (0, I_NIL, [
|
|
Prim (0, T_operation, [], [])
|
|
], []);
|
|
Prim (0, I_PAIR, [], [])
|
|
])
|
|
], [])
|
|
])
|
|
], [])
|
|
])
|
|
|
|
(* Find the toplevel expression with a given prim type from list,
|
|
because they can be in arbitrary order. *)
|
|
let find_toplevel toplevel exprs =
|
|
let open Micheline in
|
|
let rec iter toplevel = function
|
|
| (Prim (_, prim, _, _) as found) :: _
|
|
when String.equal toplevel (Michelson_v1_primitives.string_of_prim prim) ->
|
|
Some found
|
|
| _ :: rest ->
|
|
iter toplevel rest
|
|
| [] ->
|
|
None in
|
|
iter (Michelson_v1_primitives.string_of_prim toplevel) exprs
|
|
|
|
let add_do:
|
|
manager_pkh: Signature.Public_key_hash.t ->
|
|
script_code: Script_repr.lazy_expr ->
|
|
script_storage: Script_repr.lazy_expr ->
|
|
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
|
|
fun ~manager_pkh ~script_code ~script_storage ->
|
|
let open Micheline in
|
|
let open Michelson_v1_primitives in
|
|
Lwt.return (Script_repr.force_decode script_code) >>=? fun (script_code_expr, _gas_cost) ->
|
|
Lwt.return (Script_repr.force_decode script_storage) >>|? fun (script_storage_expr, _gas_cost) ->
|
|
let storage_expr = root script_storage_expr in
|
|
match root script_code_expr with
|
|
| Seq (_, toplevel)
|
|
-> begin
|
|
match find_toplevel K_parameter toplevel,
|
|
find_toplevel K_storage toplevel,
|
|
find_toplevel K_code toplevel with
|
|
Some (Prim (_, K_parameter, [
|
|
Prim (_, parameter_type, parameter_expr, parameter_annot)
|
|
], prim_param_annot)),
|
|
Some (Prim (_, K_storage, [
|
|
Prim (_, code_storage_type, code_storage_expr, code_storage_annot)
|
|
], k_storage_annot)),
|
|
Some (Prim (_, K_code, [code_expr], code_annot)) ->
|
|
(* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
|
|
|
|
let migrated_code =
|
|
Seq (0, [
|
|
Prim (0, K_parameter, [
|
|
Prim (0, T_or, [
|
|
Prim (0, T_lambda, [
|
|
Prim (0, T_unit, [], []);
|
|
Prim (0, T_list, [
|
|
Prim (0, T_operation, [], [])
|
|
], [])
|
|
], ["%do"]);
|
|
Prim (0, parameter_type, parameter_expr, "%default" :: parameter_annot)
|
|
], [])
|
|
], prim_param_annot);
|
|
Prim (0, K_storage, [
|
|
Prim (0, T_pair, [
|
|
Prim (0, T_key_hash, [], []);
|
|
Prim (0, code_storage_type, code_storage_expr, code_storage_annot)
|
|
], [])
|
|
], k_storage_annot);
|
|
Prim (0, K_code, [
|
|
Seq (0, [
|
|
Prim (0, I_DUP, [], []);
|
|
Prim (0, I_CAR, [], []);
|
|
Prim (0, I_IF_LEFT, [
|
|
Seq (0, [
|
|
Prim (0, I_PUSH, [
|
|
Prim (0, T_mutez, [], []);
|
|
Int (0, Z.zero)
|
|
], []);
|
|
Prim (0, I_AMOUNT, [], []);
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_COMPARE, [], []);
|
|
Prim (0, I_EQ, [], [])
|
|
]);
|
|
Prim (0, I_IF, [
|
|
Seq (0, []);
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_UNIT, [], []);
|
|
Prim (0, I_FAILWITH, [], [])
|
|
])
|
|
])
|
|
], [])
|
|
]);
|
|
Seq (0, [
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_DUP, [], [])
|
|
])
|
|
], []);
|
|
Prim (0, I_SWAP, [], [])
|
|
]);
|
|
Prim (0, I_CDR, [], []);
|
|
Prim (0, I_CAR, [], []);
|
|
Prim (0, I_IMPLICIT_ACCOUNT, [], []);
|
|
Prim (0, I_ADDRESS, [], []);
|
|
Prim (0, I_SENDER, [], []);
|
|
Seq (0, [
|
|
Prim (0, I_COMPARE, [], []);
|
|
Prim (0, I_NEQ, [], []);
|
|
Prim (0, I_IF, [
|
|
Seq (0, [
|
|
Prim (0, I_SENDER, [], []);
|
|
Prim (0, I_PUSH, [
|
|
Prim (0, T_string, [], []);
|
|
String (0, "Only the owner can operate.")
|
|
], []);
|
|
Prim (0, I_PAIR, [], []);
|
|
Prim (0, I_FAILWITH, [], [])
|
|
]);
|
|
Seq (0, [
|
|
Prim (0, I_UNIT, [], []);
|
|
Prim (0, I_EXEC, [], []);
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_CDR, [], [])
|
|
])
|
|
], []);
|
|
Prim (0, I_PAIR, [], [])
|
|
])
|
|
], [])
|
|
])
|
|
]);
|
|
Seq (0, [
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_CDR, [], []);
|
|
Prim (0, I_DUP, [], []);
|
|
Prim (0, I_CDR, [], [])
|
|
])
|
|
], []);
|
|
Prim (0, I_PAIR, [], []);
|
|
|
|
code_expr;
|
|
|
|
Prim (0, I_SWAP, [], []);
|
|
Prim (0, I_CAR, [], []);
|
|
Prim (0, I_SWAP, [], []);
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_DUP, [], []);
|
|
Prim (0, I_CAR, [], []);
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_CDR, [], [])
|
|
])
|
|
], [])
|
|
])
|
|
]);
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_SWAP, [], []);
|
|
Prim (0, I_PAIR, [], [])
|
|
])
|
|
], []);
|
|
Prim (0, I_PAIR, [], [])
|
|
])
|
|
], [])
|
|
])
|
|
], code_annot)
|
|
])
|
|
in
|
|
let migrated_storage = Prim (0, D_Pair, [
|
|
(* Instead of
|
|
`String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
|
|
the storage is written as unparsed with [Optimized] *)
|
|
Bytes (0, Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh) ;
|
|
storage_expr
|
|
], []) in
|
|
Script_repr.lazy_expr @@ strip_locations migrated_code,
|
|
Script_repr.lazy_expr @@ strip_locations migrated_storage
|
|
| _ ->
|
|
script_code, script_storage
|
|
end
|
|
| _ ->
|
|
script_code, script_storage
|
|
|
|
|
|
|
|
let add_set_delegate:
|
|
manager_pkh: Signature.Public_key_hash.t ->
|
|
script_code: Script_repr.lazy_expr ->
|
|
script_storage: Script_repr.lazy_expr ->
|
|
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
|
|
fun ~manager_pkh ~script_code ~script_storage ->
|
|
let open Micheline in
|
|
let open Michelson_v1_primitives in
|
|
Lwt.return (Script_repr.force_decode script_code) >>=? fun (script_code_expr, _gas_cost) ->
|
|
Lwt.return (Script_repr.force_decode script_storage) >>|? fun (script_storage_expr, _gas_cost) ->
|
|
let storage_expr = root script_storage_expr in
|
|
match root script_code_expr with
|
|
| Seq (_, toplevel)
|
|
-> begin
|
|
match find_toplevel K_parameter toplevel,
|
|
find_toplevel K_storage toplevel,
|
|
find_toplevel K_code toplevel with
|
|
Some (Prim (_, K_parameter, [
|
|
Prim (_, parameter_type, parameter_expr, parameter_annot)
|
|
], prim_param_annot)),
|
|
Some (Prim (_, K_storage, [
|
|
Prim (_, code_storage_type, code_storage_expr, code_storage_annot)
|
|
], k_storage_annot)),
|
|
Some (Prim (_, K_code, [code_expr], code_annot)) ->
|
|
(* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
|
|
|
|
let migrated_code =
|
|
Seq (0, [
|
|
Prim (0, K_parameter, [
|
|
Prim (0, T_or, [
|
|
Prim (0, T_or, [
|
|
Prim (0, T_key_hash, [], ["%set_delegate"]);
|
|
Prim (0, T_unit, [], ["%remove_delegate"])
|
|
], []);
|
|
Prim (0, parameter_type, parameter_expr, "%default" :: parameter_annot)
|
|
], [])
|
|
], prim_param_annot);
|
|
Prim (0, K_storage, [
|
|
Prim (0, T_pair, [
|
|
Prim (0, T_key_hash, [], []);
|
|
Prim (0, code_storage_type, code_storage_expr, code_storage_annot)
|
|
], [])
|
|
], k_storage_annot);
|
|
Prim (0, K_code, [
|
|
Seq (0, [
|
|
Prim (0, I_DUP, [], []);
|
|
Prim (0, I_CAR, [], []);
|
|
Prim (0, I_IF_LEFT, [
|
|
Seq (0, [
|
|
Prim (0, I_PUSH, [
|
|
Prim (0, T_mutez, [], []);
|
|
Int (0, Z.zero)
|
|
], []);
|
|
Prim (0, I_AMOUNT, [], []);
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_COMPARE, [], []);
|
|
Prim (0, I_EQ, [], [])
|
|
]);
|
|
Prim (0, I_IF, [
|
|
Seq (0, []);
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_UNIT, [], []);
|
|
Prim (0, I_FAILWITH, [], [])
|
|
])
|
|
])
|
|
], [])
|
|
]);
|
|
Seq (0, [
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_DUP, [], [])
|
|
])
|
|
], []);
|
|
Prim (0, I_SWAP, [], [])
|
|
]);
|
|
Prim (0, I_CDR, [], []);
|
|
Prim (0, I_CAR, [], []);
|
|
Prim (0, I_IMPLICIT_ACCOUNT, [], []);
|
|
Prim (0, I_ADDRESS, [], []);
|
|
Prim (0, I_SENDER, [], []);
|
|
Seq (0, [
|
|
Prim (0, I_COMPARE, [], []);
|
|
Prim (0, I_NEQ, [], []);
|
|
Prim (0, I_IF, [
|
|
Seq (0, [
|
|
Prim (0, I_SENDER, [], []);
|
|
Prim (0, I_PUSH, [
|
|
Prim (0, T_string, [], []);
|
|
String (0, "Only the owner can operate.")
|
|
], []);
|
|
Prim (0, I_PAIR, [], []);
|
|
Prim (0, I_FAILWITH, [], [])
|
|
]);
|
|
Seq (0, [
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_CDR, [], []);
|
|
Prim (0, I_NIL, [
|
|
Prim (0, T_operation, [], [])
|
|
], [])
|
|
])
|
|
], []);
|
|
Prim (0, I_IF_LEFT, [
|
|
Seq (0, [
|
|
Prim (0, I_SOME, [], []);
|
|
Prim (0, I_SET_DELEGATE, [], []);
|
|
Prim (0, I_CONS, [], []);
|
|
Prim (0, I_PAIR, [], [])
|
|
]);
|
|
Seq (0, [
|
|
Prim (0, I_DROP, [], []);
|
|
Prim (0, I_NONE, [
|
|
Prim (0, T_key_hash, [], [])
|
|
], []);
|
|
Prim (0, I_SET_DELEGATE, [], []);
|
|
Prim (0, I_CONS, [], []);
|
|
Prim (0, I_PAIR, [], [])
|
|
])
|
|
], [])
|
|
])
|
|
], [])
|
|
])
|
|
]);
|
|
Seq (0, [
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_CDR, [], []);
|
|
Prim (0, I_DUP, [], []);
|
|
Prim (0, I_CDR, [], [])
|
|
])
|
|
], []);
|
|
Prim (0, I_PAIR, [], []);
|
|
|
|
code_expr;
|
|
|
|
Prim (0, I_SWAP, [], []);
|
|
Prim (0, I_CAR, [], []);
|
|
Prim (0, I_SWAP, [], []);
|
|
Seq (0, [
|
|
Seq (0, [
|
|
Prim (0, I_DUP, [], []);
|
|
Prim (0, I_CAR, [], []);
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_CDR, [], [])
|
|
])
|
|
], [])
|
|
])
|
|
]);
|
|
Prim (0, I_DIP, [
|
|
Seq (0, [
|
|
Prim (0, I_SWAP, [], []);
|
|
Prim (0, I_PAIR, [], [])
|
|
])
|
|
], []);
|
|
Prim (0, I_PAIR, [], [])
|
|
])
|
|
], [])
|
|
])
|
|
], code_annot)
|
|
])
|
|
in
|
|
let migrated_storage = Prim (0, D_Pair, [
|
|
(* Instead of
|
|
`String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
|
|
the storage is written as unparsed with [Optimized] *)
|
|
Bytes (0, Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh) ;
|
|
storage_expr
|
|
], []) in
|
|
Script_repr.lazy_expr @@ strip_locations migrated_code,
|
|
Script_repr.lazy_expr @@ strip_locations migrated_storage
|
|
| _ ->
|
|
script_code, script_storage
|
|
end
|
|
| _ ->
|
|
script_code, script_storage
|
|
|
|
let has_default_entrypoint expr =
|
|
let open Micheline in
|
|
let open Michelson_v1_primitives in
|
|
match Script_repr.force_decode expr with
|
|
| Error _ -> false
|
|
| Ok (expr, _) ->
|
|
match root expr with
|
|
| Seq (_, toplevel) -> begin
|
|
match find_toplevel K_parameter toplevel with
|
|
| Some (Prim (_, K_parameter, [ _ ], [ "%default" ])) -> false
|
|
| Some (Prim (_, K_parameter, [ parameter_expr ], _)) ->
|
|
let rec has_default = function
|
|
| Prim (_, T_or, [ l ; r ], annots) ->
|
|
List.exists (String.equal "%default") annots || has_default l || has_default r
|
|
| Prim (_, _, _, annots) ->
|
|
List.exists (String.equal "%default") annots
|
|
| _ -> false
|
|
in
|
|
has_default parameter_expr
|
|
| Some _ | None -> false
|
|
end
|
|
| _ -> false
|
|
|
|
let add_root_entrypoint
|
|
: script_code: Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t
|
|
= fun ~script_code ->
|
|
let open Micheline in
|
|
let open Michelson_v1_primitives in
|
|
Lwt.return (Script_repr.force_decode script_code) >>|? fun (script_code_expr, _gas_cost) ->
|
|
match root script_code_expr with
|
|
| Seq (_, toplevel) ->
|
|
let migrated_code =
|
|
Seq (0, List.map (function
|
|
| Prim (_, K_parameter, [ parameter_expr ], _) ->
|
|
Prim (0, K_parameter, [ parameter_expr ], [ "%root" ])
|
|
| Prim (_, K_code, exprs, annots) ->
|
|
let rec rewrite_self = function
|
|
| Int _ | String _ | Bytes _ | Prim (_, I_CREATE_CONTRACT, _, _) as leaf -> leaf
|
|
| Prim (_, I_SELF, [], annots) ->
|
|
Prim (0, I_SELF, [], "%root" :: annots)
|
|
| Prim (_, name, args, annots) ->
|
|
Prim (0, name, List.map rewrite_self args, annots)
|
|
| Seq (_, args) ->
|
|
Seq (0, List.map rewrite_self args) in
|
|
Prim (0, K_code, List.map rewrite_self exprs, annots)
|
|
| other -> other)
|
|
toplevel) in
|
|
Script_repr.lazy_expr @@ strip_locations migrated_code
|
|
| _ ->
|
|
script_code
|