Proto: associate metadata to valid block headers and operations

src/bin_client/test/demo/main.ml

@@ -15,12 +15,17 @@ type block_header = {
 let block_header_data_encoding =
   Data_encoding.(obj1 (req "random_data" Variable.bytes))
 
+type block_header_metadata = unit
+let block_header_metadata_encoding = Data_encoding.unit
+
 type operation_data = unit
 type operation = {
   shell : Operation.shell_header ;
   protocol_data : operation_data ;
 }
 let operation_data_encoding = Data_encoding.unit
+type operation_metadata = unit
+let operation_metadata_encoding = Data_encoding.unit
 
 let max_block_length = 42
 let validation_passes = []
@@ -91,16 +96,16 @@ let begin_construction
   return { context ; fitness }
 
 let apply_operation ctxt _ =
-  return ctxt
+  return (ctxt, ())
 
 let finalize_block ctxt =
   let fitness = Fitness.get ctxt in
   let message = Some (Format.asprintf "fitness <- %Ld" fitness) in
   let fitness = Fitness.from_int64 fitness in
-  return { Updater.message ; context = ctxt.context ; fitness ;
-           max_operations_ttl = 0 ; max_operation_data_length = 0 ;
-           last_allowed_fork_level = 0l ;
-         }
+  return ({ Updater.message ; context = ctxt.context ; fitness ;
+            max_operations_ttl = 0 ; max_operation_data_length = 0 ;
+            last_allowed_fork_level = 0l ;
+          }, ())
 
 let rpc_services = RPC_directory.empty
 

src/bin_client/test/test_injection.sh

@@ -14,7 +14,7 @@ show_logs="no"
 sleep 2
 
 # autogenerated from the demo source
-protocol_version="PsbyjqSF59ENfaQxUcRqVa4DXjzUG8gP2NVEGiXpN3GntcXrV8Q"
+protocol_version="PtamL2BUfeNFM2A8Thq2Wde8vNaVD9DhoARDVB41QsHFj89kQpT"
 
 $admin_client inject protocol "$test_dir/demo"
 $admin_client list protocols

src/lib_protocol_environment/sigs/v1/updater.mli

@@ -79,6 +79,12 @@ module type PROTOCOL = sig
     protocol_data: block_header_data ;
   }
 
+  (** ... *)
+  type block_header_metadata
+
+  (** ...  *)
+  val block_header_metadata_encoding: block_header_metadata Data_encoding.t
+
   (** The version specific type of operations. *)
   type operation_data
 
@@ -91,6 +97,12 @@ module type PROTOCOL = sig
     protocol_data: operation_data ;
   }
 
+  (** ... *)
+  type operation_metadata
+
+  (** ...  *)
+  val operation_metadata_encoding: operation_metadata Data_encoding.t
+
   (** The Validation passes in which an operation can appear.
       For instance [[0]] if it only belongs to the first pass.
       An answer of [[]] means that the operation is ill-formed
@@ -160,13 +172,16 @@ module type PROTOCOL = sig
   (** Called after {!begin_application} (or {!begin_construction}) and
       before {!finalize_block}, with each operation in the block. *)
   val apply_operation:
-    validation_state -> operation -> validation_state tzresult Lwt.t
+    validation_state ->
+    operation ->
+    (validation_state * operation_metadata) tzresult Lwt.t
 
   (** The last step in a block validation sequence. It produces the
       context that will be used as input for the validation of its
       successor block candidates. *)
   val finalize_block:
-    validation_state -> validation_result tzresult Lwt.t
+    validation_state ->
+    (validation_result * block_header_metadata) tzresult Lwt.t
 
   (** The list of remote procedures exported by this implementation *)
   val rpc_services: rpc_context Lwt.t RPC_directory.t

src/lib_protocol_environment/tezos_protocol_environment.ml

@@ -67,12 +67,16 @@ module Make (Context : CONTEXT) = struct
       shell: Block_header.shell_header ;
       protocol_data: block_header_data ;
     }
+    type block_header_metadata
+    val block_header_metadata_encoding: block_header_metadata Data_encoding.t
     type operation_data
     val operation_data_encoding: operation_data Data_encoding.t
     type operation = {
       shell: Operation.shell_header ;
       protocol_data: operation_data ;
     }
+    type operation_metadata
+    val operation_metadata_encoding: operation_metadata Data_encoding.t
     val acceptable_passes: operation -> int list
     val compare_operations: operation -> operation -> int
     type validation_state
@@ -98,9 +102,11 @@ module Make (Context : CONTEXT) = struct
       ?protocol_data: block_header_data ->
       unit -> validation_state tzresult Lwt.t
     val apply_operation:
-      validation_state -> operation -> validation_state tzresult Lwt.t
+      validation_state -> operation ->
+      (validation_state * operation_metadata)  tzresult Lwt.t
     val finalize_block:
