(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) open Micheline type error += Unknown_primitive_name of string type error += Invalid_case of string type error += | Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location type prim = | K_parameter | K_storage | K_code | D_False | D_Elt | D_Left | D_None | D_Pair | D_Right | D_Some | D_True | D_Unit | I_PACK | I_UNPACK | I_BLAKE2B | I_SHA256 | I_SHA512 | I_ABS | I_ADD | I_AMOUNT | I_AND | I_BALANCE | I_CAR | I_CDR | I_CHAIN_ID | I_CHECK_SIGNATURE | I_COMPARE | I_CONCAT | I_CONS | I_CREATE_ACCOUNT | I_CREATE_CONTRACT | I_IMPLICIT_ACCOUNT | I_DIP | I_DROP | I_DUP | I_EDIV | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC | I_APPLY | I_FAILWITH | I_GE | I_GET | I_GT | I_HASH_KEY | I_IF | I_IF_CONS | I_IF_LEFT | I_IF_NONE | I_INT | I_LAMBDA | I_LE | I_LEFT | I_LOOP | I_LSL | I_LSR | I_LT | I_MAP | I_MEM | I_MUL | I_NEG | I_NEQ | I_NIL | I_NONE | I_NOT | I_NOW | I_OR | I_PAIR | I_PUSH | I_RIGHT | I_SIZE | I_SOME | I_SOURCE | I_SENDER | I_SELF | I_SLICE | I_STEPS_TO_QUOTA | I_SUB | I_SWAP | I_TRANSFER_TOKENS | I_SET_DELEGATE | I_UNIT | I_UPDATE | I_XOR | I_ITER | I_LOOP_LEFT | I_ADDRESS | I_CONTRACT | I_ISNAT | I_CAST | I_RENAME | I_DIG | I_DUG | T_bool | T_contract | T_int | T_key | T_key_hash | T_lambda | T_list | T_map | T_big_map | T_nat | T_option | T_or | T_pair | T_set | T_signature | T_string | T_bytes | T_mutez | T_timestamp | T_unit | T_operation | T_address | T_chain_id let valid_case name = let is_lower = function '_' | 'a' .. 'z' -> true | _ -> false in let is_upper = function '_' | 'A' .. 'Z' -> true | _ -> false in let rec for_all a b f = Compare.Int.(a > b) || (f a && for_all (a + 1) b f) in let len = String.length name in Compare.Int.(len <> 0) && Compare.Char.(name.[0] <> '_') && ( (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_upper name.[i])) || (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i])) || (is_lower name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i])) ) let string_of_prim = function | K_parameter -> "parameter" | K_storage -> "storage" | K_code -> "code" | D_False -> "False" | D_Elt -> "Elt" | D_Left -> "Left" | D_None -> "None" | D_Pair -> "Pair" | D_Right -> "Right" | D_Some -> "Some" | D_True -> "True" | D_Unit -> "Unit" | I_PACK -> "PACK" | I_UNPACK -> "UNPACK" | I_BLAKE2B -> "BLAKE2B" | I_SHA256 -> "SHA256" | I_SHA512 -> "SHA512" | I_ABS -> "ABS" | I_ADD -> "ADD" | I_AMOUNT -> "AMOUNT" | I_AND -> "AND" | I_BALANCE -> "BALANCE" | I_CAR -> "CAR" | I_CDR -> "CDR" | I_CHAIN_ID -> "CHAIN_ID" | I_CHECK_SIGNATURE -> "CHECK_SIGNATURE" | I_COMPARE -> "COMPARE" | I_CONCAT -> "CONCAT" | I_CONS -> "CONS" | I_CREATE_ACCOUNT -> "CREATE_ACCOUNT" | I_CREATE_CONTRACT -> "CREATE_CONTRACT" | I_IMPLICIT_ACCOUNT -> "IMPLICIT_ACCOUNT" | I_DIP -> "DIP" | I_DROP -> "DROP" | I_DUP -> "DUP" | I_EDIV -> "EDIV" | I_EMPTY_BIG_MAP -> "EMPTY_BIG_MAP" | I_EMPTY_MAP -> "EMPTY_MAP" | I_EMPTY_SET -> "EMPTY_SET" | I_EQ -> "EQ" | I_EXEC -> "EXEC" | I_APPLY -> "APPLY" | I_FAILWITH -> "FAILWITH" | I_GE -> "GE" | I_GET -> "GET" | I_GT -> "GT" | I_HASH_KEY -> "HASH_KEY" | I_IF -> "IF" | I_IF_CONS -> "IF_CONS" | I_IF_LEFT -> "IF_LEFT" | I_IF_NONE -> "IF_NONE" | I_INT -> "INT" | I_LAMBDA -> "LAMBDA" | I_LE -> "LE" | I_LEFT -> "LEFT" | I_LOOP -> "LOOP" | I_LSL -> "LSL" | I_LSR -> "LSR" | I_LT -> "LT" | I_MAP -> "MAP" | I_MEM -> "MEM" | I_MUL -> "MUL" | I_NEG -> "NEG" | I_NEQ -> "NEQ" | I_NIL -> "NIL" | I_NONE -> "NONE" | I_NOT -> "NOT" | I_NOW -> "NOW" | I_OR -> "OR" | I_PAIR -> "PAIR" | I_PUSH -> "PUSH" | I_RIGHT -> "RIGHT" | I_SIZE -> "SIZE" | I_SOME -> "SOME" | I_SOURCE -> "SOURCE" | I_SENDER -> "SENDER" | I_SELF -> "SELF" | I_SLICE -> "SLICE" | I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA" | I_SUB -> "SUB" | I_SWAP -> "SWAP" | I_TRANSFER_TOKENS -> "TRANSFER_TOKENS" | I_SET_DELEGATE -> "SET_DELEGATE" | I_UNIT -> "UNIT" | I_UPDATE -> "UPDATE" | I_XOR -> "XOR" | I_ITER -> "ITER" | I_LOOP_LEFT -> "LOOP_LEFT" | I_ADDRESS -> "ADDRESS" | I_CONTRACT -> "CONTRACT" | I_ISNAT -> "ISNAT" | I_CAST -> "CAST" | I_RENAME -> "RENAME" | I_DIG -> "DIG" | I_DUG -> "DUG" | T_bool -> "bool" | T_contract -> "contract" | T_int -> "int" | T_key -> "key" | T_key_hash -> "key_hash" | T_lambda -> "lambda" | T_list -> "list" | T_map -> "map" | T_big_map -> "big_map" | T_nat -> "nat" | T_option -> "option" | T_or -> "or" | T_pair -> "pair" | T_set -> "set" | T_signature -> "signature" | T_string -> "string" | T_bytes -> "bytes" | T_mutez -> "mutez" | T_timestamp -> "timestamp" | T_unit -> "unit" | T_operation -> "operation" | T_address -> "address" | T_chain_id -> "chain_id" let prim_of_string = function | "parameter" -> ok K_parameter | "storage" -> ok K_storage | "code" -> ok K_code | "False" -> ok D_False | "Elt" -> ok D_Elt | "Left" -> ok D_Left | "None" -> ok D_None | "Pair" -> ok D_Pair | "Right" -> ok D_Right | "Some" -> ok D_Some | "True" -> ok D_True | "Unit" -> ok D_Unit | "PACK" -> ok I_PACK | "UNPACK" -> ok I_UNPACK | "BLAKE2B" -> ok I_BLAKE2B | "SHA256" -> ok I_SHA256 | "SHA512" -> ok I_SHA512 | "ABS" -> ok I_ABS | "ADD" -> ok I_ADD | "AMOUNT" -> ok I_AMOUNT | "AND" -> ok I_AND | "BALANCE" -> ok I_BALANCE | "CAR" -> ok I_CAR | "CDR" -> ok I_CDR | "CHAIN_ID" -> ok I_CHAIN_ID | "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE | "COMPARE" -> ok I_COMPARE | "CONCAT" -> ok I_CONCAT | "CONS" -> ok I_CONS | "CREATE_ACCOUNT" -> ok I_CREATE_ACCOUNT | "CREATE_CONTRACT" -> ok I_CREATE_CONTRACT | "IMPLICIT_ACCOUNT" -> ok I_IMPLICIT_ACCOUNT | "DIP" -> ok I_DIP | "DROP" -> ok I_DROP | "DUP" -> ok I_DUP | "EDIV" -> ok I_EDIV | "EMPTY_BIG_MAP" -> ok I_EMPTY_BIG_MAP | "EMPTY_MAP" -> ok I_EMPTY_MAP | "EMPTY_SET" -> ok I_EMPTY_SET | "EQ" -> ok I_EQ | "EXEC" -> ok I_EXEC | "APPLY" -> ok I_APPLY | "FAILWITH" -> ok I_FAILWITH | "GE" -> ok I_GE | "GET" -> ok I_GET | "GT" -> ok I_GT | "HASH_KEY" -> ok I_HASH_KEY | "IF" -> ok I_IF | "IF_CONS" -> ok I_IF_CONS | "IF_LEFT" -> ok I_IF_LEFT | "IF_NONE" -> ok I_IF_NONE | "INT" -> ok I_INT | "LAMBDA" -> ok I_LAMBDA | "LE" -> ok I_LE | "LEFT" -> ok I_LEFT | "LOOP" -> ok I_LOOP | "LSL" -> ok I_LSL | "LSR" -> ok I_LSR | "LT" -> ok I_LT | "MAP" -> ok I_MAP | "MEM" -> ok I_MEM | "MUL" -> ok I_MUL | "NEG" -> ok I_NEG | "NEQ" -> ok I_NEQ | "NIL" -> ok I_NIL | "NONE" -> ok I_NONE | "NOT" -> ok I_NOT | "NOW" -> ok I_NOW | "OR" -> ok I_OR | "PAIR" -> ok I_PAIR | "PUSH" -> ok I_PUSH | "RIGHT" -> ok I_RIGHT | "SIZE" -> ok I_SIZE | "SOME" -> ok I_SOME | "SOURCE" -> ok I_SOURCE | "SENDER" -> ok I_SENDER | "SELF" -> ok I_SELF | "SLICE" -> ok I_SLICE | "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA | "SUB" -> ok I_SUB | "SWAP" -> ok I_SWAP | "TRANSFER_TOKENS" -> ok I_TRANSFER_TOKENS | "SET_DELEGATE" -> ok I_SET_DELEGATE | "UNIT" -> ok I_UNIT | "UPDATE" -> ok I_UPDATE | "XOR" -> ok I_XOR | "ITER" -> ok I_ITER | "LOOP_LEFT" -> ok I_LOOP_LEFT | "ADDRESS" -> ok I_ADDRESS | "CONTRACT" -> ok I_CONTRACT | "ISNAT" -> ok I_ISNAT | "CAST" -> ok I_CAST | "RENAME" -> ok I_RENAME | "DIG" -> ok I_DIG | "DUG" -> ok I_DUG | "bool" -> ok T_bool | "contract" -> ok T_contract | "int" -> ok T_int | "key" -> ok T_key | "key_hash" -> ok T_key_hash | "lambda" -> ok T_lambda | "list" -> ok T_list | "map" -> ok T_map | "big_map" -> ok T_big_map | "nat" -> ok T_nat | "option" -> ok T_option | "or" -> ok T_or | "pair" -> ok T_pair | "set" -> ok T_set | "signature" -> ok T_signature | "string" -> ok T_string | "bytes" -> ok T_bytes | "mutez" -> ok T_mutez | "timestamp" -> ok T_timestamp | "unit" -> ok T_unit | "operation" -> ok T_operation | "address" -> ok T_address | "chain_id" -> ok T_chain_id | n -> if valid_case n then error (Unknown_primitive_name n) else error (Invalid_case n) let prims_of_strings expr = let rec convert = function | (Int _ | String _ | Bytes _) as expr -> ok expr | Prim (loc, prim, args, annot) -> Error_monad.record_trace (Invalid_primitive_name (expr, loc)) (prim_of_string prim) >>? fun prim -> List.fold_left (fun acc arg -> acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args)) (ok []) args >>? fun args -> ok (Prim (0, prim, List.rev args, annot)) | Seq (_, args) -> List.fold_left (fun acc arg -> acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args)) (ok []) args >>? fun args -> ok (Seq (0, List.rev args)) in convert (root expr) >>? fun expr -> ok (strip_locations expr) let strings_of_prims expr = let rec convert = function | (Int _ | String _ | Bytes _) as expr -> expr | Prim (_, prim, args, annot) -> let prim = string_of_prim prim in let args = List.map convert args in Prim (0, prim, args, annot) | Seq (_, args) -> let args = List.map convert args in Seq (0, args) in strip_locations (convert (root expr)) let prim_encoding = let open Data_encoding in def "michelson.v1.primitives" @@ string_enum [ (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("parameter", K_parameter); ("storage", K_storage); ("code", K_code); ("False", D_False); ("Elt", D_Elt); ("Left", D_Left); ("None", D_None); ("Pair", D_Pair); ("Right", D_Right); ("Some", D_Some); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("True", D_True); ("Unit", D_Unit); ("PACK", I_PACK); ("UNPACK", I_UNPACK); ("BLAKE2B", I_BLAKE2B); ("SHA256", I_SHA256); ("SHA512", I_SHA512); ("ABS", I_ABS); ("ADD", I_ADD); ("AMOUNT", I_AMOUNT); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("AND", I_AND); ("BALANCE", I_BALANCE); ("CAR", I_CAR); ("CDR", I_CDR); ("CHECK_SIGNATURE", I_CHECK_SIGNATURE); ("COMPARE", I_COMPARE); ("CONCAT", I_CONCAT); ("CONS", I_CONS); ("CREATE_ACCOUNT", I_CREATE_ACCOUNT); ("CREATE_CONTRACT", I_CREATE_CONTRACT); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT); ("DIP", I_DIP); ("DROP", I_DROP); ("DUP", I_DUP); ("EDIV", I_EDIV); ("EMPTY_MAP", I_EMPTY_MAP); ("EMPTY_SET", I_EMPTY_SET); ("EQ", I_EQ); ("EXEC", I_EXEC); ("FAILWITH", I_FAILWITH); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("GE", I_GE); ("GET", I_GET); ("GT", I_GT); ("HASH_KEY", I_HASH_KEY); ("IF", I_IF); ("IF_CONS", I_IF_CONS); ("IF_LEFT", I_IF_LEFT); ("IF_NONE", I_IF_NONE); ("INT", I_INT); ("LAMBDA", I_LAMBDA); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("LE", I_LE); ("LEFT", I_LEFT); ("LOOP", I_LOOP); ("LSL", I_LSL); ("LSR", I_LSR); ("LT", I_LT); ("MAP", I_MAP); ("MEM", I_MEM); ("MUL", I_MUL); ("NEG", I_NEG); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("NEQ", I_NEQ); ("NIL", I_NIL); ("NONE", I_NONE); ("NOT", I_NOT); ("NOW", I_NOW); ("OR", I_OR); ("PAIR", I_PAIR); ("PUSH", I_PUSH); ("RIGHT", I_RIGHT); ("SIZE", I_SIZE); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("SOME", I_SOME); ("SOURCE", I_SOURCE); ("SENDER", I_SENDER); ("SELF", I_SELF); ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA); ("SUB", I_SUB); ("SWAP", I_SWAP); ("TRANSFER_TOKENS", I_TRANSFER_TOKENS); ("SET_DELEGATE", I_SET_DELEGATE); ("UNIT", I_UNIT); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("UPDATE", I_UPDATE); ("XOR", I_XOR); ("ITER", I_ITER); ("LOOP_LEFT", I_LOOP_LEFT); ("ADDRESS", I_ADDRESS); ("CONTRACT", I_CONTRACT); ("ISNAT", I_ISNAT); ("CAST", I_CAST); ("RENAME", I_RENAME); ("bool", T_bool); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("contract", T_contract); ("int", T_int); ("key", T_key); ("key_hash", T_key_hash); ("lambda", T_lambda); ("list", T_list); ("map", T_map); ("big_map", T_big_map); ("nat", T_nat); ("option", T_option); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("or", T_or); ("pair", T_pair); ("set", T_set); ("signature", T_signature); ("string", T_string); ("bytes", T_bytes); ("mutez", T_mutez); ("timestamp", T_timestamp); ("unit", T_unit); ("operation", T_operation); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("address", T_address); (* Alpha_002 addition *) ("SLICE", I_SLICE); (* Alpha_005 addition *) ("DIG", I_DIG); ("DUG", I_DUG); ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP); ("APPLY", I_APPLY); ("chain_id", T_chain_id); ("CHAIN_ID", I_CHAIN_ID) (* New instructions must be added here, for backward compatibility of the encoding. *) ] let () = register_error_kind `Permanent ~id:"michelson_v1.unknown_primitive_name" ~title:"Unknown primitive name" ~description:"In a script or data expression, a primitive was unknown." ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n) Data_encoding.(obj1 (req "wrong_primitive_name" string)) (function Unknown_primitive_name got -> Some got | _ -> None) (fun got -> Unknown_primitive_name got) ; register_error_kind `Permanent ~id:"michelson_v1.invalid_primitive_name_case" ~title:"Invalid primitive name case" ~description: "In a script or data expression, a primitive name is neither uppercase, \ lowercase or capitalized." ~pp:(fun ppf n -> Format.fprintf ppf "Primitive %s has invalid case." n) Data_encoding.(obj1 (req "wrong_primitive_name" string)) (function Invalid_case name -> Some name | _ -> None) (fun name -> Invalid_case name) ; register_error_kind `Permanent ~id:"michelson_v1.invalid_primitive_name" ~title:"Invalid primitive name" ~description: "In a script or data expression, a primitive name is unknown or has a \ wrong case." ~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.") Data_encoding.( obj2 (req "expression" (Micheline.canonical_encoding ~variant:"generic" string)) (req "location" Micheline.canonical_location_encoding)) (function | Invalid_primitive_name (expr, loc) -> Some (expr, loc) | _ -> None) (fun (expr, loc) -> Invalid_primitive_name (expr, loc))