From 9821d42582ba546a24a4c5a000e73ea012514de0 Mon Sep 17 00:00:00 2001
From: Thomas Letan <lthms@nomadic-labs.com>
Date: Tue, 10 Dec 2024 13:44:05 +0100
Subject: [PATCH] EVM Node: Fix timing advertized by the `blueprint_applied`
 event

The timing advertized was limited to the function modifying the
`session_state`, and excluding the actual application of the blueprint and
commit to the on-disk stores.

This patch addresses this by introducing a new helper `with_timing_f_e`, where
`f` stands for `function` (i.e., the continution called by the helper also
takes the result of the computation), and `e` stands for `error` (i.e., the
computation is in the error monad, not Lwt).
---
 etherlink/bin_node/lib_dev/evm_context.ml | 67 ++++++++++++-----------
 etherlink/bin_node/lib_dev/misc.ml        | 12 ++++
 etherlink/bin_node/lib_dev/misc.mli       |  8 +++
 3 files changed, 55 insertions(+), 32 deletions(-)

diff --git a/etherlink/bin_node/lib_dev/evm_context.ml b/etherlink/bin_node/lib_dev/evm_context.ml
index 6d7e5cd3160d..032fbd150ff7 100644
--- a/etherlink/bin_node/lib_dev/evm_context.ml
+++ b/etherlink/bin_node/lib_dev/evm_context.ml
@@ -788,39 +788,42 @@ module State = struct
   let rec apply_blueprint ?(events = []) ctxt conn timestamp payload
       delayed_transactions =
     let open Lwt_result_syntax in
-    let* evm_state, context, current_block, applied_kernel_upgrade, split_info =
-      let* () = apply_evm_events conn ctxt events in
-      apply_blueprint_store_unsafe
-        ctxt
-        conn
-        timestamp
-        payload
-        delayed_transactions
-    in
-    let kernel_upgrade =
-      match ctxt.session.pending_upgrade with
-      | Some {injected_before; kernel_upgrade}
-        when injected_before = ctxt.session.next_blueprint_number ->
-          Some kernel_upgrade
-      | _ -> None
-    in
+    let* _current_block =
+      Misc.with_timing_f_e Blueprint_events.blueprint_applied @@ fun () ->
+      let* evm_state, context, current_block, applied_kernel_upgrade, split_info
+          =
+        let* () = apply_evm_events conn ctxt events in
+        apply_blueprint_store_unsafe
+          ctxt
+          conn
+          timestamp
+          payload
+          delayed_transactions
+      in
+      let kernel_upgrade =
+        match ctxt.session.pending_upgrade with
+        | Some {injected_before; kernel_upgrade}
+          when injected_before = ctxt.session.next_blueprint_number ->
+            Some kernel_upgrade
+        | _ -> None
+      in
 
-    let*! () =
-      Misc.with_timing (Blueprint_events.blueprint_applied current_block)
-      @@ fun () ->
-      on_new_head
-        ?split_info
-        ctxt
-        ~applied_upgrade:applied_kernel_upgrade
-        evm_state
-        context
-        current_block
-        {
-          delayed_transactions;
-          kernel_upgrade;
-          blueprint =
-            {number = ctxt.session.next_blueprint_number; timestamp; payload};
-        }
+      let*! () =
+        on_new_head
+          ?split_info
+          ctxt
+          ~applied_upgrade:applied_kernel_upgrade
+          evm_state
+          context
+          current_block
+          {
+            delayed_transactions;
+            kernel_upgrade;
+            blueprint =
+              {number = ctxt.session.next_blueprint_number; timestamp; payload};
+          }
+      in
+      return current_block
     in
     return_unit
 
diff --git a/etherlink/bin_node/lib_dev/misc.ml b/etherlink/bin_node/lib_dev/misc.ml
index 51808b7c9125..129413999c2d 100644
--- a/etherlink/bin_node/lib_dev/misc.ml
+++ b/etherlink/bin_node/lib_dev/misc.ml
@@ -22,6 +22,18 @@ let with_timing event k =
 
   return res
 
+let with_timing_f_e event k =
+  let open Lwt_result_syntax in
+  let start = Time.System.now () in
+
+  let* res = k () in
+
+  let stop = Time.System.now () in
+  let diff = Ptime.diff stop start in
+  let*! () = event res diff in
+
+  return res
+
 let unwrap_error_monad f =
   let open Lwt_syntax in
   let* res = f () in
diff --git a/etherlink/bin_node/lib_dev/misc.mli b/etherlink/bin_node/lib_dev/misc.mli
index e0f37b46bb1e..55fa4dfd77e8 100644
--- a/etherlink/bin_node/lib_dev/misc.mli
+++ b/etherlink/bin_node/lib_dev/misc.mli
@@ -12,6 +12,14 @@ val now : unit -> Time.Protocol.t
     and advertises it with [event]. *)
 val with_timing : (Ptime.span -> unit Lwt.t) -> (unit -> 'a Lwt.t) -> 'a Lwt.t
 
+(** Same as [with_timing], but (1) [event] receives the result of [k] in
+    addition to the time necessary to compute it, and [k] is in the error
+    monad, not just the Lwt monad. *)
+val with_timing_f_e :
+  ('a -> Ptime.span -> unit Lwt.t) ->
+  (unit -> ('a, 'e) result Lwt.t) ->
+  ('a, 'e) result Lwt.t
+
 (** [unwrap_error_monad f] execute f and fails with a Failure when the
     error monad returns an error. *)
 val unwrap_error_monad : (unit -> 'a tzresult Lwt.t) -> 'a Lwt.t
-- 
GitLab