-      validation_state -> validation_result tzresult Lwt.t
+      validation_state ->
+      (validation_result * block_header_metadata) tzresult Lwt.t
     val rpc_services: rpc_context Lwt.t RPC_directory.t
     val init:
       context -> Block_header.shell_header -> validation_result tzresult Lwt.t

src/lib_protocol_environment/tezos_protocol_environment.mli

@@ -60,12 +60,16 @@ module Make (Context : CONTEXT) : sig
       shell: Block_header.shell_header ;
       protocol_data: block_header_data ;
     }
+    type block_header_metadata
+    val block_header_metadata_encoding: block_header_metadata Data_encoding.t
     type operation_data
     val operation_data_encoding: operation_data Data_encoding.t
     type operation = {
       shell: Operation.shell_header ;
       protocol_data: operation_data ;
     }
+    type operation_metadata
+    val operation_metadata_encoding: operation_metadata Data_encoding.t
     val acceptable_passes: operation -> int list
     val compare_operations: operation -> operation -> int
     type validation_state
@@ -91,9 +95,11 @@ module Make (Context : CONTEXT) : sig
       ?protocol_data: block_header_data ->
       unit -> validation_state tzresult Lwt.t
     val apply_operation:
-      validation_state -> operation -> validation_state tzresult Lwt.t
+      validation_state -> operation ->
+      (validation_state * operation_metadata) tzresult Lwt.t
     val finalize_block:
-      validation_state -> validation_result tzresult Lwt.t
+      validation_state ->
+      (validation_result * block_header_metadata) tzresult Lwt.t
     val rpc_services: rpc_context Lwt.t RPC_directory.t
     val init:
       context -> Block_header.shell_header -> validation_result tzresult Lwt.t

src/lib_shell/block_validator.ml

@@ -180,10 +180,10 @@ let apply_block
     ~predecessor_fitness:pred_header.shell.fitness
     header >>=? fun state ->
   fold_left_s (fold_left_s (fun state op ->
-      Proto.apply_operation state op >>=? fun state ->
+      Proto.apply_operation state op >>=? fun (state, _metadata) ->
       return state))
     state parsed_operations >>=? fun state ->
-  Proto.finalize_block state >>=? fun validation_result ->
+  Proto.finalize_block state >>=? fun (validation_result, _metadata) ->
   Context.get_protocol validation_result.context >>= fun new_protocol ->
   let expected_proto_level =
     if Protocol_hash.equal new_protocol Proto.hash then

src/lib_shell/prevalidation.ml

@@ -14,7 +14,7 @@ let rec apply_operations apply_operation state r max_ops ~sort ops =
   Lwt_list.fold_left_s
     (fun (state, max_ops, r) (hash, op, parsed_op) ->
        apply_operation state max_ops op parsed_op >>= function
-       | Ok state ->
+       | Ok (state, _metadata) ->
            let applied = (hash, op) :: r.applied in
            Lwt.return (state, max_ops - 1, { r with applied })
        | Error errors ->
@@ -164,4 +164,5 @@ let prevalidate
               r)
 
 let end_prevalidation (State { proto = (module Proto) ; state }) =
-  Proto.finalize_block state
+  Proto.finalize_block state >>=? fun (result, _metadata) ->
+  return result

src/lib_shell/test/test_state.ml

@@ -101,7 +101,7 @@ let build_valid_chain state vtbl pred names =
                (parsed_block block) >>=? fun vstate ->
              (* no operations *)
              Proto.finalize_block vstate
-           end >>=? fun ctxt ->
+           end >>=? fun (ctxt, _metadata) ->
            State.Block.store state block [[op]] ctxt >>=? fun _vblock ->
            State.Block.read state hash >>=? fun vblock ->
            Hashtbl.add vtbl name vblock ;

src/lib_shell_services/block_services.mli

@@ -64,7 +64,6 @@ val protocol:
 val test_chain:
   #simple -> block -> Test_chain_status.t tzresult Lwt.t
 
-
 val info:
   #simple ->
   ?include_ops:bool -> block -> block_info tzresult Lwt.t

src/proto_alpha/lib_protocol/src/main.ml

