Shell/RPC: move preapply_operation into Block_services

src/lib_shell/block_directory.ml

@@ -252,7 +252,11 @@ let rpc_directory
 
   (* helpers *)
 
-  register0 S.Helpers.preapply begin fun block q p ->
+  register0 S.Helpers.Preapply.block begin fun block q p ->
+    let timestamp =
+      match q#timestamp with
+      | None -> Time.now ()
+      | Some time -> time in
     let protocol_data =
       Data_encoding.Binary.to_bytes_exn
         Next_proto.block_header_data_encoding
@@ -269,12 +273,32 @@ let rpc_directory
         p.operations in
     Prevalidation.preapply
       ~predecessor:block
-      ~timestamp:p.timestamp
+      ~timestamp
       ~protocol_data
       ~sort_operations:q#sort_operations
       operations
   end ;
 
+  register0 S.Helpers.Preapply.operations begin fun block () ops ->
+    State.Block.context block >>= fun ctxt ->
+    let predecessor = State.Block.hash block in
+    let header = State.Block.shell_header block in
+    Next_proto.begin_construction
+      ~predecessor_context:ctxt
+      ~predecessor_timestamp:header.timestamp
+      ~predecessor_level:header.level
+      ~predecessor_fitness:header.fitness
+      ~predecessor
+      ~timestamp:(Time.now ()) () >>=? fun state ->
+    fold_left_s
+      (fun (state, acc) op ->
+         Next_proto.apply_operation state op >>=? fun (state, result) ->
+         return (state, result :: acc))
+      (state, []) ops >>=? fun (state, acc) ->
+    Next_proto.finalize_block state >>=? fun _ ->
+    return (List.rev acc)
+  end ;
+
   register1 S.Helpers.complete begin fun block prefix () () ->
     State.Block.context block >>= fun ctxt ->
     Base58.complete prefix >>= fun l1 ->

src/lib_shell_services/block_services.ml

@@ -524,26 +524,28 @@ module Make(Proto : PROTO)(Next_proto : PROTO) = struct
 
       let path = RPC_path.(path / "context" / "helpers")
 
-      let preapply_result_encoding =
+      module Preapply = struct
+
+        let path = RPC_path.(path / "preapply")
+
+        let block_result_encoding =
           obj2
             (req "shell_header" Block_header.shell_header_encoding)
             (req "operations"
                (list (Preapply_result.encoding RPC_error.encoding)))
 
