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

Merge branch 'contract-multisig' into 'dev'

Browse Source 
Contracts : multisig

See merge request ligolang/ligo!204
This commit is contained in:
Rémi Lesenechal 2019-11-21 17:58:21 +00:00
commit f4c3828866
31 changed files with 480 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/main/run/of_michelson.ml
View File

@ -24,9 +24,13 @@ let run ?options (* ?(is_input_value = false) *) (program:compiled_program) (inp
Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
Memory_proto_alpha.parse_michelson_data input_michelson input_ty
in
let body = Michelson.strip_annots body in
let open! Memory_proto_alpha.Protocol.Script_ir_translator in
let top_level = Toplevel { storage_type = output_ty ; param_type = input_ty ;
root_name = None ; legacy_create_contract_literal = false } in
let%bind descr =
Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
Memory_proto_alpha.parse_michelson body
Memory_proto_alpha.parse_michelson ~top_level body
(Item_t (input_ty, Empty_t, None)) (Item_t (output_ty, Empty_t, None)) in
let open! Memory_proto_alpha.Protocol.Script_interpreter in
let%bind (Item(output, Empty)) =
@ -79,13 +83,11 @@ let evaluate_michelson ?options program =
let%bind etv = evaluate ?options program in
ex_value_ty_to_michelson etv
let pack_message_lambda (lambda:Michelson.t) =
let open Memory_proto_alpha.Protocol.Script_typed_ir in
let input_ty = Lambda_t (Unit_t None , List_t ((Operation_t None),None,false) , None) in
let%bind lambda =
let pack_payload (payload:Michelson.t) ty =
let%bind payload =
Trace.trace_tzresult_lwt (simple_error "error parsing message") @@
Memory_proto_alpha.parse_michelson_data lambda input_ty in
Memory_proto_alpha.parse_michelson_data payload ty in
let%bind data =
Trace.trace_tzresult_lwt (simple_error "error packing message") @@
Memory_proto_alpha.pack input_ty lambda in
Memory_proto_alpha.pack ty payload in
ok @@ data

8
src/main/run/of_simplified.ml
View File

@ -35,3 +35,11 @@ let evaluate_typed_program_entry
let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry in
let%bind ex_ty_value = Of_michelson.evaluate ?options code in
Compile.Of_simplified.uncompile_typed_program_entry_expression_result program entry ex_ty_value
let compile_program
?options
(program : Ast_typed.program) (entry : string)
: unit result =
let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry in
let%bind _ex_ty_value = Of_michelson.evaluate ?options code in
ok ()

16
src/passes/4-typer-new/typer.ml
View File

@ -432,6 +432,18 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
| E_literal (Literal_string s) -> (
return_wrapped (e_string s) state @@ Wrap.literal (t_string ())
)
| E_literal (Literal_signature s) -> (
return_wrapped (e_signature s) state @@ Wrap.literal (t_signature ())
)
| E_literal (Literal_key s) -> (
return_wrapped (e_key s) state @@ Wrap.literal (t_key ())
)
| E_literal (Literal_key_hash s) -> (
return_wrapped (e_key_hash s) state @@ Wrap.literal (t_key_hash ())
)
| E_literal (Literal_chain_id s) -> (
return_wrapped (e_chain_id s) state @@ Wrap.literal (t_chain_id ())
)
| E_literal (Literal_bytes b) -> (
return_wrapped (e_bytes b) state @@ Wrap.literal (t_bytes ())
)
@ -1000,6 +1012,10 @@ let untype_literal (l:O.literal) : I.literal result =
| Literal_mutez n -> ok (Literal_mutez n)
| Literal_int n -> ok (Literal_int n)
| Literal_string s -> ok (Literal_string s)
| Literal_key s -> ok (Literal_key s)
| Literal_key_hash s -> ok (Literal_key_hash s)
| Literal_chain_id s -> ok (Literal_chain_id s)
| Literal_signature s -> ok (Literal_signature s)
| Literal_bytes b -> ok (Literal_bytes b)
| Literal_address s -> ok (Literal_address s)
| Literal_operation s -> ok (Literal_operation s)

12
src/passes/4-typer-old/typer.ml
View File

@ -404,6 +404,14 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
return (E_literal (Literal_unit)) (t_unit ())
| E_literal (Literal_string s) ->
return (E_literal (Literal_string s)) (t_string ())
| E_literal (Literal_key s) ->
return (E_literal (Literal_key s)) (t_key ())
| E_literal (Literal_key_hash s) ->
return (E_literal (Literal_key_hash s)) (t_key_hash ())
| E_literal (Literal_chain_id s) ->
return (E_literal (Literal_chain_id s)) (t_chain_id ())
| E_literal (Literal_signature s) ->
return (E_literal (Literal_signature s)) (t_signature ())
| E_literal (Literal_bytes s) ->
return (E_literal (Literal_bytes s)) (t_bytes ())
| E_literal (Literal_int n) ->
@ -808,6 +816,10 @@ let untype_literal (l:O.literal) : I.literal result =
| Literal_mutez n -> ok (Literal_mutez n)
| Literal_int n -> ok (Literal_int n)
| Literal_string s -> ok (Literal_string s)
| Literal_signature s -> ok (Literal_signature s)
| Literal_key s -> ok (Literal_key s)
| Literal_key_hash s -> ok (Literal_key_hash s)
| Literal_chain_id s -> ok (Literal_chain_id s)
| Literal_bytes b -> ok (Literal_bytes b)
| Literal_address s -> ok (Literal_address s)
| Literal_operation s -> ok (Literal_operation s)

7
src/passes/6-transpiler/transpiler.ml
View File

@ -130,6 +130,9 @@ let rec transpile_type (t:AST.type_value) : type_value result =
| T_constant (Type_name "unit", []) -> ok (T_base Base_unit)
| T_constant (Type_name "operation", []) -> ok (T_base Base_operation)
| T_constant (Type_name "signature", []) -> ok (T_base Base_signature)
| T_constant (Type_name "key_hash", []) -> ok (T_base Base_key_hash)
| T_constant (Type_name "key", []) -> ok (T_base Base_key)
| T_constant (Type_name "chain_id", []) -> ok (T_base Base_chain_id)
| T_constant (Type_name "contract", [x]) ->
let%bind x' = transpile_type x in
ok (T_contract x')
@ -237,6 +240,10 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
| Literal_bytes s -> D_bytes s
| Literal_string s -> D_string s
| Literal_address s -> D_string s
| Literal_signature s -> D_string s
| Literal_key s -> D_string s
| Literal_key_hash s -> D_string s
| Literal_chain_id s -> D_string s
| Literal_operation op -> D_operation op
| Literal_unit -> D_unit

18
src/passes/6-transpiler/untranspiler.ml
View File

@ -150,6 +150,24 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
bind_map_list aux lst in
return (E_list lst')
)
| T_constant (Type_name "key", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "key" v) @@
get_string v in
return (E_literal (Literal_key n))
)
| T_constant (Type_name "key_hash", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "key_hash" v) @@
get_string v in
return (E_literal (Literal_key_hash n))
)
| T_constant (Type_name "chain_id", []) -> (
let%bind n =
trace_strong (wrong_mini_c_value "chain_id" v) @@
get_string v in
return (E_literal (Literal_chain_id n))
)
| T_constant (Type_name "set", [ty]) -> (
let%bind lst =
trace_strong (wrong_mini_c_value "set" v) @@

13
src/passes/8-compiler/compiler_type.ml
View File

@ -32,6 +32,8 @@ module Ty = struct
let mutez = Mutez_t None
let string = String_t None
let key = Key_t None
let key_hash = Key_hash_t None
let chain_id = Chain_id_t None
let list a = List_t (a, None , has_big_map a)
let set a = Set_t (a, None)
let address = Address_t None
@ -69,6 +71,9 @@ module Ty = struct
| Base_bytes -> return bytes_k
| Base_operation -> fail (not_comparable "operation")
| Base_signature -> fail (not_comparable "signature")
| Base_key -> fail (not_comparable "key")
| Base_key_hash -> fail (not_comparable "key_hash")
| Base_chain_id -> fail (not_comparable "chain_id")
let comparable_type : type_value -> ex_comparable_ty result = fun tv ->
match tv with
@ -85,7 +90,7 @@ module Ty = struct
let base_type : type_base -> ex_ty result = fun b ->
let return x = ok @@ Ex_ty x in
match b with
match b with
| Base_unit -> return unit
| Base_void -> fail (not_compilable_type "void")
| Base_bool -> return bool
@ -98,6 +103,9 @@ module Ty = struct
| Base_bytes -> return bytes
| Base_operation -> return operation
| Base_signature -> return signature
| Base_key -> return key
| Base_key_hash -> return key_hash
| Base_chain_id -> return chain_id
let rec type_ : type_value -> ex_ty result =
function
@ -180,6 +188,9 @@ let base_type : type_base -> O.michelson result =
| Base_bytes -> ok @@ O.prim T_bytes
| Base_operation -> ok @@ O.prim T_operation
| Base_signature -> ok @@ O.prim T_signature
| Base_key -> ok @@ O.prim T_key
| Base_key_hash -> ok @@ O.prim T_key_hash
| Base_chain_id -> ok @@ O.prim T_chain_id
let rec type_ : type_value -> O.michelson result =
function

9
src/passes/8-compiler/uncompiler.ml
View File

@ -31,6 +31,15 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result =
trace_option (simple_error "too big to fit an int") @@
Alpha_context.Script_int.to_int n in
ok @@ D_nat n
| (Chain_id_t _), id ->
let str = Tezos_crypto.Base58.simple_encode
(Tezos_base__TzPervasives.Chain_id.b58check_encoding)
id in
ok @@ D_string str
| (Key_hash_t _ ), n ->
ok @@ D_string (Signature.Public_key_hash.to_b58check n)
| (Key_t _ ), n ->
ok @@ D_string (Signature.Public_key.to_b58check n)
| (Timestamp_t _), n ->
let n =
Z.to_int @@

1
src/passes/operators/helpers.ml
View File

@ -127,6 +127,7 @@ module Typer = struct
t_bytes () ;
t_address () ;
t_timestamp () ;
t_key_hash () ;
] in
ok @@ t_bool ()