@@ -17,6 +17,9 @@ type block_header = Alpha_context.Block_header.t = {
 
 let block_header_data_encoding = Alpha_context.Block_header.protocol_data_encoding
 
+type block_header_metadata = unit
+let block_header_metadata_encoding = Data_encoding.unit
+
 type operation_data = Alpha_context.Operation.protocol_data
 type operation = Alpha_context.Operation.t = {
   shell: Operation.shell_header ;
@@ -25,6 +28,9 @@ type operation = Alpha_context.Operation.t = {
 
 let operation_data_encoding = Alpha_context.Operation.protocol_data_encoding
 
+type operation_metadata = unit
+let operation_metadata_encoding = Data_encoding.unit
+
 let acceptable_passes = Alpha_context.Operation.acceptable_passes
 
 let max_block_length =
@@ -124,13 +130,13 @@ let apply_operation ({ mode ; ctxt ; op_count ; _ } as data) operation =
   Apply.apply_operation ctxt Optimized predecessor
     (Alpha_context.Operation.hash operation) operation >>=? fun (ctxt, _) ->
   let op_count = op_count + 1 in
-  return { data with ctxt ; op_count }
+  return ({ data with ctxt ; op_count }, ())
 
 let finalize_block { mode ; ctxt ; op_count ; deposit = _ } =
   match mode with
   | Partial_construction _ ->
       let ctxt = Alpha_context.finalize ctxt in
-      return ctxt
+      return (ctxt, ())
   | Application
       { baker ;  block_header = { protocol_data = { contents = protocol_data ; _ } ; _ } }
   | Full_construction { protocol_data ; baker ; _ } ->
@@ -145,7 +151,7 @@ let finalize_block { mode ; ctxt ; op_count ; deposit = _ } =
           "lvl %ld, fit %Ld, prio %d, %d ops"
           level fitness priority op_count in
       let ctxt = Alpha_context.finalize ~commit_message ctxt in
-      return ctxt
+      return (ctxt, ())
 
 let compare_operations op1 op2 =
   Apply.compare_operations op1 op2

src/proto_alpha/lib_protocol/test/helpers/helpers_block.ml

@@ -167,10 +167,12 @@ let make init_block =
   let (operations,_) = List.split init_block.sourced_operations in
   begin_construction_pre init_block >>=? fun vs ->
   Proto_alpha.Error_monad.fold_left_s
-    Main.apply_operation
+    (fun ctxt op -> Main.apply_operation ctxt op >>=? fun (ctxt, _) -> return ctxt)
     vs
     operations
-  >>=? Main.finalize_block >>=? get_header_hash init_block
+  >>=? fun ctxt ->
+  Main.finalize_block ctxt >>=? fun (ctxt, _) ->
+  get_header_hash init_block ctxt
 
 
 let make_init psh pbh lvl prio ops ctxt =

src/proto_demo/lib_protocol/src/main.ml

@@ -13,15 +13,21 @@ type block_header = {
   shell : Block_header.shell_header ;
   protocol_data : block_header_data ;
 }
+
 let block_header_data_encoding =
   Data_encoding.(obj1 (req "random_data" Variable.bytes))
 
+type block_header_metadata = unit
+let block_header_metadata_encoding = Data_encoding.unit
+
 type operation_data = unit
 type operation = {
   shell : Operation.shell_header ;
   protocol_data : operation_data ;
 }
 let operation_data_encoding = Data_encoding.unit
+type operation_metadata = unit
+let operation_metadata_encoding = Data_encoding.unit
 let max_operation_data_length = 42
 
 let max_block_length = 42
@@ -94,16 +100,16 @@ let begin_construction
   return { context ; fitness }
 
 let apply_operation ctxt _ =
-  return ctxt
+  return (ctxt, ())
 
 let finalize_block ctxt =
   let fitness = Fitness.get ctxt in
   let message = Some (Format.asprintf "fitness <- %Ld" fitness) in
   let fitness = Fitness.from_int64 fitness in
-  return { Updater.message ; context = ctxt.context ; fitness ;
-           max_operations_ttl = 0 ; max_operation_data_length = 0 ;
-           last_allowed_fork_level = 0l ;
-         }
+  return ({ Updater.message ; context = ctxt.context ; fitness ;
+            max_operations_ttl = 0 ; max_operation_data_length = 0 ;
+            last_allowed_fork_level = 0l ;
+          }, ())
 
 let rpc_services = Services.rpc_services
 

src/proto_genesis/lib_protocol/src/main.ml

@@ -37,8 +37,12 @@ type operation = {
   shell: Operation.shell_header ;
   protocol_data: operation_data ;
 }
+
 let operation_data_encoding = Data_encoding.unit
 
+type operation_metadata = unit
+let operation_metadata_encoding = Data_encoding.unit
+
 let acceptable_passes _op = []
 let compare_operations _ _ = 0
 let validation_passes = []
@@ -58,6 +62,9 @@ let block_header_data_encoding =
     (fun (command, signature) ->  { command ; signature })
     Data.Command.signed_encoding
 
+type block_header_metadata = unit
+let block_header_metadata_encoding = Data_encoding.unit
+
 let max_block_length =
   Data_encoding.Binary.length
     Data.Command.encoding
@@ -142,7 +149,7 @@ let begin_construction
 let apply_operation _vctxt _ =
   Lwt.return (Error []) (* absurd *)
 
-let finalize_block state = return state
+let finalize_block state = return (state, ())
 
 let rpc_services = Services.rpc_services