Proto+client: add RPCs and CLI entries to typecheck / hash / sign data.

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") ;
   ]

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
 

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
 

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 ()

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: "..."

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)