15
src/passes/operators/operators.ml
View File

@ -52,12 +52,14 @@ module Simplify = struct
("set" , "set") ;
("map" , "map") ;
("big_map" , "big_map") ;
("chain_id" , "chain_id") ;
]
module Pascaligo = struct
let constants = [
("get_force" , "MAP_GET_FORCE") ;
("get_chain_id", "CHAIN_ID");
("transaction" , "CALL") ;
("get_contract" , "CONTRACT") ;
("get_entrypoint" , "CONTRACT_ENTRYPOINT") ;
@ -77,6 +79,8 @@ module Simplify = struct
("bitwise_xor" , "XOR") ;
("string_concat" , "CONCAT") ;
("string_slice" , "SLICE") ;
("crypto_check", "CHECK_SIGNATURE") ;
("crypto_hash_key", "HASH_KEY") ;
("bytes_concat" , "CONCAT") ;
("bytes_slice" , "SLICE") ;
("bytes_pack" , "PACK") ;
@ -89,7 +93,6 @@ module Simplify = struct
("list_iter" , "LIST_ITER") ;
("list_fold" , "LIST_FOLD") ;
("list_map" , "LIST_MAP") ;
(*ici*)
("map_iter" , "MAP_ITER") ;
("map_map" , "MAP_MAP") ;
("map_fold" , "MAP_FOLD") ;
@ -458,7 +461,11 @@ module Typer = struct
let balance = constant "BALANCE" @@ t_mutez ()
let address = constant "ADDRESS" @@ t_address ()
let chain_id = constant "CHAIN_ID" @@ t_chain_id ()
let address = typer_1 "ADDRESS" @@ fun contract ->
let%bind () = assert_t_contract contract in
ok @@ t_address ()
let now = constant "NOW" @@ t_timestamp ()
@ -774,6 +781,7 @@ module Typer = struct
check_signature ;
sender ;
source ;
chain_id ;
unit ;
balance ;
amount ;
@ -857,7 +865,7 @@ module Compiler = struct
("UNIT" , simple_constant @@ prim I_UNIT) ;
("BALANCE" , simple_constant @@ prim I_BALANCE) ;
("AMOUNT" , simple_constant @@ prim I_AMOUNT) ;
("ADDRESS" , simple_constant @@ prim I_ADDRESS) ;
("ADDRESS" , simple_unary @@ prim I_ADDRESS) ;
("NOW" , simple_constant @@ prim I_NOW) ;
("CALL" , simple_ternary @@ prim I_TRANSFER_TOKENS) ;
("SOURCE" , simple_constant @@ prim I_SOURCE) ;
@ -874,6 +882,7 @@ module Compiler = struct
("PACK" , simple_unary @@ prim I_PACK) ;
("CONCAT" , simple_binary @@ prim I_CONCAT) ;
("CONS" , simple_binary @@ prim I_CONS) ;
("CHAIN_ID", simple_constant @@ prim I_CHAIN_ID ) ;
]
(*

4
src/stages/ast_simplified/PP.ml
View File

@ -29,6 +29,10 @@ let literal ppf (l:literal) = match l with
| Literal_string s -> fprintf ppf "%S" s
| Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
| Literal_address s -> fprintf ppf "@%S" s
| Literal_signature s -> fprintf ppf "@%S" s
| Literal_key s -> fprintf ppf "@%S" s
| Literal_key_hash s -> fprintf ppf "@%S" s
| Literal_chain_id s -> fprintf ppf "@%S" s
| Literal_operation _ -> fprintf ppf "Operation(...bytes)"
let rec expression ppf (e:expression) = match e.expression with

7
src/stages/ast_simplified/combinators.ml
View File

@ -24,6 +24,9 @@ let t_nat : type_expression = T_constant ("nat", [])
let t_tez : type_expression = T_constant ("tez", [])
let t_unit : type_expression = T_constant ("unit", [])
let t_address : type_expression = T_constant ("address", [])
let t_signature : type_expression = T_constant ("signature", [])
let t_key : type_expression = T_constant ("key", [])
let t_key_hash : type_expression = T_constant ("key_hash", [])
let t_option o : type_expression = T_constant ("option", [o])
let t_list t : type_expression = T_constant ("list", [t])
let t_variable n : type_expression = T_variable n
@ -62,6 +65,10 @@ let e_bool ?loc b : expression = location_wrap ?loc @@ E_literal (Literal_bool
let e_string ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_address s)
let e_mutez ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_mutez s)
let e_signature ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_signature s)
let e_key ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_chain_id s)
let e'_bytes b : expression' result =
let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in
ok @@ E_literal (Literal_bytes bytes)

