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

Michelson: Enforces ordering on data

Browse Source
This commit is contained in:
Milo Davis 2017-08-16 14:26:45 +02:00
parent fe871e9ecd
commit 804c3a4886
10 changed files with 169 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
src/client/embedded/alpha/client_proto_programs.ml
View File

@ -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
"@[<v 2>Map literals cannot contain duplicate keys, \
however a duplicate key was found:@ \
@[%a@]"
(print_expr no_locations) expr
| Unordered_map_keys (_, expr) ->
cctxt.warning
"@[<v 2>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
"@[<v 2>Set literals cannot contain duplicate values, \
however a duplicate value was found:@ \
@[%a@]"
(print_expr no_locations) expr
| Unordered_set_values (_, expr) ->
cctxt.warning
"@[<v 2>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."

101
src/proto/alpha/script_ir_translator.ml
View File

@ -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

4
src/proto/alpha/script_ir_translator.mli
View File

@ -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

4
test/contracts/list_id_map.tz Normal file
View File

@ -0,0 +1,4 @@
parameter (list string);
return (list string);
storage unit;
code {CAR; LAMBDA string string {}; MAP; UNIT; SWAP; PAIR}

6
test/contracts/map_id.tz
View File

@ -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 {}

4
test/contracts/pair_id.tz Normal file
View File

@ -0,0 +1,4 @@
parameter (pair bool bool);
return (pair bool bool);
storage unit;
code {}

4
test/contracts/set_id.tz Normal file
View File

@ -0,0 +1,4 @@
parameter (set string);
return (set string);
storage unit;
code {}

2
test/contracts/str_id.tz
View File

@ -1,4 +1,4 @@
parameter string;
return string;
storage unit;
code {CAR; UNIT; SWAP; PAIR};
code {};

31
test/test_contracts.sh
View File

@ -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"

13
test/test_utils.sh
View File

@ -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