Client, RPCs: do not sign transfer simulations

src/proto_alpha/lib_client/injection.ml

@@ -68,6 +68,26 @@ let preapply (type t)
     end
   | _ -> failwith "Unexpected result"
 
+let simulate (type t)
+    (cctxt: #Proto_alpha.full) ~chain ~block
+    ?branch (contents : t contents_list) =
+  get_branch cctxt ~chain ~block branch >>=? fun branch ->
+  let op : _ Operation.t =
+    { shell = { branch } ;
+      protocol_data = { contents ; signature = None } } in
+  let oph = Operation.hash op in
+  Alpha_services.Helpers.Scripts.run_operation
+    cctxt (chain, block) (Operation.pack op) >>=? function
+  | (Operation_data op', Operation_metadata result) -> begin
+      match Operation.equal
+              op { shell = { branch } ; protocol_data = op' },
+            Apply_operation_result.kind_equal_list contents result.contents with
+      | Some Operation.Eq, Some Apply_operation_result.Eq ->
+          return ((oph, op, result) : t preapply_result)
+      | _ -> failwith "Unexpected result"
+    end
+  | _ -> failwith "Unexpected result"
+
 let estimated_gas_single
     (type kind)
     (Manager_operation_result { operation_result ;
@@ -197,7 +217,7 @@ let detect_script_failure :
 
 let may_patch_limits
     (type kind) (cctxt : #Proto_alpha.full) ~chain ~block ?branch
-    ?src_sk (contents: kind contents_list) : kind contents_list tzresult Lwt.t =
+    (contents: kind contents_list) : kind contents_list tzresult Lwt.t =
   Alpha_services.Constants.all cctxt
     (chain, block) >>=? fun { parametric = {
       hard_gas_limit_per_operation = gas_limit ;
@@ -287,8 +307,7 @@ let may_patch_limits
       end in
   match may_need_patching contents with
   | Some contents ->
-      preapply cctxt ~chain ~block
+      simulate cctxt ~chain ~block ?branch contents >>=? fun (_, _, result) ->
-        ?branch ?src_sk contents >>=? fun (_, _, result) ->
       let res = pack_contents_list contents result.contents in
       patch_list res
   | None -> return contents
@@ -297,7 +316,7 @@ let inject_operation
     (type kind) cctxt ~chain ~block
     ?confirmations ?branch ?src_sk (contents: kind contents_list)  =
   may_patch_limits
-    cctxt ~chain ~block ?branch ?src_sk contents >>=? fun contents ->
+    cctxt ~chain ~block ?branch contents >>=? fun contents ->
   preapply cctxt ~chain ~block
     ?branch ?src_sk contents >>=? fun (_oph, op, result) ->
   begin match detect_script_failure result with

src/proto_alpha/lib_protocol/src/helpers_services.ml

@@ -123,6 +123,15 @@ module Scripts = struct
         ~query: RPC_query.empty
         RPC_path.(path / "hash_data")
 
+    let run_operation =
+      RPC_service.post_service
+        ~description:
+          "Run an operation without signature checks"
+        ~query: RPC_query.empty
+        ~input: Operation.encoding
+        ~output: Apply_operation_result.operation_data_and_metadata_encoding
+        RPC_path.(path / "run_operation")
+
   end
 
   let register () =
@@ -180,6 +189,59 @@ module Scripts = struct
       parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) ->
       Script_ir_translator.hash_data ctxt typ data >>=? fun (hash, ctxt) ->
       return (hash, Gas.level ctxt)
+    end ;
+    register0 S.run_operation begin fun ctxt ()
+      { shell ; protocol_data = Operation_data protocol_data } ->
+      (* this code is a duplicate of Apply without signature check *)
+      let partial_precheck_manager_contents
+          (type kind) ctxt (op : kind Kind.manager contents)
+        : context tzresult Lwt.t =
+        let Manager_operation { source ; fee ; counter ; operation } = op in
+        Contract.must_be_allocated ctxt source >>=? fun () ->
+        Contract.check_counter_increment ctxt source counter >>=? fun () ->
+        begin
+          match operation with
+          | Reveal pk ->
+              Contract.reveal_manager_key ctxt source pk
+          | _ -> return ctxt
+        end >>=? fun ctxt ->
+        Contract.get_manager_key ctxt source >>=? fun _public_key ->
+        (* signature check unplugged from here *)
+        Contract.increment_counter ctxt source >>=? fun ctxt ->
+        Contract.spend ctxt source fee >>=? fun ctxt ->
+        return ctxt in
+      let rec partial_precheck_manager_contents_list
+        : type kind.
+          Alpha_context.t -> kind Kind.manager contents_list ->
+          context tzresult Lwt.t =
+        fun ctxt contents_list ->
+          match contents_list with
+          | Single (Manager_operation _ as op) ->
+              partial_precheck_manager_contents ctxt op
+          | Cons (Manager_operation _ as op, rest) ->
+              partial_precheck_manager_contents ctxt op >>=? fun ctxt ->
+              partial_precheck_manager_contents_list ctxt rest in
+      let return contents =
+        return (Operation_data protocol_data,
+                Apply_operation_result.Operation_metadata { contents }) in
+      let operation : _ operation = { shell ; protocol_data } in
+      let hash = Operation.hash { shell ; protocol_data } in
+      let ctxt = Contract.init_origination_nonce ctxt hash in
+      match protocol_data.contents with
+      | Single (Manager_operation _) as op ->
+          partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
+          Apply.apply_manager_contents_list ctxt Readable op >>= fun (_ctxt, result) ->
+          return result
+      | Cons (Manager_operation _, _) as op ->
+          partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
+          Apply.apply_manager_contents_list ctxt Readable op >>= fun (_ctxt, result) ->
+          return result
+      | _ ->
+          Apply.apply_contents_list
+            ctxt Readable shell.branch operation
+            operation.protocol_data.contents >>=? fun (_ctxt, result) ->
+          return result
+
     end
 
   let run_code ctxt block code (storage, input, amount, contract) =
@@ -199,6 +261,9 @@ module Scripts = struct
   let hash_data ctxt block =
     RPC_context.make_call0 S.hash_data ctxt block ()
 
+  let run_operation ctxt block =
+    RPC_context.make_call0 S.run_operation ctxt block ()
+
 end
 
 module Forge = struct

src/proto_alpha/lib_protocol/src/helpers_services.mli

@@ -52,6 +52,10 @@ module Scripts : sig
     'a #RPC_context.simple ->
     'a -> Script.expr * Script.expr * Z.t option -> (string * Gas.t) shell_tzresult Lwt.t
 
+  val run_operation:
+    'a #RPC_context.simple ->
+    'a -> packed_operation ->
+    (packed_protocol_data * Apply_operation_result.packed_operation_metadata) shell_tzresult Lwt.t
 
 end