Shell/RPC: preapply now take a list of list of operations.

Progress towards the multipass validator.

lib_client_base/client_node_rpcs.ml

@@ -69,12 +69,12 @@ module Blocks = struct
   type preapply_param = Services.Blocks.preapply_param = {
     timestamp: Time.t ;
     proto_header: MBytes.t ;
-    operations: Operation.t list ;
+    operations: Operation.t list list ;
     sort_operations: bool ;
   }
   type preapply_result = Services.Blocks.preapply_result = {
     shell_header: Block_header.shell_header ;
-    operations: error Preapply_result.t ;
+    operations: error Preapply_result.t list ;
   }
   let net_id cctxt h =
     call_service1 cctxt Services.Blocks.net_id h ()

lib_client_base/client_node_rpcs.mli

@@ -113,7 +113,7 @@ module Blocks : sig
 
   type preapply_result = {
     shell_header: Block_header.shell_header ;
-    operations: error Preapply_result.t ;
+    operations: error Preapply_result.t list ;
   }
 
   val preapply:
@@ -122,7 +122,7 @@ module Blocks : sig
     ?timestamp:Time.t ->
     ?sort:bool ->
     proto_header:MBytes.t ->
-    Operation.t list -> preapply_result tzresult Lwt.t
+    Operation.t list list -> preapply_result tzresult Lwt.t
 
 end
 

lib_embedded_client_alpha/client_baking_forge.ml

@@ -158,8 +158,9 @@ let forge_block cctxt block
   let request = List.length operations in
   let proto_header = forge_faked_proto_header ~priority ~seed_nonce_hash in
   Client_node_rpcs.Blocks.preapply
-    cctxt block ~timestamp ~sort ~proto_header operations >>=?
+    cctxt block ~timestamp ~sort ~proto_header [operations] >>=?
   fun { operations = result ; shell_header } ->
+  let result = List.hd result in
   let valid = List.length result.applied in
   lwt_log_info "Found %d valid operations (%d refused) for timestamp %a"
     valid (request - valid)
@@ -446,13 +447,14 @@ let bake (cctxt : Client_commands.full_context) state =
        let proto_header =
          forge_faked_proto_header ~priority ~seed_nonce_hash in
        Client_node_rpcs.Blocks.preapply cctxt block
-         ~timestamp ~sort:true ~proto_header operations >>= function
+         ~timestamp ~sort:true ~proto_header [operations] >>= function
        | Error errs ->
            lwt_log_error "Error while prevalidating operations:\n%a"
              pp_print_error
              errs >>= fun () ->
            return None
        | Ok { operations ; shell_header } ->
+           let operations = List.hd operations in
            lwt_debug
              "Computed condidate block after %a (slot %d): %d/%d fitness: %a"
              Block_hash.pp_short bi.hash priority

lib_node_services/node_rpc_services.ml

@@ -305,7 +305,7 @@ module Blocks = struct
   type preapply_param = {
     timestamp: Time.t ;
     proto_header: MBytes.t ;
-    operations: Operation.t list ;
+    operations: Operation.t list list ;
     sort_operations: bool ;
   }
 
@@ -318,12 +318,12 @@ module Blocks = struct
        (obj4
           (req "timestamp" Time.encoding)
           (req "proto_header" bytes)
-          (req "operations" (list (dynamic_size Operation.encoding)))
+          (req "operations" (list (dynamic_size (list (dynamic_size Operation.encoding)))))
           (dft "sort_operations" bool false)))
 
   type preapply_result = {
     shell_header: Block_header.shell_header ;
-    operations: error Preapply_result.t ;
+    operations: error Preapply_result.t list ;
   }
 
   let preapply_result_encoding =
@@ -335,7 +335,7 @@ module Blocks = struct
        (obj2
           (req "shell_header" Block_header.shell_header_encoding)
           (req "operations"
-             (Preapply_result.encoding Error.encoding))))
+             (list (Preapply_result.encoding Error.encoding)))))
 
   let preapply =
     RPC_service.post_service

lib_node_services/node_rpc_services.mli

@@ -120,13 +120,13 @@ module Blocks : sig
   type preapply_param = {
     timestamp: Time.t ;
     proto_header: MBytes.t ;
-    operations: Operation.t list ;
+    operations: Operation.t list list ;
     sort_operations: bool ;
   }
 
   type preapply_result = {
     shell_header: Block_header.shell_header ;
-    operations: error Preapply_result.t ;
+    operations: error Preapply_result.t list ;
   }
   val preapply:
     ([ `POST ], unit,

lib_node_shell/node.ml

@@ -475,12 +475,20 @@ module RPC = struct
     end >>=? fun predecessor ->
     Prevalidation.start_prevalidation
       ~proto_header ~predecessor ~timestamp () >>=? fun validation_state ->
-    let ops = List.map (fun x -> Operation.hash x, x) ops in
+    let ops = List.map (List.map (fun x -> Operation.hash x, x)) ops in
+    Lwt_list.fold_left_s
+      (fun (validation_state, rs) ops ->
          Prevalidation.prevalidate
            validation_state ~sort ops >>= fun (validation_state, r) ->
+         Lwt.return (validation_state, rs @ [r]))
+      (validation_state, []) ops >>= fun (validation_state, rs) ->
     let operations_hash =
       Operation_list_list_hash.compute
-        [Operation_list_hash.compute (List.map fst r.applied)] in
+        (List.map
+           (fun r ->
+              Operation_list_hash.compute
+                (List.map fst r.Preapply_result.applied))
+           rs) in
     Prevalidation.end_prevalidation
       validation_state >>=? fun { fitness ; context } ->
     let pred_shell_header = State.Block.shell_header predecessor in
@@ -496,11 +504,11 @@ module RPC = struct
       proto_level ;
       predecessor = State.Block.hash predecessor ;
       timestamp ;
-      validation_passes = 1 ;
+      validation_passes = List.length rs ;
       operations_hash ;
       fitness ;
     } in
-    return (shell_header, r)
+    return (shell_header, rs)
 
   let complete node ?block str =
     match block with

lib_node_shell/node.mli

@@ -94,8 +94,8 @@ module RPC : sig
   val preapply:
     t -> block ->
     timestamp:Time.t -> proto_header:MBytes.t ->
-    sort_operations:bool -> Operation.t list ->
+    sort_operations:bool -> Operation.t list list ->
-    (Block_header.shell_header * error Preapply_result.t) tzresult Lwt.t
+    (Block_header.shell_header * error Preapply_result.t list) tzresult Lwt.t
 
   val context_dir:
     t -> block -> 'a RPC_directory.t option Lwt.t