From e0c039e244133acfd42ec6360f809e7bee9bafcf Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Mon, 12 Sep 2016 14:06:23 +0200 Subject: [PATCH] Proto+client: add RPCs and CLI entries to typecheck / hash / sign data. --- .../bootstrap/client_proto_programs.ml | 65 ++++++++++++++++++- .../embedded/bootstrap/client_proto_rpcs.ml | 6 ++ .../embedded/bootstrap/client_proto_rpcs.mli | 3 + src/proto/bootstrap/script_ir_translator.ml | 13 ++++ src/proto/bootstrap/services.ml | 27 ++++++++ src/proto/bootstrap/services_registration.ml | 12 ++++ 6 files changed, 123 insertions(+), 3 deletions(-) diff --git a/src/client/embedded/bootstrap/client_proto_programs.ml b/src/client/embedded/bootstrap/client_proto_programs.ml index 8ac8763bb..341cb5b8c 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.ml +++ b/src/client/embedded/bootstrap/client_proto_programs.ml @@ -105,7 +105,7 @@ let parse_data s = try match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with | [node] -> Lwt.return (Script_located_ir.strip_locations node) - | _ -> Cli_entries.error "single data expected" + | _ -> Cli_entries.error "single data expression expected" with | exn -> report_parse_error "data: " exn lexbuf @@ -114,7 +114,7 @@ let parse_data_type s = try match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with | [node] -> Lwt.return (Script_located_ir.strip_locations node) - | _ -> Cli_entries.error "single data type expected" + | _ -> Cli_entries.error "single type expression expected" with | exn -> report_parse_error "data_type: " exn lexbuf @@ -170,10 +170,69 @@ let commands () = (fun program () -> let open Data_encoding in Client_proto_rpcs.Helpers.typecheck_code (block ()) program >>= function - | Ok _contracts -> + | Ok () -> message "Well typed" ; Lwt.return () | Error errs -> pp_print_error Format.err_formatter errs ; error "ill-typed program") ; + command + ~group: "programs" + ~desc: "ask the node to typecheck a tagged data expression" + (prefixes [ "typecheck" ; "data" ] + @@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck" parse_data + @@ prefixes [ "against" ; "type" ] + @@ Cli_entries.param ~name:"type" ~desc:"the expected type" parse_data + @@ stop) + (fun data exp_ty () -> + let open Data_encoding in + Client_proto_rpcs.Helpers.typecheck_untagged_data + (block ()) (data, exp_ty) >>= function + | Ok () -> + message "Well typed" ; + Lwt.return () + | Error errs -> + pp_print_error Format.err_formatter errs ; + error "ill-typed data") ; + command + ~group: "programs" + ~desc: "ask the node to compute the hash of an untagged data expression \ + using the same algorithm as script instruction H" + (prefixes [ "hash" ; "data" ] + @@ Cli_entries.param ~name:"data" ~desc:"the data to hash" parse_data + @@ stop) + (fun data () -> + let open Data_encoding in + Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function + | Ok hash -> + message "%S" hash; + Lwt.return () + | Error errs -> + pp_print_error Format.err_formatter errs ; + error "ill-formed data") ; + command + ~group: "programs" + ~desc: "ask the node to compute the hash of an untagged data expression \ + using the same algorithm as script instruction H, sign it using \ + a given secret key, and display it using the format expected by \ + script instruction CHECK_SIGNATURE" + (prefixes [ "hash" ; "and" ; "sign" ; "data" ] + @@ Cli_entries.param ~name:"data" ~desc:"the data to hash" parse_data + @@ prefixes [ "for" ] + @@ Client_keys.Secret_key.alias_param + @@ stop) + (fun data (_, key) () -> + let open Data_encoding in + Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function + | Ok hash -> + let signature = Ed25519.sign key (MBytes.of_string hash) in + message "Hash: %S@.Signature: %S" + hash + (signature |> + Data_encoding.Binary.to_bytes Ed25519.signature_encoding |> + Hex_encode.hex_of_bytes) ; + Lwt.return () + | Error errs -> + pp_print_error Format.err_formatter errs ; + error "ill-formed data") ; ] diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.ml b/src/client/embedded/bootstrap/client_proto_rpcs.ml index 024698d5a..6fc2c0810 100644 --- a/src/client/embedded/bootstrap/client_proto_rpcs.ml +++ b/src/client/embedded/bootstrap/client_proto_rpcs.ml @@ -127,6 +127,12 @@ module Helpers = struct let typecheck_code = call_error_service1 Services.Helpers.typecheck_code + let typecheck_tagged_data = call_error_service1 Services.Helpers.typecheck_tagged_data + + let typecheck_untagged_data = call_error_service1 Services.Helpers.typecheck_untagged_data + + let hash_data = call_error_service1 Services.Helpers.hash_data + let level block ?offset lvl = call_error_service2 Services.Helpers.level block lvl offset diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.mli b/src/client/embedded/bootstrap/client_proto_rpcs.mli index 758b87dac..095707df5 100644 --- a/src/client/embedded/bootstrap/client_proto_rpcs.mli +++ b/src/client/embedded/bootstrap/client_proto_rpcs.mli @@ -93,6 +93,9 @@ module Helpers : sig val minimal_time: block -> ?prio:int -> unit -> Time.t tzresult Lwt.t val typecheck_code: block -> Script.code -> unit tzresult Lwt.t + val typecheck_tagged_data: block -> Script.expr -> unit tzresult Lwt.t + val typecheck_untagged_data: block -> Script.expr * Script.expr -> unit tzresult Lwt.t + val hash_data: block -> Script.expr -> string tzresult Lwt.t val level: block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t val levels: block -> Cycle.t -> Level.t list tzresult Lwt.t diff --git a/src/proto/bootstrap/script_ir_translator.ml b/src/proto/bootstrap/script_ir_translator.ml index 3d149557c..944c91d21 100644 --- a/src/proto/bootstrap/script_ir_translator.ml +++ b/src/proto/bootstrap/script_ir_translator.ml @@ -1448,3 +1448,16 @@ let typecheck_code let ret_type_full = Pair_t (ret_type, storage_type) in parse_lambda ctxt ~storage_type arg_type_full ret_type_full code >>=? fun _ -> return () + +let typecheck_tagged_data + : context -> Script.expr -> unit tzresult Lwt.t + = fun ctxt data -> + parse_tagged_data ctxt data >>=? fun (Ex _) -> + return () + +let typecheck_untagged_data + : context -> Script.expr * Script.expr -> unit tzresult Lwt.t + = fun ctxt (data, exp_ty) -> + parse_ty exp_ty >>=? fun (Ex exp_ty) -> + parse_untagged_data ctxt exp_ty data >>=? fun _ -> + return () diff --git a/src/proto/bootstrap/services.ml b/src/proto/bootstrap/services.ml index 7310611e0..ee0f0c147 100644 --- a/src/proto/bootstrap/services.ml +++ b/src/proto/bootstrap/services.ml @@ -333,6 +333,33 @@ module Helpers = struct ~output: (wrap_tzerror empty) RPC.Path.(custom_root / "helpers" / "typecheck_code") + let typecheck_tagged_data custom_root = + RPC.service + ~description: "Check that some tagged data expression is well formed \ + and well typed in the current context" + ~input: (obj1 (req "data" Script.expr_encoding)) + ~output: (wrap_tzerror empty) + RPC.Path.(custom_root / "helpers" / "typecheck_tagged_data") + + let typecheck_untagged_data custom_root = + RPC.service + ~description: "Check that some untagged data expression is well formed \ + and of a given type in the current context" + ~input: (obj2 + (req "data" Script.expr_encoding) + (req "type" Script.expr_encoding)) + ~output: (wrap_tzerror empty) + RPC.Path.(custom_root / "helpers" / "typecheck_untagged_data") + + let hash_data custom_root = + RPC.service + ~description: "Computes the hash of some (untagged) data expression \ + using the same algorithm as script instruction H" + ~input: (obj1 (req "data" Script.expr_encoding)) + ~output: (wrap_tzerror @@ + obj1 (req "hash" string)) + RPC.Path.(custom_root / "helpers" / "hash_data") + let level custom_root = RPC.service ~description: "..." diff --git a/src/proto/bootstrap/services_registration.ml b/src/proto/bootstrap/services_registration.ml index fc3165822..cba81697e 100644 --- a/src/proto/bootstrap/services_registration.ml +++ b/src/proto/bootstrap/services_registration.ml @@ -183,6 +183,18 @@ let () = register1 Services.Helpers.typecheck_code Script_ir_translator.typecheck_code +let () = + register1 Services.Helpers.typecheck_tagged_data + Script_ir_translator.typecheck_tagged_data + +let () = + register1 Services.Helpers.typecheck_untagged_data + Script_ir_translator.typecheck_untagged_data + +let () = + register1 Services.Helpers.hash_data + (fun _ctxt expr -> return (Script.hash_expr expr)) + let compute_level ctxt raw offset = return (Level.from_raw ctxt ?offset raw)