-      type preapply_param = {
+        type block_param = {
-        timestamp: Time.t ;
           protocol_data: Next_proto.block_header_data ;
           operations: Next_proto.operation list list ;
         }
 
-      let preapply_param_encoding =
+        let block_param_encoding =
           (conv
-           (fun { timestamp ; protocol_data ; operations } ->
+             (fun { protocol_data ; operations } ->
-              (timestamp, protocol_data, operations))
+                (protocol_data, operations))
-           (fun (timestamp, protocol_data, operations) ->
+             (fun (protocol_data, operations) ->
-              { timestamp ; protocol_data ; operations })
+                { protocol_data ; operations })
-           (obj3
+             (obj2
-              (req "timestamp" Time.encoding)
                 (req "protocol_data"
                    (conv
                       (fun h -> ((), h)) (fun ((), h) -> h)
@@ -553,23 +555,37 @@ module Make(Proto : PROTO)(Next_proto : PROTO) = struct
                 (req "operations"
                    (list (dynamic_size (list next_operation_encoding))))))
 
-      let preapply_query : < sort_operations: bool > RPC_query.t =
+        let block_query =
           let open RPC_query in
-        query (fun sort -> object
+          query (fun sort timestamp -> object
                   method sort_operations = sort
+                  method timestamp = timestamp
                 end)
           |+ flag "sort" (fun t -> t#sort_operations)
+          |+ opt_field "timestamp" Time.rpc_arg (fun t -> t#timestamp)
           |> seal
 
-      let preapply =
+        let block =
           RPC_service.post_service
             ~description:
               "Simulate the validation of a block that would contain \
-             the given operations and return the resulting fitness."
+               the given operations and return the resulting fitness \
-          ~query: preapply_query
+               and context hash."
-          ~input: preapply_param_encoding
+            ~query: block_query
-          ~output: preapply_result_encoding
+            ~input: block_param_encoding
-          RPC_path.(path / "preapply")
+            ~output: block_result_encoding
+            RPC_path.(path / "block")
+
+        let operations =
+          RPC_service.post_service
+            ~description:
+              "Simulate the validation of an operation."
+            ~query: RPC_query.empty
+            ~input: (list next_operation_encoding)
+            ~output: (list (dynamic_size Next_proto.operation_metadata_encoding))
+            RPC_path.(path / "operations")
+
+      end
 
       let complete =
         let prefix_arg =
@@ -830,14 +846,25 @@ module Make(Proto : PROTO)(Next_proto : PROTO) = struct
 
     module S = S.Helpers
 
-    let preapply ctxt =
+    module Preapply = struct
-      let f = make_call0 S.preapply ctxt in
+
+      module S = S.Preapply
+
+      let block ctxt =
+        let f = make_call0 S.block ctxt in
         fun
           ?(chain = `Main) ?(block = `Head 0)
-        ?(sort = false) ~timestamp ~protocol_data operations ->
+          ?(sort = false) ?timestamp ~protocol_data operations ->
           f chain block
-          (object method sort_operations = sort end)
+            (object method sort_operations = sort method timestamp = timestamp end)
-          { timestamp ; protocol_data ; operations  }
+            { protocol_data ; operations  }
+
+      let operations ctxt =
+        let f = make_call0 S.operations ctxt in
+        fun ?(chain = `Main) ?(block = `Head 0) operations ->
+          f chain block () operations
+
+    end
 
     let complete ctxt =
       let f = make_call1 S.complete ctxt in

src/lib_shell_services/block_services.mli

@@ -222,14 +222,23 @@ module Make(Proto : PROTO)(Next_proto : PROTO) : sig
 
   module Helpers : sig
 
-    val preapply:
+    module Preapply : sig
+
+      val block:
         #simple -> ?chain:chain -> ?block:block ->
         ?sort:bool ->
-      timestamp:Time.t ->
+        ?timestamp:Time.t ->
         protocol_data:Next_proto.block_header_data ->
         Next_proto.operation list list ->
         (Block_header.shell_header * error Preapply_result.t list) tzresult Lwt.t
 
+      val operations:
+        #simple -> ?chain:chain -> ?block:block ->
+        Next_proto.operation list ->
+        Next_proto.operation_metadata list tzresult Lwt.t
+
+    end
+
     val complete:
       #simple -> ?chain:chain -> ?block:block ->
       string -> string list tzresult Lwt.t
@@ -413,17 +422,26 @@ module Make(Proto : PROTO)(Next_proto : PROTO) : sig
 
     module Helpers : sig
 
-      type preapply_param = {
+      module Preapply : sig
-        timestamp: Time.t ;
+
+        type block_param = {
           protocol_data: Next_proto.block_header_data ;
           operations: Next_proto.operation list list ;
         }
 
-      val preapply:
+        val block:
           ([ `POST ], prefix,
-         prefix, < sort_operations : bool >, preapply_param,
+           prefix, < sort_operations : bool;
+                     timestamp : Time.t option >, block_param,
            Block_header.shell_header * error Preapply_result.t list) RPC_service.t
 
+        val operations:
+          ([ `POST ], prefix,
+           prefix, unit, Next_proto.operation list,
+           Next_proto.operation_metadata list) RPC_service.t
+
+      end
+
       val complete:
         ([ `GET ], prefix,
          prefix * string, unit, unit,

src/proto_alpha/lib_baking/client_baking_forge.ml

@@ -199,7 +199,7 @@ let forge_block cctxt ?(chain = `Main) block
   let request = List.length operations in
   let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in
   let operations = classify_operations operations in
-  Block_services.Helpers.preapply
+  Block_services.Helpers.Preapply.block
     cctxt ~block ~timestamp ~sort ~protocol_data operations >>=?
   fun (shell_header, result) ->
   let valid =
@@ -519,7 +519,8 @@ let bake (cctxt : #Proto_alpha.full) state =
        let protocol_data =
          forge_faked_protocol_data ~priority ~seed_nonce_hash in
        let operations = classify_operations operations in
-       Block_services.Helpers.preapply cctxt ~chain ~block
+       Block_services.Helpers.Preapply.block
+         cctxt ~chain ~block
          ~timestamp ~sort:true ~protocol_data operations >>= function
        | Error errs ->
            lwt_log_error "Error while prevalidating operations:@\n%a"

src/proto_alpha/lib_client/injection.ml

@@ -51,10 +51,10 @@ let preapply
     { shell = { branch } ;
       protocol_data = { contents ; signature } } in
   let oph = Operation.hash op in
-  Block_services.hash cctxt ~chain ~block () >>=? fun bh ->
+  Block_services.Helpers.Preapply.operations cctxt ~chain ~block
-  Alpha_services.Helpers.apply_operation cctxt
+    [op] >>=? function
-    (chain, block) bh oph bytes signature >>=? fun result ->
+  | [result] -> return (oph, op, result)
-  return (oph, op, result)
+  | _ -> failwith "Unexpected result"
 
 let estimated_gas = function
   | Sourced_operation_result (Manager_operations_result { operation_results }) ->

src/proto_alpha/lib_protocol/src/helpers_services.ml

@@ -100,18 +100,6 @@ module S = struct
                   (opt "big_map_diff" (list (tup2 string (option Script.expr_encoding)))))
       RPC_path.(custom_root / "run_code")
 
-  let apply_operation =
-    RPC_service.post_service
-      ~description: "Applies an operation in the current context"
-      ~query: RPC_query.empty
-      ~input: (obj4
-                 (req "pred_block" Block_hash.encoding)
-                 (req "operation_hash" Operation_hash.encoding)
-                 (req "forged_operation" bytes)
-                 (opt "signature" Signature.encoding))
-      ~output: Apply_operation_result.encoding
-      RPC_path.(custom_root / "apply_operation")
-
   let trace_code =
     RPC_service.post_service
       ~description: "Run a piece of code in the current context, \
@@ -170,22 +158,6 @@ module S = struct
 
 end
 
-module I = struct
-
-  let apply_operation ctxt () (pred_block, hash, forged_operation, signature) =
-    (* ctxt accept_failing_script baker_contract pred_block block_prio operation *)
-    match Data_encoding.Binary.of_bytes
-            Operation.unsigned_encoding
-            forged_operation with
-    | None -> fail Cannot_parse_operation
-    | Some (shell, contents) ->
-        let operation = { shell ; protocol_data = { contents ; signature } } in
-        Apply.apply_operation
-          ctxt Readable pred_block hash operation >>=? fun (_, result) ->
-        return result
-
-end
-
 let () =
   let open Services_registration in
   register0 S.level begin fun ctxt q () ->
@@ -202,7 +174,6 @@ let () =
     let timestamp = Alpha_context.Timestamp.current ctxt in
     Baking.minimal_time ctxt q.priority timestamp
   end ;
-  register0 S.apply_operation I.apply_operation ;
   register0 S.run_code begin fun ctxt ()
     (code, storage, parameter, amount, contract) ->
     Lwt.return (Gas.set_limit ctxt (Constants.hard_gas_limit_per_operation ctxt)) >>=? fun ctxt ->
@@ -271,10 +242,6 @@ let run_code ctxt block code (storage, input, amount, contract) =
   RPC_context.make_call0 S.run_code ctxt
     block () (code, storage, input, amount, contract)
 
-let apply_operation ctxt block pred_block hash forged_operation signature =
-  RPC_context.make_call0 S.apply_operation ctxt
-    block () (pred_block, hash, forged_operation, signature)
-
 let trace_code ctxt block code (storage, input, amount, contract) =
   RPC_context.make_call0 S.trace_code ctxt
     block () (code, storage, input, amount, contract)

src/proto_alpha/lib_protocol/src/helpers_services.mli

@@ -28,11 +28,6 @@ val minimal_time:
     timestamp for the successor of [blk]. [?priority] defaults to
     [0]. *)
 
-val apply_operation:
-  'a #RPC_context.simple ->
-  'a -> Block_hash.t -> Operation_hash.t -> MBytes.t -> Signature.t option ->
-  Apply_operation_result.operation_result shell_tzresult Lwt.t
-
 val run_code:
   'a #RPC_context.simple ->
   'a -> Script.expr ->

src/proto_genesis/lib_client/client_proto_main.ml

@@ -15,7 +15,7 @@ let protocol =
 
 let bake cctxt ?(timestamp = Time.now ()) block command sk =
   let protocol_data = { command ; signature = Signature.zero } in
-  Block_services.Helpers.preapply
+  Block_services.Helpers.Preapply.block
     cctxt ~block ~timestamp ~protocol_data
     [] >>=? fun (shell_header, _) ->
   let blk = Data.Command.forge shell_header command in