diff --git a/src/bin_signer/handler.ml b/src/bin_signer/handler.ml index ede757e9cf909cc19f82d66a664890f8a8ae9d35..b50ef1335e8f020a9de5873b66698302fdf30dfb 100644 --- a/src/bin_signer/handler.ml +++ b/src/bin_signer/handler.ml @@ -7,7 +7,10 @@ (* *) (**************************************************************************) -let log = Signer_logging.lwt_log_notice +open Signer_logging + +let log = lwt_log_notice + module Authorized_key = Client_aliases.Alias (struct @@ -32,10 +35,12 @@ let sign (cctxt : #Client_context.wallet) Signer_messages.Sign.Request.{ pkh ; data ; signature } ?magic_bytes ~require_auth = - log "Request for signing %d bytes of data for key %a, magic byte = %02X" - (MBytes.length data) - Signature.Public_key_hash.pp pkh - (MBytes.get_uint8 data 0) >>= fun () -> + log Tag.DSL.(fun f -> + f "Request for signing %d bytes of data for key %a, magic byte = %02X" + -% t event "request_for_signing" + -% s num_bytes (MBytes.length data) + -% a Signature.Public_key_hash.Logging.tag pkh + -% s magic_byte (MBytes.get_uint8 data 0)) >>= fun () -> check_magic_byte magic_bytes data >>=? fun () -> begin match require_auth, signature with | false, _ -> return_unit @@ -52,24 +57,36 @@ let sign failwith "invalid authentication signature" end >>=? fun () -> Client_keys.get_key cctxt pkh >>=? fun (name, _pkh, sk_uri) -> - log "Signing data for key %s" name >>= fun () -> + log Tag.DSL.(fun f -> + f "Signing data for key %s" + -% t event "signing_data" + -% s Client_keys.Logging.tag name) >>= fun () -> Client_keys.sign cctxt sk_uri data >>=? fun signature -> return signature let public_key (cctxt : #Client_context.wallet) pkh = - log "Request for public key %a" - Signature.Public_key_hash.pp pkh >>= fun () -> + log Tag.DSL.(fun f -> + f "Request for public key %a" + -% t event "request_for_public_key" + -% a Signature.Public_key_hash.Logging.tag pkh) >>= fun () -> Client_keys.list_keys cctxt >>=? fun all_keys -> match List.find (fun (_, h, _, _) -> Signature.Public_key_hash.equal h pkh) all_keys with | exception Not_found -> - log "No public key found for hash %a" - Signature.Public_key_hash.pp pkh >>= fun () -> + log Tag.DSL.(fun f -> + f "No public key found for hash %a" + -% t event "not_found_public_key" + -% a Signature.Public_key_hash.Logging.tag pkh) >>= fun () -> Lwt.fail Not_found | (_, _, None, _) -> - log "No public key found for hash %a" - Signature.Public_key_hash.pp pkh >>= fun () -> + log Tag.DSL.(fun f -> + f "No public key found for hash %a" + -% t event "not_found_public_key" + -% a Signature.Public_key_hash.Logging.tag pkh) >>= fun () -> Lwt.fail Not_found | (name, _, Some pk, _) -> - log "Found public key for hash %a (name: %s)" - Signature.Public_key_hash.pp pkh name >>= fun () -> + log Tag.DSL.(fun f -> + f "Found public key for hash %a (name: %s)" + -% t event "found_public_key" + -% a Signature.Public_key_hash.Logging.tag pkh + -% s Client_keys.Logging.tag name) >>= fun () -> return pk diff --git a/src/bin_signer/http_daemon.ml b/src/bin_signer/http_daemon.ml index 64479cf91b3e6204fc3ea78f54e495860f97d117..00a7c7dc3b104ae8ff9586c68b26e942dfbeebd1 100644 --- a/src/bin_signer/http_daemon.ml +++ b/src/bin_signer/http_daemon.ml @@ -8,6 +8,7 @@ (**************************************************************************) let log = Signer_logging.lwt_log_notice +open Signer_logging let run (cctxt : #Client_context.wallet) ~hosts ?magic_bytes ~require_auth mode = let dir = RPC_directory.empty in @@ -32,7 +33,10 @@ let run (cctxt : #Client_context.wallet) ~hosts ?magic_bytes ~require_auth mode List.map (fun host -> let host = Ipaddr.V6.to_string host in - log "Listening on address %s" host >>= fun () -> + log Tag.DSL.(fun f -> + f "Listening on address %s" + -% t event "signer_listening" + -% s host_name host) >>= fun () -> RPC_server.launch ~host mode dir ~media_types:Media_type.all_media_types >>= fun _server -> @@ -49,7 +53,10 @@ let run_https (cctxt : #Client_context.wallet) ~host ~port ~cert ~key ?magic_byt failwith "Cannot resolve listening address: %S" host | points -> let hosts = fst (List.split points) in - log "Accepting HTTPS requests on port %d" port >>= fun () -> + log Tag.DSL.(fun f -> + f "Accepting HTTPS requests on port %d" + -% t event "accepting_https_requests" + -% s port_number port) >>= fun () -> let mode : Conduit_lwt_unix.server = `TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port) in run (cctxt : #Client_context.wallet) ~hosts ?magic_bytes ~require_auth mode @@ -60,7 +67,10 @@ let run_http (cctxt : #Client_context.wallet) ~host ~port ?magic_bytes ~require_ failwith "Cannot resolve listening address: %S" host | points -> let hosts = fst (List.split points) in - log "Accepting HTTP requests on port %d" port >>= fun () -> + log Tag.DSL.(fun f -> + f "Accepting HTTP requests on port %d" + -% t event "accepting_http_requests" + -% s port_number port) >>= fun () -> let mode : Conduit_lwt_unix.server = `TCP (`Port port) in run (cctxt : #Client_context.wallet) ~hosts ?magic_bytes ~require_auth mode diff --git a/src/bin_signer/https_daemon.ml b/src/bin_signer/https_daemon.ml new file mode 100644 index 0000000000000000000000000000000000000000..6ed6f3bbfa2008c4faf572aa186baacd607682d4 --- /dev/null +++ b/src/bin_signer/https_daemon.ml @@ -0,0 +1,41 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Signer_logging + +let log = lwt_log_notice + +let run (cctxt : #Client_context.wallet) ~host ~port ~cert ~key = + log Tag.DSL.(fun f -> + f "Accepting HTTPS requests on port %d" + -% t event "accepting_https_requests" + -% s port_number port) >>= fun () -> + let mode : Conduit_lwt_unix.server = + `TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port) in + let dir = RPC_directory.empty in + let dir = + RPC_directory.register1 dir Signer_services.sign begin fun pkh () data -> + Handler.sign cctxt pkh data + end in + let dir = + RPC_directory.register1 dir Signer_services.public_key begin fun pkh () () -> + Handler.public_key cctxt pkh + end in + Lwt.catch + (fun () -> + RPC_server.launch ~host mode dir + ~media_types:Media_type.all_media_types + ~cors: { allowed_origins = [ "*" ] ; + allowed_headers = [ "Content-Type" ] } + >>= fun _server -> + fst (Lwt.wait ())) + (function + | Unix.Unix_error(Unix.EADDRINUSE, "bind","") -> + failwith "Port already in use." + | exn -> Lwt.return (error_exn exn)) diff --git a/src/bin_signer/signer_logging.ml b/src/bin_signer/signer_logging.ml index 84556e2945245e1cf78e9282ef29fc577b168a93..f53ccf297a04b5770078aecd36b4a1f87f098a9c 100644 --- a/src/bin_signer/signer_logging.ml +++ b/src/bin_signer/signer_logging.ml @@ -7,4 +7,10 @@ (* *) (**************************************************************************) -include Tezos_stdlib.Logging.Make(struct let name = "client.signer" end) +include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.signer" end) + +let host_name = Tag.def ~doc:"Host name" "host" Format.pp_print_text +let magic_byte = Tag.def ~doc:"Magic byte" "magic_byte" Format.pp_print_int +let num_bytes = Tag.def ~doc:"Number of bytes" "num_bytes" Format.pp_print_int +let port_number = Tag.def ~doc:"Port number" "port" Format.pp_print_int +let unix_socket_path = Tag.def ~doc:"UNIX socket file path" "unix_socket" Format.pp_print_text diff --git a/src/bin_signer/signer_logging.mli b/src/bin_signer/signer_logging.mli index 79bef502af972dcb5c662c8432d0022e14ca76a8..ad31e1f8bfc62e1833ae5fdbadcb96e3c2fa1e6d 100644 --- a/src/bin_signer/signer_logging.mli +++ b/src/bin_signer/signer_logging.mli @@ -7,4 +7,10 @@ (* *) (**************************************************************************) -include Tezos_stdlib.Logging.LOG +include Tezos_stdlib.Logging.SEMLOG + +val host_name: string Tag.def +val magic_byte: int Tag.def +val num_bytes: int Tag.def +val port_number: int Tag.def +val unix_socket_path: string Tag.def diff --git a/src/bin_signer/socket_daemon.ml b/src/bin_signer/socket_daemon.ml index 6c8ebc570b86bcf8516193030107f7d630cf7dc5..6c54107f23cef09d00f723753cd231bc11a8e951 100644 --- a/src/bin_signer/socket_daemon.ml +++ b/src/bin_signer/socket_daemon.ml @@ -7,9 +7,10 @@ (* *) (**************************************************************************) +open Signer_logging open Signer_messages -let log = Signer_logging.lwt_log_notice +let log = lwt_log_notice let run (cctxt : #Client_context.wallet) path ?magic_bytes ~require_auth = Lwt_utils_unix.Socket.bind path >>=? fun fd -> @@ -46,13 +47,20 @@ let run (cctxt : #Client_context.wallet) path ?magic_bytes ~require_auth = begin match path with | Tcp (host, port) -> - log "Accepting TCP requests on port %s:%d" host port + log Tag.DSL.(fun f -> + f "Accepting TCP requests on port %s:%d" + -% t event "accepting_tcp_requests" + -% s host_name host + -% s port_number port) | Unix path -> Sys.set_signal Sys.sigint (Signal_handle begin fun _ -> Format.printf "Removing the local socket file and quitting.@." ; Unix.unlink path ; exit 0 end) ; - log "Accepting UNIX requests on %s" path + log Tag.DSL.(fun f -> + f "Accepting UNIX requests on %s" + -% t event "accepting_unix_requests" + -% s unix_socket_path path) end >>= fun () -> loop () diff --git a/src/lib_base/block_locator.ml b/src/lib_base/block_locator.ml index 234ba685f7a1aaa22bc598222bee44b5caed75b9..edd45d2371a553dcf6e964c063b24c05cdcb932e 100644 --- a/src/lib_base/block_locator.ml +++ b/src/lib_base/block_locator.ml @@ -133,6 +133,8 @@ type step = { strict_step: bool ; } +let pp_step ppf step = Format.fprintf ppf "%d%s" step.step (if step.strict_step then "" else " max") + let to_steps seed locator = fold locator seed ~init:[] diff --git a/src/lib_base/block_locator.mli b/src/lib_base/block_locator.mli index 28f17bbfeca8db634f3895d0ef82661dc6a9e297..3a26b9a5236f822a6df1c7213438136579edc045 100644 --- a/src/lib_base/block_locator.mli +++ b/src/lib_base/block_locator.mli @@ -50,6 +50,8 @@ type step = { locator, and the expected difference of level between the two blocks (or an upper bounds when [strict_step = false]). *) +val pp_step: Format.formatter -> step -> unit + val to_steps: seed -> t -> step list (** Build all the 'steps' composing the locator using a given seed, starting with the oldest one (typically the predecessor of the diff --git a/src/lib_base/p2p_peer_id.ml b/src/lib_base/p2p_peer_id.ml index 31083d907eb2441d64e65e2914f7f7b868c874f0..fc5d995c5eb92b972fa28c24a81d935ea1587187 100644 --- a/src/lib_base/p2p_peer_id.ml +++ b/src/lib_base/p2p_peer_id.ml @@ -15,3 +15,17 @@ let rpc_arg = ~descr:"A cryptographic node identity (Base58Check-encoded)" "peer_id" +let pp_source ppf = function + | None -> () + | Some peer -> Format.fprintf ppf " from peer %a" pp peer + +module Logging = struct + open Tezos_stdlib.Logging + include Make_semantic(struct let name = "node.distributed_db.p2p_reader" end) + let mk_tag pp = Tag.def ~doc:"P2P peer ID" "p2p_peer_id" pp + let tag = mk_tag pp_short + let tag_opt = mk_tag (fun ppf -> function + | None -> () + | Some peer -> pp_short ppf peer) + let tag_source = Tag.def ~doc:"Peer which provided information" "p2p_peer_id_source" pp_source +end diff --git a/src/lib_base/p2p_peer_id.mli b/src/lib_base/p2p_peer_id.mli index dfe7023d18aed7486afa1df8742272a6697acfb3..4f43ad7ac224f89ebadc9206c38c3af045925bfc 100644 --- a/src/lib_base/p2p_peer_id.mli +++ b/src/lib_base/p2p_peer_id.mli @@ -8,3 +8,9 @@ (**************************************************************************) include Tezos_crypto.S.HASH with type t = Crypto_box.Public_key_hash.t + +module Logging: sig + val tag: t Tag.def + val tag_opt: t option Tag.def + val tag_source: t option Tag.def +end diff --git a/src/lib_client_base/client_keys.ml b/src/lib_client_base/client_keys.ml index a248bd4cbb407cd26379f4ca0b4b6b7639c496e0..1a8c3fe1afc6d0ffcb16e33363a37065ee3df259 100644 --- a/src/lib_client_base/client_keys.ml +++ b/src/lib_client_base/client_keys.ml @@ -33,13 +33,19 @@ let () = (function Invalid_uri s -> Some (Uri.to_string s) | _ -> None) (fun s -> Invalid_uri (Uri.of_string s)) -module Public_key_hash = Client_aliases.Alias (struct - type t = Signature.Public_key_hash.t - let encoding = Signature.Public_key_hash.encoding - let of_source s = Lwt.return (Signature.Public_key_hash.of_b58check s) - let to_source p = return (Signature.Public_key_hash.to_b58check p) - let name = "public key hash" - end) +module Public_key_hash = struct + include Client_aliases.Alias (struct + type t = Signature.Public_key_hash.t + let encoding = Signature.Public_key_hash.encoding + let of_source s = Lwt.return (Signature.Public_key_hash.of_b58check s) + let to_source p = return (Signature.Public_key_hash.to_b58check p) + let name = "public key hash" + end) +end + +module Logging = struct + let tag = Tag.def ~doc:"Identity" "pk_alias" Format.pp_print_text +end module type KEY = sig type t diff --git a/src/lib_client_base/client_keys.mli b/src/lib_client_base/client_keys.mli index f0fc2b8a7ae48ff56557ca44eb124cd43229329a..6dface59122e40e530b05a002e0de12d5c1d7dcd 100644 --- a/src/lib_client_base/client_keys.mli +++ b/src/lib_client_base/client_keys.mli @@ -29,6 +29,10 @@ module Public_key : module Secret_key : Client_aliases.Alias with type t = sk_uri +module Logging : sig + val tag : string Tag.def +end + (** {2 Interface for external signing modules.} *) module type SIGNER = sig diff --git a/src/lib_crypto/block_hash.ml b/src/lib_crypto/block_hash.ml index 5c0984ce27180262540227586927538ef9e08a42..4b1e2dfa418ede62e3aeeab1c4b7d34bbc935f70 100644 --- a/src/lib_crypto/block_hash.ml +++ b/src/lib_crypto/block_hash.ml @@ -14,5 +14,11 @@ include Blake2B.Make (Base58) (struct let size = None end) + +module Logging = struct + let tag = Tag.def ~doc:"Block Hash" "block_hash" pp_short + let predecessor_tag = Tag.def ~doc:"Block Predecessor Hash" "predecessor_hash" pp_short +end + let () = Base58.check_encoded_prefix b58check_encoding "B" 51 diff --git a/src/lib_crypto/block_hash.mli b/src/lib_crypto/block_hash.mli index f7841dc59e5c59041dcf19277ae39775c12d1069..ee2844bf162b79121329f0fe403b76a6f40653df 100644 --- a/src/lib_crypto/block_hash.mli +++ b/src/lib_crypto/block_hash.mli @@ -8,3 +8,8 @@ (**************************************************************************) include S.HASH + +module Logging : sig + val tag : t Tag.def + val predecessor_tag : t Tag.def +end diff --git a/src/lib_crypto/ed25519.ml b/src/lib_crypto/ed25519.ml index 649e926abf1761de44265a6ff1895f52eb4a88db..acef1ebea35db35c017cb6c0fbe4cf18dae522cd 100644 --- a/src/lib_crypto/ed25519.ml +++ b/src/lib_crypto/ed25519.ml @@ -9,13 +9,17 @@ open Error_monad -module Public_key_hash = Blake2B.Make(Base58)(struct - let name = "Ed25519.Public_key_hash" - let title = "An Ed25519 public key hash" - let b58check_prefix = Base58.Prefix.ed25519_public_key_hash - let size = Some 20 - end) - +module Public_key_hash = struct + include Blake2B.Make(Base58)(struct + let name = "Ed25519.Public_key_hash" + let title = "An Ed25519 public key hash" + let b58check_prefix = Base58.Prefix.ed25519_public_key_hash + let size = Some 20 + end) + module Logging = struct + let tag = Tag.def ~doc:title name pp + end +end let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz1" 36 diff --git a/src/lib_crypto/operation_hash.ml b/src/lib_crypto/operation_hash.ml index 9d42ab52c351a011337ffaee2b11097515e33433..0d40f87821af365f4a427b6d6c9b35356c866c8b 100644 --- a/src/lib_crypto/operation_hash.ml +++ b/src/lib_crypto/operation_hash.ml @@ -17,3 +17,6 @@ include Blake2B.Make (Base58) (struct let () = Base58.check_encoded_prefix b58check_encoding "o" 51 +module Logging = struct + let tag = Tag.def ~doc:title name pp +end diff --git a/src/lib_crypto/operation_hash.mli b/src/lib_crypto/operation_hash.mli index f7841dc59e5c59041dcf19277ae39775c12d1069..e911881114aa3ac06e09fbc1f39bf340c403ceee 100644 --- a/src/lib_crypto/operation_hash.mli +++ b/src/lib_crypto/operation_hash.mli @@ -8,3 +8,7 @@ (**************************************************************************) include S.HASH + +module Logging : sig + val tag : t Tag.def +end diff --git a/src/lib_crypto/p256.ml b/src/lib_crypto/p256.ml index 832fd68c520de225db4c72c0e0b75a2ef3bde9c4..4a839bba7eecd30f01845a37a850744c9bb9b8be 100644 --- a/src/lib_crypto/p256.ml +++ b/src/lib_crypto/p256.ml @@ -7,12 +7,18 @@ (* *) (**************************************************************************) -module Public_key_hash = Blake2B.Make(Base58)(struct - let name = "P256.Public_key_hash" - let title = "A P256 public key hash" - let b58check_prefix = Base58.Prefix.p256_public_key_hash - let size = Some 20 - end) +module Public_key_hash = struct + include Blake2B.Make(Base58)(struct + let name = "P256.Public_key_hash" + let title = "A P256 public key hash" + let b58check_prefix = Base58.Prefix.p256_public_key_hash + let size = Some 20 + end) + + module Logging = struct + let tag = Tag.def ~doc:title name pp + end +end let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz3" 36 diff --git a/src/lib_crypto/protocol_hash.ml b/src/lib_crypto/protocol_hash.ml index b7c303309fde38a30ff9a1e8d91386748f3593ae..4b197e5803dc25bb0a9a05cefe9ff2fffbe0bb70 100644 --- a/src/lib_crypto/protocol_hash.ml +++ b/src/lib_crypto/protocol_hash.ml @@ -17,3 +17,6 @@ include Blake2B.Make (Base58) (struct let () = Base58.check_encoded_prefix b58check_encoding "P" 51 +module Logging = struct + let tag = Tag.def ~doc:title name pp +end diff --git a/src/lib_crypto/protocol_hash.mli b/src/lib_crypto/protocol_hash.mli index f7841dc59e5c59041dcf19277ae39775c12d1069..e911881114aa3ac06e09fbc1f39bf340c403ceee 100644 --- a/src/lib_crypto/protocol_hash.mli +++ b/src/lib_crypto/protocol_hash.mli @@ -8,3 +8,7 @@ (**************************************************************************) include S.HASH + +module Logging : sig + val tag : t Tag.def +end diff --git a/src/lib_crypto/s.ml b/src/lib_crypto/s.ml index 4ae75ed177595de58f9833fb51ce11650ae66b76..52a8527744f65b9293533dc0a8f6eaaf3b363179 100644 --- a/src/lib_crypto/s.ml +++ b/src/lib_crypto/s.ml @@ -169,6 +169,9 @@ module type SIGNATURE = sig val zero: t + module Logging : sig + val tag : t Tag.def + end end module Public_key : sig diff --git a/src/lib_crypto/secp256k1.ml b/src/lib_crypto/secp256k1.ml index d1de8083ab8455c273da2da5d601786cceb3a462..8112968f343fd8ef18ac748bf78f471f86859e1f 100644 --- a/src/lib_crypto/secp256k1.ml +++ b/src/lib_crypto/secp256k1.ml @@ -7,12 +7,17 @@ (* *) (**************************************************************************) -module Public_key_hash = Blake2B.Make(Base58)(struct - let name = "Secp256k1.Public_key_hash" - let title = "A Secp256k1 public key hash" - let b58check_prefix = Base58.Prefix.secp256k1_public_key_hash - let size = Some 20 - end) +module Public_key_hash = struct + include Blake2B.Make(Base58)(struct + let name = "Secp256k1.Public_key_hash" + let title = "A Secp256k1 public key hash" + let b58check_prefix = Base58.Prefix.secp256k1_public_key_hash + let size = Some 20 + end) + module Logging = struct + let tag = Tag.def ~doc:title name pp + end +end let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz2" 36 diff --git a/src/lib_crypto/signature.ml b/src/lib_crypto/signature.ml index 3284c335423c70d3fd04b77c96f1bea295e34054..dc7935be3ad387ab19a4cad7163aa810662da13f 100644 --- a/src/lib_crypto/signature.ml +++ b/src/lib_crypto/signature.ml @@ -193,6 +193,9 @@ module Public_key_hash = struct ~descr:"A Secp256k1 of a Ed25519 public key hash (Base58Check-encoded)" "pkh" + module Logging = struct + let tag = Tag.def ~doc:title name pp + end end module Public_key = struct diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml index 52dd4a4d81cc359fba50484fa97064b273bc1f6b..bf9da9d9903d92263f9840731bdb5caf6d963ecb 100644 --- a/src/lib_error_monad/error_monad.ml +++ b/src/lib_error_monad/error_monad.ml @@ -711,3 +711,5 @@ let with_timeout ?(canceler = Lwt_canceler.create ()) timeout f = Lwt_canceler.cancel canceler >>= fun () -> fail Timeout end + +let errs_tag = Tag.def ~doc:"Errors" "errs" pp_print_error diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index ad7e65201eda73e00c55d4e25ceadfda8196514d..1f0333cd60ef0bc4a77d8f4eb23d58e1e5d5f162 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -69,3 +69,5 @@ module Make(Prefix : sig val id : string end) : Error_monad_sig.S (**/**) val json_to_string : (Data_encoding.json -> string) ref + +val errs_tag : error list Tag.def diff --git a/src/lib_shell/bootstrap_pipeline.ml b/src/lib_shell/bootstrap_pipeline.ml index 0782a38c893af697b32e2d8fe89dd71c138739f7..fb4c3e2b50a3677435eae9161f1eff77d99d2fa8 100644 --- a/src/lib_shell/bootstrap_pipeline.ml +++ b/src/lib_shell/bootstrap_pipeline.ml @@ -7,7 +7,10 @@ (* *) (**************************************************************************) -include Logging.Make(struct let name = "node.validator.bootstrap_pipeline" end) +include Logging.Make_semantic(struct let name = "node.validator.bootstrap_pipeline" end) + +let node_time_tag = Tag.def ~doc:"local time at this node" "node_time" Time.pp_hum +let block_time_tag = Tag.def ~doc:"claimed creation time of block" "block_time" Time.pp_hum open Validation_errors @@ -31,6 +34,8 @@ type t = { mutable errors: Error_monad.error list ; } +let operations_index_tag = Tag.def ~doc:"Operations index" "operations_index" Format.pp_print_int + let assert_acceptable_header pipeline hash (header : Block_header.t) = let chain_state = Distributed_db.chain_state pipeline.chain_db in @@ -60,29 +65,36 @@ let assert_acceptable_header pipeline return_unit let fetch_step pipeline (step : Block_locator.step) = - lwt_log_info "fetching step %a -> %a (%d%s) from peer %a." - Block_hash.pp_short step.block - Block_hash.pp_short step.predecessor - step.step - (if step.strict_step then "" else " max") - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "fetching step %a -> %a (%a) from peer %a." + -% t event "fetching_step_from_peer" + -% a Block_hash.Logging.tag step.block + -% a Block_hash.Logging.predecessor_tag step.predecessor + -% a (Tag.def ~doc:"" "" Block_locator.pp_step) step + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> let rec fetch_loop acc hash cpt = Lwt_unix.yield () >>= fun () -> if cpt < 0 then - lwt_log_info "invalid step from peer %a (too long)." - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "invalid step from peer %a (too long)." + -% t event "step_too_long" + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> fail (Invalid_locator (pipeline.peer_id, pipeline.locator)) else if Block_hash.equal hash step.predecessor then if step.strict_step && cpt <> 0 then - lwt_log_info "invalid step from peer %a (too short)." - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "invalid step from peer %a (too short)." + -% t event "step_too_short" + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> fail (Invalid_locator (pipeline.peer_id, pipeline.locator)) else return acc else - lwt_debug "fetching block header %a from peer %a." - Block_hash.pp_short hash - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "fetching block header %a from peer %a." + -% t event "fetching_block_header_from_peer" + -% a Block_hash.Logging.tag hash + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> protect ~canceler:pipeline.canceler begin fun () -> Distributed_db.Block_header.fetch ~timeout:pipeline.block_header_timeout @@ -90,9 +102,11 @@ let fetch_step pipeline (step : Block_locator.step) = hash () end >>=? fun header -> assert_acceptable_header pipeline hash header >>=? fun () -> - lwt_debug "fetched block header %a from peer %a." - Block_hash.pp_short hash - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "fetched block header %a from peer %a." + -% t event "fetched_block_header_from_peer" + -% a Block_hash.Logging.tag hash + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> fetch_loop ((hash, header) :: acc) header.shell.predecessor (cpt - 1) in fetch_loop [] step.block step.step >>=? fun headers -> @@ -116,31 +130,39 @@ let headers_fetch_worker_loop pipeline = return_unit end >>= function | Ok () -> - lwt_log_info "fetched all step from peer %a." - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "fetched all steps from peer %a." + -% t event "fetched_all_steps_from_peer" + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> Lwt_pipe.close pipeline.fetched_headers ; Lwt.return_unit | Error [Exn Lwt.Canceled | Canceled | Exn Lwt_pipe.Closed] -> Lwt.return_unit | Error [ Distributed_db.Block_header.Timeout bh ] -> - lwt_log_info "request for header %a from peer %a timed out." - Block_hash.pp_short bh - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "request for header %a from peer %a timed out." + -% t event "header_request_timeout" + -% a Block_hash.Logging.tag bh + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit | Error [ Future_block_header { block; block_time; time } ] -> - lwt_log_notice "Block locator %a from peer %a contains future blocks. \ - local time: %a, block time: %a" - Block_hash.pp_short block - Time.pp_hum time - Time.pp_hum block_time - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "Block locator %a from peer %a contains future blocks. \ + local time: %a, block time: %a" + -% t event "locator_contains_future_blocks" + -% a Block_hash.Logging.tag block + -% a P2p_peer.Id.Logging.tag pipeline.peer_id + -% a node_time_tag time + -% a block_time_tag block_time) >>= fun () -> Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit | Error err -> pipeline.errors <- pipeline.errors @ err ; - lwt_log_error "@[Unexpected error (headers fetch):@ %a@]" - pp_print_error err >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "@[Unexpected error (headers fetch):@ %a@]" + -% t event "unexpected_error" + -% a errs_tag err) >>= fun () -> Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit @@ -150,9 +172,11 @@ let rec operations_fetch_worker_loop pipeline = protect ~canceler:pipeline.canceler begin fun () -> Lwt_pipe.pop pipeline.fetched_headers >>= return end >>=? fun (hash, header) -> - lwt_log_info "fetching operations of block %a from peer %a." - Block_hash.pp_short hash - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "fetching operations of block %a from peer %a." + -% t event "fetching_operations" + -% a Block_hash.Logging.tag hash + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> let operations = map_p (fun i -> @@ -163,9 +187,11 @@ let rec operations_fetch_worker_loop pipeline = (hash, i) header.shell.operations_hash end) (0 -- (header.shell.validation_passes - 1)) >>=? fun operations -> - lwt_log_info "fetched operations of block %a from peer %a." - Block_hash.pp_short hash - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "fetched operations of block %a from peer %a." + -% t event "fetched_operations" + -% a Block_hash.Logging.tag hash + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> return operations in protect ~canceler:pipeline.canceler begin fun () -> Lwt_pipe.push pipeline.fetched_blocks @@ -178,15 +204,20 @@ let rec operations_fetch_worker_loop pipeline = Lwt_pipe.close pipeline.fetched_blocks ; Lwt.return_unit | Error [ Distributed_db.Operations.Timeout (bh, n) ] -> - lwt_log_info "request for operations %a:%d from peer %a timed out." - Block_hash.pp_short bh n - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "request for operations %a:%d from peer %a timed out." + -% t event "request_operations_timeout" + -% a Block_hash.Logging.tag bh + -% s operations_index_tag n + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit | Error err -> pipeline.errors <- pipeline.errors @ err ; - lwt_log_error "@[Unexpected error (operations fetch):@ %a@]" - pp_print_error err >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "@[Unexpected error (operations fetch):@ %a@]" + -% t event "unexpected_error" + -% a errs_tag err) >>= fun () -> Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit @@ -196,9 +227,11 @@ let rec validation_worker_loop pipeline = protect ~canceler:pipeline.canceler begin fun () -> Lwt_pipe.pop pipeline.fetched_blocks >>= return end >>=? fun (hash, header, operations) -> - lwt_log_info "requesting validation for block %a from peer %a." - Block_hash.pp_short hash - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "requesting validation for block %a from peer %a." + -% t event "requesting_validation" + -% a Block_hash.Logging.tag hash + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> operations >>=? fun operations -> protect ~canceler:pipeline.canceler begin fun () -> Block_validator.validate @@ -207,9 +240,11 @@ let rec validation_worker_loop pipeline = pipeline.block_validator pipeline.chain_db hash header operations end >>=? fun _block -> - lwt_log_info "validated block %a from peer %a." - Block_hash.pp_short hash - P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "validated block %a from peer %a." + -% t event "validated_block" + -% a Block_hash.Logging.tag hash + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) >>= fun () -> return_unit end >>= function | Ok () -> validation_worker_loop pipeline @@ -223,8 +258,10 @@ let rec validation_worker_loop pipeline = Lwt.return_unit | Error err -> pipeline.errors <- pipeline.errors @ err ; - lwt_log_error "@[Unexpected error (validator):@ %a@]" - pp_print_error err >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "@[Unexpected error (validator):@ %a@]" + -% t event "unexpected_error" + -% a errs_tag err) >>= fun () -> Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit diff --git a/src/lib_shell/chain.ml b/src/lib_shell/chain.ml index 73b3cd310a21f2d2fd12dba41bb8e90df500467e..0c8735bf05c7ba14ba09de48b4bac13dce65bf40 100644 --- a/src/lib_shell/chain.ml +++ b/src/lib_shell/chain.ml @@ -9,6 +9,8 @@ open State_logging +let block_hash_tag = Tag.def ~doc:"Block hash" "block_hash" Block_hash.pp_short + let mempool_encoding = Mempool.encoding let genesis chain_state = @@ -57,7 +59,10 @@ let locked_set_head chain_store data block = if Block_hash.equal hash ancestor then Lwt.return_unit else - lwt_debug "pop_block %a" Block_hash.pp_short hash >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "pop_block %a" + -% t event "pop_block" + -% a block_hash_tag hash) >>= fun () -> Store.Chain_data.In_main_branch.remove (chain_store, hash) >>= fun () -> State.Block.predecessor block >>= function | Some predecessor -> @@ -66,7 +71,10 @@ let locked_set_head chain_store data block = in let push_block pred_hash block = let hash = State.Block.hash block in - lwt_debug "push_block %a" Block_hash.pp_short hash >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "push_block %a" + -% t event "push_block" + -% a block_hash_tag hash) >>= fun () -> Store.Chain_data.In_main_branch.store (chain_store, pred_hash) hash >>= fun () -> Lwt.return hash diff --git a/src/lib_shell/distributed_db.ml b/src/lib_shell/distributed_db.ml index e2802c4028f4c347ab39cda6e85e8f8ab35c16e7..c8aed78d83fbba910a27e0c9c95e17c09b910528 100644 --- a/src/lib_shell/distributed_db.ml +++ b/src/lib_shell/distributed_db.ml @@ -24,6 +24,10 @@ module Make_raw val name : string val encoding : t Data_encoding.t val pp : Format.formatter -> t -> unit + + module Logging : sig + val tag : t Tag.def + end end) (Disk_table : Distributed_db_functors.DISK_TABLE with type key := Hash.t) @@ -164,6 +168,9 @@ module Raw_operation_hashes = struct let encoding = let open Data_encoding in obj2 (req "block" Block_hash.encoding) (req "index" uint16) + module Logging = struct + let tag = Tag.def ~doc:"Operation hashes" "operation_hashes" pp + end end) (Operation_hashes_storage) (Operations_table) @@ -233,6 +240,9 @@ module Raw_operations = struct let encoding = let open Data_encoding in obj2 (req "block" Block_hash.encoding) (req "index" uint16) + module Logging = struct + let tag = Tag.def ~doc:"Operations" "operations" pp + end end) (Operations_storage) (Operations_table) @@ -458,15 +468,18 @@ module P2p_reader = struct f chain_db module Handle_msg_Logging = - Logging.Make(struct let name = "node.distributed_db.p2p_reader" end) + Tezos_stdlib.Logging.Make_semantic(struct let name = "node.distributed_db.p2p_reader" end) let handle_msg global_db state msg = let open Message in let open Handle_msg_Logging in - lwt_debug "Read message from %a: %a" - P2p_peer.Id.pp_short state.gid Message.pp_json msg >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "Read message from %a: %a" + -% t event "read_message" + -% a P2p_peer.Id.Logging.tag state.gid + -% a Message.Logging.tag msg) >>= fun () -> match msg with @@ -497,9 +510,11 @@ module P2p_reader = struct Lwt.return_unit end else if Time.(add (now ()) 15L < head.shell.timestamp) then begin (* TODO some penalty *) - lwt_log_notice "Received future block %a from peer %a." - Block_hash.pp_short (Block_header.hash head) - P2p_peer.Id.pp_short state.gid >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "Received future block %a from peer %a." + -% t event "received_future_block" + -% a Block_hash.Logging.tag (Block_header.hash head) + -% a P2p_peer.Id.Logging.tag state.gid) >>= fun () -> Lwt.return_unit end else begin chain_db.callback.notify_branch state.gid locator ; @@ -548,9 +563,11 @@ module P2p_reader = struct Lwt.return_unit end else if Time.(add (now ()) 15L < header.shell.timestamp) then begin (* TODO some penalty *) - lwt_log_notice "Received future block %a from peer %a." - Block_hash.pp_short head - P2p_peer.Id.pp_short state.gid >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "Received future block %a from peer %a." + -% t event "received_future_block" + -% a Block_hash.Logging.tag head + -% a P2p_peer.Id.Logging.tag state.gid) >>= fun () -> Lwt.return_unit end else begin chain_db.callback.notify_head state.gid header mempool ; diff --git a/src/lib_shell/distributed_db_functors.ml b/src/lib_shell/distributed_db_functors.ml index f14f584bfc54800189b84b0591ef65cb9799c65a..5adfd662fc1cafc88932cb6a959c601ac153ff8c 100644 --- a/src/lib_shell/distributed_db_functors.ml +++ b/src/lib_shell/distributed_db_functors.ml @@ -320,6 +320,10 @@ module Make_request_scheduler val name : string val encoding : t Data_encoding.t val pp : Format.formatter -> t -> unit + + module Logging : sig + val tag : t Tag.def + end end) (Table : MEMORY_TABLE with type key := Hash.t) (Request : REQUEST with type key := Hash.t) : sig @@ -331,7 +335,7 @@ module Make_request_scheduler end = struct - include Logging.Make(struct let name = "node.distributed_db.scheduler." ^ Hash.name end) + include Logging.Make_semantic(struct let name = "node.distributed_db.scheduler." ^ Hash.name end) type key = Hash.t @@ -363,24 +367,38 @@ end = struct let request t p k = assert (Lwt_pipe.push_now t.queue (Request (p, k))) let notify t p k = - debug "push received %a from %a" - Hash.pp k P2p_peer.Id.pp_short p ; + debug Tag.DSL.(fun f -> + f "push received %a from %a" + -% t event "push_received" + -% a Hash.Logging.tag k + -% a P2p_peer.Id.Logging.tag p); assert (Lwt_pipe.push_now t.queue (Notify (p, k))) let notify_cancelation t k = - debug "push cancelation %a" - Hash.pp k ; + debug Tag.DSL.(fun f -> + f "push cancelation %a" + -% t event "push_cancelation" + -% a Hash.Logging.tag k); assert (Lwt_pipe.push_now t.queue (Notify_cancelation k)) let notify_invalid t p k = - debug "push received invalid %a from %a" - Hash.pp k P2p_peer.Id.pp_short p ; + debug Tag.DSL.(fun f -> + f "push received invalid %a from %a" + -% t event "push_received_invalid" + -% a Hash.Logging.tag k + -% a P2p_peer.Id.Logging.tag p); assert (Lwt_pipe.push_now t.queue (Notify_invalid (p, k))) let notify_duplicate t p k = - debug "push received duplicate %a from %a" - Hash.pp k P2p_peer.Id.pp_short p ; + debug Tag.DSL.(fun f -> + f "push received duplicate %a from %a" + -% t event "push_received_duplicate" + -% a Hash.Logging.tag k + -% a P2p_peer.Id.Logging.tag p); assert (Lwt_pipe.push_now t.queue (Notify_duplicate (p, k))) let notify_unrequested t p k = - debug "push received unrequested %a from %a" - Hash.pp k P2p_peer.Id.pp_short p ; + debug Tag.DSL.(fun f -> + f "push received unrequested %a from %a" + -% t event "push_received_unrequested" + -% a Hash.Logging.tag k + -% a P2p_peer.Id.Logging.tag p); assert (Lwt_pipe.push_now t.queue (Notify_unrequested (p, k))) let compute_timeout state = @@ -401,17 +419,16 @@ end = struct Lwt_unix.sleep delay end - let may_pp_peer ppf = function - | None -> () - | Some peer -> P2p_peer.Id.pp_short ppf peer - (* TODO should depend on the ressource kind... *) let initial_delay = 0.5 let process_event state now = function | Request (peer, key) -> begin - lwt_debug "registering request %a from %a" - Hash.pp key may_pp_peer peer >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "registering request %a from %a" + -% t event "registering_request" + -% a Hash.Logging.tag key + -% a P2p_peer.Id.Logging.tag_opt peer) >>= fun () -> try let data = Table.find state.pending key in let peers = @@ -423,8 +440,11 @@ end = struct next_request = min data.next_request (now +. initial_delay) ; peers ; } ; - lwt_debug "registering request %a from %a -> replaced" - Hash.pp key may_pp_peer peer >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "registering request %a from %a -> replaced" + -% t event "registering_request_replaced" + -% a Hash.Logging.tag key + -% a P2p_peer.Id.Logging.tag_opt peer) >>= fun () -> Lwt.return_unit with Not_found -> let peers = @@ -436,33 +456,50 @@ end = struct next_request = now ; delay = initial_delay ; } ; - lwt_debug "registering request %a from %a -> added" - Hash.pp key may_pp_peer peer >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "registering request %a from %a -> added" + -% t event "registering_request_added" + -% a Hash.Logging.tag key + -% a P2p_peer.Id.Logging.tag_opt peer) >>= fun () -> Lwt.return_unit end | Notify (peer, key) -> Table.remove state.pending key ; - lwt_debug "received %a from %a" - Hash.pp key P2p_peer.Id.pp_short peer >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "received %a from %a" + -% t event "received" + -% a Hash.Logging.tag key + -% a P2p_peer.Id.Logging.tag peer) >>= fun () -> Lwt.return_unit | Notify_cancelation key -> Table.remove state.pending key ; - lwt_debug "canceled %a" - Hash.pp key >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "canceled %a" + -% t event "canceled" + -% a Hash.Logging.tag key) >>= fun () -> Lwt.return_unit | Notify_invalid (peer, key) -> - lwt_debug "received invalid %a from %a" - Hash.pp key P2p_peer.Id.pp_short peer >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "received invalid %a from %a" + -% t event "received_invalid" + -% a Hash.Logging.tag key + -% a P2p_peer.Id.Logging.tag peer) >>= fun () -> (* TODO *) Lwt.return_unit | Notify_unrequested (peer, key) -> - lwt_debug "received unrequested %a from %a" - Hash.pp key P2p_peer.Id.pp_short peer >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "received unrequested %a from %a" + -% t event "received_unrequested" + -% a Hash.Logging.tag key + -% a P2p_peer.Id.Logging.tag peer) >>= fun () -> (* TODO *) Lwt.return_unit | Notify_duplicate (peer, key) -> - lwt_debug "received duplicate %a from %a" - Hash.pp key P2p_peer.Id.pp_short peer >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "received duplicate %a from %a" + -% t event "received_duplicate" + -% a Hash.Logging.tag key + -% a P2p_peer.Id.Logging.tag peer) >>= fun () -> (* TODO *) Lwt.return_unit @@ -473,7 +510,8 @@ end = struct Lwt.choose [ (state.events >|= fun _ -> ()) ; timeout ; shutdown ] >>= fun () -> if Lwt.state shutdown <> Lwt.Sleep then - lwt_debug "terminating" >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "terminating" -% t event "terminating") >>= fun () -> Lwt.return_unit else if Lwt.state state.events <> Lwt.Sleep then let now = Unix.gettimeofday () in @@ -482,7 +520,8 @@ end = struct Lwt_list.iter_s (process_event state now) events >>= fun () -> loop state else - lwt_debug "timeout" >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "timeout" -% t event "timeout") >>= fun () -> let now = Unix.gettimeofday () in let active_peers = Request.active state.param in let requests = @@ -515,8 +554,11 @@ end = struct P2p_peer.Map.fold begin fun peer request acc -> acc >>= fun () -> Lwt_list.iter_s (fun key -> - lwt_debug "requested %a from %a" - Hash.pp key P2p_peer.Id.pp_short peer) + lwt_debug Tag.DSL.(fun f -> + f "requested %a from %a" + -% t event "requested" + -% a Hash.Logging.tag key + -% a P2p_peer.Id.Logging.tag peer)) request end requests Lwt.return_unit >>= fun () -> loop state diff --git a/src/lib_shell/distributed_db_functors.mli b/src/lib_shell/distributed_db_functors.mli index 524546a634bf3a6fd6f06757dbb4eaf32bafafb0..eac7bcd9d168d6006701e34f66e64cd7a3ccda4c 100644 --- a/src/lib_shell/distributed_db_functors.mli +++ b/src/lib_shell/distributed_db_functors.mli @@ -172,6 +172,10 @@ module Make_request_scheduler val name : string val encoding : t Data_encoding.t val pp : Format.formatter -> t -> unit + + module Logging : sig + val tag : t Tag.def + end end) (Table : MEMORY_TABLE with type key := Hash.t) (Request : REQUEST with type key := Hash.t) : sig diff --git a/src/lib_shell/distributed_db_message.ml b/src/lib_shell/distributed_db_message.ml index 7466963d99de11a75748e39c59b035ea549413b5..3d6d4c1bb4b215361130d89f258c35f46cc50e1c 100644 --- a/src/lib_shell/distributed_db_message.ml +++ b/src/lib_shell/distributed_db_message.ml @@ -302,3 +302,7 @@ let raw_encoding = P2p.Raw.encoding encoding let pp_json ppf msg = Data_encoding.Json.pp ppf (Data_encoding.Json.construct raw_encoding (Message msg)) + +module Logging = struct + let tag = Tag.def ~doc:"Message" "message" pp_json +end diff --git a/src/lib_shell/distributed_db_message.mli b/src/lib_shell/distributed_db_message.mli index 32a932af4434262d39ecee6d50ea502143c2cad7..cdf20dd753db036fda501c1fd2c2a3df00ea475d 100644 --- a/src/lib_shell/distributed_db_message.mli +++ b/src/lib_shell/distributed_db_message.mli @@ -50,3 +50,7 @@ module Bounded_encoding : sig val set_protocol_max_size: int option -> unit val set_mempool_max_operations: int option -> unit end + +module Logging : sig + val tag : t Tag.def +end diff --git a/src/lib_shell/node.ml b/src/lib_shell/node.ml index 26193cfe8387a95cb55c9c08c6497ed77d05b0da..1587e0b56e3c248770d53ad238a6467d2cd17812 100644 --- a/src/lib_shell/node.ml +++ b/src/lib_shell/node.ml @@ -46,12 +46,14 @@ let init_p2p p2p_params = match p2p_params with | None -> let c_meta = init_connection_metadata None in - lwt_log_notice "P2P layer is disabled" >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "P2P layer is disabled" -% t event "p2p_disabled") >>= fun () -> return (P2p.faked_network peer_metadata_cfg c_meta) | Some (config, limits) -> let c_meta = init_connection_metadata (Some config) in let conn_metadata_cfg = connection_metadata_cfg c_meta in - lwt_log_notice "bootstrapping chain..." >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "bootstrapping chain..." -% t event "bootstrapping_chain") >>= fun () -> P2p.create ~config ~limits peer_metadata_cfg diff --git a/src/lib_shell/protocol_validator.ml b/src/lib_shell/protocol_validator.ml index ac9fce097d65eab4889a596606d128fc98f65903..104040aeb823551e4ab87128fbf6988c5deba178 100644 --- a/src/lib_shell/protocol_validator.ml +++ b/src/lib_shell/protocol_validator.ml @@ -9,7 +9,7 @@ open Validation_errors -include Logging.Make(struct let name = "node.validator.block" end) +include Logging.Make_semantic(struct let name = "node.validator.block" end) type 'a request = | Request_validation: { @@ -68,11 +68,14 @@ let rec worker_loop bv = | Ok () -> worker_loop bv | Error [Canceled | Exn Lwt_pipe.Closed] -> - lwt_log_notice "terminating" >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "terminating" -% t event "terminating") >>= fun () -> Lwt.return_unit | Error err -> - lwt_log_error "@[Unexpected error (worker):@ %a@]" - pp_print_error err >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "@[Unexpected error (worker):@ %a@]" + -% t event "unexpected_error" + -% a errs_tag err) >>= fun () -> Lwt_canceler.cancel bv.canceler >>= fun () -> Lwt.return_unit @@ -99,13 +102,17 @@ let shutdown { canceler ; worker } = let validate { messages } hash protocol = match Registered_protocol.get hash with | Some protocol -> - lwt_debug "previously validated protocol %a (before pipe)" - Protocol_hash.pp_short hash >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "previously validated protocol %a (before pipe)" + -% t event "previously_validated_protocol" + -% a Protocol_hash.Logging.tag hash) >>= fun () -> return protocol | None -> let res, wakener = Lwt.task () in - lwt_debug "pushing validation request for protocol %a" - Protocol_hash.pp_short hash >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "pushing validation request for protocol %a" + -% t event "pushing_validation_request" + -% a Protocol_hash.Logging.tag hash) >>= fun () -> Lwt_pipe.push messages (Message (Request_validation { hash ; protocol }, Some wakener)) >>= fun () -> @@ -119,14 +126,11 @@ let fetch_and_compile_protocol pv ?peer ?timeout hash = Distributed_db.Protocol.read_opt pv.db hash >>= function | Some protocol -> return protocol | None -> - let may_print_peer ppf = function - | None -> () - | Some peer -> - Format.fprintf ppf " from peer %a" - P2p_peer.Id.pp peer in - lwt_log_notice "Fetching protocol %a%a" - Protocol_hash.pp_short hash - may_print_peer peer >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "Fetching protocol %a%a" + -% t event "fetching_protocol" + -% a Protocol_hash.Logging.tag hash + -% a P2p_peer.Id.Logging.tag_source peer) >>= fun () -> Distributed_db.Protocol.fetch pv.db ?peer ?timeout hash () end >>=? fun protocol -> validate pv hash protocol >>=? fun proto -> diff --git a/src/lib_shell/state.ml b/src/lib_shell/state.ml index f9120bb829a82fc8da9bff5252868e5ba48d7f7b..1b057e401d004141eb48d190652642799e5cd123 100644 --- a/src/lib_shell/state.ml +++ b/src/lib_shell/state.ml @@ -577,7 +577,10 @@ module Chain = struct end let destroy state chain = - lwt_debug "destroy %a" Chain_id.pp (id chain) >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "destroy %a" + -% t event "destroy" + -% a chain_id (id chain)) >>= fun () -> Shared.use state.global_data begin fun { global_store ; chains } -> Chain_id.Table.remove chains (id chain) ; Store.Chain.destroy global_store (id chain) >>= fun () -> diff --git a/src/lib_shell/state_logging.ml b/src/lib_shell/state_logging.ml index bb7f7d3cfe719d2a40feac8735d5d36979fbe33c..4f58ff49d86e567902b1716f30c6fa65f81d99fb 100644 --- a/src/lib_shell/state_logging.ml +++ b/src/lib_shell/state_logging.ml @@ -7,4 +7,6 @@ (* *) (**************************************************************************) -include Tezos_stdlib.Logging.Make(struct let name = "node.state" end) +include Tezos_stdlib.Logging.Make_semantic(struct let name = "node.state" end) + +let chain_id = Tag.def ~doc:"Chain ID" "chain_id" Chain_id.pp diff --git a/src/lib_shell/state_logging.mli b/src/lib_shell/state_logging.mli index 79bef502af972dcb5c662c8432d0022e14ca76a8..96b9dc1f7b46bf71ca87f7af5a4350b6410e8f0d 100644 --- a/src/lib_shell/state_logging.mli +++ b/src/lib_shell/state_logging.mli @@ -7,4 +7,6 @@ (* *) (**************************************************************************) -include Tezos_stdlib.Logging.LOG +include Tezos_stdlib.Logging.SEMLOG + +val chain_id: Chain_id.t Tag.def diff --git a/src/lib_shell/validator.ml b/src/lib_shell/validator.ml index eb43bf2b160569264e358077d0c92af50a488830..87d76174390f5d7424a4e968c9b4ba30645ad6e1 100644 --- a/src/lib_shell/validator.ml +++ b/src/lib_shell/validator.ml @@ -7,7 +7,7 @@ (* *) (**************************************************************************) -include Logging.Make(struct let name = "node.validator" end) +include Logging.Make_semantic(struct let name = "node.validator" end) type t = { @@ -40,7 +40,10 @@ let create state db let activate v ?max_child_ttl ~start_prevalidator chain_state = let chain_id = State.Chain.id chain_state in - lwt_log_notice "activate chain %a" Chain_id.pp chain_id >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "activate chain %a" + -% t event "active_chain" + -% a State_logging.chain_id chain_id) >>= fun () -> try Chain_id.Table.find v.active_chains chain_id with Not_found -> let nv = diff --git a/src/lib_shell/worker_logging.ml b/src/lib_shell/worker_logging.ml index 2aea54b15f4120085df374099a052ce181551870..e44b2c245b1a7df75f99e5d83ffeda0fb46600ac 100644 --- a/src/lib_shell/worker_logging.ml +++ b/src/lib_shell/worker_logging.ml @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -include Tezos_stdlib.Logging.Make(struct let name = "node.worker" end) +include Tezos_stdlib.Logging.Make_semantic(struct let name = "node.worker" end) diff --git a/src/lib_shell/worker_logging.mli b/src/lib_shell/worker_logging.mli index 79bef502af972dcb5c662c8432d0022e14ca76a8..e31ffbbcf300c98fb3bdcf3f8d4cd13f79dc5f62 100644 --- a/src/lib_shell/worker_logging.mli +++ b/src/lib_shell/worker_logging.mli @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -include Tezos_stdlib.Logging.LOG +include Tezos_stdlib.Logging.SEMLOG diff --git a/src/lib_signer_backends/ledger.ml b/src/lib_signer_backends/ledger.ml index 4d19725072249b8e11b353f05145c789ac3b1ee9..5f840bc04d5d0d9dee1d97f4c6beec73d5ac0449 100644 --- a/src/lib_signer_backends/ledger.ml +++ b/src/lib_signer_backends/ledger.ml @@ -9,7 +9,7 @@ open Client_keys -include Logging.Make(struct let name = "client.signer.ledger" end) +include Tezos_stdlib.Logging.Make(struct let name = "client.signer.ledger" end) let scheme = "ledger" diff --git a/src/lib_stdlib/logging.ml b/src/lib_stdlib/logging.ml index 7360afdc7a50b721dc7f910758b0904b3ee01531..2a48aefe4667021eb0988dd06758f0b000f5ee67 100644 --- a/src/lib_stdlib/logging.ml +++ b/src/lib_stdlib/logging.ml @@ -16,19 +16,51 @@ module type MESSAGE = sig val name: string end +type level = Lwt_log_core.level = + | Debug + (** Debugging message. They can be automatically removed by the + syntax extension. *) + | Info + (** Informational message. Suitable to be displayed when the + program is in verbose mode. *) + | Notice + (** Same as {!Info}, but is displayed by default. *) + | Warning + (** Something strange happend *) + | Error + (** An error message, which should not means the end of the + program. *) + | Fatal + type log_section = .. type log_message = { section : log_section ; - text : string ; + level : level ; + text : string option ; tags : Tag.set ; } -let taps : (log_message -> unit) list ref = ref [] +type tap_id = int +let next_tap : int ref = ref 0 + +type tap = { + id : tap_id ; + process : log_message -> unit ; +} -let tap f = taps := f :: !taps +let taps : tap list ref = ref [] -let call_taps v = List.iter (fun f -> f v) !taps +let tap process = let id = !next_tap in + begin + next_tap := id + 1 ; + taps := { id ; process } :: !taps ; + id + end + +let untap x = taps := List.filter (fun tap -> tap.id <> x) !taps + +let call_taps v = List.iter (fun tap -> tap.process v) !taps module type SEMLOG = sig @@ -73,34 +105,34 @@ module Make_semantic(S : MESSAGE) : SEMLOG = struct let log_f ~level = - if level >= Lwt_log_core.Section.level section then + if level < Lwt_log_core.Section.level section then + fun format ?(tags=Tag.empty) -> + Format.ikfprintf + (fun _ -> call_taps { section = Section ; level ; text = None ; tags }; Lwt.return_unit) + Format.std_formatter + format + else fun format ?(tags=Tag.empty) -> Format.kasprintf (fun text -> - call_taps { section = Section ; text ; tags }; + call_taps { section = Section ; level ; text = Some text ; tags }; Lwt_log_core.log ~section ~level text) format - else + + let ign_log_f ~level = + if level < Lwt_log_core.Section.level section then fun format ?(tags=Tag.empty) -> Format.ikfprintf - (fun _ -> call_taps { section = Section ; text = "" ; tags }; Lwt.return_unit) + (fun _ -> call_taps { section = Section ; level ; text = None ; tags }) Format.std_formatter format - - let ign_log_f ~level = - if level >= Lwt_log_core.Section.level section then + else fun format ?(tags=Tag.empty) -> Format.kasprintf (fun text -> - call_taps { section = Section ; text ; tags }; + call_taps { section = Section ; level ; text = Some text ; tags }; Lwt_log_core.ign_log ~section ~level text) format - else - fun format ?(tags=Tag.empty) -> - Format.ikfprintf - (fun _ -> call_taps { section = Section ; text = "" ; tags }) - Format.std_formatter - format let debug f = f (ign_log_f ~level:Lwt_log_core.Debug) ?tags:(Some Tag.empty) let log_info f = f (ign_log_f ~level:Lwt_log_core.Info) ?tags:(Some Tag.empty) @@ -143,7 +175,7 @@ end let sections = ref [] -module Make_unregistered(S : sig val name: string end) : LOG = struct +module Make_unregistered(S : MESSAGE) : LOG = struct let section = Lwt_log_core.Section.make S.name type log_section += Section @@ -155,7 +187,7 @@ module Make_unregistered(S : sig val name: string end) : LOG = struct else Format.kasprintf (fun msg -> - call_taps { section = Section ; text = msg ; tags = Tag.empty }; + call_taps { section = Section ; level ; text = Some msg ; tags = Tag.empty }; Lwt_log_core.log ?exn ~section ?location ?logger ~level msg) format @@ -166,7 +198,7 @@ module Make_unregistered(S : sig val name: string end) : LOG = struct else Format.kasprintf (fun msg -> - call_taps { section = Section ; text = msg ; tags = Tag.empty }; + call_taps { section = Section ; level ; text = Some msg ; tags = Tag.empty }; Lwt_log_core.ign_log ?exn ~section ?location ?logger ~level msg) format @@ -186,7 +218,7 @@ module Make_unregistered(S : sig val name: string end) : LOG = struct end -module Make(S : sig val name: string end) : LOG = struct +module Make(S : MESSAGE) : LOG = struct let () = sections := S.name :: !sections include Make_unregistered(S) @@ -199,21 +231,5 @@ module Core = struct let worker = Tag.def ~doc:"Name of affected worker" "worker" Format.pp_print_text end -type level = Lwt_log_core.level = - | Debug - (** Debugging message. They can be automatically removed by the - syntax extension. *) - | Info - (** Informational message. Suitable to be displayed when the - program is in verbose mode. *) - | Notice - (** Same as {!Info}, but is displayed by default. *) - | Warning - (** Something strange happend *) - | Error - (** An error message, which should not means the end of the - program. *) - | Fatal - type template = Lwt_log_core.template let default_template = "$(date) - $(section): $(message)" diff --git a/src/lib_stdlib/logging.mli b/src/lib_stdlib/logging.mli index ff1181f95cc632ef04a1fcee38aba3d7b67ff87a..3ffbe415373dc42d62abc90ef1c8835091ca6999 100644 --- a/src/lib_stdlib/logging.mli +++ b/src/lib_stdlib/logging.mli @@ -7,15 +7,43 @@ (* *) (**************************************************************************) +type level = Lwt_log_core.level = + | Debug + (** Debugging message. They can be automatically removed by the + syntax extension. *) + | Info + (** Informational message. Suitable to be displayed when the + program is in verbose mode. *) + | Notice + (** Same as {!Info}, but is displayed by default. *) + | Warning + (** Something strange happend *) + | Error + (** An error message, which should not means the end of the + program. *) + | Fatal + +(** Unique tag for a logging module. + Match against, e.g. `Logging.Core.Section`. *) type log_section = private .. type log_message = { section : log_section ; - text : string ; + level : level ; + text : string option ; tags : Tag.set ; } -val tap : (log_message -> unit) -> unit +type tap_id + +(** Intercept events as they are logged. All events will generate a call to + your tap function, but `text` will only be included for events that + actually print a message according to the active logging configuration. *) +val tap : (log_message -> unit) -> tap_id + +(** Remove a previously set tap by supplying its tap_id. Does nothing if + the tap was removed already. *) +val untap : tap_id -> unit type ('a,'b) msgf = (('a, Format.formatter, unit, 'b) format4 -> ?tags:Tag.set -> 'a) -> ?tags:Tag.set -> 'b type ('a,'b) log = ('a,'b) msgf -> 'b @@ -75,27 +103,11 @@ module Core : sig val worker : string Tag.def end -module Make(S: sig val name: string end) : LOG -module Make_unregistered(S: sig val name: string end) : LOG +module Make(S: MESSAGE) : LOG +module Make_unregistered(S: MESSAGE) : LOG module Make_semantic(S: MESSAGE) : SEMLOG -type level = Lwt_log_core.level = - | Debug - (** Debugging message. They can be automatically removed by the - syntax extension. *) - | Info - (** Informational message. Suitable to be displayed when the - program is in verbose mode. *) - | Notice - (** Same as {!Info}, but is displayed by default. *) - | Warning - (** Something strange happend *) - | Error - (** An error message, which should not means the end of the - program. *) - | Fatal - type template = Lwt_log.template val default_template : template diff --git a/src/lib_stdlib/tag.ml b/src/lib_stdlib/tag.ml index c2a11195c72e4d1eaa9ebb775ccd57f93823df78..0b59af6b5b89baa60d8c7930e6cf8e061fee5353 100644 --- a/src/lib_stdlib/tag.ml +++ b/src/lib_stdlib/tag.ml @@ -130,9 +130,12 @@ let max_binding_opt s = option_map snd @@ TagSet.max_binding_opt s let choose s = snd @@ TagSet.choose s let choose_opt s = option_map snd @@ TagSet.choose_opt s let split tag s = (fun (l,m,r) -> (l,unveil tag m,r)) @@ TagSet.split (Key.V tag) s -(* XXX find should be different from find_opt but Logs has find_opt called find *) +(* In order to match the usual interface for maps, `find` should be different from + `find_opt` but `Logs` has `find_opt` called `find` so we favor that. *) let find tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s let find_opt tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s +(* This would usually be called `find` but `Logs` has it with this name. We can't + have it at both named because `Logs` has `find_opt` as `find`. *) let get tag s = find_opt tag s |> function | None -> invalid_arg (Format.asprintf "tag named %s not found in set" (name tag)) | Some v -> v diff --git a/src/lib_stdlib/tag.mli b/src/lib_stdlib/tag.mli index e01f4de513725437b3335d7660fc2ba38bf90744..415b6ef9493e4c241df4259e7bc5556413286a92 100644 --- a/src/lib_stdlib/tag.mli +++ b/src/lib_stdlib/tag.mli @@ -77,6 +77,7 @@ val max_binding_opt : set -> t option val choose : set -> t val choose_opt : set -> t option val split : 'a def -> set -> set * 'a option * set +val find_opt : 'a def -> set -> 'a option val find : 'a def -> set -> 'a option val get : 'a def -> set -> 'a val find_first : (Key.t -> bool) -> set -> t @@ -87,10 +88,30 @@ val map : (t -> t) -> set -> set val mapi : (t -> t) -> set -> set val pp_set : Format.formatter -> set -> unit +(** DSL for logging messages. Opening this locally makes it easy to supply a number + of semantic tags for a log event while using their values in the human-readable + text. For example: + + {[ + lwt_log_info Tag.DSL.(fun f -> + f "request for operations %a:%d from peer %a timed out." + -% t event "request_operations_timeout" + -% a Block_hash.Logging.tag bh + -% s operations_index_tag n + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) + ]} *) module DSL : sig type (_,_,_,_) arg + + (** Use a semantic tag with a `%a` format, supplying the pretty printer from the tag. *) val a : 'v def -> 'v -> (('b -> 'v -> 'c) -> 'v -> 'd, 'b, 'c, 'd) arg + + (** Use a semantic tag with ordinary formats such as `%s`, `%d`, and `%f`. *) val s : 'v def -> 'v -> ('v -> 'd, 'b, 'c, 'd) arg + + (** Supply a semantic tag without formatting it. *) val t : 'v def -> 'v -> ('d, 'b, 'c, 'd) arg + + (** Perform the actual application of a tag to a format. *) val (-%) : (?tags:set -> 'a) -> ('a,Format.formatter,unit,'d) arg -> (?tags:set -> 'd) end diff --git a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml index 33b40899eb5a42ba03bc4f2d8ea942b71bc7b92a..029ac1ee6c0c1017abc2fa2de20ac5138d3d6ee9 100644 --- a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml @@ -7,12 +7,13 @@ (* *) (**************************************************************************) -include Logging.Make(struct let name = "client.denunciation" end) +include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.denunciation" end) open Proto_alpha open Alpha_context open Client_baking_blocks +open Logging module HLevel = Hashtbl.Make(struct include Raw_level @@ -55,7 +56,10 @@ let get_block_offset level = else `Head 5) | Error errs -> - lwt_log_error "Invalid level conversion : %a" pp_print_error errs >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Invalid level conversion : %a" + -% t event "invalid_level_conversion" + -% a errs_tag errs) >>= fun () -> Lwt.return (`Head 0) let process_endorsements (cctxt : #Proto_alpha.full) state ~chain @@ -83,17 +87,24 @@ let process_endorsements (cctxt : #Proto_alpha.full) state ~chain ~op1:existing_endorsement ~op2:new_endorsement () >>=? fun bytes -> let bytes = Signature.concat bytes Signature.zero in - lwt_log_notice "Double endorsement detected" >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "Double endorsement detected" + -% t event "double_endorsement_detected" + -% t conflicting_endorsements_tag (existing_endorsement, new_endorsement)) >>= fun () -> (* A denunciation may have already occured *) Shell_services.Injection.operation cctxt ~chain bytes >>=? fun op_hash -> - lwt_log_notice "Double endorsement evidence injected %a" - Operation_hash.pp op_hash >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "Double endorsement evidence injected %a" + -% t event "double_endorsement_denounced" + -% a Operation_hash.Logging.tag op_hash) >>= fun () -> return @@ HLevel.replace state.endorsements_table level (Delegate_Map.add delegate new_endorsement map) end | _ -> - lwt_log_error "Inconsistent endorsement found %a" - Operation_hash.pp hash >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Inconsistent endorsement found %a" + -% t event "inconsistent_endorsement" + -% a Operation_hash.Logging.tag hash) >>= fun () -> return_unit ) endorsements >>=? fun () -> return_unit @@ -108,7 +119,7 @@ let process_block (cctxt : #Proto_alpha.full) state ~chain (header : Alpha_block (Delegate_Map.add baker hash map) | Some existing_hash when Block_hash.(=) existing_hash hash -> (* This case should never happen *) - lwt_debug "Double baking detected but block hashes are equivalent. Skipping..." >>= fun () -> + lwt_debug Tag.DSL.(fun f -> f "Double baking detected but block hashes are equivalent. Skipping..." -% t event "double_baking_but_not") >>= fun () -> return @@ HLevel.replace state.blocks_table level (Delegate_Map.add baker hash map) | Some existing_hash -> @@ -126,11 +137,15 @@ let process_block (cctxt : #Proto_alpha.full) state ~chain (header : Alpha_block Alpha_services.Forge.double_baking_evidence cctxt (`Main, block) ~branch:block_hash ~bh1 ~bh2 () >>=? fun bytes -> let bytes = Signature.concat bytes Signature.zero in - lwt_log_notice "Double baking detected" >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "Double baking detected" + -% t event "double_baking_detected") >>= fun () -> (* A denunciation may have already occured *) Shell_services.Injection.operation cctxt ~chain bytes >>=? fun op_hash -> - lwt_log_notice "Double baking evidence injected %a" - Operation_hash.pp op_hash >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "Double baking evidence injected %a" + -% t event "double_baking_denounced" + -% a Operation_hash.Logging.tag op_hash) >>= fun () -> return @@ HLevel.replace state.blocks_table level (Delegate_Map.add baker hash map) end @@ -166,10 +181,18 @@ let endorsements_index = 0 *) let process_new_block (cctxt : #Proto_alpha.full) state { hash ; chain_id ; level ; protocol ; next_protocol } = if Protocol_hash.(protocol <> next_protocol) then - lwt_log_error "Protocol changing detected. Skipping the block." >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Protocol changing detected. Skipping the block." + -% t event "protocol_change_detected" + (* TODO which protocols -- in tag *) + ) >>= fun () -> return_unit else - lwt_debug "Block level : %a" Raw_level.pp level >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "Block level : %a" + -% t event "accuser_saw_block" + -% a level_tag level + -% t Block_hash.Logging.tag hash) >>= fun () -> let chain = `Hash chain_id in let block = `Hash (hash, 0) in state.highest_level_encountered <- Raw_level.max level state.highest_level_encountered ; @@ -179,9 +202,11 @@ let process_new_block (cctxt : #Proto_alpha.full) state { hash ; chain_id ; leve | Ok block_info -> process_block cctxt state ~chain block_info | Error errs -> - lwt_log_error "Error while fetching operations in block %a@\n%a" - Block_hash.pp_short hash - pp_print_error errs >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Error while fetching operations in block %a@\n%a" + -% t event "fetch_operations_error" + -% a Block_hash.Logging.tag hash + -% a errs_tag errs) >>= fun () -> return_unit end >>=? fun () -> (* Processing endorsements *) @@ -192,9 +217,11 @@ let process_new_block (cctxt : #Proto_alpha.full) state { hash ; chain_id ; leve process_endorsements cctxt state ~chain endorsements level else return_unit | Error errs -> - lwt_log_error "Error while fetching operations in block %a@\n%a" - Block_hash.pp_short hash - pp_print_error errs >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Error while fetching operations in block %a@\n%a" + -% t event "fetch_operations_error" + -% a Block_hash.Logging.tag hash + -% a errs_tag errs) >>= fun () -> return_unit end >>=? fun () -> cleanup_old_operations state ; @@ -205,14 +232,17 @@ let create (cctxt : #Proto_alpha.full) ~preserved_levels valid_blocks_stream = let process_block cctxt state bi = process_new_block cctxt state bi >>= function | Ok () -> - lwt_log_notice - "Block %a registered" - Block_hash.pp_short bi.Client_baking_blocks.hash + lwt_log_notice Tag.DSL.(fun f -> + f "Block %a registered" + -% t event "accuser_processed_block" + -% a Block_hash.Logging.tag bi.Client_baking_blocks.hash) >>= return | Error errs -> - lwt_log_error "Error while processing block %a@\n%a" - Block_hash.pp_short bi.hash - pp_print_error errs + lwt_log_error Tag.DSL.(fun f -> + f "Error while processing block %a@\n%a" + -% t event "accuser_block_error" + -% a Block_hash.Logging.tag bi.hash + -% a errs_tag errs) >>= return in diff --git a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml index 5ed358dbc3318b7ce0c2f06641e5b9f5cfbe8d22..7f7757002dc632c053c0f025165fddb03cb97ac8 100644 --- a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml +++ b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml @@ -10,7 +10,9 @@ open Proto_alpha open Alpha_context -include Logging.Make(struct let name = "client.endorsement" end) +include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.endorsement" end) + +open Logging module State = Daemon_state.Make(struct let name = "endorsement" end) @@ -104,51 +106,71 @@ let endorse_for_delegate cctxt block delegate = let { Client_baking_blocks.hash ; level } = block in let b = `Hash (hash, 0) in Client_keys.get_key cctxt delegate >>=? fun (name, _pk, sk) -> - lwt_debug "Endorsing %a for %s (level %a)!" - Block_hash.pp_short hash name - Raw_level.pp level >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "Endorsing %a for %s (level %a)!" + -% t event "endorsing" + -% a Block_hash.Logging.tag hash + -% s Client_keys.Logging.tag name + -% a level_tag level) >>= fun () -> inject_endorsement cctxt b hash level sk delegate >>=? fun oph -> - lwt_log_notice - "Injected endorsement for block '%a' \ - (level %a, contract %s) '%a'" - Block_hash.pp_short hash - Raw_level.pp level - name - Operation_hash.pp_short oph >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> + f "Injected endorsement for block '%a' \ + (level %a, contract %s) '%a'" + -% t event "injected_endorsement" + -% a Block_hash.Logging.tag hash + -% a level_tag level + -% s Client_keys.Logging.tag name + -% a Operation_hash.Logging.tag oph) >>= fun () -> return_unit let allowed_to_endorse cctxt bi delegate = Client_keys.Public_key_hash.name cctxt delegate >>=? fun name -> - lwt_debug "Checking if allowed to endorse block %a for %s" - Block_hash.pp_short bi.Client_baking_blocks.hash name >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "Checking if allowed to endorse block %a for %s" + -% t event "check_endorsement_ok" + -% a Block_hash.Logging.tag bi.Client_baking_blocks.hash + -% s Client_keys.Logging.tag name) >>= fun () -> let b = `Hash (bi.hash, 0) in let level = bi.level in get_signing_slots cctxt b delegate level >>=? function | None | Some [] -> - lwt_debug "No slot found for %a/%s" - Block_hash.pp_short bi.hash name >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "No slot found for %a/%s" + -% t event "endorsement_no_slots_found" + -% a Block_hash.Logging.tag bi.hash + -% s Client_keys.Logging.tag name) >>= fun () -> return_false | Some (_ :: _ as slots) -> - lwt_debug "Found slots for %a/%s (%d)" - Block_hash.pp_short bi.hash name (List.length slots) >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "Found slots for %a/%s (%a)" + -% t event "endorsement_slots_found" + -% a Block_hash.Logging.tag bi.hash + -% s Client_keys.Logging.tag name + -% a endorsement_slots_tag slots) >>= fun () -> previously_endorsed_level cctxt delegate level >>=? function | true -> - lwt_debug "Level %a (or higher) previously endorsed: do not endorse." - Raw_level.pp level >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "Level %a (or higher) previously endorsed: do not endorse." + -% t event "previously_endorsed" + -% a level_tag level) >>= fun () -> return_false | false -> return_true let prepare_endorsement ~(max_past:int64) () (cctxt : #Proto_alpha.full) state bi = if Time.diff (Time.now ()) bi.Client_baking_blocks.timestamp > max_past then - lwt_log_info "Ignore block %a: forged too far the past" - Block_hash.pp_short bi.hash >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "Ignore block %a: forged too far the past" + -% t event "endorsement_stale_block" + -% a Block_hash.Logging.tag bi.hash) >>= fun () -> return_unit else - lwt_log_info "Received new block %a" - Block_hash.pp_short bi.hash >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "Received new block %a" + -% t event "endorsement_got_block" + -% a Block_hash.Logging.tag bi.hash) >>= fun () -> let time = Time.(add (now ()) state.delay) in let timeout = Lwt_unix.sleep (Int64.to_float state.delay) in get_delegates cctxt state >>=? fun delegates -> @@ -168,11 +190,6 @@ let compute_timeout state = timeout >>= fun () -> Lwt.return (block, delegates) -let check_error f = - f >>= function - | Ok () -> Lwt.return_unit - | Error errs -> lwt_log_error "Error while endorsing:@\n%a" pp_print_error errs - let create (cctxt: #Proto_alpha.full) ?(max_past=110L) diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index d4750094a9ccc1c64479cd1dce22dac6f8b9a52e..f162db4145510cc96ca95b918035192f2dca9608 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -10,7 +10,8 @@ open Proto_alpha open Alpha_context -include Logging.Make(struct let name = "client.baking" end) +include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.baking" end) +open Logging (* The index of the different components of the protocol's validation passes *) @@ -326,11 +327,13 @@ let forge_block cctxt ?(chain = `Main) block List.fold_left (fun acc r -> acc + List.length r.Preapply_result.applied) 0 result in - lwt_log_info "Found %d valid operations (%d refused) for timestamp %a" - valid_op_count (total_op_count - valid_op_count) - Time.pp_hum timestamp >>= fun () -> - lwt_log_info "Computed fitness %a" - Fitness.pp shell_header.fitness >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "Found %d valid operations (%d refused) for timestamp %a@.Computed fitness %a" + -% t event "found_valid_operations" + -% s valid_ops valid_op_count + -% s refused_ops (total_op_count - valid_op_count) + -% a timestamp_tag timestamp + -% a fitness_tag shell_header.fitness) >>= fun () -> (* everything went well (or we don't care about errors): GO! *) if best_effort || all_ops_valid result then @@ -359,6 +362,7 @@ let previously_baked_level cctxt pkh new_lvl = | Some last_lvl -> return (Raw_level.(last_lvl >= new_lvl)) + let get_baking_slot cctxt ?max_priority (bi: Client_baking_blocks.block_info) delegates = let chain = `Hash bi.chain_id in @@ -370,12 +374,16 @@ let get_baking_slot cctxt ~delegates (chain, block) >>= function | Error errs -> - lwt_log_error "Error while fetching baking possibilities:\n%a" - pp_print_error errs >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Error while fetching baking possibilities:\n%a" + -% t event "baking_slot_fetch_errors" + -% a errs_tag errs) >>= fun () -> Lwt.return_nil | Ok [] -> - lwt_log_info "Found no baking rights for level %a" - Raw_level.pp level >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "Found no baking rights for level %a" + -% t event "no_baking_rights" + -% a level_tag level) >>= fun () -> Lwt.return_nil | Ok slots -> let slots = @@ -447,7 +455,11 @@ let safe_get_unrevealed_nonces cctxt block = get_unrevealed_nonces cctxt block >>= function | Ok r -> Lwt.return r | Error err -> - lwt_warn "Cannot read nonces: %a@." pp_print_error err >>= fun () -> + lwt_warn Tag.DSL.(fun f -> + f "Cannot read nonces: %a@." + -% t event "read_nonce_fail" + -% a errs_tag err) + >>= fun () -> Lwt.return_nil let insert_block @@ -470,16 +482,22 @@ let insert_block get_baking_slot cctxt ?max_priority bi delegates >>= function | [] -> lwt_debug - "Can't compute slots for %a" Block_hash.pp_short bi.hash >>= fun () -> + Tag.DSL.(fun f -> + f "Can't compute slots for %a" + -% t event "cannot_compute_slot" + -% a Block_hash.Logging.tag bi.hash) >>= fun () -> return_unit | (_ :: _) as slots -> iter_p (fun ((timestamp, (_, _, delegate)) as slot) -> Client_keys.Public_key_hash.name cctxt delegate >>=? fun name -> - lwt_log_info "New baking slot at %a for %s after %a" - Time.pp_hum timestamp - name - Block_hash.pp_short bi.hash >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "New baking slot at %a for %s after %a" + -% t event "have_baking_slot" + -% a timestamp_tag timestamp + -% s Client_keys.Logging.tag name + -% a Block_hash.Logging.tag bi.hash + -% t Signature.Public_key_hash.Logging.tag delegate) >>= fun () -> state.future_slots <- insert_baking_slot slot state.future_slots ; return_unit ) @@ -498,14 +516,18 @@ let pop_baking_slots state = let filter_invalid_operations (cctxt : #full) state block_info (operations : packed_operation list list) = let open Client_baking_simulator in - lwt_debug "Starting client-side validation %a" - Block_hash.pp block_info.Client_baking_blocks.hash >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "Starting client-side validation %a" + -% t event "baking_local_validation_start" + -% a Block_hash.Logging.tag block_info.Client_baking_blocks.hash) >>= fun () -> begin begin_construction cctxt state.index block_info >>= function | Ok inc -> return inc | Error errs -> - lwt_log_error "Error while fetching current context : %a" - pp_print_error errs >>= fun () -> - lwt_log_notice "Retrying to open the context" >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Error while fetching current context : %a" + -% t event "context_fetch_error" + -% a errs_tag errs) >>= fun () -> + lwt_log_notice Tag.DSL.(fun f -> f "Retrying to open the context" -% t event "reopen_context") >>= fun () -> Client_baking_simulator.load_context ~context_path:state.context_path >>= fun index -> begin_construction cctxt index block_info >>=? fun inc -> state.index <- index; @@ -518,9 +540,11 @@ let filter_invalid_operations (cctxt : #full) state block_info (operations : pac let validate_operation inc op = add_operation inc op >>= function | Error errs -> - lwt_log_info "Client-side validation: invalid operation filtered %a\n%a" - Operation_hash.pp (Operation.hash_packed op) - pp_print_error errs + lwt_log_info Tag.DSL.(fun f -> + f "Client-side validation: invalid operation filtered %a\n%a" + -% t event "baking_rejected_invalid_operation" + -% a Operation_hash.Logging.tag (Operation.hash_packed op) + -% a errs_tag errs) >>= fun () -> return_none | Ok inc -> return_some inc @@ -548,8 +572,10 @@ let filter_invalid_operations (cctxt : #full) state block_info (operations : pac filter_map_s (is_valid_endorsement inc) endorsements >>=? fun endorsements -> finalize_construction inc >>= function | Error errs -> - lwt_log_error "Client-side validation: invalid block built. Building an empty block...\n%a" - pp_print_error errs >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Client-side validation: invalid block built. Building an empty block...\n%a" + -% t event "built_invalid_block_error" + -% a errs_tag errs) >>= fun () -> return [ [] ; [] ; [] ; [] ] | Ok () -> let quota : Alpha_environment.Updater.quota list = Main.validation_passes in @@ -586,11 +612,13 @@ let bake_slot else timestamp in Client_keys.Public_key_hash.name cctxt delegate >>=? fun name -> - lwt_debug "Try baking after %a (slot %d) for %s (%a)" - Block_hash.pp_short bi.hash - priority - name - Time.pp_hum timestamp >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "Try baking after %a (slot %d) for %s (%a)" + -% t event "try_baking" + -% a Block_hash.Logging.tag bi.hash + -% s bake_priorty_tag priority + -% s Client_keys.Logging.tag name + -% a timestamp_tag timestamp) >>= fun () -> (* get and process operations *) Alpha_block_services.Mempool.pending_operations cctxt ~chain () >>=? fun mpool -> let operations = ops_of_mempool mpool in @@ -611,9 +639,10 @@ let bake_slot return operations end >>= function | Error errs -> - lwt_log_error "Client-side validation: error while filtering invalid operations :@\n%a" - pp_print_error - errs >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Client-side validation: error while filtering invalid operations :@\n%a" + -% t event "client_side_validation_error" + -% a errs_tag errs) >>= fun () -> return_none | Ok operations -> Alpha_block_services.Helpers.Preapply.block @@ -621,21 +650,20 @@ let bake_slot ~timestamp ~sort:true ~protocol_data operations >>= function | Error errs -> - lwt_log_error "Error while prevalidating operations:@\n%a" - pp_print_error - errs >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Error while prevalidating operations:@\n%a" + -% t event "prevalidate_operations_error" + -% a errs_tag errs) >>= fun () -> return_none | Ok (shell_header, operations) -> - lwt_debug - "Computed candidate block after %a (slot %d): %a/%d fitness: %a" - Block_hash.pp_short bi.hash priority - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf "+") - (fun ppf operations -> Format.fprintf ppf "%d" - (List.length operations.Preapply_result.applied))) - operations - total_op_count - Fitness.pp shell_header.fitness >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "Computed candidate block after %a (slot %d): %a/%d fitness: %a" + -% t event "candidate_block" + -% a Block_hash.Logging.tag bi.hash + -% s bake_priorty_tag priority + -% a operations_tag operations + -% s bake_op_count_tag total_op_count + -% a fitness_tag shell_header.fitness) >>= fun () -> let operations = List.map (fun l -> List.map snd l.Preapply_result.applied) operations in return @@ -674,9 +702,11 @@ let bake state () = let slots = pop_baking_slots state in - lwt_log_info "Found %d current slots and %d future slots." - (List.length slots) - (List.length state.future_slots) >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "Found %d current slots and %d future slots." + -% t event "pop_baking_slots" + -% s current_slots_tag (List.length slots) + -% s future_slots_tag (List.length state.future_slots)) >>= fun () -> let seed_nonce = generate_seed_nonce () in let seed_nonce_hash = Nonce.hash seed_nonce in @@ -704,8 +734,10 @@ let bake (* avoid double baking *) previously_baked_level cctxt src_pkh level >>=? function - | true -> lwt_log_error "Level %a : previously baked" - Raw_level.pp level >>= return + | true -> lwt_log_error Tag.DSL.(fun f -> + f "Level %a : previously baked" + -% t event "double_bake_near_miss" + -% a level_tag level) >>= return | false -> inject_block cctxt ~force:true ~chain @@ -727,9 +759,9 @@ let bake pp_operation_list_list operations >>= fun () -> return_unit end - | _ -> (* no candidates, or none fit-enough *) - lwt_debug "No valid candidates." >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "No valid candidates." -% t event "no_baking_candidates") >>= fun () -> return_unit diff --git a/src/proto_alpha/lib_delegate/client_baking_scheduling.ml b/src/proto_alpha/lib_delegate/client_baking_scheduling.ml index 6be4bfb21a9d01ef3c0aff13bab0c118f95092e2..740db9904269ebe46257e1c5695b726e301055aa 100644 --- a/src/proto_alpha/lib_delegate/client_baking_scheduling.ml +++ b/src/proto_alpha/lib_delegate/client_baking_scheduling.ml @@ -7,7 +7,9 @@ (* *) (**************************************************************************) -include Logging.Make(struct let name = "client.scheduling" end) +include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.scheduling" end) + +open Logging let sleep_until time = let delay = Time.diff time (Time.now ()) in @@ -16,19 +18,26 @@ let sleep_until time = else Some (Lwt_unix.sleep (Int64.to_float delay)) -let rec wait_for_first_event stream = +let rec wait_for_first_event ~name stream = Lwt_stream.get stream >>= function | None | Some (Error _) -> - lwt_log_info "Can't fetch the current event. Waiting for new event." >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "Can't fetch the current event. Waiting for new event." + -% t event "cannot_fetch_event" + -% t worker_tag name) >>= fun () -> (* NOTE: this is not a tight loop because of Lwt_stream.get *) - wait_for_first_event stream + wait_for_first_event ~name stream | Some (Ok bi) -> Lwt.return bi -let log_errors_and_continue p = +let log_errors_and_continue ~name p = p >>= function | Ok () -> Lwt.return_unit - | Error errs -> lwt_log_error "Error while baking:@\n%a" pp_print_error errs + | Error errs -> lwt_log_error Tag.DSL.(fun f -> + f "Error while baking:@\n%a" + -% t event "daemon_error" + -% t worker_tag name + -% a errs_tag errs) let main ~(name: string) @@ -52,9 +61,12 @@ let main unit tzresult Lwt.t)) = - lwt_log_info "Setting up before the %s can start." name >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "Setting up before the %s can start." + -% t event "daemon_setup" + -% s worker_tag name) >>= fun () -> - wait_for_first_event stream >>= fun first_event -> + wait_for_first_event ~name stream >>= fun first_event -> Shell_services.Blocks.hash cctxt ~block:`Genesis () >>=? fun genesis_hash -> (* statefulness *) @@ -68,7 +80,7 @@ let main | Some t -> t in state_maker genesis_hash first_event >>=? fun state -> - log_errors_and_continue @@ pre_loop cctxt state first_event >>= fun () -> + log_errors_and_continue ~name @@ pre_loop cctxt state first_event >>= fun () -> (* main loop *) let rec worker_loop () = @@ -82,23 +94,32 @@ let main | `Event (None | Some (Error _)) -> (* exit when the node is unavailable *) last_get_event := None ; - lwt_log_error "Connection to node lost, %s exiting." name >>= fun () -> + lwt_log_error Tag.DSL.(fun f -> + f "Connection to node lost, %s exiting." + -% t event "daemon_connection_lost" + -% s worker_tag name) >>= fun () -> exit 1 | `Event (Some (Ok event)) -> begin (* new event: cancel everything and execute callback *) last_get_event := None ; (* TODO: pretty-print events (requires passing a pp as argument) *) - log_errors_and_continue @@ event_k cctxt state event + log_errors_and_continue ~name @@ event_k cctxt state event end | `Timeout timesup -> (* main event: it's time *) - lwt_debug "Waking up for %s." name >>= fun () -> + lwt_debug Tag.DSL.(fun f -> + f "Waking up for %s." + -% t event "daemon_wakeup" + -% s worker_tag name) >>= fun () -> (* core functionality *) - log_errors_and_continue @@ timeout_k cctxt state timesup + log_errors_and_continue ~name @@ timeout_k cctxt state timesup end >>= fun () -> (* and restart *) worker_loop () in (* ignition *) - lwt_log_info "Starting %s daemon" name >>= fun () -> + lwt_log_info Tag.DSL.(fun f -> + f "Starting %s daemon" + -% t event "daemon_start" + -% s worker_tag name) >>= fun () -> worker_loop () diff --git a/src/proto_alpha/lib_delegate/client_baking_scheduling.mli b/src/proto_alpha/lib_delegate/client_baking_scheduling.mli index 24cffc0afcda335d28aa8908d1bcf240b24fc4ce..96408080f1e3d9dcab6fdc15ddc4127f60fc5ce0 100644 --- a/src/proto_alpha/lib_delegate/client_baking_scheduling.mli +++ b/src/proto_alpha/lib_delegate/client_baking_scheduling.mli @@ -11,6 +11,7 @@ val sleep_until: Time.t -> unit Lwt.t option val wait_for_first_event: + name:string -> 'event tzresult Lwt_stream.t -> 'event Lwt.t diff --git a/src/proto_alpha/lib_delegate/logging.ml b/src/proto_alpha/lib_delegate/logging.ml new file mode 100644 index 0000000000000000000000000000000000000000..7004b6ac324d3c9335b6ff1f7f9647584e1ebe5c --- /dev/null +++ b/src/proto_alpha/lib_delegate/logging.ml @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha +open Alpha_context + +let timestamp_tag = Tag.def ~doc:"Timestamp when event occurred" "timestamp" Time.pp_hum +let valid_ops = Tag.def ~doc:"Valid Operations" "valid_ops" Format.pp_print_int +let refused_ops = Tag.def ~doc:"Refused Operations" "refused_ops" Format.pp_print_int +let bake_priorty_tag = Tag.def ~doc:"Baking Priority" "bake_priority" Format.pp_print_int +let fitness_tag = Tag.def ~doc:"Fitness" "fitness" Fitness.pp +let current_slots_tag = Tag.def ~doc:"Number of baking slots that can be baked at this time" "current_slots" Format.pp_print_int +let future_slots_tag = Tag.def ~doc:"Number of baking slots in the foreseeable future but not yet bakeable" "future_slots" Format.pp_print_int + +let operations_tag = Tag.def ~doc:"Block Operations" "operations" + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf "+") + (fun ppf operations -> Format.fprintf ppf "%d" (List.length operations.Preapply_result.applied))) + +let bake_op_count_tag = Tag.def ~doc:"Bake Operation Count" "operation_count" Format.pp_print_int + +let endorsement_slot_tag = Tag.def ~doc:"Endorsement Slot" "endorsement_slot" Format.pp_print_int +let endorsement_slots_tag = Tag.def ~doc:"Endorsement Slots" "endorsement_slots" Format.(fun ppf v -> pp_print_int ppf (List.length v)) +let denounced_endorsements_slots_tag = Tag.def ~doc:"Endorsement Slots" "denounced_endorsement_slots" Format.(pp_print_list pp_print_int) +let denouncement_source_tag = Tag.def ~doc:"Denounce Source" "source" Format.pp_print_text + +let level_tag = Tag.def ~doc:"Level" "level" Raw_level.pp + +let worker_tag = Tag.def ~doc:"Worker in which event occurred" "worker" Format.pp_print_text + +let conflicting_endorsements_tag = Tag.def ~doc:"Two conflicting endorsements signed by the same key" "conflicting_endorsements" Format.( + fun ppf (a,b) -> fprintf ppf "%a / %a" Operation_hash.pp (Operation.hash a) Operation_hash.pp (Operation.hash b)) diff --git a/src/proto_alpha/lib_delegate/logging.mli b/src/proto_alpha/lib_delegate/logging.mli new file mode 100644 index 0000000000000000000000000000000000000000..c074b153ccad0f4cc071c29bd2f82e5e8fc13ce3 --- /dev/null +++ b/src/proto_alpha/lib_delegate/logging.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val timestamp_tag : Time.t Tag.def +val valid_ops : int Tag.def +val refused_ops : int Tag.def +val bake_priorty_tag : int Tag.def +val fitness_tag : Fitness.t Tag.def +val current_slots_tag : int Tag.def +val future_slots_tag : int Tag.def + +val operations_tag : error Preapply_result.t list Tag.def +val bake_op_count_tag : int Tag.def +val endorsement_slot_tag : int Tag.def +val endorsement_slots_tag : int list Tag.def +val denounced_endorsements_slots_tag : int list Tag.def +val denouncement_source_tag : string Tag.def +val level_tag : Proto_alpha.Alpha_context.Raw_level.t Tag.def +val worker_tag : string Tag.def + +open Proto_alpha.Alpha_context +val conflicting_endorsements_tag : (Kind.endorsement operation * Kind.endorsement operation) Tag.def