Michelson: Enforces ordering on data

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
+          "@[<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."

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) ->
+    | Set_t t, (Prim (loc, "Set", vs) as expr) ->
-        traced @@
         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))
+             begin match last_value with
-          (empty_set t) vs
+              | 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) ->
+    | Map_t (tk, tv), (Prim (loc, "Map", vs) as expr) ->
-        traced @@
+        (fold_left_s
-        fold_left_s
+          (fun (last_value, map) -> function
-          (fun acc -> 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) ->
+    ?type_logger: (int * (Script.expr list * Script.expr list) -> unit) -> 
-    arg ty -> ret ty -> Script.expr -> (arg, ret) lambda tzresult Lwt.t =
+   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

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

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}

test/contracts/map_id.tz

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

test/contracts/pair_id.tz

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

test/contracts/set_id.tz

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

test/contracts/str_id.tz

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

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/list_id_map.tz Unit '(List "1" "2" "3")' '(List "1" "2" "3")'
-assert_output $CONTRACT_PATH/map_id.tz Unit '(List)' 'List'
+assert_output $CONTRACT_PATH/list_id_map.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 "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"

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