Merge pull request #13563 from MinaProtocol/georgeee/itn-additional-i…

…nternal-tracing

Add internal logging to track pool items

src/app/cli/src/cli_entrypoint/mina_cli_entrypoint.ml

@@ -1031,11 +1031,15 @@ let setup_daemon logger =
             ~f:(fun (span, context) ->
               let secs = Time_ns.Span.to_sec span in
               let monitor_infos = get_monitor_infos context.monitor in
+              let o1trace = o1trace context in
+              [%log internal] "Long_async_cycle"
+                ~metadata:
+                  [ ("duration", `Float secs); ("trace", `List o1trace) ] ;
               [%log debug]
                 ~metadata:
                   [ ("long_async_cycle", `Float secs)
                   ; ("monitors", `List monitor_infos)
-                  ; ("o1trace", `List (o1trace context))
+                  ; ("o1trace", `List o1trace)
                   ]
                 "Long async cycle, $long_async_cycle seconds, $monitors, \
                  $o1trace" ;
@@ -1046,11 +1050,15 @@ let setup_daemon logger =
             ~f:(fun (context, span) ->
               let secs = Time_ns.Span.to_sec span in
               let monitor_infos = get_monitor_infos context.monitor in
+              let o1trace = o1trace context in
+              [%log internal] "Long_async_job"
+                ~metadata:
+                  [ ("duration", `Float secs); ("trace", `List o1trace) ] ;
               [%log debug]
                 ~metadata:
                   [ ("long_async_job", `Float secs)
                   ; ("monitors", `List monitor_infos)
-                  ; ("o1trace", `List (o1trace context))
+                  ; ("o1trace", `List o1trace)
                   ; ( "most_recent_2_backtrace"
                     , `String
                         (String.concat ~sep:"␤"

src/app/test_executive/verification_key_update.ml

@@ -344,7 +344,8 @@ module Make (Inputs : Intf.Test.Inputs_intf) = struct
          the old key v1"
         (send_invalid_zkapp ~logger
            (Network.Node.get_ingress_uri whale1)
-           zkapp_command_update_vk2_refers_vk1 "Verification_failed" )
+           zkapp_command_update_vk2_refers_vk1
+           "Expected vk hash doesn't match hash in vk we received" )
     in
     let%bind () =
       section

src/app/test_executive/zkapps.ml

@@ -756,7 +756,7 @@ module Make (Inputs : Intf.Test.Inputs_intf) = struct
       section_hard "Send a zkapp with a different chain id"
         (send_invalid_zkapp ~logger
            (Network.Node.get_ingress_uri node)
-           zkapp_command_cross_network_replay "Verification_failed" )
+           zkapp_command_cross_network_replay "Invalid_proof" )
     in
     let%bind () =
       section_hard "Send a zkapp with an insufficient fee"
@@ -775,7 +775,7 @@ module Make (Inputs : Intf.Test.Inputs_intf) = struct
       section_hard "Send a zkapp with an invalid proof"
         (send_invalid_zkapp ~logger
            (Network.Node.get_ingress_uri node)
-           zkapp_command_invalid_proof "Verification_failed" )
+           zkapp_command_invalid_proof "Invalid_proof" )
     in
     let%bind () =
       section_hard "Send a zkapp with an insufficient replace fee"
@@ -800,7 +800,7 @@ module Make (Inputs : Intf.Test.Inputs_intf) = struct
       section_hard "Send a zkApp transaction with an invalid signature"
         (send_invalid_zkapp ~logger
            (Network.Node.get_ingress_uri node)
-           zkapp_command_invalid_signature "Verification_failed" )
+           zkapp_command_invalid_signature "Invalid_signature" )
     in
     let%bind () =
       section_hard "Send a zkApp transaction with a nonexistent fee payer"

src/lib/block_producer/block_producer.ml

@@ -897,12 +897,18 @@ let run ~context:(module Context : CONTEXT) ~vrf_evaluator ~prover ~verifier
                              | `Prover_error _ ) as err ->
                                err )
                     in
+                    let txs =
+                      Mina_block.transactions ~constraint_constants
+                        (Breadcrumb.block breadcrumb)
+                      |> List.map ~f:Transaction.yojson_summary_with_status
+                    in
                     [%log internal] "@block_metadata"
                       ~metadata:
                         [ ( "blockchain_length"
                           , Mina_numbers.Length.to_yojson
                             @@ Mina_block.blockchain_length
                             @@ Breadcrumb.block breadcrumb )
+                        ; ("transactions", `List txs)
                         ] ;
                     [%str_log info]
                       ~metadata:

src/lib/mina_base/signed_command.ml

@@ -127,6 +127,8 @@ module Make_str (_ : Wire_types.Concrete) = struct
 
   include (Stable.Latest : module type of Stable.Latest with type t := t)
 
+  let signature Poly.{ signature; _ } = signature
+
   let payload Poly.{ payload; _ } = payload
 
   let fee = Fn.compose Payload.fee payload

src/lib/mina_base/signed_command_intf.ml

@@ -84,6 +84,8 @@ module type S = sig
 
   include Hashable.S with type t := t
 
+  val signature : t -> Signature.t
+
   val payload : t -> Signed_command_payload.t
 
   val fee : t -> Currency.Fee.t

src/lib/mina_lib/mina_lib.ml

@@ -1843,8 +1843,9 @@ let create ?wallets (config : Config.t) =
               ; on_push = notify_online
               ; log_gossip_heard = config.net_config.log_gossip_heard.new_state
               ; time_controller = config.net_config.time_controller
-              ; consensus_constants = config.net_config.consensus_constants
+              ; consensus_constants
               ; genesis_constants = config.precomputed_values.genesis_constants
+              ; constraint_constants
               }
           in
           let sinks = (block_sink, tx_remote_sink, snark_remote_sink) in

src/lib/mina_lib/tests/tests.ml

@@ -80,6 +80,7 @@ let%test_module "Epoch ledger sync tests" =
           ; time_controller
           ; consensus_constants
           ; genesis_constants = precomputed_values.genesis_constants
+          ; constraint_constants
           }
       in
       let pids = Child_processes.Termination.create_pid_table () in

src/lib/network_pool/intf.ml

@@ -41,6 +41,39 @@ module type Resource_pool_base_intf = sig
     -> t
 end
 
+module Verification_error = struct
+  type t =
+    | Fee_higher
+    | Fee_equal
+    | Recently_seen
+    | Invalid of Error.t
+    | Failure of Error.t
+
+  let to_error = function
+    | Fee_equal ->
+        Error.of_string "fee equal to cheapest work we have"
+    | Fee_higher ->
+        Error.of_string "fee higher than cheapest work we have"
+    | Invalid err ->
+        Error.tag err ~tag:"invalid"
+    | Failure err ->
+        Error.tag err ~tag:"failure"
+    | Recently_seen ->
+        Error.of_string "recently seen"
+
+  let to_short_string = function
+    | Recently_seen ->
+        "recently_seen"
+    | Fee_equal ->
+        "fee_equal"
+    | Fee_higher ->
+        "fee_higher"
+    | Invalid _ ->
+        "invalid"
+    | Failure _ ->
+        "failure"
+end
+
 (** A [Resource_pool_diff_intf] is a representation of a mutation to
  *  perform on a [Resource_pool_base_intf]. It includes the logic for
  *  processing this mutation and applying it to an underlying
@@ -82,7 +115,7 @@ module type Resource_pool_diff_intf = sig
   val verify :
        pool
     -> t Envelope.Incoming.t
-    -> verified Envelope.Incoming.t Deferred.Or_error.t
+    -> (verified Envelope.Incoming.t, Verification_error.t) Deferred.Result.t
 
   (** Warning: Using this directly could corrupt the resource pool if it
       conincides with applying locally generated diffs or diffs from the network
@@ -97,10 +130,16 @@ module type Resource_pool_diff_intf = sig
   val is_empty : t -> bool
 
   val update_metrics :
-       t Envelope.Incoming.t
+       logger:Logger.t
+    -> log_gossip_heard:bool
+    -> t Envelope.Incoming.t
     -> Mina_net2.Validation_callback.t
-    -> Logger.t option
     -> unit
+
+  val log_internal :
+    ?reason:string -> logger:Logger.t -> string -> t Envelope.Incoming.t -> unit
+
+  val t_of_verified : verified -> t
 end
 
 (** A [Resource_pool_intf] ties together an associated pair of
@@ -248,7 +287,7 @@ module type Snark_resource_pool_intf = sig
          Transaction_snark_work.Statement.t
          * Ledger_proof.t One_or_two.t Priced_proof.t
     -> sender:Envelope.Sender.t
-    -> bool Deferred.t
+    -> (unit, Verification_error.t) Deferred.Result.t
 
   val snark_pool_json : t -> Yojson.Safe.t
 

src/lib/network_pool/network_pool_base.ml

@@ -116,12 +116,13 @@ end)
       ~capacity:
         (Resource_pool.Diff.max_per_15_seconds, `Per (Time.Span.of_sec 15.0))
 
-  let apply_and_broadcast t
+  let apply_and_broadcast ({ logger; _ } as t)
       (diff : Resource_pool.Diff.verified Envelope.Incoming.t) cb =
+    let env = Envelope.Incoming.map ~f:Resource_pool.Diff.t_of_verified diff in
     let rebroadcast (diff', rejected) =
       let open Broadcast_callback in
       if Resource_pool.Diff.is_empty diff' then (
-        [%log' trace t.logger]
+        [%log trace]
           "Refusing to rebroadcast $diff. Pool diff apply feedback: empty diff"
           ~metadata:
             [ ( "diff"
@@ -130,22 +131,27 @@ end)
             ] ;
         drop diff' rejected cb )
       else (
-        [%log' debug t.logger] "Rebroadcasting diff %s"
-          (Resource_pool.Diff.summary diff') ;
+        [%log debug] "Rebroadcasting diff %s" (Resource_pool.Diff.summary diff') ;
         forward t.write_broadcasts diff' rejected cb )
     in
     O1trace.sync_thread apply_and_broadcast_thread_label (fun () ->
         match Resource_pool.Diff.unsafe_apply t.resource_pool diff with
         | Ok (`Accept, accepted, rejected) ->
+            Resource_pool.Diff.log_internal ~logger "accepted" env ;
             rebroadcast (accepted, rejected)
         | Ok (`Reject, accepted, rejected) ->
+            Resource_pool.Diff.log_internal ~logger "rejected"
+              ~reason:"not_applied" env ;
             Broadcast_callback.reject accepted rejected cb
         | Error (`Locally_generated res) ->
+            Resource_pool.Diff.log_internal ~logger "rejected"
+              ~reason:"locally_generated" env ;
             rebroadcast res
         | Error (`Other e) ->
             [%log' debug t.logger]
               "Refusing to rebroadcast. Pool diff apply feedback: $error"
               ~metadata:[ ("error", Error_json.error_to_yojson e) ] ;
+            Resource_pool.Diff.log_internal ~logger "rejected" env ;
             Broadcast_callback.error e cb )
 
   let log_rate_limiter_occasionally t rl =

src/lib/network_pool/pool_sink.ml

@@ -95,7 +95,7 @@ module Base
         if BC.is_expired cb then Deferred.return None
         else
           let summary = `String (Diff.summary @@ Envelope.Incoming.data env) in
-          [%log' debug logger] "Verifying $diff from $sender"
+          [%log debug] "Verifying $diff from $sender"
             ~metadata:
               [ ("diff", summary)
               ; ("sender", Envelope.Sender.to_yojson env.sender)
@@ -105,19 +105,25 @@ module Base
               ~score:(Diff.score env.data)
           with
           | `Capacity_exceeded ->
-              [%log' debug logger]
+              [%log debug]
                 ~metadata:
                   [ ("sender", Envelope.Sender.to_yojson env.sender)
                   ; ("diff", summary)
                   ]
                 "exceeded capacity from $sender" ;
               BC.error (Error.of_string "exceeded capacity") cb ;
+              Diff.log_internal ~logger "rejected" ~reason:"rate_limit" env ;
               Deferred.return None
           | `Within_capacity ->
               O1trace.thread verify_diffs_thread_label (fun () ->
                   match%map Diff.verify resource_pool env with
-                  | Error err ->
-                      [%log' debug logger]
+                  | Error ver_err ->
+                      Diff.log_internal ~logger "rejected"
+                        ~reason:
+                          (Intf.Verification_error.to_short_string ver_err)
+                        env ;
+                      let err = Intf.Verification_error.to_error ver_err in
+                      [%log debug]
                         "Refusing to rebroadcast $diff. Verification error: \
                          $error"
                         ~metadata:
@@ -128,7 +134,7 @@ module Base
                       BC.error err cb ;
                       None
                   | Ok verified_diff ->
-                      [%log' debug logger] "Verified diff: $verified_diff"
+                      [%log debug] "Verified diff: $verified_diff"
                         ~metadata:
                           [ ( "verified_diff"
                             , Diff.verified_to_yojson
@@ -157,10 +163,10 @@ module Base
         let%bind () = on_push () in
         let env' = Msg.convert msg in
         let cb' = Msg.convert_callback cb in
+        Diff.log_internal ~logger "received" env' ;
         ( match cb' with
         | BC.External cb'' ->
-            Diff.update_metrics env' cb''
-              (Option.some_if log_gossip_heard logger) ;
+            Diff.update_metrics env' cb'' ~log_gossip_heard ~logger ;
             don't_wait_for
               ( match%map Mina_net2.Validation_callback.await cb'' with
               | None ->
@@ -173,8 +179,9 @@ module Base
                   () )
         | _ ->
             () ) ;
-        if Throttle.num_jobs_waiting_to_start throttle > max_waiting_jobs then
-          [%log warn] "Ignoring push to %s: throttle is full" trace_label
+        if Throttle.num_jobs_waiting_to_start throttle > max_waiting_jobs then (
+          Diff.log_internal ~logger "rejected" ~reason:"throttle_full" env' ;
+          [%log warn] "Ignoring push to %s: throttle is full" trace_label )
         else
           don't_wait_for
             (Throttle.enqueue throttle (fun () ->