7
src/stages/ast_simplified/combinators.mli
View File

@ -18,6 +18,9 @@ val t_nat : type_expression
val t_tez : type_expression
val t_unit : type_expression
val t_address : type_expression
val t_key : type_expression
val t_key_hash : type_expression
val t_signature : type_expression
(*
val t_option : type_expression -> type_expression
*)
@ -51,6 +54,10 @@ val e_timestamp : ?loc:Location.t -> int -> expression
val e_bool : ?loc:Location.t -> bool -> expression
val e_string : ?loc:Location.t -> string -> expression
val e_address : ?loc:Location.t -> string -> expression
val e_signature : ?loc:Location.t -> string -> expression
val e_key : ?loc:Location.t -> string -> expression
val e_key_hash : ?loc:Location.t -> string -> expression
val e_chain_id : ?loc:Location.t -> string -> expression
val e_mutez : ?loc:Location.t -> int -> expression
val e'_bytes : string -> expression' result
val e_bytes : ?loc:Location.t -> string -> expression result

12
src/stages/ast_simplified/misc.ml
View File

@ -61,6 +61,18 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
| Literal_address _, _ -> fail @@ different_literals_because_different_types "address vs non-address" a b
| Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b
| Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b
| Literal_signature a, Literal_signature b when a = b -> ok ()
| Literal_signature _, Literal_signature _ -> fail @@ different_literals "different signature" a b
| Literal_signature _, _ -> fail @@ different_literals_because_different_types "signature vs non-signature" a b
| Literal_key a, Literal_key b when a = b -> ok ()
| Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b
| Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b
| Literal_key_hash a, Literal_key_hash b when a = b -> ok ()
| Literal_key_hash _, Literal_key_hash _ -> fail @@ different_literals "different key_hash" a b
| Literal_key_hash _, _ -> fail @@ different_literals_because_different_types "key_hash vs non-key_hash" a b
| Literal_chain_id a, Literal_chain_id b when a = b -> ok ()
| Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b
| Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b
let rec assert_value_eq (a, b: (expression * expression )) : unit result =
let error_content () =

