Shell: forced upgrades

src/lib_base/block_header.ml

@@ -92,3 +92,17 @@ let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b
 
 let hash block = Block_hash.hash_bytes [to_bytes block]
 let hash_raw bytes = Block_hash.hash_bytes [bytes]
+
+let forced_protocol_upgrades : (Int32.t * Protocol_hash.t) list = [
+  (* nothing *)
+]
+
+module LevelMap =
+  Map.Make(struct type t = Int32.t let compare = Int32.compare end)
+let get_forced_protocol_upgrade =
+  let table =
+    List.fold_left
+      (fun map (level, hash) -> LevelMap.add level hash map)
+      LevelMap.empty
+      forced_protocol_upgrades in
+  fun ~level -> LevelMap.find_opt level table

src/lib_base/block_header.mli

@@ -30,3 +30,5 @@ include S.HASHABLE with type t := t
 val of_bytes_exn: MBytes.t -> t
 
 val bounded_encoding: ?max_size:int -> unit -> t Data_encoding.t
+
+val get_forced_protocol_upgrade: level:Int32.t -> Protocol_hash.t option

src/lib_shell/block_validator.ml

@@ -112,6 +112,16 @@ let check_liveness chain_state pred hash operations_hashes operations =
   assert_operation_liveness hash live_blocks operations >>=? fun () ->
   return ()
 
+let may_patch_protocol
+    ~level
+    (validation_result : Tezos_protocol_environment_shell.validation_result) =
+  match Block_header.get_forced_protocol_upgrade ~level with
+  | None ->
+      return validation_result
+  | Some hash ->
+      Context.set_protocol validation_result.context hash >>= fun context ->
+      return { validation_result with context }
+
 let apply_block
     chain_state
     pred (module Proto : Registered_protocol.T)
@@ -189,6 +199,8 @@ let apply_block
     (state, []) parsed_operations >>=? fun (state, ops_metadata) ->
   let ops_metadata = List.rev ops_metadata in
   Proto.finalize_block state >>=? fun (validation_result, block_data) ->
+  may_patch_protocol
+    ~level:header.shell.level validation_result >>=? fun validation_result ->
   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/block_validator.mli

@@ -42,3 +42,8 @@ val status: t -> Worker_types.worker_status
 val pending_requests : t -> (Time.t * Block_validator_worker_state.Request.view) list
 val current_request : t -> (Time.t * Time.t * Block_validator_worker_state.Request.view) option
 val last_events : t -> (Lwt_log_core.level * Block_validator_worker_state.Event.t list) list
+
+val may_patch_protocol:
+  level:Int32.t ->
+  Tezos_protocol_environment_shell.validation_result ->
+  Tezos_protocol_environment_shell.validation_result tzresult Lwt.t

src/lib_shell/prevalidation.ml

@@ -183,8 +183,11 @@ let preapply ~predecessor ~timestamp ~protocol_data ~sort_operations:sort ops =
             Operation_list_hash.compute
               (List.map fst r.Preapply_result.applied))
          rs) in
-  end_prevalidation validation_state >>=? fun { fitness ; context ; message } ->
+  end_prevalidation validation_state >>=? fun validation_result ->
   let pred_shell_header = State.Block.shell_header predecessor in
+  let level = Int32.succ pred_shell_header.level in
+  Block_validator.may_patch_protocol
+    ~level validation_result >>=? fun { fitness ; context ; message } ->
   State.Block.protocol_hash predecessor >>= fun pred_protocol ->
   Context.get_protocol context >>= fun protocol ->
   let proto_level =
@@ -193,7 +196,7 @@ let preapply ~predecessor ~timestamp ~protocol_data ~sort_operations:sort ops =
     else
       ((pred_shell_header.proto_level + 1) mod 256) in
   let shell_header : Block_header.shell_header = {
-    level = Int32.succ pred_shell_header.level ;
+    level ;
     proto_level ;
     predecessor = State.Block.hash predecessor ;
     timestamp ;

src/lib_shell/prevalidator.ml

@@ -548,11 +548,6 @@ let timestamp w =
   let pv = Worker.state w in
   pv.timestamp
 
-let context w =
-  let pv = Worker.state w in
-  Lwt.return pv.validation_state >>=? fun validation_state ->
-  Prevalidation.end_prevalidation validation_state
-
 let inject_operation w op =
   Worker.push_request_and_wait w (Inject op)
 

src/lib_shell/prevalidator.mli

@@ -45,7 +45,6 @@ val inject_operation: t -> Operation.t -> unit tzresult Lwt.t
 val flush: t -> Block_hash.t -> unit tzresult Lwt.t
 val timestamp: t -> Time.t
 val operations: t -> error Preapply_result.t * Operation.t Operation_hash.Map.t
-val context: t -> Tezos_protocol_environment_shell.validation_result tzresult Lwt.t
 val pending: ?block:State.Block.t -> t -> Operation.t Operation_hash.Map.t Lwt.t
 
 val running_workers: unit -> (Chain_id.t * t) list