From 804c3a488674294e4efc6cbb4e6a6bdafce60713 Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Wed, 16 Aug 2017 14:26:45 +0200 Subject: [PATCH] Michelson: Enforces ordering on data --- .../embedded/alpha/client_proto_programs.ml | 24 +++++ src/proto/alpha/script_ir_translator.ml | 101 +++++++++++++++--- src/proto/alpha/script_ir_translator.mli | 4 + test/contracts/list_id_map.tz | 4 + test/contracts/map_id.tz | 6 +- test/contracts/pair_id.tz | 4 + test/contracts/set_id.tz | 4 + test/contracts/str_id.tz | 2 +- test/test_contracts.sh | 31 +++++- test/test_utils.sh | 13 ++- 10 files changed, 169 insertions(+), 24 deletions(-) create mode 100644 test/contracts/list_id_map.tz create mode 100644 test/contracts/pair_id.tz create mode 100644 test/contracts/set_id.tz diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index 83c46cd11..6da20d936 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -347,6 +347,30 @@ let report_errors cctxt errs = (snd (human_kind got)) print_enumeration (List.map (fun k -> let (a, n) = human_kind k in a ^ " " ^ n) exp) + | Duplicate_map_keys (_, expr) -> + cctxt.warning + "@[Map literals cannot contain duplicate keys, \ + however a duplicate key was found:@ \ + @[%a@]" + (print_expr no_locations) expr + | Unordered_map_keys (_, expr) -> + cctxt.warning + "@[Keys in a map literal must be in strictly ascending order, \ + but they were unordered in literal:@ \ + @[%a@]" + (print_expr no_locations) expr + | Duplicate_set_values (_, expr) -> + cctxt.warning + "@[Set literals cannot contain duplicate values, \ + however a duplicate value was found:@ \ + @[%a@]" + (print_expr no_locations) expr + | Unordered_set_values (_, expr) -> + cctxt.warning + "@[Values in a set literal must be in strictly ascending order, \ + but they were unordered in literal:@ \ + @[%a@]" + (print_expr no_locations) expr | Fail_not_in_tail_position loc -> cctxt.warning "%aThe FAIL instruction must appear in a tail position." diff --git a/src/proto/alpha/script_ir_translator.ml b/src/proto/alpha/script_ir_translator.ml index e6100172f..517cec73e 100644 --- a/src/proto/alpha/script_ir_translator.ml +++ b/src/proto/alpha/script_ir_translator.ml @@ -46,6 +46,10 @@ type error += Inconsistent_types : _ ty * _ ty -> error type error += Ill_typed_data : string option * Script.expr * _ ty -> error type error += Ill_formed_type of string option * Script.expr type error += Ill_typed_contract : Script.expr * _ ty * _ ty * _ ty * type_map -> error +type error += Unordered_map_keys of Script.location * Script.expr +type error += Unordered_set_values of Script.location * Script.expr +type error += Duplicate_map_keys of Script.location * Script.expr +type error += Duplicate_set_values of Script.location * Script.expr (* ---- Error helpers -------------------------------------------------------*) @@ -329,7 +333,7 @@ let rec unparse_data (fun item acc -> unparse_data t item :: acc ) set [] in - Prim (-1, "Set", items) + Prim (-1, "Set", List.rev items) | Map_t (kt, vt), map -> let kt = ty_of_comparable_ty kt in let items = @@ -339,7 +343,7 @@ let rec unparse_data unparse_data vt v ]) :: acc) map [] in - Prim (-1, "Map", items) + Prim (-1, "Map", List.rev items) | Lambda_t _, Lam (_, original_code) -> original_code @@ -712,31 +716,49 @@ let rec parse_data | List_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "List" ])) (* Sets *) - | Set_t t, Prim (_, "Set", vs) -> - traced @@ + | Set_t t, (Prim (loc, "Set", vs) as expr) -> fold_left_s - (fun acc v -> + (fun (last_value, set) v -> parse_comparable_data ?type_logger ctxt t v >>=? fun v -> - return (set_update v true acc)) - (empty_set t) vs + begin match last_value with + | Some value -> + if Compare.Int.(0 <= (compare_comparable t value v)) + then + if Compare.Int.(0 = (compare_comparable t value v)) + then fail (Duplicate_set_values (loc, expr)) + else fail (Unordered_set_values (loc, expr)) + else return () + | None -> return () + end >>=? fun () -> + return (Some v, set_update v true set)) + (None, empty_set t) vs >>|? snd |> traced | Set_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Set" ])) (* Maps *) - | Map_t (tk, tv), Prim (_, "Map", vs) -> - traced @@ - fold_left_s - (fun acc -> function + | Map_t (tk, tv), (Prim (loc, "Map", vs) as expr) -> + (fold_left_s + (fun (last_value, map) -> function | Prim (_, "Item", [ k; v ]) -> parse_comparable_data ?type_logger ctxt tk k >>=? fun k -> parse_data ?type_logger ctxt tv v >>=? fun v -> - return (map_update k (Some v) acc) + begin match last_value with + | Some value -> + if Compare.Int.(0 <= (compare_comparable tk value k)) + then + if Compare.Int.(0 = (compare_comparable tk value k)) + then fail (Duplicate_map_keys (loc, expr)) + else fail (Unordered_map_keys (loc, expr)) + else return () + | None -> return () + end >>=? fun () -> + return (Some k, map_update k (Some v) map) | Prim (loc, "Item", l) -> fail @@ Invalid_arity (loc, "Item", 2, List.length l) | Prim (loc, name, _) -> fail @@ Invalid_primitive (loc, [ "Item" ], name) | Int _ | String _ | Seq _ -> fail (error ())) - (empty_map tk) vs + (None, empty_map tk) vs) >>|? snd |> traced | Map_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Map" ])) @@ -749,8 +771,8 @@ and parse_comparable_data and parse_lambda : type arg ret storage. context -> ?storage_type: storage ty -> - ?type_logger: (int * (Script.expr list * Script.expr list) -> unit) -> - arg ty -> ret ty -> Script.expr -> (arg, ret) lambda tzresult Lwt.t = + ?type_logger: (int * (Script.expr list * Script.expr list) -> unit) -> + arg ty -> ret ty -> Script.expr -> (arg, ret) lambda tzresult Lwt.t = fun ctxt ?storage_type ?type_logger arg ret script_instr -> parse_instr ctxt ?storage_type ?type_logger script_instr (Item_t (arg, Empty_t)) >>=? function @@ -1646,6 +1668,55 @@ let () = | _ -> None) (fun (loc, (name, exp, got)) -> Invalid_namespace (loc, name, exp, got)) ; + register_error_kind + `Permanent + ~id:"unorderedMapLiteral" + ~title:"Invalid map key order" + ~description:"Map keys must be in strictly increasing order" + (obj2 + (req "location" Script.location_encoding) + (req "item" Script.expr_encoding)) + (function + | Unordered_map_keys (loc, expr) -> Some (loc, expr) + | _ -> None) + (fun (loc, expr) -> Unordered_map_keys (loc, expr)); + register_error_kind + `Permanent + ~id:"duplicateMapKeys" + ~title:"Duplicate map keys" + ~description:"Map literals cannot contain duplicated keys" + (obj2 + (req "location" Script.location_encoding) + (req "item" Script.expr_encoding)) + (function + | Duplicate_map_keys (loc, expr) -> Some (loc, expr) + | _ -> None) + (fun (loc, expr) -> Duplicate_map_keys (loc, expr)); + register_error_kind + `Permanent + ~id:"unorderedSetLiteral" + ~title:"Invalid set value order" + ~description:"Set values must be in strictly increasing order" + (obj2 + (req "location" Script.location_encoding) + (req "value" Script.expr_encoding)) + (function + | Unordered_set_values (loc, expr) -> Some (loc, expr) + | _ -> None) + (fun (loc, expr) -> Unordered_set_values (loc, expr)); + register_error_kind + `Permanent + ~id:"duplicateSetValuesInLiteral" + ~title:"Sets literals cannot contain duplicate elements" + ~description:"Set literals cannot contain duplicate elements, \ + but a duplicae was found while parsing." + (obj2 + (req "location" Script.location_encoding) + (req "value" Script.expr_encoding)) + (function + | Duplicate_set_values (loc, expr) -> Some (loc, expr) + | _ -> None) + (fun (loc, expr) -> Duplicate_set_values (loc, expr)); (* -- Instruction typing errors ------------- *) register_error_kind `Permanent diff --git a/src/proto/alpha/script_ir_translator.mli b/src/proto/alpha/script_ir_translator.mli index 8efc03c6f..3b5b78c57 100644 --- a/src/proto/alpha/script_ir_translator.mli +++ b/src/proto/alpha/script_ir_translator.mli @@ -46,6 +46,10 @@ type error += Invalid_constant : Script.location * Script.expr * _ Script_typed_ type error += Invalid_contract of Script.location * Contract.t type error += Comparable_type_expected : Script.location * _ Script_typed_ir.ty -> error type error += Inconsistent_types : _ Script_typed_ir.ty * _ Script_typed_ir.ty -> error +type error += Unordered_map_keys of Script.location * Script.expr +type error += Unordered_set_values of Script.location * Script.expr +type error += Duplicate_map_keys of Script.location * Script.expr +type error += Duplicate_set_values of Script.location * Script.expr (* Toplevel errors *) type error += Ill_typed_data : string option * Script.expr * _ Script_typed_ir.ty -> error diff --git a/test/contracts/list_id_map.tz b/test/contracts/list_id_map.tz new file mode 100644 index 000000000..3ae75b50f --- /dev/null +++ b/test/contracts/list_id_map.tz @@ -0,0 +1,4 @@ +parameter (list string); +return (list string); +storage unit; +code {CAR; LAMBDA string string {}; MAP; UNIT; SWAP; PAIR} diff --git a/test/contracts/map_id.tz b/test/contracts/map_id.tz index 3ae75b50f..2d2981bb1 100644 --- a/test/contracts/map_id.tz +++ b/test/contracts/map_id.tz @@ -1,4 +1,4 @@ -parameter (list string); -return (list string); +parameter (map nat nat); +return (map nat nat); storage unit; -code {CAR; LAMBDA string string {}; MAP; UNIT; SWAP; PAIR} +code {} diff --git a/test/contracts/pair_id.tz b/test/contracts/pair_id.tz new file mode 100644 index 000000000..0284956e5 --- /dev/null +++ b/test/contracts/pair_id.tz @@ -0,0 +1,4 @@ +parameter (pair bool bool); +return (pair bool bool); +storage unit; +code {} diff --git a/test/contracts/set_id.tz b/test/contracts/set_id.tz new file mode 100644 index 000000000..e98f7f8fd --- /dev/null +++ b/test/contracts/set_id.tz @@ -0,0 +1,4 @@ +parameter (set string); +return (set string); +storage unit; +code {} diff --git a/test/contracts/str_id.tz b/test/contracts/str_id.tz index 2eaecaaf4..1fc1cd60c 100644 --- a/test/contracts/str_id.tz +++ b/test/contracts/str_id.tz @@ -1,4 +1,4 @@ parameter string; return string; storage unit; -code {CAR; UNIT; SWAP; PAIR}; +code {}; diff --git a/test/test_contracts.sh b/test/test_contracts.sh index 1ce4a63e7..189f7ef2c 100755 --- a/test/test_contracts.sh +++ b/test/test_contracts.sh @@ -20,9 +20,17 @@ CONTRACT_PATH=contracts # FORMAT: assert_output contract_file storage input expected_result assert_output $CONTRACT_PATH/ret_int.tz Unit Unit 300 + +# Identity on strings assert_output $CONTRACT_PATH/str_id.tz Unit '"Hello"' '"Hello"' assert_output $CONTRACT_PATH/str_id.tz Unit '"abcd"' '"abcd"' +# Identity on pairs +assert_output $CONTRACT_PATH/pair_id.tz Unit '(Pair True False)' '(Pair True False)' +assert_output $CONTRACT_PATH/pair_id.tz Unit '(Pair False True)' '(Pair False True)' +assert_output $CONTRACT_PATH/pair_id.tz Unit '(Pair True True)' '(Pair True True)' +assert_output $CONTRACT_PATH/pair_id.tz Unit '(Pair False False)' '(Pair False False)' + # Logical not assert_output $CONTRACT_PATH/not.tz Unit True False assert_output $CONTRACT_PATH/not.tz Unit False True @@ -58,7 +66,7 @@ assert_output $CONTRACT_PATH/concat_list.tz Unit '(List )' '""' assert_output $CONTRACT_PATH/concat_list.tz \ Unit '(List "Hello" " " "World" "!")' '"Hello World!"' -# Find maximum int32 in list -- returns None if not found +# Find maximum int in list -- returns None if not found assert_output $CONTRACT_PATH/max_in_list.tz Unit '(List)' 'None' assert_output $CONTRACT_PATH/max_in_list.tz Unit '(List 1)' '(Some 1)' assert_output $CONTRACT_PATH/max_in_list.tz Unit '(List -1)' '(Some -1)' @@ -74,11 +82,21 @@ assert_output $CONTRACT_PATH/list_id.tz Unit '(List "1" "2" "3")' '(List "1" "2" assert_output $CONTRACT_PATH/list_id.tz Unit '(List)' 'List' assert_output $CONTRACT_PATH/list_id.tz Unit '(List "a" "b" "c")' '(List "a" "b" "c")' -assert_output $CONTRACT_PATH/map_id.tz Unit '(List "1" "2" "3")' '(List "1" "2" "3")' -assert_output $CONTRACT_PATH/map_id.tz Unit '(List)' 'List' -assert_output $CONTRACT_PATH/map_id.tz Unit '(List "a" "b" "c")' '(List "a" "b" "c")' +assert_output $CONTRACT_PATH/list_id_map.tz Unit '(List "1" "2" "3")' '(List "1" "2" "3")' +assert_output $CONTRACT_PATH/list_id_map.tz Unit '(List)' 'List' +assert_output $CONTRACT_PATH/list_id_map.tz Unit '(List "a" "b" "c")' '(List "a" "b" "c")' +# Identity on maps +assert_output $CONTRACT_PATH/map_id.tz Unit '(Map (Item 0 1))' '(Map (Item 0 1))' +assert_output $CONTRACT_PATH/map_id.tz Unit '(Map (Item 0 0))' '(Map (Item 0 0))' +assert_output $CONTRACT_PATH/map_id.tz Unit '(Map (Item 0 0) (Item 3 4))' '(Map (Item 0 0) (Item 3 4))' + +# Identity on sets +assert_output $CONTRACT_PATH/set_id.tz Unit '(Set "a" "b" "c")' '(Set "a" "b" "c")' +assert_output $CONTRACT_PATH/set_id.tz Unit '(Set)' 'Set' +assert_output $CONTRACT_PATH/set_id.tz Unit '(Set "asdf" "bcde")' '(Set "asdf" "bcde")' + # Set member -- set is in storage assert_output $CONTRACT_PATH/set_member.tz '(Set)' '"Hi"' 'False' assert_output $CONTRACT_PATH/set_member.tz '(Set "Hi")' '"Hi"' 'True' @@ -229,4 +247,9 @@ account=tz1SuakBpFdG9b4twyfrSMqZzruxhpMeSrE5 ${TZCLIENT} transfer 0.00 from bootstrap1 to default_account -arg "\"$account\"" assert_balance $account "100.00 ęś©" +assert_fails ${TZCLIENT} typecheck data '(Map (Item 0 1) (Item 0 1))' against type '(map nat nat)' +assert_fails ${TZCLIENT} typecheck data '(Map (Item 0 1) (Item 10 1) (Item 5 1))' against type '(map nat nat)' +assert_fails ${TZCLIENT} typecheck data '(Set "A" "C" "B")' against type '(set string)' +assert_fails ${TZCLIENT} typecheck data '(Set "A" "B" "B")' against type '(set string)' + printf "\nEnd of test\n" diff --git a/test/test_utils.sh b/test/test_utils.sh index d47961935..8a201a0d8 100755 --- a/test/test_utils.sh +++ b/test/test_utils.sh @@ -98,7 +98,7 @@ assert_output () { { printf '\nTest failed with error at line %s\n' "$(caller)" > /dev/stderr; exit 1; }); if [ "$expected" != "$output" ]; then - echo "Test at" `caller` failed > /dev/stderr; + echo "Test at " `caller` failed > /dev/stderr; printf "Expected %s but got %s" "$expected" "$output" > /dev/stderr; exit 1; fi @@ -178,6 +178,17 @@ assert() { fi } +assert_fails() { + printf "[Asserting failure]\n" + if "$@" 2> /dev/null; then + printf "Expected command line to fail, but succeeded:\n" + echo "$@" + exit 1 + else + return 0 + fi +} + BOOTSTRAP1_IDENTITY=tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx BOOTSTRAP1_PUBLIC=edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav BOOTSTRAP1_SECRET=edskRuR1azSfboG86YPTyxrQgosh5zChf5bVDmptqLTb5EuXAm9rsnDYfTKhq7rDQujdn5WWzwUMeV3agaZ6J2vPQT58jJAJPi