4
src/stages/ast_simplified/types.ml
View File

@ -95,6 +95,10 @@ and literal =
| Literal_bytes of bytes
| Literal_address of string
| Literal_timestamp of int
| Literal_signature of string
| Literal_key of string
| Literal_key_hash of string
| Literal_chain_id of string
| Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
and 'a matching =

4
src/stages/ast_typed/PP.ml
View File

@ -74,7 +74,11 @@ and literal ppf (l:literal) : unit =
| Literal_string s -> fprintf ppf "%s" s
| Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
| Literal_address s -> fprintf ppf "@%s" s
| Literal_signature s -> fprintf ppf "@%s" s
| Literal_key s -> fprintf ppf "@%s" s
| Literal_key_hash s -> fprintf ppf "@%s" s
| Literal_operation _ -> fprintf ppf "Operation(...bytes)"
| Literal_chain_id s -> fprintf ppf "@%s" s
and single_record_patch ppf ((s, ae) : string * ae) =
fprintf ppf "%s <- %a" s annotated_expression ae

10
src/stages/ast_typed/combinators.ml
View File

@ -16,8 +16,10 @@ let t_string ?s () : type_value = make_t (T_constant (Type_name "string", [])) s
let t_bytes ?s () : type_value = make_t (T_constant (Type_name "bytes", [])) s
let t_key ?s () : type_value = make_t (T_constant (Type_name "key", [])) s
let t_key_hash ?s () : type_value = make_t (T_constant (Type_name "key_hash", [])) s
let t_signature ?s () : type_value = make_t (T_constant (Type_name "signature", [])) s
let t_int ?s () : type_value = make_t (T_constant (Type_name "int", [])) s
let t_address ?s () : type_value = make_t (T_constant (Type_name "address", [])) s
let t_chain_id ?s () : type_value = make_t (T_constant (Type_name "chain_id", [])) s
let t_operation ?s () : type_value = make_t (T_constant (Type_name "operation", [])) s
let t_nat ?s () : type_value = make_t (T_constant (Type_name "nat", [])) s
let t_mutez ?s () : type_value = make_t (T_constant (Type_name "tez", [])) s
@ -184,6 +186,10 @@ let assert_t_key = get_t_key
let assert_t_signature = get_t_signature
let assert_t_key_hash = get_t_key_hash
let assert_t_contract (t:type_value) : unit result = match t.type_value' with
| T_constant (Type_name "contract", _) -> ok ()
| _ -> simple_fail "not a contract"
let assert_t_list t =
let%bind _ = get_t_list t in
ok ()
@ -238,6 +244,10 @@ let e_string s : expression = E_literal (Literal_string s)
let e_bytes s : expression = E_literal (Literal_bytes s)
let e_timestamp s : expression = E_literal (Literal_timestamp s)
let e_address s : expression = E_literal (Literal_address s)
let e_signature s : expression = E_literal (Literal_signature s)
let e_key s : expression = E_literal (Literal_key s)
let e_key_hash s : expression = E_literal (Literal_key_hash s)
let e_chain_id s : expression = E_literal (Literal_chain_id s)
let e_operation s : expression = E_literal (Literal_operation s)
let e_lambda l : expression = E_lambda l
let e_pair a b : expression = E_tuple [a; b]

7
src/stages/ast_typed/combinators.mli
View File

@ -19,6 +19,8 @@ val t_int : ?s:S.type_expression -> unit -> type_value
val t_nat : ?s:S.type_expression -> unit -> type_value
val t_mutez : ?s:S.type_expression -> unit -> type_value
val t_address : ?s:S.type_expression -> unit -> type_value
val t_chain_id : ?s:S.type_expression -> unit -> type_value
val t_signature : ?s:S.type_expression -> unit -> type_value
val t_unit : ?s:S.type_expression -> unit -> type_value
val t_option : type_value -> ?s:S.type_expression -> unit -> type_value
val t_pair : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
@ -101,6 +103,7 @@ val assert_t_int : type_value -> unit result
val assert_t_nat : type_value -> unit result
val assert_t_bool : type_value -> unit result
val assert_t_unit : type_value -> unit result
val assert_t_contract : type_value -> unit result
(*
val e_record : ae_map -> expression
val ez_e_record : ( string * annotated_expression ) list -> expression
@ -118,6 +121,10 @@ val e_string : string -> expression
val e_bytes : bytes -> expression
val e_timestamp : int -> expression
val e_address : string -> expression
val e_signature : string -> expression
val e_key : string -> expression
val e_key_hash : string -> expression
val e_chain_id : string -> expression
val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression
val e_lambda : lambda -> expression
val e_pair : value -> value -> expression

12
src/stages/ast_typed/misc.ml
View File

@ -380,6 +380,18 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
| Literal_address a, Literal_address b when a = b -> ok ()
| Literal_address _, Literal_address _ -> fail @@ different_literals "different addresss" a b
| Literal_address _, _ -> fail @@ different_literals_because_different_types "address vs non-address" a b
| Literal_signature a, Literal_signature b when a = b -> ok ()
| Literal_signature _, Literal_signature _ -> fail @@ different_literals "different signature" a b
| Literal_signature _, _ -> fail @@ different_literals_because_different_types "signature vs non-signature" a b
| Literal_key a, Literal_key b when a = b -> ok ()
| Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b
| Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b
| Literal_key_hash a, Literal_key_hash b when a = b -> ok ()
| Literal_key_hash _, Literal_key_hash _ -> fail @@ different_literals "different key_hash" a b
| Literal_key_hash _, _ -> fail @@ different_literals_because_different_types "key_hash vs non-key_hash" a b
| Literal_chain_id a, Literal_chain_id b when a = b -> ok ()
| Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b
| Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b
| Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b
| Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b

4
src/stages/ast_typed/types.ml
View File

@ -126,6 +126,10 @@ and literal =
| Literal_string of string
| Literal_bytes of bytes
| Literal_address of string
| Literal_signature of string
| Literal_key of string
| Literal_key_hash of string
| Literal_chain_id of string
| Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
and access =

3
src/stages/mini_c/PP.ml
View File

@ -21,6 +21,9 @@ let type_base ppf : type_base -> _ = function
| Base_bytes -> fprintf ppf "bytes"
| Base_operation -> fprintf ppf "operation"
| Base_signature -> fprintf ppf "signature"
| Base_key -> fprintf ppf "key"
| Base_key_hash -> fprintf ppf "key_hash"
| Base_chain_id -> fprintf ppf "chain_id"
let rec type_ ppf : type_value -> _ = function
| T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b

3
src/stages/mini_c/types.ml
View File

@ -5,8 +5,9 @@ type type_base =
| Base_bool
| Base_int | Base_nat | Base_tez
| Base_timestamp
| Base_string | Base_bytes | Base_address
| Base_string | Base_bytes | Base_address | Base_key
| Base_operation | Base_signature
| Base_chain_id | Base_key_hash
type 'a annotated = string option * 'a

4
src/stages/typesystem/misc.ml
View File

@ -101,6 +101,10 @@ module Substitution = struct
| (T.Literal_string _ as x)
| (T.Literal_bytes _ as x)
| (T.Literal_address _ as x)
| (T.Literal_signature _ as x)
| (T.Literal_key _ as x)
| (T.Literal_key_hash _ as x)
| (T.Literal_chain_id _ as x)
| (T.Literal_operation _ as x) ->
ok @@ x
and s_matching_expr ~v ~expr : T.matching_expr w = fun _ ->

5
src/test/contracts/chain_id.ligo Normal file
View File

@ -0,0 +1,5 @@
function get_chain_id (const tt : chain_id) : chain_id is
block {
var toto : chain_id := get_chain_id ;
} with ( toto )

5
src/test/contracts/key_hash.ligo Normal file
View File

@ -0,0 +1,5 @@
function check_hash_key (const kh1 : key_hash; const k2 : key) : bool*key_hash is block {
var ret : bool := False ;
var kh2 : key_hash := crypto_hash_key(k2) ;
if kh1 = kh2 then ret := True else skip;
} with (ret, kh2)

62
src/test/contracts/multisig.ligo Normal file
View File

@ -0,0 +1,62 @@
// storage type
type counter_t is nat
type threshold_t is nat
type authorized_keys_t is list(key)
type id_t is string
type storage_t is record
id : id_t ;
counter : counter_t ;
threshold : threshold_t ;
auth : authorized_keys_t ;
end
// I/O types
type message_t is (unit -> list(operation))
type signatures_t is list(key_hash * signature)
type check_message_pt is record
counter : counter_t ;
message : message_t ;
signatures : signatures_t ;
end
type contract_return_t is (list(operation) * storage_t)
type entry_point_t is
| CheckMessage of check_message_pt
function check_message (const param : check_message_pt;
const s : storage_t) : contract_return_t is block {
var message : message_t := param.message ;
if param.counter =/= s.counter then
failwith ("Counters does not match")
else block {
const packed_payload : bytes =
bytes_pack((message , param.counter , s.id , get_chain_id));
var valid : nat := 0n ;
var keys : authorized_keys_t := s.auth ;
for pkh_sig in list param.signatures block {
case keys of
| nil -> skip
| key # tl -> block {
keys := tl ;
if pkh_sig.0 = crypto_hash_key(key) then
if crypto_check(key,pkh_sig.1,packed_payload) then valid := valid + 1n ;
else failwith ("Invalid signature")
else skip;
}
end
};
if valid < s.threshold then
failwith ("Not enough signatures passed the check")
else s.counter := s.counter + 1n ;
}
} with (message(unit), s)
function main(const param : entry_point_t; const s : storage_t) : contract_return_t is
case param of
| CheckMessage (p) -> check_message(p,s)
end

1
src/test/dune
View File

@ -4,6 +4,7 @@
simple-utils
ligo
alcotest
tezos-crypto
)
(preprocess
(pps ppx_let)

23
src/test/integration_tests.ml
View File

@ -1267,7 +1267,30 @@ let entrypoints_ligo () : unit result =
(* hmm... *)
ok ()
let chain_id () : unit result =
let%bind program = type_file "./contracts/chain_id.ligo" in
let pouet = Tezos_crypto.Base58.simple_encode
Tezos_base__TzPervasives.Chain_id.b58check_encoding
Tezos_base__TzPervasives.Chain_id.zero in
let make_input = e_chain_id pouet in
let make_expected = e_chain_id pouet in
let%bind () = expect_eq program "get_chain_id" make_input make_expected in
ok ()
let key_hash () : unit result =
let open Tezos_crypto in
let (raw_pkh,raw_pk,_) = Signature.generate_key () in
let pkh_str = Signature.Public_key_hash.to_b58check raw_pkh in
let pk_str = Signature.Public_key.to_b58check raw_pk in
let%bind program = type_file "./contracts/key_hash.ligo" in
let make_input = e_pair (e_key_hash pkh_str) (e_key pk_str) in
let make_expected = e_pair (e_bool true) (e_key_hash pkh_str) in
let%bind () = expect_eq program "check_hash_key" make_input make_expected in
ok ()
let main = test_suite "Integration (End to End)" [
test "key hash" key_hash ;
test "chain id" chain_id ;
test "type alias" type_alias ;
test "function" function_ ;
test "blockless function" blockless;

188
src/test/multisig_tests.ml Normal file
View File

@ -0,0 +1,188 @@
open Trace
open Test_helpers
let type_file = Ligo.Compile.Of_source.type_file (Syntax_name "pascaligo")
let get_program =
let s = ref None in
fun () -> match !s with
| Some s -> ok s
| None -> (
let%bind program = type_file "./contracts/multisig.ligo" in
s := Some program ;
ok program
)
let compile_main () =
let%bind program,_ = get_program () in
let%bind () =
Ligo.Run.Of_simplified.compile_program
program "main" in
ok ()
open Ast_simplified
let gen_keys = fun () ->
let open Tezos_crypto in
let (raw_pkh,raw_pk,raw_sk) = Signature.generate_key () in
(raw_pkh,raw_pk,raw_sk)
let str_keys (raw_pkh, raw_pk, raw_sk) =
let open Tezos_crypto in
let sk_str = Signature.Secret_key.to_b58check raw_sk in
let pk_str = Signature.Public_key.to_b58check raw_pk in
let pkh_str = Signature.Public_key_hash.to_b58check raw_pkh in
(pkh_str,pk_str,sk_str)
let sign_message (payload : expression) sk : string result =
let open Tezos_crypto in
let%bind program,_ = get_program () in
let%bind code =
let env = Ast_typed.program_environment program in
Compile.Of_simplified.compile_expression_as_function
~env ~state:(Typer.Solver.initial_state) payload in
let Compiler.Program.{input=_;output=(Ex_ty payload_ty);body=_} = code in
let%bind (payload: Tezos_utils.Michelson.michelson) =
Ligo.Run.Of_michelson.evaluate_michelson code in
let%bind packed_payload = Ligo.Run.Of_michelson.pack_payload payload payload_ty in
let (signed_data:Signature.t) = Signature.sign sk packed_payload in
let signature_str = Signature.to_b58check signed_data in
ok signature_str
let init_storage threshold counter pkeys =
let keys = List.map
(fun el ->
let (_,pk_str,_) = str_keys el in
e_key @@ pk_str)
pkeys in
ez_e_record [
("id" , e_string "MULTISIG" ) ;
("counter" , e_nat counter ) ;
("threshold" , e_nat threshold) ;
("auth" , e_typed_list keys t_key ) ;
]
let empty_op_list =
(e_typed_list [] t_operation)
let empty_message = e_lambda "arguments"
(Some t_unit) (Some (t_list t_operation))
empty_op_list
let chain_id_zero = e_chain_id @@ Tezos_crypto.Base58.simple_encode
Tezos_base__TzPervasives.Chain_id.b58check_encoding
Tezos_base__TzPervasives.Chain_id.zero
(* sign the message 'msg' with 'keys', if 'is_valid'=false the providid signature will be incorrect *)
let params counter msg keys is_validl =
let aux = fun acc (key,is_valid) ->
let (_,_pk,sk) = key in
let (pkh,_,_) = str_keys key in
let payload = e_tuple
[ msg ;
e_nat counter ;
e_string (if is_valid then "MULTISIG" else "XX") ;
chain_id_zero ] in
let%bind signature = sign_message payload sk in
ok @@ (e_pair (e_key_hash pkh) (e_signature signature))::acc in
let%bind signed_msgs = Trace.bind_fold_list aux [] (List.rev @@ List.combine keys is_validl) in
ok @@ e_constructor
"CheckMessage"
(ez_e_record [
("counter" , e_nat counter ) ;
("message" , msg) ;
("signatures" , e_typed_list signed_msgs (t_pair (t_key_hash,t_signature)) ) ;
])
(* Provide one valid signature when the threshold is two of two keys *)
let not_enough_1_of_2 () =
let%bind program,_ = get_program () in
let exp_failwith = "Not enough signatures passed the check" in
let keys = gen_keys () in
let%bind test_params = params 0 empty_message [keys] [true] in
let%bind () = expect_string_failwith
program "main" (e_pair test_params (init_storage 2 0 [keys;gen_keys()])) exp_failwith in
ok ()
let unmatching_counter () =
let%bind program,_ = get_program () in
let exp_failwith = "Counters does not match" in
let keys = gen_keys () in
let%bind test_params = params 1 empty_message [keys] [true] in
let%bind () = expect_string_failwith
program "main" (e_pair test_params (init_storage 1 0 [keys])) exp_failwith in
ok ()
(* Provide one invalid signature (correct key but incorrect signature)
when the threshold is one of one key *)
let invalid_1_of_1 () =
let%bind program,_ = get_program () in
let exp_failwith = "Invalid signature" in
let keys = [gen_keys ()] in
let%bind test_params = params 0 empty_message keys [false] in
let%bind () = expect_string_failwith
program "main" (e_pair test_params (init_storage 1 0 keys)) exp_failwith in
ok ()
(* Provide one valid signature when the threshold is one of one key *)
let valid_1_of_1 () =
let%bind program,_ = get_program () in
let keys = gen_keys () in
let%bind () = expect_eq_n_trace_aux [0;1;2] program "main"
(fun n ->
let%bind params = params n empty_message [keys] [true] in
ok @@ e_pair params (init_storage 1 n [keys])
)
(fun n ->
ok @@ e_pair empty_op_list (init_storage 1 (n+1) [keys])
) in
ok ()
(* Provive two valid signatures when the threshold is two of three keys *)
let valid_2_of_3 () =
let%bind program,_ = get_program () in
let param_keys = [gen_keys (); gen_keys ()] in
let st_keys = param_keys @ [gen_keys ()] in
let%bind () = expect_eq_n_trace_aux [0;1;2] program "main"
(fun n ->
let%bind params = params n empty_message param_keys [true;true] in
ok @@ e_pair params (init_storage 2 n st_keys)
)
(fun n ->
ok @@ e_pair empty_op_list (init_storage 2 (n+1) st_keys)
) in
ok ()
(* Provide one invalid signature and two valid signatures when the threshold is two of three keys *)
let invalid_3_of_3 () =
let%bind program,_ = get_program () in
let valid_keys = [gen_keys() ; gen_keys()] in
let invalid_key = gen_keys () in
let param_keys = valid_keys @ [invalid_key] in
let st_keys = valid_keys @ [gen_keys ()] in
let%bind test_params = params 0 empty_message param_keys [false;true;true] in
let exp_failwith = "Invalid signature" in
let%bind () = expect_string_failwith
program "main" (e_pair test_params (init_storage 2 0 st_keys)) exp_failwith in
ok ()
(* Provide two valid signatures when the threshold is three of three keys *)
let not_enough_2_of_3 () =
let%bind program,_ = get_program () in
let valid_keys = [gen_keys() ; gen_keys()] in
let st_keys = gen_keys () :: valid_keys in
let%bind test_params = params 0 empty_message (valid_keys) [true;true] in
let exp_failwith = "Not enough signatures passed the check" in
let%bind () = expect_string_failwith
program "main" (e_pair test_params (init_storage 3 0 st_keys)) exp_failwith in
ok ()
let main = test_suite "Multisig" [
test "compile" compile_main ;
test "unmatching_counter" unmatching_counter ;
test "valid_1_of_1" valid_1_of_1 ;
test "invalid_1_of_1" invalid_1_of_1 ;
test "not_enough_signature" not_enough_1_of_2 ;
test "valid_2_of_3" valid_2_of_3 ;
test "invalid_3_of_3" invalid_3_of_3 ;
test "not_enough_2_of_3" not_enough_2_of_3 ;
]

1
src/test/test.ml
View File

@ -11,6 +11,7 @@ let () =
Heap_tests.main ;
Coase_tests.main ;
Vote_tests.main ;
Multisig_tests.main ;
Bin_tests.main ;
] ;
()

11
src/test/test_helpers.ml
View File

@ -95,6 +95,17 @@ let expect_n_aux ?options lst program entry_point make_input make_expecter =
let%bind _ = bind_map_list aux lst in
ok ()
let expect_eq_n_trace_aux ?options lst program entry_point make_input make_expected =
let aux n =
let%bind input = make_input n in
let%bind expected = make_expected n in
trace (simple_error ("expect_eq_n " ^ (string_of_int n))) @@
let result = expect_eq ?options program entry_point input expected in
result
in
let%bind _ = bind_map_list_seq aux lst in
ok ()
let expect_eq_n_aux ?options lst program entry_point make_input make_expected =
let aux n =
let input = make_input n in