From 1577b71cb4979f7b21cb6ca1781aeb58dc75eeb3 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 11 Jan 2019 11:32:44 -0500 Subject: [PATCH 01/20] Stdlib-unix: Fix concurrency bug in `create_dir` --- src/lib_stdlib_unix/lwt_utils_unix.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/lib_stdlib_unix/lwt_utils_unix.ml b/src/lib_stdlib_unix/lwt_utils_unix.ml index 0fd6447cd442..4fc58b3f46a9 100644 --- a/src/lib_stdlib_unix/lwt_utils_unix.ml +++ b/src/lib_stdlib_unix/lwt_utils_unix.ml @@ -109,7 +109,14 @@ let rec create_dir ?(perm = 0o755) dir = Lwt_unix.file_exists dir >>= function | false -> create_dir (Filename.dirname dir) >>= fun () -> - Lwt_unix.mkdir dir perm + Lwt.catch + (fun () -> Lwt_unix.mkdir dir perm) + (function + | Unix.Unix_error (Unix.EEXIST, _, _) -> + (* This is the case where the directory has been created + by another Lwt.t, after the call to Lwt_unix.file_exists. *) + Lwt.return_unit + | e -> Lwt.fail e) | true -> Lwt_unix.stat dir >>= function | { st_kind = S_DIR ; _ } -> Lwt.return_unit -- GitLab From 19b925db81f584514226564745918fd7e01f0cbb Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 11 Jan 2019 11:44:08 -0500 Subject: [PATCH 02/20] Data-encoding: Add the `With_version` module --- src/lib_data_encoding/data_encoding.ml | 51 +++++ src/lib_data_encoding/data_encoding.mli | 26 +++ src/lib_data_encoding/test/test.ml | 1 + src/lib_data_encoding/test/versioned.ml | 248 ++++++++++++++++++++++++ 4 files changed, 326 insertions(+) create mode 100644 src/lib_data_encoding/test/versioned.ml diff --git a/src/lib_data_encoding/data_encoding.ml b/src/lib_data_encoding/data_encoding.ml index f212170bb550..9ea33f697e74 100644 --- a/src/lib_data_encoding/data_encoding.ml +++ b/src/lib_data_encoding/data_encoding.ml @@ -122,6 +122,57 @@ struct | Bytes bytes -> fun_bytes bytes | Both (bytes, value) -> fun_combine (fun_value value) (fun_bytes bytes) + module With_version = struct + + let version_case enc choose wrap name nth = + case + ~title:(Printf.sprintf "%s version %d" name nth) + Json_only + (obj1 (req (Printf.sprintf "%s.v%d" name nth) enc)) + choose wrap + + let make_encoding ~name l = + union ~tag_size: `Uint8 (List.mapi (fun nth f -> f name nth) l) + + type _ t = + | Version_0 : 'v0 encoding -> 'v0 t + | Version_S : { + previous: 'vn t ; + encoding: 'vnp1 encoding ; + upgrade: 'vn -> 'vnp1 + } -> 'vnp1 t + + let first_version e = Version_0 e + + let next_version encoding upgrade previous = + Version_S { encoding ; upgrade ; previous } + + let encoding : type a. name: _ -> a t -> a encoding = + fun ~name version -> + match version with + | Version_0 e -> + make_encoding ~name + [ version_case e (fun x -> Some x) (fun x -> x) ] + | Version_S { previous ; encoding ; upgrade } -> + let rec mk_nones : + type b. (b -> a) -> b t -> (string -> int -> a case) list = + fun upgr -> function + | Version_0 e -> + [ version_case e (fun _ -> None) (fun x -> upgr x) ] + | Version_S { previous ; encoding ; upgrade } -> + let others = + mk_nones (fun x -> upgr (upgrade x)) previous in + version_case encoding (fun _ -> None) (fun x -> upgr x) + :: others + in + let nones = mk_nones upgrade previous in + let cases = + version_case encoding (fun x -> Some x) (fun x -> x) :: nones + |> List.rev + in + make_encoding ~name cases + end + end include Encoding diff --git a/src/lib_data_encoding/data_encoding.mli b/src/lib_data_encoding/data_encoding.mli index 1b28409b349a..120b3b9450dc 100644 --- a/src/lib_data_encoding/data_encoding.mli +++ b/src/lib_data_encoding/data_encoding.mli @@ -531,6 +531,32 @@ module Encoding: sig fun_value:('a -> 'b) -> fun_bytes:(MBytes.t -> 'b) -> fun_combine:('b -> 'b -> 'b) -> 'a lazy_t -> 'b + (** Create a {!Data_encoding.t} value which records knowledge of + older versions of a given encoding as long as one can “upgrade” + from an older version to the next (if upgrade is impossible one + should consider that the encoding is completely different). + + See the module [Documented_example] in ["./test/versioned.ml"] + for a tutorial. + *) + module With_version: sig + + (** An encapsulation of consecutive encoding versions. *) + type _ t + + (** [first_version enc] records that [enc] is the first (known) + version of the object. *) + val first_version : 'a encoding -> 'a t + + (** [next_version enc upgrade prev] constructs a new version from + the previous version [prev] and an [upgrade] function. *) + val next_version : 'a encoding -> ('b -> 'a) -> 'b t -> 'a t + + (** Make an encoding from an encapsulation of versions; the + argument [~name] is used to prefix the version “tag” in the + encoding, it should not change from one version to the next. *) + val encoding : name: string -> 'a t -> 'a encoding + end end include module type of Encoding with type 'a t = 'a Encoding.t diff --git a/src/lib_data_encoding/test/test.ml b/src/lib_data_encoding/test/test.ml index c3dadd6d9e2b..5c1bf75dd2b1 100644 --- a/src/lib_data_encoding/test/test.ml +++ b/src/lib_data_encoding/test/test.ml @@ -31,4 +31,5 @@ let () = "read_failure", Read_failure.tests ; "write_failure", Write_failure.tests ; "randomized", Randomized.tests ; + "versioned", Versioned.tests ; ] diff --git a/src/lib_data_encoding/test/versioned.ml b/src/lib_data_encoding/test/versioned.ml new file mode 100644 index 000000000000..0dec21d40efd --- /dev/null +++ b/src/lib_data_encoding/test/versioned.ml @@ -0,0 +1,248 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** + Tests for the {!Data_encoding.With_version} module. +*) + +(** This module is a simple example of use of {!With_version}. *) +module Documented_example = struct + (** + Here we show how to {i “versionize”} a given random encoding (which + just happens to be very similar to {!Internal_event.Debug_event}). *) + + (** We are going to provide successive versions of a module + implementing {!INTENDED_SIGNATURE} (which is similar to a + simplified {!Internal_event.EVENT_DEFINITION}): *) + module type INTENDED_SIGNATURE = sig + type t + val encoding : t Data_encoding.t + val pp : Format.formatter -> t -> unit + end + + (** The name, once used with {!With_version.encoding}, appears in + the serialized values, it has to remain constant across versions: *) + let name = "versioned-documented-example" + + (** + The first version has a [(string * string) list] field. *) + module V0 = struct + type t = { message : string ; attachment : (string * string) list } + + (** This is the “naked” (i.e. non-versioned) encoding of version-0: *) + let encoding = + let open Data_encoding in + conv + (fun { message ; attachment } -> (message, attachment)) + (fun (message, attachment) -> { message ; attachment }) + (obj2 (req "message" string) (req "attach" (list (tup2 string string)))) + end + + (** The versioned implementation of {!INTENDED_SIGNATURE}: *) + module First_version : INTENDED_SIGNATURE with type t = V0.t = struct + include V0 + + (** The encoding with the version tagging: *) + let encoding = + Data_encoding.With_version.(encoding ~name (first_version V0.encoding)) + + let pp ppf { message ; attachment } = + let open Format in + fprintf ppf "%s:@ %s@ [" name message ; + pp_open_box ppf 2 ; + pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") + (fun fmt (k, v) -> fprintf fmt "%s: %S" k v) + ppf attachment ; + pp_close_box ppf () ; + fprintf ppf "]" ; + () + end + + (** In a later version we want the attachment to be any piece of + Json and not just a key-value list: *) + module V1 = struct + + (** Version 1 is very similar to {!Internal_event.Debug_event}: *) + type t = { message : string ; attachment : Data_encoding.Json.t } + + let make ?(attach = `Null) message () = { message ; attachment = attach } + + (** Note the “upgrade” function which can make a {!V1.t} from a {!V0.t}: *) + let of_v0 { V0.message ; attachment } = + { message ; + attachment = `O (List.map (fun (k, v) -> (k, `String v)) attachment) } + + (** Again we build first a version-free encoding: *) + let encoding = + let open Data_encoding in + conv + (fun { message ; attachment } -> (message, attachment)) + (fun (message, attachment) -> { message ; attachment }) + (obj2 (req "message" string) (req "attachment" json)) + end + + (** The second version exports {!V1.t} while being able to parse + (and upgrade from) {!First_version.t} values. *) + module Second_version : INTENDED_SIGNATURE with type t = V1.t = struct + include V1 + + (** Here is the interesting use of {!Data_encoding.With_version}: the + encoding uses both {!V0.encoding} and {!V1.encoding} and + provides {!V1.of_v0} as an upgrade function. *) + let encoding = + Data_encoding.With_version.( + encoding ~name ( + first_version V0.encoding + |> next_version V1.encoding V1.of_v0)) + + let pp ppf { message ; attachment } = + let open Format in + fprintf ppf "%s:@ %s@ %a" name message Data_encoding.Json.pp attachment + end + + + (** This test “serializes” successively using + {!First_version.encoding} and {!Second_version.encoding}, and then + shows that the former's output can be parsed with the later. *) + let actual_test () = + let v0_thing : First_version.t = + { V0. message = "The v0 message" ; + attachment = [ "k1", "v1" ; "k2", "v2" ] } in + let json_v0 = + Data_encoding.Json.construct First_version.encoding v0_thing in + let expected_json_v0 = + `O [name ^ ".v0", (* -> here we see how the [~name] is used. *) + `O [ + "message", `String v0_thing.V0.message ; + "attach", `A (List.map + (fun (k, v) -> `A [ `String k ; `String v ]) + v0_thing.V0.attachment) ] ] in + begin if json_v0 <> expected_json_v0 then + Alcotest.failf "Json-v0: %a@ Vs@ %a" + Data_encoding.Json.pp json_v0 Data_encoding.Json.pp expected_json_v0 + end; + (* Up to here we only used the {!First_version} module. Now the + same process with {!Second_version}: *) + let v1_thing : Second_version.t = + {V1. message = "The v1 message" ; + attachment = `O [ "k1" , `String "v1" ; "kn" , `Float 42. ] } in + let json_v1 = + Data_encoding.Json.construct Second_version.encoding v1_thing in + let expected_json_v1 = + `O [name ^ ".v1", + `O [ + "message", `String v1_thing.V1.message ; + "attachment", v1_thing.V1.attachment ] ] in + begin if json_v1 <> expected_json_v1 then + Alcotest.failf "Json-v1: %a@ Vs@ %a" + Data_encoding.Json.pp json_v1 Data_encoding.Json.pp expected_json_v1 + end; + (* Now the {b interesting part}, we decode (“destruct”) the JSON from + {!First_version} with {!Second_version}: *) + let v0_decoded_later : Second_version.t = + Data_encoding.Json.destruct Second_version.encoding json_v0 in + (* And we check that going through JSON is equivalent to just + calling the upgrade function directly on the {!First_version.t} + value: *) + let expected_v1 = V1.of_v0 v0_thing in + begin if v0_decoded_later <> expected_v1 then + Alcotest.failf "Parsing v0 with v1: %a@ Vs@ %a" + Second_version.pp v0_decoded_later Second_version.pp expected_v1 + end; + () + +end + +(** This test builds a few successive versions of encodings and tries + out parsing/printing with successive encapsulated + versioned-encodings. + + Check out ["_build/_tests/versioned.001.output"] to see how they look. +*) +let test_n_encapsulated_versions () = + let open Data_encoding in + let name = "test0" in + let version_0 = + (obj2 (req "left" string) (req "right" (string))) + in + let versioned_0 = + With_version.(encoding ~name @@ first_version version_0) in + let value_0 = "v0", "k0" in + let json_0 = Json.construct versioned_0 value_0 in + Helpers.no_exception begin fun () -> + let result = Json.destruct versioned_0 json_0 in + if result <> value_0 then + Alcotest.failf "value-0" + end; + let module Ex = struct + type v0 = string * string + type t = + | Hide: 'a Data_encoding.t * 'a With_version.t * 'a * (v0 -> 'a) -> t + end in + let make_next (Ex.Hide (enc, versioned, example, from_v0)) index = + let new_tag = Printf.sprintf "left-%d" index in + let version_n = obj2 (req new_tag string) (req "right" enc) in + let upgrade vn = "some-random-extra-string", vn in + let versioned_n = With_version.(next_version version_n upgrade versioned) in + let encoding = With_version.(encoding ~name versioned_n) in + let example_n = "val4" ^ new_tag, example in + let json_example_n = Json.construct encoding example_n in + Helpers.no_exception begin fun () -> + let result = Json.destruct encoding json_example_n in + if result <> example_n then + Alcotest.failf "value-%d" index + end; + let json_example_p = + Json.construct With_version.(encoding ~name versioned) example in + Helpers.no_exception begin fun () -> + let result = Json.destruct encoding json_example_p in + if result <> upgrade example then + Alcotest.failf "value-%d-previous-encoding" index + end; + let next_upgrade = fun x -> upgrade (from_v0 x) in + Helpers.no_exception begin fun () -> + let result = Json.destruct encoding json_0 in + if result <> next_upgrade value_0 then + Alcotest.failf "value-%d-from-v0-encoding" index + end; + Format.eprintf "json_example_%d:@ %a\n%!" index Json.pp json_example_n; + Format.eprintf "json_example_%d-from-v0:@ %a\n%!" index Json.pp + (Json.construct encoding (next_upgrade value_0)); + Ex.Hide (version_n, versioned_n, example_n, next_upgrade) + in + let Ex.Hide _ = + ListLabels.fold_left + (List.init 10 ((+) 1)) + ~init:(Ex.Hide (version_0, With_version.(first_version version_0), + value_0, fun x -> x)) + ~f:make_next + in + () + + +let tests = [ + "example-test", `Quick, Documented_example.actual_test; + "test-encapsulated-versions", `Quick, test_n_encapsulated_versions; +] -- GitLab From db0bbfa5f8ea659f27aa18980ef116a164253f2c Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 11 Jan 2019 11:46:22 -0500 Subject: [PATCH 03/20] Clic: Add `Scriptable` (for `--for-script`) --- src/lib_clic/dune | 1 + src/lib_clic/scriptable.ml | 56 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+) create mode 100644 src/lib_clic/scriptable.ml diff --git a/src/lib_clic/dune b/src/lib_clic/dune index b574473f99aa..191e491afebd 100644 --- a/src/lib_clic/dune +++ b/src/lib_clic/dune @@ -6,6 +6,7 @@ -open Tezos_stdlib -open Tezos_error_monad)) (libraries tezos-stdlib + lwt.unix tezos-error-monad)) (alias diff --git a/src/lib_clic/scriptable.ml b/src/lib_clic/scriptable.ml new file mode 100644 index 000000000000..ac08e08f4aec --- /dev/null +++ b/src/lib_clic/scriptable.ml @@ -0,0 +1,56 @@ +open Error_monad + +type output_format = + | Rows of { separator : string ; escape : [ `No | `OCaml ] } + +let rows separator escape = Rows { separator ; escape } + +let tsv = rows "\t" `No + +let csv = rows "," `OCaml + +let clic_arg () = + let open Clic in + arg ~doc:"Make the output script-friendly" ~long:"for-script" + ~placeholder:"FORMAT" + (parameter (fun _ spec -> + match String.lowercase_ascii spec with + | "tsv" -> return tsv + | "csv" -> return csv + | other -> + failwith + "Cannot recognize format %S, please try 'TSV' or 'CSV'" other)) + + +let fprintf_lwt chan fmt = + Format.kasprintf + (fun s -> + protect (fun () -> Lwt_io.write chan s >>= fun () -> return_unit)) + fmt + +let output ?(channel = Lwt_io.stdout) how_option ~for_human ~for_script = + match how_option with + | None -> for_human () + | Some (Rows { separator ; escape }) -> + let open Format in + iter_s + (fun row -> + fprintf_lwt channel "%a@." + (pp_print_list + ~pp_sep:(fun fmt () -> pp_print_string fmt separator) + (fun fmt cell -> + match escape with + | `OCaml -> fprintf fmt "%S" cell + | `No -> pp_print_string fmt cell)) + row) + (for_script ()) + >>=? fun () -> + protect (fun () -> Lwt_io.flush channel >>= fun () -> return_unit) + +let output_for_human how_option for_human = + output how_option ~for_human ~for_script:(fun () -> []) + +let output_row ?channel how_option ~for_human ~for_script = + output ?channel how_option ~for_human + ~for_script:(fun () -> [for_script ()]) + -- GitLab From 30816ed09353feb6234d9c3132bb4912e7399b2f Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 11 Jan 2019 11:51:25 -0500 Subject: [PATCH 04/20] Build,CI: Add the `tezos-event-logging` library --- .gitlab-ci.yml | 111 +-- src/lib_base/dune | 2 + src/lib_base/tezos-base.opam | 1 + src/lib_base/tzPervasives.ml | 2 + src/lib_base/tzPervasives.mli | 2 + src/lib_event_logging/dune | 16 + src/lib_event_logging/internal_event.ml | 696 ++++++++++++++++++ src/lib_event_logging/internal_event.mli | 333 +++++++++ .../tezos-event-logging.opam | 22 + 9 files changed, 1134 insertions(+), 51 deletions(-) create mode 100644 src/lib_event_logging/dune create mode 100644 src/lib_event_logging/internal_event.ml create mode 100644 src/lib_event_logging/internal_event.mli create mode 100644 src/lib_event_logging/tezos-event-logging.opam diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 92101c24a2e2..9d70dfd9d1fd 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -311,136 +311,136 @@ opam:13:tezos-crypto: variables: package: tezos-crypto -opam:14:tezos-micheline: +opam:14:tezos-event-logging: + <<: *opam_definition + variables: + package: tezos-event-logging + +opam:15:tezos-micheline: <<: *opam_definition variables: package: tezos-micheline -opam:15:lmdb: +opam:16:lmdb: <<: *opam_definition variables: package: lmdb -opam:16:pbkdf: +opam:17:pbkdf: <<: *opam_definition variables: package: pbkdf -opam:17:ocplib-resto-cohttp: +opam:18:ocplib-resto-cohttp: <<: *opam_definition variables: package: ocplib-resto-cohttp -opam:18:tezos-base: +opam:19:tezos-base: <<: *opam_definition variables: package: tezos-base -opam:19:irmin-lmdb: +opam:20:irmin-lmdb: <<: *opam_definition variables: package: irmin-lmdb -opam:20:bip39: +opam:21:bip39: <<: *opam_definition variables: package: bip39 -opam:21:tezos-rpc-http: +opam:22:tezos-rpc-http: <<: *opam_definition variables: package: tezos-rpc-http -opam:22:tezos-shell-services: +opam:23:tezos-shell-services: <<: *opam_definition variables: package: tezos-shell-services -opam:23:tezos-stdlib-unix: +opam:24:tezos-stdlib-unix: <<: *opam_definition variables: package: tezos-stdlib-unix -opam:24:tezos-storage: +opam:25:tezos-storage: <<: *opam_definition variables: package: tezos-storage -opam:25:tezos-protocol-environment-sigs: +opam:26:tezos-protocol-environment-sigs: <<: *opam_definition variables: package: tezos-protocol-environment-sigs -opam:26:ledgerwallet: +opam:27:ledgerwallet: <<: *opam_definition variables: package: ledgerwallet -opam:27:tezos-client-base: +opam:28:tezos-client-base: <<: *opam_definition variables: package: tezos-client-base -opam:28:tezos-protocol-compiler: +opam:29:tezos-protocol-compiler: <<: *opam_definition variables: package: tezos-protocol-compiler -opam:29:ledgerwallet-tezos: +opam:30:ledgerwallet-tezos: <<: *opam_definition variables: package: ledgerwallet-tezos -opam:30:tezos-signer-services: +opam:31:tezos-signer-services: <<: *opam_definition variables: package: tezos-signer-services -opam:31:tezos-protocol-environment: +opam:32:tezos-protocol-environment: <<: *opam_definition variables: package: tezos-protocol-environment -opam:32:tezos-protocol-alpha: +opam:33:tezos-protocol-alpha: <<: *opam_definition variables: package: tezos-protocol-alpha -opam:33:tezos-signer-backends: +opam:34:tezos-signer-backends: <<: *opam_definition variables: package: tezos-signer-backends -opam:34:tezos-protocol-environment-shell: +opam:35:tezos-protocol-environment-shell: <<: *opam_definition variables: package: tezos-protocol-environment-shell -opam:35:tezos-client-alpha: +opam:36:tezos-client-alpha: <<: *opam_definition variables: package: tezos-client-alpha -opam:36:tezos-client-commands: +opam:37:tezos-client-commands: <<: *opam_definition variables: package: tezos-client-commands -opam:37:tezos-protocol-updater: +opam:38:tezos-protocol-updater: <<: *opam_definition variables: package: tezos-protocol-updater -opam:38:tezos-baking-alpha: +opam:39:tezos-baking-alpha: <<: *opam_definition variables: package: tezos-baking-alpha -opam:39:tezos-protocol-demo: - <<: *opam_definition - variables: - package: tezos-protocol-demo - opam:40:tezos-protocol-genesis: <<: *opam_definition variables: @@ -476,76 +476,76 @@ opam:46:tezos-client-base-unix: variables: package: tezos-client-base-unix -opam:47:tezos-client-demo: - <<: *opam_definition - variables: - package: tezos-client-demo - -opam:48:tezos-client-genesis: +opam:47:tezos-client-genesis: <<: *opam_definition variables: package: tezos-client-genesis -opam:49:ocplib-ezresto: +opam:48:ocplib-ezresto: <<: *opam_definition variables: package: ocplib-ezresto -opam:50:tezos-shell: +opam:49:tezos-embedded-protocol-alpha: <<: *opam_definition variables: package: tezos-shell -opam:51:tezos-embedded-protocol-alpha: +opam:50:tezos-embedded-protocol-demo: <<: *opam_definition variables: - package: tezos-embedded-protocol-alpha + package: tezos-embedded-protocol-demo -opam:52:tezos-embedded-protocol-demo: +opam:51:tezos-embedded-protocol-genesis: <<: *opam_definition variables: - package: tezos-embedded-protocol-demo + package: tezos-embedded-protocol-genesis -opam:53:tezos-embedded-protocol-genesis: +opam:52:tezos-shell: <<: *opam_definition variables: - package: tezos-embedded-protocol-genesis + package: tezos-shell -opam:54:tezos-endorser-alpha-commands: +opam:53:tezos-endorser-alpha-commands: <<: *opam_definition variables: package: tezos-endorser-alpha-commands -opam:55:tezos-client: +opam:54:tezos-client: <<: *opam_definition variables: package: tezos-client -opam:56:ocplib-ezresto-directory: +opam:55:ocplib-ezresto-directory: <<: *opam_definition variables: package: ocplib-ezresto-directory -opam:57:tezos-accuser-alpha: +opam:56:tezos-accuser-alpha: <<: *opam_definition variables: package: tezos-accuser-alpha -opam:58:tezos-endorser-alpha: +opam:57:tezos-endorser-alpha: <<: *opam_definition variables: package: tezos-endorser-alpha -opam:59:tezos-accuser-alpha-commands: +opam:58:tezos-accuser-alpha-commands: <<: *opam_definition variables: package: tezos-accuser-alpha-commands -opam:60:tezos-baker-alpha: +opam:59:tezos-baker-alpha: <<: *opam_definition variables: package: tezos-baker-alpha +opam:60:tezos-protocol-demo: + <<: *opam_definition + variables: + package: tezos-protocol-demo + opam:61:tezos-signer: <<: *opam_definition variables: @@ -561,6 +561,15 @@ opam:63:ocplib-json-typed-browser: variables: package: ocplib-json-typed-browser +opam:64:tezos-baker-alpha-commands: + <<: *opam_definition + variables: + package: tezos-baker-alpha-commands + +opam:63:tezos-client-demo: + <<: *opam_definition + variables: + package: tezos-client-demo ##END_OPAM## diff --git a/src/lib_base/dune b/src/lib_base/dune index 2d3b672a35fb..bd319ad2e44d 100644 --- a/src/lib_base/dune +++ b/src/lib_base/dune @@ -10,11 +10,13 @@ -open Tezos_rpc -open Tezos_clic -open Tezos_micheline + -open Tezos_event_logging -safe-string)) (libraries tezos-stdlib tezos-crypto tezos-data-encoding tezos-error-monad + tezos-event-logging tezos-rpc tezos-clic tezos-micheline diff --git a/src/lib_base/tezos-base.opam b/src/lib_base/tezos-base.opam index 6b26c9a8c51d..8b2cd686004e 100644 --- a/src/lib_base/tezos-base.opam +++ b/src/lib_base/tezos-base.opam @@ -12,6 +12,7 @@ depends: [ "tezos-crypto" "tezos-data-encoding" "tezos-error-monad" + "tezos-event-logging" "tezos-micheline" "tezos-rpc" "calendar" diff --git a/src/lib_base/tzPervasives.ml b/src/lib_base/tzPervasives.ml index 553229797241..de459c1b78e3 100644 --- a/src/lib_base/tzPervasives.ml +++ b/src/lib_base/tzPervasives.ml @@ -68,3 +68,5 @@ module Lwt_exit = Lwt_exit include Utils.Infix include Error_monad + +module Internal_event = Internal_event \ No newline at end of file diff --git a/src/lib_base/tzPervasives.mli b/src/lib_base/tzPervasives.mli index 1dade5bd92e6..fc9e36a8a62c 100644 --- a/src/lib_base/tzPervasives.mli +++ b/src/lib_base/tzPervasives.mli @@ -65,3 +65,5 @@ module Lwt_exit = Lwt_exit include (module type of (struct include Utils.Infix end)) include (module type of (struct include Error_monad end)) + +module Internal_event = Internal_event diff --git a/src/lib_event_logging/dune b/src/lib_event_logging/dune new file mode 100644 index 000000000000..7a6dde4fb167 --- /dev/null +++ b/src/lib_event_logging/dune @@ -0,0 +1,16 @@ +(library + (name tezos_event_logging) + (public_name tezos-event-logging) + (flags (:standard -open Tezos_stdlib + -open Tezos_data_encoding + -open Tezos_error_monad + -safe-string)) + (libraries tezos-stdlib + tezos-data-encoding + tezos-error-monad + lwt)) + +(alias + (name runtest_indent) + (deps (glob_files *.ml{,i})) + (action (run bash %{libexec:tezos-stdlib:test-ocp-indent.sh} %{deps}))) diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml new file mode 100644 index 000000000000..062823f04364 --- /dev/null +++ b/src/lib_event_logging/internal_event.ml @@ -0,0 +1,696 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* open TzPervasives → circular dependencies because of legacy-logging usage *) +open Tezos_error_monad +open Error_monad +module Data_encoding = Tezos_data_encoding.Data_encoding +module List = struct + include List + include Tezos_stdlib.TzList +end +module String = struct + include String + include Tezos_stdlib.TzString +end + + +let valid_char c = + match c with + | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' + | '.' | '@' | '-' | '_' | '+' | '=' | '~' -> true + | _ -> false + +let check_name_exn name or_fail = + String.iter + (fun c -> if valid_char c then () else or_fail name c) + name ; + () + + +type level = Lwt_log_core.level = + Debug | Info | Notice | Warning | Error | Fatal +module Level = struct + type t = level + let default = Info + let to_lwt_log t = t + let to_string = Lwt_log_core.string_of_level + let of_string = Lwt_log_core.level_of_string + let encoding = + let open Data_encoding in + string_enum + (List.map + (fun l -> to_string l, l) + [ Debug ; Info ; Notice ; Warning ; Error ; Fatal ]) +end + +module Section: sig + type t = private string + val make : string -> t + val make_sanitized : string -> t + val to_lwt_log : t -> Lwt_log_core.section + val encoding : t Data_encoding.t + val to_string : t -> string +end = struct + type t = string + let make s = + check_name_exn s (fun name char -> + Printf.ksprintf Pervasives.invalid_arg + "Internal_event.Section: invalid name %S (contains %c)" name char) ; + s + + let make_sanitized s = + String.map (fun c -> if valid_char c then c else '_') s |> make + + let to_lwt_log s = Lwt_log_core.Section.make s + + let to_string t = t + + let encoding = + let open Data_encoding in + string +end + +module type EVENT_DEFINITION = sig + type t + + val name : string + + val doc : string + + val pp : Format.formatter -> t -> unit + + val encoding : t Data_encoding.t + + val level : t -> level +end + +module Event_defaults = struct + let level _ = Level.default +end + +module type EVENT = sig + include EVENT_DEFINITION + + val emit : ?section : Section.t -> (unit -> t) -> unit tzresult Lwt.t +end + +type 'a event_definition = (module EVENT_DEFINITION with type t = 'a) + +module type SINK = sig + + type t + + val uri_scheme : string + + val configure : Uri.t -> t tzresult Lwt.t + + val handle : + t -> 'a event_definition -> + ?section : Section.t -> (unit -> 'a) -> unit tzresult Lwt.t + + val close : t -> unit tzresult Lwt.t +end + +type 'a sink_definition = (module SINK with type t = 'a) + +module All_sinks = struct + + + type registered = + | Registered : + { scheme : string ; definition : 'a sink_definition } -> registered + + type active = + | Active : { scheme : string ; configuration : Uri.t ; + sink : 'a ; definition : 'a sink_definition } -> active + + let registered : registered list ref = ref [] + + let active : active list ref = ref [] + + let find_registered_exn scheme_to_find = + List.find + (function + | Registered { scheme ; _ } -> + String.equal scheme scheme_to_find) + !registered + + let register (type a) m = + let module S = (val m : SINK with type t = a) in + match find_registered_exn S.uri_scheme with + | exception _ -> + registered := + Registered { scheme = S.uri_scheme ; definition = m } :: !registered + | _ -> + (* This should be considered a programming error: *) + Printf.ksprintf Pervasives.invalid_arg + "Internal_event: registering duplicate URI scheme: %S" S.uri_scheme + + type activation_error_reason = + | Missing_uri_scheme of string + | Uri_scheme_not_registered of string + type error += Activation_error of activation_error_reason + + let () = + let description = + "Activation of an Internal Event SINK with an URI failed" in + let title = "Internal Event Sink: Wrong Activation URI" in + register_error_kind `Permanent ~id:"internal-event-activation-error" ~title + ~description + ~pp:(fun ppf -> function + | Missing_uri_scheme uri -> + Format.fprintf ppf "%s: Missing URI scheme %S" title uri + | Uri_scheme_not_registered uri -> + Format.fprintf ppf "%s: URI scheme not registered %S" title uri) + Data_encoding.( + union [ + case ~title:"missing-uri-scheme" + (Tag 0) + (obj1 (req "missing-uri-scheme" (obj1 (req "uri" string)))) + (function Missing_uri_scheme uri -> Some uri | _ -> None) + (fun uri -> Missing_uri_scheme uri) ; + case ~title:"non-registered-uri-scheme" + (Tag 2) + (obj1 (req "non-registered-uri-scheme" (obj1 (req "uri" string)))) + (function Uri_scheme_not_registered uri -> Some uri | _ -> None) + (fun uri -> Uri_scheme_not_registered uri) ; + ]) + (function + | Activation_error reason -> Some reason | _ -> None) + (fun reason -> Activation_error reason) + + let activate uri = + begin match Uri.scheme uri with + | None -> fail (Activation_error (Missing_uri_scheme (Uri.to_string uri))) + | Some scheme_to_activate -> + let activate (type a) scheme definition = + let module S = (val definition : SINK with type t = a) in + S.configure uri >>=? fun sink -> + return (Active { scheme ; configuration = uri ; definition ; sink }) + in + begin match find_registered_exn scheme_to_activate with + | Registered { scheme ; definition } -> + activate scheme definition + | exception _ -> + fail (Activation_error + (Uri_scheme_not_registered (Uri.to_string uri))) + end + >>=? fun act -> + active := act :: !active ; + return_unit + end + + let close () = + let close_one (type a) sink definition = + let module S = (val definition : SINK with type t = a) in + S.close sink in + iter_s + (fun (Active { sink ; definition ; _ }) -> close_one sink definition) + !active + + + let handle def section v = + let handle (type a) sink definition = + let module S = (val definition : SINK with type t = a) in + S.handle ?section sink def v in + List.fold_left + (fun prev -> function Active { sink ; definition ; _ } -> + prev >>=? fun () -> + handle sink definition) + return_unit + !active + + let pp_state fmt () = + let open Format in + let pp_list_of_sinks name list pp = + pp_open_box fmt 2 ; + pp_print_if_newline fmt () ; + pp_print_string fmt "* " ; + fprintf fmt "%s: [" name; + pp_print_cut fmt () ; + pp_print_list + ~pp_sep:(fun fmt () -> pp_print_string fmt "," ; pp_print_space fmt ()) + pp + fmt + list ; + pp_close_box fmt () ; + pp_print_cut fmt () ; + pp_print_string fmt "]" ; + in + pp_open_box fmt 0 ; + pp_list_of_sinks "Registered sinks" !registered + (fun fmt (Registered { scheme ; _ }) -> + fprintf fmt "\"%s://..\"" scheme) ; + pp_print_break fmt 2 0 ; + pp_list_of_sinks "Active sinks" !active + (fun fmt (Active { configuration ; _ }) -> + fprintf fmt "\"%a\"" Uri.pp_hum configuration) ; + pp_print_cut fmt () ; + pp_close_box fmt () ; + () +end + +module Generic = struct + + type definition = + | Definition: (string * 'a event_definition) -> definition + + type event = + | Event: (string * 'a event_definition * 'a) -> event + + type with_name = < doc : string; name : string > + + let json_schema (Definition (_, d)) + : < schema : Json_schema.schema ; with_name > = + let aux (type a) (ev : a event_definition) = + let module E = (val ev : EVENT_DEFINITION with type t = a) in + object + method name = E.name + method doc = E.doc + method schema = Data_encoding.Json.schema E.encoding + end in + aux d + + let explode_event (Event (_, def, ev)) = + let aux (type a) def ev = + let module M = (val def : EVENT_DEFINITION with type t = a) in + object + method name = M.name + method doc = M.doc + method pp fmt () = M.pp fmt ev + method json = Data_encoding.Json.construct M.encoding ev + end in + aux def ev +end + +module All_definitions = struct + + open Generic + + let all : definition list ref = ref [] + + let fail_registration fmt = + Format.kasprintf (fun s -> + (* This should be considered a programming error: *) + Pervasives.invalid_arg ("Internal_event registration error: " ^ s)) + fmt + + let add (type a) ev = + let module E = (val ev : EVENT_DEFINITION with type t = a) in + match List.find (function Definition (n, _) -> E.name = n) !all with + | _ -> + fail_registration "duplicate Event name: %S" E.name + | exception _ -> + check_name_exn E.name + (fail_registration "invalid event name: %S contains '%c'") ; + all := Definition (E.name, ev) :: !all + + let get () = !all + + let find match_name = + match List.find (function Definition (n, _) -> match_name n) !all with + | s -> Some s + | exception _ -> None + +end + +module Make (E : EVENT_DEFINITION) : EVENT with type t = E.t = struct + include E + + let emit ?section x = + (* In order to evaluate the event at most once, we wrap it in a + `Lazy.t`: *) + let x = lazy (x ()) in + All_sinks.handle (module E) section (fun () -> Lazy.force x) + + let () = All_definitions.add (module E) +end + +module Legacy_logging = struct + + let sections = ref [] + + module type LOG = sig + val debug: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a + val warn: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a + val fatal_error: ('a, Format.formatter, unit, unit) format4 -> 'a + + val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_fatal_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + end + + open Tezos_stdlib + 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 + module type SEMLOG = sig + module Tag = Tag + val debug: ('a, unit) log + val log_info: ('a, unit) log + val log_notice: ('a, unit) log + val warn: ('a, unit) log + val log_error: ('a, unit) log + val fatal_error: ('a, unit) log + val lwt_debug: ('a, unit Lwt.t) log + val lwt_log_info: ('a, unit Lwt.t) log + val lwt_log_notice: ('a, unit Lwt.t) log + val lwt_warn: ('a, unit Lwt.t) log + val lwt_log_error: ('a, unit Lwt.t) log + val lwt_fatal_error: ('a, unit Lwt.t) log + val event : string Tag.def + val exn : exn Tag.def + end + + module Make_event (P : sig val name : string end) = struct + + module Definition = struct + let name = "legacy-logging-event." ^ P.name + + type t = { + message : string ; + section : string ; + level : level ; + tags : Tag.set ; + } + + let make ?(tags = Tag.empty) level message = + { message ; section = P.name ; level ; tags } + + + let v0_encoding = + let open Data_encoding in + conv + (fun { message ; section ; level ; tags } -> + (message, section, level, tags)) + (fun (message, section, level, tags) -> + { message ; section ; level ; tags }) + (obj4 + (req "message" string) + (req "section" string) + (req "level" Level.encoding) + (dft "tags" + (conv + (fun tags -> Format.asprintf "%a" Tag.pp_set tags) + (fun _ -> Tag.empty) + string) + Tag.empty) + ) + + let encoding = + Data_encoding.With_version.(encoding ~name (first_version v0_encoding)) + + let pp ppf { message ; _ } = + let open Format in + fprintf ppf "%s" message + + let doc = "Generic event legacy / string-based information logging." + + let level { level ; _ } = level + end + + let section = Section.make P.name + + let () = sections := P.name :: !sections + + module Event = Make (Definition) + + let emit_async level fmt ?tags = + Format.kasprintf + (fun message -> + Lwt.ignore_result + (Event.emit ~section (fun () -> Definition.make ?tags level message))) + fmt + let emit_lwt level fmt ?tags = + Format.kasprintf + (fun message -> + Event.emit ~section (fun () -> Definition.make ?tags level message) + >>= function + | Ok () -> Lwt.return_unit + | Error el -> Format.kasprintf Lwt.fail_with "%a" pp_print_error el) + fmt + end + + module Make (P : sig val name : string end) = struct + include Make_event(P) + let emit_async = emit_async ?tags:None + let debug f = emit_async Debug f + let log_info f = emit_async Info f + let log_notice f = emit_async Notice f + let warn f = emit_async Warning f + let log_error f = emit_async Error f + let fatal_error f = emit_async Fatal f + let emit_lwt = emit_lwt ?tags:None + let lwt_debug f = emit_lwt Debug f + let lwt_log_info f = emit_lwt Info f + let lwt_log_notice f = emit_lwt Notice f + let lwt_warn f = emit_lwt Warning f + let lwt_log_error f = emit_lwt Error f + let lwt_fatal_error f = emit_lwt Fatal f + end + module Make_semantic (P : sig val name : string end) = struct + include Make_event(P) + let debug (f: ('a, unit) msgf) = f (emit_async Debug) ?tags:None + let log_info f = f (emit_async Info) ?tags:None + let log_notice f = f (emit_async Notice) ?tags:None + let warn f = f (emit_async Warning) ?tags:None + let log_error f = f (emit_async Error) ?tags:None + let fatal_error f = f (emit_async Fatal) ?tags:None + let lwt_debug f = f (emit_lwt Debug) ?tags:None + let lwt_log_info f = f (emit_lwt Info) ?tags:None + let lwt_log_notice f = f (emit_lwt Notice) ?tags:None + let lwt_warn f = f (emit_lwt Warning) ?tags:None + let lwt_log_error f = f (emit_lwt Error) ?tags:None + let lwt_fatal_error f = f (emit_lwt Fatal) ?tags:None + module Tag = Tag + let event = + Tag.def ~doc:"String identifier for the class of event being logged" + "event" Format.pp_print_text + let exn = + Tag.def ~doc:"Exception which was detected" + "exception" (fun f e -> Format.pp_print_text f (Printexc.to_string e)) + end +end + +module Error_event = struct + type t = { + message : string option ; + severity : [ `Fatal | `Recoverable ] ; + trace : Error_monad.error list ; + } + + let make ?message ?(severity = `Recoverable) trace () = + { message ; trace; severity } + + module Definition = struct + let name = "error-event" + + type nonrec t = t + + let encoding = + let open Data_encoding in + let v0_encoding = + conv + (fun { message ; trace ; severity } -> (message, severity, trace)) + (fun (message, severity, trace) -> { message ; severity ; trace }) + (obj3 + (opt "message" string) + (req "severity" + (string_enum ["fatal", `Fatal; "recoverable", `Recoverable])) + (req "trace" (list Error_monad.error_encoding))) + in + With_version.(encoding ~name (first_version v0_encoding)) + + let pp f x = + Format.fprintf f "%s:@ %s" name + (match x.message with Some x -> x | None -> "") + + let doc = "Generic event for any kind of error." + + let level { severity ; _ } = + match severity with + | `Fatal -> Fatal + | `Recoverable -> Error + end + + include (Make (Definition) : EVENT with type t := t) + + let to_lwt ?section ?message ?severity f = + f () + >>= function + | Ok () -> Lwt.return_unit + | Error el -> + emit ?section (fun () -> make ?message ?severity el ()) + >>= function + | Ok () -> Lwt.return_unit + | Error el -> + Format.kasprintf (Lwt_log.error) + "Error while emitting error logging event !! %a" + pp_print_error el +end + +module Debug_event = struct + type t = { message : string ; attachment : Data_encoding.Json.t } + + let make ?(attach = `Null) message () = { message ; attachment = attach } + + let v0_encoding = + let open Data_encoding in + conv + (fun { message ; attachment } -> (message, attachment)) + (fun (message, attachment) -> { message ; attachment }) + (obj2 (req "message" string) (req "attachment" json)) + + module Definition = struct + let name = "debug-event" + + type nonrec t = t + + let encoding = + Data_encoding.With_version.(encoding ~name (first_version v0_encoding)) + + let pp ppf { message ; attachment } = + let open Format in + fprintf ppf "%s:@ %s@ %a" name message Data_encoding.Json.pp attachment + + let doc = "Generic event for semi-structured debug information." + + include Event_defaults + end + + include (Make (Definition) : EVENT with type t := t) +end + +module Lwt_worker_event = struct + type t = { name : string ; event : [ `Started | `Ended | `Failed of string ] } + + let v0_encoding = + let open Data_encoding in + conv + (fun { name ; event } -> (name, event)) + (fun (name, event) -> { name ; event }) + (obj2 + (req "name" string) + (req "event" + (union [ + case ~title:"started" (Tag 0) + (obj1 (req "kind" (constant "started"))) + (function `Started -> Some () | _ -> None) + (fun () -> `Started) ; + case ~title:"ended" (Tag 1) + (obj1 (req "kind" (constant "ended"))) + (function `Ended -> Some () | _ -> None) + (fun () -> `Ended) ; + case ~title:"failed" (Tag 2) + (obj2 + (req "kind" (constant "failed")) + (req "exception" string)) + (function `Failed s -> Some ((), s) | _ -> None) + (fun ((), s) -> `Failed s) ; + ]) + )) + + module Definition = struct + let name = "lwt-worker-event" + + type nonrec t = t + + let encoding = + Data_encoding.With_version.(encoding ~name (first_version v0_encoding)) + + let pp ppf { name ; event } = + let open Format in + fprintf ppf "Worker %s:@ %a" name + (fun fmt -> function + | `Failed msg -> fprintf ppf "Failed with %s" msg + | `Ended -> fprintf fmt "Ended" + | `Started -> fprintf fmt "Started") + event + + let doc = "Generic event for callers of the function Lwt_utils.worker." + + let level { event ; _ } = + match event with + | `Failed _ -> Error + | `Started | `Ended -> Info + end + + include (Make (Definition) : EVENT with type t := t) + + let on_event name event = + let section = Printf.ksprintf Section.make_sanitized "lwt-worker-%s" name in + Error_event.to_lwt + ~message:(Printf.sprintf "Trying to emit worker event for %S" name) + ~severity:`Fatal + (fun () -> emit ~section (fun () -> { name ; event })) +end + + + +module Lwt_log_sink = struct + + (* let default_template = "$(date) - $(section): $(message)" *) + + let default_section = Lwt_log_core.Section.main + + module Sink : SINK = struct + type t = unit + + let uri_scheme = "lwt-log" + + let configure _ = return_unit + + let handle (type a) () m ?section (v : unit -> a) = + let module M = (val m : EVENT_DEFINITION with type t = a) in + protect + (fun () -> + let ev = v () in + let section = + Option.unopt_map ~f:Section.to_lwt_log + section ~default:default_section in + let level = M.level ev in + Format.kasprintf + (Lwt_log_core.log ~section ~level) + "%a" M.pp ev + >>= fun () -> return_unit) + + let close _ = + Lwt_log.close !Lwt_log.default + >>= fun () -> + return_unit + end + include Sink + + let () = All_sinks.register (module Sink) + +end diff --git a/src/lib_event_logging/internal_event.mli b/src/lib_event_logging/internal_event.mli new file mode 100644 index 000000000000..6a967700b950 --- /dev/null +++ b/src/lib_event_logging/internal_event.mli @@ -0,0 +1,333 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** + This module defines a “structured event logging framework.” + + Internal-Event streams are like traditional logs but they have a proper + {!Data_encoding} format in order to be processed by software. + + The module defines “Sinks” {!SINK} as the receptacle for structured + events: pluggable modules which can absorb (i.e. display, store, + forward) the events emitted within the code-base. +*) + +open Tezos_error_monad +open Error_monad + +(** {3 Events Definitions and Registration } *) + +type level = Debug | Info | Notice | Warning | Error | Fatal +(** The relative importance of a particular event (compatible with + traditional logging systems, cf. {!Lwt_log_core.level}). *) + +(** Module to manipulate values of type {!level}. *) +module Level : sig + + type t = level + (** Alias of {!level}. *) + + val default : t + (** The default level is {!Info}, it is used in {!Event_defaults}. *) + + val to_lwt_log : t -> Lwt_log_core.level + (** Cast the level to a value of {!Lwt_log_core.level}. *) + + val to_string : t -> string + val of_string : string -> t option + val encoding : t Data_encoding.t +end + + +(** Sections are a simple way of classifying events at the time of + their emission. *) +module Section: sig + type t = private string + + val make_sanitized : string -> t + (** Build a {!Section.t} by replacing special characters with ['_']. *) + + val to_lwt_log : t -> Lwt_log_core.section + (** Make the equivalent {!Lwt_log} section. *) + + val encoding : t Data_encoding.t + val to_string : t -> string +end + +(** Parameters defining an inspectable type of events. *) +module type EVENT_DEFINITION = sig + type t + + val name : string + (** Defines the identifier for the event. Names should be unique and + are restricted to alphanumeric characters or [".@-_+=,~"].*) + + val doc : string + (** A display-friendly test which describes what the event means. *) + + val pp : Format.formatter -> t -> unit + + val encoding : t Data_encoding.t + + val level : t -> level + (** Return the prefered {!level} for a given event instance. *) +end + +(** Default values for fields in {!EVENT_DEFINITION}. *) +module Event_defaults : sig + (** Use this module as needed with [include Event_defaults]. *) + + val level : 'a -> level +end + +(** Events created with {!Make} provide the {!EVENT} API. *) +module type EVENT = sig + include EVENT_DEFINITION + + val emit : ?section: Section.t -> (unit -> t) -> unit tzresult Lwt.t + (** Output an event of type {!t}, if no sinks are listening the + function won't be applied. *) +end + +(** Build an event from an event-definition. *) +module Make(E: EVENT_DEFINITION): EVENT with type t = E.t + +type 'a event_definition = (module EVENT_DEFINITION with type t = 'a) +(** [event_definition] wraps {!EVENT_DEFINITION} as a first class module. *) + +(** Helper functions to manipulate all kinds of events in a generic way. *) +module Generic : sig + type definition = Definition : (string * 'a event_definition) -> definition + + type event = Event : (string * 'a event_definition * 'a) -> event + + type with_name = < doc : string; name : string > + + val json_schema : definition -> < schema : Json_schema.schema ; with_name > + (** Get the JSON schema (together with [name] and [doc]) of a given + event definition. *) + + val explode_event : event -> + < pp : Format.formatter -> unit -> unit ; + json : Data_encoding.json ; + with_name > + (** Get the JSON representation and a pretty-printer for a given + event {i instance}. *) +end + +(** Access to all the event definitions registered with {!Make}. *) +module All_definitions : sig + + (** Get the list of all the known definitions. *) + val get : unit -> Generic.definition list + + (** Find the definition matching on the given name. *) + val find: (string -> bool) -> Generic.definition option +end + +(** {3 Sink Definitions and Registration } *) + +(** An implementation of {!SINK} is responsible for handling/storing + events, for instance, a sink could be output to a file, to a + database, or a simple “memory-less” forwarding mechanism. *) +module type SINK = sig + + (** A sink can store any required state, e.g. a database handle, in + a value of the [t] type see {!configure}. *) + type t + + val uri_scheme : string + (** Registered sinks are a distinguished by their URI scheme. *) + + val configure : Uri.t -> t tzresult Lwt.t + (** When a registered sink is activated the {!configure} function is + called to initialize it. The parameters should be encoded or + obtained from the URI (the scheme of the URI is already + {!uri_scheme}). *) + + val handle : + t -> 'a event_definition -> + ?section: Section.t -> (unit -> 'a) -> unit tzresult Lwt.t + (** A sink's main function is to {!handle} incoming events from the + code base. *) + + val close : t -> unit tzresult Lwt.t + (** A function to be called on graceful termination of processes + (e.g. to flush file-descriptors, etc.). *) +end + +type 'a sink_definition = (module SINK with type t = 'a) +(** [sink_definition] wraps {!SINK_DEFINITION} as a first class module. *) + +(** Use {!All_sinks.register} to add a new {i inactive} sink, then + {!All_sinks.activate} to make it handle events. *) +module All_sinks : sig + + val register : 'a sink_definition -> unit + (** Register a new sink (e.g. + [let () = Internal_event.All_sinks.register (module Sink_implementation)]) + for it to be available (but inactive) in the framework. *) + + val activate : Uri.t -> unit tzresult Lwt.t + (** Make a registered sink active: the function finds it by URI + scheme and calls {!configure}. *) + + val close : unit -> unit tzresult Lwt.t + (** Call [close] on all the sinks. *) + + val pp_state : Format.formatter -> unit -> unit + (** Display the state of registered/active sinks. *) +end + +(** {3 Common Event Definitions } *) + +(** {!Error_event.t} is a generic event to emit values of type + {!Error_monad.error list}. *) +module Error_event : sig + type t = { + message : string option ; + severity : [ `Fatal | `Recoverable ] ; + trace : Error_monad.error list ; + } + (** Errors mainly store {!Error_monad.error list} values. One can + attach a message and a severity (the default is [`Recoverable] + which corresponds to the {!Error} {!level}, while [`Fatal] + corresponds to {!Fatal}). *) + + val make : + ?message: string -> + ?severity:[ `Fatal | `Recoverable ] -> + Error_monad.error list -> + unit -> t + + include EVENT with type t := t + + val to_lwt : + ?section:Section.t -> + ?message:string -> + ?severity:[ `Fatal | `Recoverable ] -> + (unit -> (unit, error list) result Lwt.t) -> unit Lwt.t + (** [to_lwt f] calls [f ()] and emits an {!Error_event.t} event if + it results in an error. It then continues in the [_ Lwt.t] + monad (e.g. there is no call to [Lwt.fail]). *) +end + +(** The debug-event is meant for emitting (temporarily) + semi-structured data in the event stream. *) +module Debug_event : sig + type t = { + message : string ; + attachment : Data_encoding.Json.t ; + } + val make : ?attach: Data_encoding.Json.t -> string -> unit -> t + include EVENT with type t := t +end + +(** The worker event is meant for use with {!Lwt_utils.worker}. *) +module Lwt_worker_event : sig + type t = { + name : string; + event : [ `Ended | `Failed of string | `Started ]; + } + include EVENT with type t := t + + val on_event : + string -> [ `Ended | `Failed of string | `Started ] -> unit Lwt.t + (** [on_event msg status] emits an event of type [t] and matches + the signature required by {!Lwt_utils.worker}. *) +end + +(** {3 Compatibility With Legacy Logging } *) + +(** The module {!Legacy_logging} replaces the previous + [Logging.Make_*] functors by injecting the non-structured logs + into the event-logging framework. + {b Please do not use for new modules.} *) +module Legacy_logging : sig + + module type LOG = sig + val debug: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a + val warn: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a + val fatal_error: ('a, Format.formatter, unit, unit) format4 -> 'a + + val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_fatal_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + end + open Tezos_stdlib + 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 + module type SEMLOG = sig + module Tag = Tag + val debug: ('a, unit) log + val log_info: ('a, unit) log + val log_notice: ('a, unit) log + val warn: ('a, unit) log + val log_error: ('a, unit) log + val fatal_error: ('a, unit) log + val lwt_debug: ('a, unit Lwt.t) log + val lwt_log_info: ('a, unit Lwt.t) log + val lwt_log_notice: ('a, unit Lwt.t) log + val lwt_warn: ('a, unit Lwt.t) log + val lwt_log_error: ('a, unit Lwt.t) log + val lwt_fatal_error: ('a, unit Lwt.t) log + val event : string Tag.def + val exn : exn Tag.def + end + module Make : (sig val name : string end) -> sig + module Event : EVENT + include LOG + end + module Make_semantic : (sig val name : string end) -> sig + module Event : EVENT + include SEMLOG + end + + val sections : string list ref +end + + +(** {3 Common Event-Sink Definitions } *) + +(** The lwt-sink outputs pretty-printed renderings of events to the + lwt-log logging framework (see the {!Lwt_log_core} module). + + It is activated {i by default} in {!Internal_event_unix.Configuration.default} + (in any case it can be activated with [TEZOS_EVENTS_CONFIG="lwt-log://"]. To + configure further how the sink outputs to a file or the user's + terminal, one needs to use the [TEZOS_LOG] variable (see also the module + {!Lwt_log_sink_unix}). +*) +module Lwt_log_sink: sig + val uri_scheme : string +end diff --git a/src/lib_event_logging/tezos-event-logging.opam b/src/lib_event_logging/tezos-event-logging.opam new file mode 100644 index 000000000000..456138424aa2 --- /dev/null +++ b/src/lib_event_logging/tezos-event-logging.opam @@ -0,0 +1,22 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "ocamlfind" { build } + "dune" { build & = "1.0.1" } + "tezos-stdlib" + "tezos-data-encoding" + "tezos-error-monad" + "lwt" +] +build: [ + [ "dune" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "dune" "runtest" "-p" name "-j" jobs ] +] -- GitLab From 3c53dbc7d275e2dd36a385c13ea930576c2971f0 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 11 Jan 2019 11:58:04 -0500 Subject: [PATCH 05/20] Event-logging: Add module `Internal_event_unix` --- src/lib_stdlib_unix/internal_event_unix.ml | 103 ++++++++++++++++++++ src/lib_stdlib_unix/internal_event_unix.mli | 62 ++++++++++++ 2 files changed, 165 insertions(+) create mode 100644 src/lib_stdlib_unix/internal_event_unix.ml create mode 100644 src/lib_stdlib_unix/internal_event_unix.mli diff --git a/src/lib_stdlib_unix/internal_event_unix.ml b/src/lib_stdlib_unix/internal_event_unix.ml new file mode 100644 index 000000000000..83b69829ee59 --- /dev/null +++ b/src/lib_stdlib_unix/internal_event_unix.ml @@ -0,0 +1,103 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Configuration = struct + type t = { activate : Uri.t list } + + let default = + { activate = [ + Uri.make ~scheme:Internal_event.Lwt_log_sink.uri_scheme () + ] } + + let encoding = + let open Data_encoding in + conv + (fun { activate } -> List.map Uri.to_string activate) + (fun activate -> { activate = List.map Uri.of_string activate }) + (obj1 + (dft "activate" + ~description: "List of URIs to activate/configure sinks." + (list string) [])) + + let of_file path = + Lwt_utils_unix.Json.read_file path >>=? fun json -> + protect (fun () -> return (Data_encoding.Json.destruct encoding json)) + + let apply { activate } = + List.fold_left + (fun prev uri -> + prev >>=? fun () -> + Internal_event.All_sinks.activate uri) + return_unit + activate +end + +let env_var_name = "TEZOS_EVENTS_CONFIG" + +let init ?(configuration = Configuration.default) () = + begin + begin match Sys.(getenv_opt env_var_name) with + | None -> + return_unit + | Some s -> + let uris = + String.split ' ' s + |> List.map (String.split '\n') |> List.concat + |> List.map (String.split '\t') |> List.concat + |> List.filter ((<>) "") + |> List.map Uri.of_string in + List.fold_left + (fun prev uri -> + prev >>=? fun () -> + match Uri.scheme uri with + | None -> + Configuration.of_file (Uri.path uri) >>=? fun cfg -> + Configuration.apply cfg + | Some _ -> + Internal_event.All_sinks.activate uri) + return_unit + uris >>=? fun () -> + Internal_event.Debug_event.( + emit (make "Loaded URIs from environment" + ~attach:(`O [ "variable", `String env_var_name ; + "value", `String s ]))) + end >>=? fun () -> + Configuration.apply configuration + end + >>= function + | Ok () -> Lwt.return_unit + | Error el -> + Format.kasprintf Lwt.fail_with + "ERROR@ Initializing Internal_event_unix:@ %a\n%!" + Error_monad.pp_print_error el + +let close () = + Internal_event.All_sinks.close () + >>= function + | Ok () -> Lwt.return_unit + | Error el -> + Format.kasprintf Lwt.fail_with + "ERROR@ closing Internal_event_unix:@ %a\n%!" + Error_monad.pp_print_error el diff --git a/src/lib_stdlib_unix/internal_event_unix.mli b/src/lib_stdlib_unix/internal_event_unix.mli new file mode 100644 index 000000000000..fc5ae9f6187c --- /dev/null +++ b/src/lib_stdlib_unix/internal_event_unix.mli @@ -0,0 +1,62 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Configure the event-logging framework for UNIx-based applications. *) + +(** The JSON-file-friendly definition of the configuration of the + internal-events framework. It allows one to activate registered + event sinks. *) +module Configuration : sig + type t + + (** The default configuration is empty (it doesn't activate any sink). *) + val default : t + + (** The serialization format. *) + val encoding : t RPC_encoding.t + + (** Parse a json file at [path] into a configuration. *) + val of_file : string -> t tzresult Lwt.t + + val apply : t -> unit tzresult Lwt.t + (** Run {!Tezos_base.Internal_event.All_sinks.activate} for every + URI in the configuration. *) +end + +val init : + ?configuration:Configuration.t -> + unit -> + unit Lwt.t +(** Initialize the internal-event sinks by looking at the + [?configuration] argument and then at the (whitespace separated) list + of URIs in the ["TEZOS_EVENTS_CONFIG"] environment variable, if an URI + does not have a scheme it is expected to be a path to a configuration + JSON file (cf. {!Configuration.of_file}), e.g.: + [export TEZOS_EVENTS_CONFIG="unix-files:///tmp/events-unix debug://"], or + [export TEZOS_EVENTS_CONFIG="debug:// /path/to/config.json"]. +*) + +val close : unit -> unit Lwt.t +(** Call [close] on all the sinks. *) -- GitLab From b425a3e9dafa008e293a9506ae36439689a269fe Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 11 Jan 2019 11:58:53 -0500 Subject: [PATCH 06/20] Stdlib-unix: Add module `File_event_sink` --- src/lib_stdlib_unix/file_event_sink.ml | 548 ++++++++++++++++++++++++ src/lib_stdlib_unix/file_event_sink.mli | 98 +++++ 2 files changed, 646 insertions(+) create mode 100644 src/lib_stdlib_unix/file_event_sink.ml create mode 100644 src/lib_stdlib_unix/file_event_sink.mli diff --git a/src/lib_stdlib_unix/file_event_sink.ml b/src/lib_stdlib_unix/file_event_sink.ml new file mode 100644 index 000000000000..895dc67f3ce5 --- /dev/null +++ b/src/lib_stdlib_unix/file_event_sink.ml @@ -0,0 +1,548 @@ +(******************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Micro_seconds : sig + (** Module with time-stamps with “at least micro-seconds” precision. *) + type t = private float + val now : unit -> t + val of_float: float -> t + val encoding : t Data_encoding.t + val date_string : t -> string * string +end = struct + (* Time.t is in seconds, we want more precision. *) + type t = float + let now () = Unix.gettimeofday () + let of_float f = f + let encoding = + let open Data_encoding in + conv (* Cf. https://github.com/OCamlPro/ocplib-json-typed/issues/25 *) + (fun f -> f *. 1_000_000. |> Int64.of_float) + (fun i64 -> Int64.to_float i64 /. 1_000_000.) + int64 + let date_string time_value = + let open Unix in + let open Printf in + let tm = gmtime time_value in + (sprintf "%04d%02d%02d" (1900 + tm.tm_year) + (tm.tm_mon + 1) tm.tm_mday, + sprintf "%02d%02d%02d-%06d" tm.tm_hour tm.tm_min tm.tm_sec + ((time_value -. floor time_value) *. 1_000_000. |> int_of_float)) +end + +module Event_filter = struct + + type t = + | True + | False + | Or of t list + | And of t list + | Name of string + | Name_matches of Re.re + | Level_in of Internal_event.level list + | Section_in of Internal_event.Section.t option list + + let rec run ~section_option ~level ~name filter = + let continue = run ~section_option ~level ~name in + match filter with + | True -> true + | False -> false + | Or l -> List.exists continue l + | And l -> List.for_all continue l + | Name s -> String.equal s name + | Name_matches re -> Re.execp re name + | Level_in l -> List.mem level l + | Section_in l -> List.mem section_option l + + let rec pp fmt filter = + let open Format in + match filter with + | True -> pp_print_string fmt "true" + | False -> pp_print_string fmt "false" + | Or l -> + fprintf fmt "(or@ @[<2>%a@]" + (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ") pp) l + | And l -> + fprintf fmt "(and@ @[<2>%a@]" + (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ") pp) l + | Name s -> fprintf fmt "(name-is@ %S)" s + | Name_matches re -> fprintf fmt "(name-matches@ %a)" Re.pp_re re + | Level_in l -> + fprintf fmt "(level-in@ [%s])" + (String.concat "," (List.map Internal_event.Level.to_string l)) + | Section_in l -> + fprintf fmt "(section-in@ [%a])" + (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") + (fun fmt -> function + | None -> fprintf fmt "None" + | Some s -> fprintf fmt "(Some %s)" + (Internal_event.Section.to_string s))) + l + [@@warning "-32"] (* -> The "unused value" warning. *) + + let t = True + let f = False + [@@warning "-32"] (* -> The "unused value" warning. *) + let any l = Or l + let all l = And l + [@@warning "-32"] (* -> The "unused value" warning. *) + let name_is s = Name s + let name_matches s = Name_matches s + let name_matches_posix s = name_matches (Re.Posix.compile_pat s) + let level_in l = Level_in l + let section_in l = Section_in l + + let levels_in_order = + Internal_event.[ Debug ; Info ; Notice ; Warning ; Error ; Fatal] + + let level_at_least lvl = + List.fold_left + (function + | None -> (function l when l = lvl -> Some [l] | _ -> None) + | Some s -> (fun l -> Some (l :: s))) + None + levels_in_order + |> Option.unopt_exn (Failure "level_at_least not found") + |> level_in + +end + +type t = { + path : string ; + (* Hopefully temporary hack to handle event which are emitted with + the non-cooperative log functions in `Legacy_logging`: *) + lwt_bad_citizen_hack : (string * Data_encoding.json) list ref ; + event_filter: Event_filter.t ; +} + + +type 'event wrapped = + { time_stamp : Micro_seconds.t ; + section : Internal_event.Section.t option ; + event : 'event } + +let wrap time_stamp section event = { time_stamp ; section ; event } + +let wrapped_encoding event_encoding = + let open Data_encoding in + let v0 = + conv + (fun { time_stamp ; section ; event } -> (time_stamp, section, event)) + (fun (time_stamp, section, event) -> { time_stamp ; section ; event }) + (obj3 + (req "time_stamp" Micro_seconds.encoding) + (req "section" (option Internal_event.Section.encoding)) + (req "event" event_encoding)) + in + With_version.(encoding ~name:"file-event-sink-item" (first_version v0)) + +module Section_dir = struct + + let of_section (section : Internal_event.Section.t option) = + Option.unopt_map (section :> string option) + ~default:"no-section" ~f:(Printf.sprintf "section-%s") + + let section_name = + function + | "no-section" -> Ok None + | other -> + (match String.remove_prefix ~prefix:"section-" other with + | None -> Error "wrong-dir-name" + | Some s -> Ok (Some s)) +end + + + +module Sink_implementation : Internal_event.SINK with type t = t = struct + + type nonrec t = t + + let uri_scheme = "unix-files" + + let configure uri = + let event_filter = + let name_res = + Uri.get_query_param' uri "name-matches" |> Option.unopt ~default:[] in + let names = Uri.get_query_param' uri "name" |> Option.unopt ~default:[] in + let levels = + Option.( + Uri.get_query_param uri "level-at-least" + >>= Internal_event.Level.of_string + >>= fun l -> + (* some (fun all more -> all [Event_filter.level_at_least l ; more ]) *) + some [Event_filter.level_at_least l] + ) + |> Option.unopt ~default:[] + in + let sections = + let somes = + Uri.get_query_param' uri "section" |> Option.unopt ~default:[] + |> List.map (fun s -> Some (Internal_event.Section.make_sanitized s)) + in + let none = + match Uri.get_query_param uri "no-section" with + | Some "true" -> [None] + | _ -> [] + in + match somes @ none with + | [] -> [] + | more -> [Event_filter.section_in more] + in + Event_filter.( + match + levels @ sections + @ List.map name_matches_posix name_res + @ List.map name_is names + with + | [] -> t + | more -> any more + ) in + let t = + { path = Uri.path uri ; lwt_bad_citizen_hack = ref [] ; event_filter } in + return t + + + let output_json ~pp file_path event_json = + Lwt.catch (fun () -> + Lwt_utils_unix.create_dir ~perm:0o700 (Filename.dirname file_path) + >>= fun () -> + Lwt_utils_unix.Json.write_file file_path + event_json + >>= function + | Ok () -> return_unit + | Error el -> + failwith + "ERROR while Handling %a,@ cannot write JSON to %s:@ %a\n%!" + pp () file_path Error_monad.pp_print_error el + ) + (function + | e -> + failwith "ERROR while Handling %a: %a\n%!" + pp () Error_monad.pp_exn e) + + let handle + (type a) { path ; lwt_bad_citizen_hack ; event_filter } + m ?section (v : unit -> a) = + let module M = (val m : Internal_event.EVENT_DEFINITION with type t = a) in + let now = Micro_seconds.now () in + let date, time = Micro_seconds.date_string now in + let forced = v () in + let level = M.level forced in + match + Event_filter.run + ~section_option:section ~level ~name:M.name event_filter + with + | true -> + let event_json = + Data_encoding.Json.construct + (wrapped_encoding M.encoding) + (wrap now section forced) in + let tag = + let hash = + Marshal.to_string event_json [] + |> Digest.string |> Digest.to_hex in + String.sub hash 0 8 in + let section_dir = Section_dir.of_section section in + let dir_path = + List.fold_left Filename.concat path + [ section_dir; M.name ; date ; time ] in + let file_path = + Filename.concat dir_path + (Printf.sprintf "%s_%s_%s.json" date time tag) in + lwt_bad_citizen_hack := (file_path, event_json) :: !lwt_bad_citizen_hack ; + output_json file_path event_json ~pp:(fun fmt () -> M.pp fmt forced) + >>=? fun () -> + lwt_bad_citizen_hack := + List.filter (fun (f, _) -> f <> file_path) !lwt_bad_citizen_hack ; + return_unit + | false -> return_unit + + let close { lwt_bad_citizen_hack ; _ } = + iter_s + (fun (f, j) -> + output_json f j + ~pp:(fun fmt () -> Format.fprintf fmt "Destacking: %s" f)) + !lwt_bad_citizen_hack + >>=? fun () -> + return_unit +end + +let () = + Internal_event.All_sinks.register (module Sink_implementation) + +open Sink_implementation + +module Query = struct + + let with_file_kind dir p = + protect (fun () -> + Lwt_unix.stat (Filename.concat dir p) >>= fun {Lwt_unix. st_kind ; _ } -> + return st_kind) + >>=? function + | Unix.S_DIR -> return (`Directory p) + | Unix.S_REG -> return (`Regular_file p) + | Unix.S_CHR + | Unix.S_BLK + | Unix.S_LNK + | Unix.S_FIFO + | Unix.S_SOCK as k -> return (`Special (k, p)) + + let fold_directory path ~init ~f = + protect (fun () -> + Lwt_unix.opendir path >>= fun dirhandle -> return dirhandle) + >>=? fun dirhandle -> + let rec iter prev = + protect (fun () -> + Lwt.catch + (fun () -> + Lwt_unix.readdir dirhandle >>= fun d -> + with_file_kind path d + >>=? fun wk -> + return (Some wk)) + (function + | End_of_file -> + Lwt_unix.closedir dirhandle >>= fun () -> + return None + | (e : exn) -> + failwith "ERROR while folding %s: %s" + path (Printexc.to_string e))) + >>=? fun opt -> + prev >>=? fun p -> + begin match opt with + | Some more -> iter (f p more) + | None -> prev + end + in + iter init + + let (//) = Filename.concat + + module Time_constraint = struct + type op = [ `Lt | `Le | `Ge | `Gt ] + type t = [ + | `Date of op * float + | `Time of op * float + | `And of t * t + | `Or of t * t + | `All + ] + + let rec check_logic check_terminal (t : t) string = + let continue = check_logic check_terminal in + match t with + | `All -> true + | `And (a, b) -> continue a string && continue b string + | `Or (a, b) -> continue a string || continue b string + | `Date _ | `Time _ as term -> check_terminal term + + let op_with_string = + function + | `Lt -> (fun a b -> String.compare a b > 0) + | `Gt -> (fun a b -> String.compare a b < 0) + | `Le -> (fun a b -> String.compare a b >= 0) + | `Ge -> (fun a b -> String.compare a b <= 0) + + let check_date (t : t) date_string = + check_logic + (function + | `Date (op, f) -> + let s = Micro_seconds.(date_string (of_float f) |> fst) in + op_with_string op s date_string + | `Time _ -> true) + t date_string + + let check_time (t : t) string = + check_logic + (function + | `Time (op, f) -> + let s = Micro_seconds.(date_string (of_float f) |> snd) in + op_with_string op s string + | `Date _ -> true) + t Micro_seconds.date_string + end + + module Report = struct + type item = [ + | `Error of [ + | `Parsing_event of [ + | `Encoding of string * exn + | `Json of string * error list + ] + | `Cannot_recognize_section of string + ] + | `Warning of [ + | `Expecting_regular_file_at of string + | `Expecting_directory_at of string + | `Unknown_event_name_at of string * string + ] + ] + + let pp fmt (x : item) = + let open Format in + let error fmt = + function + | `Parsing_event e -> + (match e with + | `Encoding (path, exn) -> + fprintf fmt "@[Parse error:@ wrong encoding for %S: %a@]" + path pp_exn exn + | `Json (path, el) -> + fprintf fmt "@[Parse error:@ wrong JSON for %S: %a@]" + path pp_print_error el) + | `Cannot_recognize_section sec -> + fprintf fmt + "@[Directory error:@ cannot recognize section directory@ %S@]" + sec + in + let warning fmt = + function + | `Expecting_regular_file_at path -> fprintf fmt "%S@ is not a regular file" path + | `Expecting_directory_at path -> fprintf fmt "%S@ is not a directory" path + | `Unknown_event_name_at (name, path) -> fprintf fmt "Unknown event name@ %S@ at@ %S" name path + in + match x with + | `Error e -> fprintf fmt "@[Error:@ %a@]" error e + | `Warning e -> fprintf fmt "@[Warning:@ %a@]" warning e + + let make_return m ((prev : item list), value) warning = + return ((m warning :: prev), value) + let return_with_warning v e = make_return (fun e -> `Warning e) v e + let return_with_error v e = make_return (fun e -> `Error e) v e + end + open Report + + + let fold_event_kind_directory ~time_query path ~init ~f = + fold_directory path ~init:(return init) + ~f:(fun previous -> function + | `Directory "." | `Directory ".." -> return previous + | `Directory date when Time_constraint.check_date time_query date -> + fold_directory (path // date) + ~init:(return previous) + ~f:(fun previous -> function + | `Directory "." | `Directory ".." -> return previous + | `Directory time when Time_constraint.check_time time_query time -> + fold_directory (path // date // time) + ~init:(return previous) + ~f:(fun previous -> function + | `Directory "." | `Directory ".." -> return previous + | `Regular_file file -> + f previous (path // date // time // file) + | `Directory p | `Special (_, p) -> + return_with_warning previous + (`Expecting_regular_file_at + (path // date // time // p)) + ) + | `Directory _ (* filtered out *) -> return previous + | `Regular_file p | `Special (_, p) -> + return_with_warning previous + (`Expecting_directory_at (path // date // p))) + | `Directory _ (* filtered out *) -> return previous + | `Regular_file p | `Special (_, p) -> + return_with_warning previous + (`Expecting_directory_at (path // p))) + + let handle_event_kind_directory (type a) ~time_query ~section_path ~init ~f ev = + let module Event = + (val ev : Internal_event.EVENT_DEFINITION with type t = a) in + let handle_event_file previous path = + Lwt_utils_unix.Json.read_file path + >>= function + | Ok json -> + begin try + let { time_stamp ; event } = + Data_encoding.Json.destruct + (wrapped_encoding Event.encoding) json in + f (snd previous) + ~time_stamp:(time_stamp :> float) + (Internal_event.Generic.Event + (Event.name, ev, event)) + >>=? fun user_return -> + return (fst previous, user_return) + with + e -> + return_with_error previous (`Parsing_event (`Encoding (path, e))) + end + | Error el -> + return_with_error previous (`Parsing_event (`Json (path, el))) + in + fold_event_kind_directory ~time_query + (section_path // Event.name) ~init + ~f:(fun prev file -> handle_event_file prev file) + + + let fold + ?on_unknown ?only_sections ?only_names ?(time_query = `All) uri ~init ~f = + let name_matches = + match only_names with + | None -> (fun _ -> true) + | Some l -> (fun name -> List.mem name l) in + let section_matches = + match only_sections with + | None -> (fun _ -> true) + | Some l -> (fun name -> List.mem name l) in + configure uri + >>=? fun { path = sink_path ; _ } -> + fold_directory sink_path ~init:(return ([], init)) ~f:(fun previous -> function + | `Directory ("." | "..") -> return previous + | `Directory dir -> + begin match Section_dir.section_name dir with + | Ok sec when section_matches sec -> + fold_directory (sink_path // dir) + ~init:(return ([], init)) ~f:(fun previous -> function + | `Directory ("." | "..") -> return previous + | `Directory event_name when name_matches event_name -> + let open Internal_event in + begin match All_definitions.find ((=) event_name) with + | Some (Generic.Definition (_, ev)) -> + handle_event_kind_directory ~time_query ev + ~section_path:(sink_path // dir) + ~init:previous ~f + | None -> + begin match on_unknown with + | None -> + return_with_warning previous + (`Unknown_event_name_at + (event_name, sink_path // dir)) + | Some f -> + fold_event_kind_directory ~time_query + (sink_path // dir // event_name) + ~init:previous + ~f:(fun prev file -> + f file >>=? fun () -> + return prev) + end + end + | `Directory _ (* filtered out *) -> return previous + | `Regular_file p | `Special (_, p) -> + return_with_warning previous + (`Expecting_directory_at (sink_path // p))) + | Ok _ (* section does not match *) -> return previous + | Error _ -> + return_with_error previous (`Cannot_recognize_section dir) + end + | `Regular_file p | `Special (_, p) -> + return_with_warning previous + (`Expecting_directory_at (sink_path // p))) +end diff --git a/src/lib_stdlib_unix/file_event_sink.mli b/src/lib_stdlib_unix/file_event_sink.mli new file mode 100644 index 000000000000..bfaae1a7fe24 --- /dev/null +++ b/src/lib_stdlib_unix/file_event_sink.mli @@ -0,0 +1,98 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** An implementation of {!Tezos_base.Internal_event.SINK} which + writes the events as JSON files in a given directory structure. + + It is registered with the URI scheme ["unix-files"], one can activate it + with an URI containing the top-level directory in which the JSON + files will be written, e.g. + ["export TEZOS_EVENTS_CONFIG=unix-files:///the/path/to/write"] + (the path should be inexistent or already a directory). + + The directory structure is as follows: + ["////"] + where [""] is either ["no-section"] or + ["section-"]. +*) + +(** The module {!Query} provides a {!fold} function over the events + stored by a given instantiation of the [SINK.t]. *) +module Query : sig + + module Time_constraint : sig + type op = [ `Lt | `Le | `Ge | `Gt ] + type t = + [ `All + | `And of t * t + | `Or of t * t + | `Date of op * float + | `Time of op * float ] + end + + (** The {!fold} function returns a list of non-fatal errors and + warnings that happened during the scan, those are defined in + {!Report.item}. *) + module Report : sig + type item = [ + | `Error of [ + | `Parsing_event of [ + | `Encoding of string * exn + | `Json of string * error list + ] + | `Cannot_recognize_section of string + ] + | `Warning of [ + | `Expecting_regular_file_at of string + | `Expecting_directory_at of string + | `Unknown_event_name_at of string * string + ] + ] + val pp: Format.formatter -> item -> unit + end + + (** Scan a folder for events. + + - [?on_unknown] is a function which takes a path to a JSON file. + - [?only_sections] is an optional filter on the sections in which the + events have been emitted ({!Internal_event.Section.t}). + - [?only_names] is an optional filter on the event names. + - [?time_query] is a filter restricting the allowed events' + emission dates (cf. {!Time_constraint}). + + See also an example of use in {!Client_event_logging_commands} + (command ["tezos-client-admin query events from + unix-files:///..."]). + *) + val fold : + ?on_unknown:(string -> unit tzresult Lwt.t) -> + ?only_sections:string option list -> + ?only_names:string list -> + ?time_query:Time_constraint.t -> + Uri.t -> + init:'a -> + f:('a -> time_stamp:float -> Internal_event.Generic.event -> 'a tzresult Lwt.t) -> + (Report.item list * 'a) tzresult Lwt.t +end -- GitLab From 622b7312b58e8bcb16823911068264344568a98c Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 11 Jan 2019 12:00:16 -0500 Subject: [PATCH 07/20] Baker: Use structured logging in `Client_baking_blocks` --- .../lib_delegate/client_baking_blocks.ml | 80 ++++++++++++++----- 1 file changed, 62 insertions(+), 18 deletions(-) diff --git a/src/proto_alpha/lib_delegate/client_baking_blocks.ml b/src/proto_alpha/lib_delegate/client_baking_blocks.ml index b32ab18ad97a..cd434104a172 100644 --- a/src/proto_alpha/lib_delegate/client_baking_blocks.ml +++ b/src/proto_alpha/lib_delegate/client_baking_blocks.ml @@ -25,9 +25,6 @@ open Proto_alpha open Alpha_context -open Logging - -include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.blocks" end) type block_info = { hash: Block_hash.t ; @@ -64,31 +61,78 @@ let info cctxt ?(chain = `Main) block = cctxt ~chain ~block () >>=? fun shell_header -> raw_info cctxt ~chain hash shell_header + +module Block_seen_event = struct + type t = { + hash : Block_hash.t ; + header : Tezos_base.Block_header.t ; + occurrence : [ `Valid_blocks of Chain_id.t | `Heads ] + } + let make hash header occurrence () = { hash ; header ; occurrence } + module Definition = struct + let name = "block-seen" + type nonrec t = t + let encoding = + let open Data_encoding in + let v0_encoding = + conv + (function { hash ; header ; occurrence } -> + (hash, occurrence, header)) + (fun (b, o, h) -> make b h o ()) + (obj3 + (req "hash" Block_hash.encoding) + (* Occurrence has to come before header, because: + (Invalid_argument + "Cannot merge two objects when the left element is of + variable length and the right one of dynamic + length. You should use the reverse order, or wrap the + second one with Data_encoding.dynamic_size.") *) + (req "occurrence" + (union [ + case ~title:"heads" (Tag 0) + (obj1 (req "occurrence-kind" (constant "heads"))) + (function `Heads -> Some () | _ -> None) + (fun () -> `Heads) ; + case ~title:"valid-blocks" (Tag 1) + (obj2 + (req "occurrence-kind" (constant "valid-blocks")) + (req "chain-id" Chain_id.encoding)) + (function `Valid_blocks ch -> Some ((), ch) | _ -> None) + (fun ((), ch) ->`Valid_blocks ch) ; + ])) + (req "header" Tezos_base.Block_header.encoding) + ) + in + With_version.(encoding ~name (first_version v0_encoding)) + let pp ppf { hash ; _ } = + Format.fprintf ppf "Saw block %a" Block_hash.pp_short hash + let doc = "Block observed while monitoring a blockchain." + include Internal_event.Event_defaults + end + module Event = Internal_event.Make(Definition) +end + + let monitor_valid_blocks cctxt ?chains ?protocols ~next_protocols () = Monitor_services.valid_blocks cctxt ?chains ?protocols ?next_protocols () >>=? fun (block_stream, _stop) -> return (Lwt_stream.map_s - (fun ((chain, block), data) -> - log_info Tag.DSL.(fun f -> - f "Saw block %a on chain %a" - -% t event "monitor_saw_valid_block" - -% a Block_hash.Logging.tag block - -% a State_logging.chain_id chain - -% t block_header_tag data) ; - raw_info cctxt ~chain:(`Hash chain) block data.Tezos_base.Block_header.shell) + (fun ((chain, block), header) -> + Block_seen_event.(Event.emit + (make block header (`Valid_blocks chain))) + >>=? fun () -> + raw_info cctxt ~chain:(`Hash chain) block + header.Tezos_base.Block_header.shell) block_stream) let monitor_heads cctxt ~next_protocols chain = Monitor_services.heads cctxt ?next_protocols chain >>=? fun (block_stream, _stop) -> return (Lwt_stream.map_s - (fun (block, data) -> - log_info Tag.DSL.(fun f -> - f "Saw head %a" - -% t event "monitor_saw_head" - -% a Block_hash.Logging.tag block - -% t block_header_tag data) ; - raw_info cctxt ~chain block data.Tezos_base.Block_header.shell) + (fun (block, ({ Tezos_base.Block_header.shell } as header)) -> + Block_seen_event.(Event.emit (make block header `Heads)) + >>=? fun () -> + raw_info cctxt ~chain block shell) block_stream) let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = -- GitLab From 2939dac72246145458cf20fa6fadbe56955a159f Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 11 Jan 2019 12:03:18 -0500 Subject: [PATCH 08/20] Admin-client: Add event-logging commands --- src/bin_client/main_admin.ml | 3 +- .../client_event_logging_commands.ml | 273 ++++++++++++++++++ 2 files changed, 275 insertions(+), 1 deletion(-) create mode 100644 src/lib_client_commands/client_event_logging_commands.ml diff --git a/src/bin_client/main_admin.ml b/src/bin_client/main_admin.ml index 612d8ea91bfd..caba560664ec 100644 --- a/src/bin_client/main_admin.ml +++ b/src/bin_client/main_admin.ml @@ -30,6 +30,7 @@ let select_commands _ _ = Client_admin_commands.commands () ; Client_p2p_commands.commands () ; Client_protocols_commands.commands () ; - Client_rpc_commands.commands ]) + Client_rpc_commands.commands ; + Client_event_logging_commands.commands () ]) let () = Client_main_run.run (module Client_config) ~select_commands diff --git a/src/lib_client_commands/client_event_logging_commands.ml b/src/lib_client_commands/client_event_logging_commands.ml new file mode 100644 index 000000000000..b4ac658da12a --- /dev/null +++ b/src/lib_client_commands/client_event_logging_commands.ml @@ -0,0 +1,273 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let group = + Clic.{ name = "event-logging-framework" ; + title = "Commands to inspect the event-logging framework" } + +let date_parameter option_name build = + let open Clic in + parameter (fun _ s -> + let problem fmt = Printf.ksprintf invalid_arg fmt in + try + if String.length s <> 8 then problem "date should be `YYYYMMDD`" ; + String.iteri + (fun idx -> function + | '0' .. '9' -> () + | other -> + problem "character %d is not a digit: '%c'." idx other) + s ; + let month = int_of_string (String.sub s 4 2) - 1 in + if month < 0 then problem "The month cannot be '00'" ; + if month > 11 then problem "The month cannot be more than '12'" ; + let day = int_of_string (String.sub s 6 2) in + if day > 31 then problem "The month cannot be more than '31'" ; + let t = + let tm = + Unix.{ + tm_sec = 0 ; + tm_min = 0 ; + tm_hour = 0 ; + tm_mday = day ; + tm_mon = month; + tm_year = int_of_string (String.sub s 0 4) - 1900; + tm_wday = 0; + tm_yday = 0; + tm_isdst = false } in + Unix.mktime tm |> fst in + return (build t) + with + | Invalid_argument e -> failwith "In `%s %S`, %s" option_name s e + | e -> failwith "Exn: %a" pp_exn e) + +let flat_pp pp o = + Format.( + asprintf "%a" (fun fmt () -> + pp_set_margin fmt 2_000_000 ; + pp fmt o) ()) + +let commands () = + let open Clic in + let command ~desc = command ~group ~desc in + [ + command + ~desc:"Query the events from an event sink." + (args7 + (arg + ~doc:"Filter on event names" + ~long:"names" + ~placeholder:"LIST" + (parameter (fun _ s -> + try return (String.split_on_char ',' s) + with _ -> failwith "List of names cannot be parsed"))) + (arg + ~doc:"Filter on event sections (use '_' for no-section)" + ~long:"sections" + ~placeholder:"LIST" + (parameter (fun _ s -> + try return ( + String.split_on_char ',' s + |> List.map (function "_" -> None | other -> Some other)) + with _ -> failwith "List of sections cannot be parsed"))) + (arg + ~doc:"Filter out events before DATE" + ~long:"since" + ~placeholder:"DATE" + (date_parameter "--since" (fun s -> (`Date (`Ge, s))))) + (arg + ~doc:"Filter out events after DATE" + ~long:"until" + ~placeholder:"DATE" + (date_parameter "--until" (fun s -> (`Date (`Le, s))))) + (switch + ~doc:"Display events as JSON instead of pretty-printing them" + ~long:"as-json" + ()) + (switch + ~doc:"Try to display unknown events" + ~long:"dump-unknown" + ()) + (Scriptable.clic_arg ()) + ) + (prefixes [ "query" ; "events" ; "from" ] + @@ (param + ~name:"Sink-Name" + ~desc:"The URI of the SINK to query" + (parameter (fun _ s -> + try return (Uri.of_string s) + with _ -> failwith "Uri cannot be parsed"))) + + @@ stop) + (fun + (only_names, only_sections, + since, until, as_json, dump_unknown, scriptable) + uri + (cctxt : #Client_context.full) -> + let open Tezos_stdlib_unix in + begin match Uri.scheme uri with + | None | Some "unix-files" -> + let script_row kind date evname data () = + [kind; date; evname; data] in + Scriptable.output_for_human scriptable (fun () -> + cctxt#message "### Events" >>= fun () -> + return_unit) + >>=? fun () -> + let on_unknown = + if not dump_unknown then None else Some (fun path -> + Scriptable.output_row scriptable + ~for_human:(fun () -> + cctxt#message "Unknown: %s" path + >>= fun () -> + Lwt_stream.iter_s + (fun line -> cctxt#message " |%s" line) + (Lwt_io.lines_of_file path) + >>= fun () -> + return_unit) + ~for_script:(script_row "unknown-event" "-" "-" path)) + in + let time_query = + match since, until with + | None, None -> None + | Some a, None | None, Some a -> Some a + | Some a, Some b -> Some (`And (a, b)) in + File_event_sink.Query.fold ?only_names ?on_unknown ?only_sections + ?time_query uri ~init:() + ~f:(fun () ~time_stamp ev -> + let o = + Internal_event.Generic.explode_event ev in + let time_string time_value = + let open Unix in + let tm = gmtime time_value in + Printf.sprintf "%04d%02d%02d-%02d%02d%02d-%04d" + (1900 + tm.tm_year) + (tm.tm_mon + 1) tm.tm_mday + tm.tm_hour tm.tm_min tm.tm_sec + ((time_value -. floor time_value) + *. 10_000. |> int_of_float) + in + let pp fmt o = + if as_json + then Data_encoding.Json.pp fmt o#json + else o#pp fmt () in + Scriptable.output_row scriptable + ~for_human:(fun () -> + cctxt#message "@[<2>* [%s %s]@ %a@]" + (time_string time_stamp) o#name pp o + >>= fun () -> + return_unit) + ~for_script:(fun () -> + let text = flat_pp pp o in + script_row "event" (time_string time_stamp) o#name text ())) + >>=? begin function + | ([], ()) -> return_unit + | (errors_and_warnings, ()) -> + let open Format in + Scriptable.output scriptable + ~for_human:(fun () -> + cctxt#message + "### Some things were not perfect:@.@[<2>%a@]" + (pp_print_list + ~pp_sep:(fun fmt () -> fprintf fmt "@.") + (fun fmt item -> + fprintf fmt "* %a" + File_event_sink.Query.Report.pp item)) + errors_and_warnings + >>= fun () -> + return_unit) + ~for_script:(fun () -> + let make_row e = + let text = flat_pp File_event_sink.Query.Report.pp e in + let tag = + match e with + | `Error _ -> "error" + | `Warning _ -> "warning" in + script_row tag "-" "-" text () + in + List.map make_row errors_and_warnings) + end + | Some other -> + cctxt#message "URI scheme %S not handled as of now." other + >>= fun () -> + return_unit + end + ) ; + command + ~desc:"Display configuration/state information about the \ + internal-event logging framework." + no_options + (prefixes [ "show" ; "event-logging" ] @@ stop) + (fun () (cctxt : #Client_context.full) -> + let pp_event_definitions fmt schs = + let open Format in + pp_open_box fmt 0 ; + pp_print_list + ~pp_sep:(fun fmt () -> fprintf fmt "@;") + (fun fmt obj_schema -> + pp_open_box fmt 2 ; + fprintf fmt "* `%s`:@ " obj_schema#name ; + pp_print_text fmt obj_schema#doc ; + pp_close_box fmt ()) + fmt + schs; + pp_close_box fmt () + in + cctxt#message "Event logging framework:@.Sinks state:@ %a@.Events registered:@ %a" + Internal_event.All_sinks.pp_state () + pp_event_definitions Internal_event.( + All_definitions.get () |> List.map Generic.json_schema) + >>= fun () -> + return_unit + ) ; + command + ~desc:"Output the JSON schema of an internal-event." + no_options + (prefixes [ "output" ; "schema" ; "of" ] + @@ (param + ~name:"Event-Name" + ~desc:"Name of the event" + (parameter (fun _ s -> return s))) + @@ (prefix "to") + @@ (param + ~name:"File-path" + ~desc:"Path to a JSON file" + (parameter (fun _ s -> return s))) + @@ stop) + (fun () event path (cctxt : #Client_context.full) -> + let open Internal_event in + match All_definitions.find ((=) event) with + | None -> + failwith "Event %S not found" event + | Some ev -> + let o = Generic.json_schema ev in + Lwt_io.with_file ~mode:Lwt_io.output path + (fun chan -> + let v = Format.asprintf "%a" Json_schema.pp o#schema in + Lwt_io.write chan v) + >>= fun () -> + cctxt#message "Wrote schema of %s to %s" event path + >>= fun () -> + return_unit + ) ; + ] \ No newline at end of file -- GitLab From 25ff4e037161a2d4b4aa6968c141fd319c69917f Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 11 Jan 2019 12:53:59 -0500 Subject: [PATCH 09/20] Replace legacy logging with `Internal_event` --- src/bin_client/dune | 4 +- src/bin_node/node_config_file.ml | 33 ++- src/bin_node/node_config_file.mli | 5 +- src/bin_node/node_logging.ml | 4 +- src/bin_node/node_logging.mli | 2 +- src/bin_node/node_run_command.ml | 14 +- src/bin_node/node_shared_arg.ml | 6 +- src/bin_node/node_shared_arg.mli | 2 +- src/bin_signer/signer_logging.ml | 3 +- src/bin_signer/signer_logging.mli | 2 +- src/lib_base/base_logging.ml | 2 +- src/lib_base/base_logging.mli | 2 +- src/lib_base/lwt_exit.ml | 18 +- src/lib_base/p2p_peer_id.ml | 4 +- src/lib_base/p2p_peer_id.mli | 1 + src/lib_base/tzPervasives.ml | 2 +- .../scriptable.mli} | 36 ++- .../client_context_unix.ml | 3 +- src/lib_client_base_unix/client_main_run.ml | 7 +- .../client_event_logging_commands.mli} | 2 +- src/lib_event_logging/internal_event.ml | 3 - src/lib_p2p/moving_average.ml | 1 + src/lib_p2p/p2p.ml | 4 +- src/lib_p2p/p2p_discovery.ml | 6 +- src/lib_p2p/p2p_fd.ml | 2 +- src/lib_p2p/p2p_io_scheduler.ml | 5 +- src/lib_p2p/p2p_maintenance.ml | 3 +- src/lib_p2p/p2p_pool.ml | 3 +- src/lib_p2p/p2p_socket.ml | 4 +- src/lib_p2p/p2p_welcome.ml | 3 +- src/lib_p2p/test/test_p2p_banned_peers.ml | 5 +- src/lib_p2p/test/test_p2p_io_scheduler.ml | 6 +- src/lib_p2p/test/test_p2p_ipv6set.ml | 4 +- src/lib_p2p/test/test_p2p_peerset.ml | 4 +- src/lib_p2p/test/test_p2p_pool.ml | 4 +- src/lib_p2p/test/test_p2p_socket.ml | 4 +- .../tezos_protocol_environment.ml | 2 +- src/lib_protocol_updater/updater_logging.ml | 2 +- src/lib_protocol_updater/updater_logging.mli | 2 +- src/lib_rpc_http/RPC_logging.ml | 2 +- src/lib_rpc_http/RPC_logging.mli | 2 +- src/lib_shell/bench/helpers/test.ml | 2 +- src/lib_shell/block_validator.mli | 2 +- src/lib_shell/block_validator_process.ml | 4 +- src/lib_shell/bootstrap_pipeline.ml | 6 +- src/lib_shell/chain_validator.ml | 3 +- src/lib_shell/chain_validator.mli | 2 +- src/lib_shell/distributed_db.ml | 6 +- src/lib_shell/distributed_db_functors.ml | 4 +- src/lib_shell/mempool_peer_worker.ml | 10 +- src/lib_shell/mempool_worker.ml | 6 +- src/lib_shell/node.ml | 64 ++++- src/lib_shell/peer_validator.mli | 2 +- src/lib_shell/prevalidator.mli | 2 +- src/lib_shell/protocol_validator.ml | 3 +- src/lib_shell/test/test_state_checkpoint.ml | 1 - src/lib_shell/validator.ml | 2 +- src/lib_shell/worker.ml | 22 +- src/lib_shell/worker.mli | 4 +- .../block_validator_worker_state.ml | 4 +- .../block_validator_worker_state.mli | 2 +- .../chain_validator_worker_state.ml | 6 +- .../chain_validator_worker_state.mli | 2 +- .../peer_validator_worker_state.ml | 4 +- .../peer_validator_worker_state.mli | 2 +- .../prevalidator_worker_state.ml | 12 +- .../prevalidator_worker_state.mli | 2 +- src/lib_shell_services/state_logging.ml | 2 +- src/lib_shell_services/state_logging.mli | 2 +- src/lib_shell_services/worker_types.ml | 27 +- src/lib_shell_services/worker_types.mli | 4 +- src/lib_signer_backends/ledger.ml | 4 +- src/lib_stdlib/logging.ml | 251 ------------------ src/lib_stdlib/logging.mli | 130 --------- src/lib_stdlib/lwt_utils.ml | 21 +- src/lib_stdlib/lwt_utils.mli | 7 +- src/lib_stdlib_unix/internal_event_unix.ml | 4 +- src/lib_stdlib_unix/internal_event_unix.mli | 4 + .../{logging_unix.ml => lwt_log_sink_unix.ml} | 43 +-- ...logging_unix.mli => lwt_log_sink_unix.mli} | 16 +- src/lib_storage/store_logging.ml | 2 +- src/lib_storage/store_logging.mli | 2 +- .../client_baking_denunciation.ml | 2 +- .../lib_delegate/client_baking_endorsement.ml | 2 +- .../lib_delegate/client_baking_forge.ml | 2 +- .../lib_delegate/client_baking_nonces.ml | 2 +- .../lib_delegate/client_baking_revelation.ml | 2 +- .../lib_delegate/client_baking_scheduling.ml | 3 +- .../lib_protocol/test/helpers/test.ml | 2 +- 89 files changed, 334 insertions(+), 602 deletions(-) rename src/{lib_shell/worker_logging.ml => lib_clic/scriptable.mli} (61%) rename src/{lib_shell/worker_logging.mli => lib_client_commands/client_event_logging_commands.mli} (97%) delete mode 100644 src/lib_stdlib/logging.ml delete mode 100644 src/lib_stdlib/logging.mli rename src/lib_stdlib_unix/{logging_unix.ml => lwt_log_sink_unix.ml} (89%) rename src/lib_stdlib_unix/{logging_unix.mli => lwt_log_sink_unix.mli} (84%) diff --git a/src/bin_client/dune b/src/bin_client/dune index a36e187ea8ec..8b9fa23b3a22 100644 --- a/src/bin_client/dune +++ b/src/bin_client/dune @@ -4,6 +4,7 @@ (libraries tezos-base tezos-rpc-http tezos-shell-services + tezos-shell tezos-client-base tezos-client-commands tezos-client-genesis @@ -22,7 +23,8 @@ -open Tezos_shell_services -open Tezos_client_base -open Tezos_client_commands - -open Tezos_client_base_unix))) + -open Tezos_client_base_unix + -linkall))) (install (section bin) diff --git a/src/bin_node/node_config_file.ml b/src/bin_node/node_config_file.ml index 7046e64e332e..6c0654943931 100644 --- a/src/bin_node/node_config_file.ml +++ b/src/bin_node/node_config_file.ml @@ -39,7 +39,8 @@ type t = { data_dir : string ; p2p : p2p ; rpc : rpc ; - log : Logging_unix.cfg ; + log : Lwt_log_sink_unix.cfg ; + internal_events : Internal_event_unix.Configuration.t ; shell : shell ; } @@ -128,7 +129,8 @@ let default_config = { data_dir = default_data_dir ; p2p = default_p2p ; rpc = default_rpc ; - log = Logging_unix.default_cfg ; + log = Lwt_log_sink_unix.default_cfg ; + internal_events = Internal_event_unix.Configuration.default ; shell = default_shell ; } @@ -364,7 +366,8 @@ let worker_limits_encoding { backlog_size ; backlog_level ; zombie_lifetime ; zombie_memory }) (obj4 (dft "worker_backlog_size" uint16 default_size) - (dft "worker_backlog_level" Logging_unix.level_encoding default_level) + (dft "worker_backlog_level" + Internal_event.Level.encoding default_level) (dft "worker_zombie_lifetime" float default_zombie_lifetime) (dft "worker_zombie_memory" float default_zombie_memory)) @@ -473,11 +476,11 @@ let shell = let encoding = let open Data_encoding in conv - (fun { data_dir ; rpc ; p2p ; log ; shell } -> - (data_dir, rpc, p2p, log, shell)) - (fun (data_dir, rpc, p2p, log, shell) -> - { data_dir ; rpc ; p2p ; log ; shell }) - (obj5 + (fun { data_dir ; rpc ; p2p ; log ; internal_events ; shell } -> + (data_dir, rpc, p2p, log, internal_events, shell)) + (fun (data_dir, rpc, p2p, log, internal_events, shell) -> + { data_dir ; rpc ; p2p ; log ; internal_events ; shell }) + (obj6 (dft "data-dir" ~description: "Location of the data dir on disk." string default_data_dir) @@ -487,8 +490,13 @@ let encoding = (req "p2p" ~description: "Configuration of network parameters" p2p) (dft "log" - ~description: "Configuration of logging parameters" - Logging_unix.cfg_encoding Logging_unix.default_cfg) + ~description: + "Configuration of the Lwt-log sink (part of the logging framework)" + Lwt_log_sink_unix.cfg_encoding Lwt_log_sink_unix.default_cfg) + (dft "internal-events" + ~description: "Configuration of the structured logging framework" + Internal_event_unix.Configuration.encoding + Internal_event_unix.Configuration.default) (dft "shell" ~description: "Configuration of network parameters" shell default_shell)) @@ -592,7 +600,7 @@ let update tls = Option.first_some rpc_tls cfg.rpc.tls ; } - and log : Logging_unix.cfg = { + and log : Lwt_log_sink_unix.cfg = { cfg.log with output = Option.unopt ~default:cfg.log.output log_output ; } @@ -609,7 +617,8 @@ let update bootstrap_threshold } in - return { data_dir ; p2p ; rpc ; log ; shell } + let internal_events = cfg.internal_events in + return { data_dir ; p2p ; rpc ; log ; internal_events ; shell } let resolve_addr ~default_addr ?default_port ?(passive = false) peer = let addr, port = P2p_point.Id.parse_addr_port peer in diff --git a/src/bin_node/node_config_file.mli b/src/bin_node/node_config_file.mli index f0455ace1c01..9cfbdbe3db0b 100644 --- a/src/bin_node/node_config_file.mli +++ b/src/bin_node/node_config_file.mli @@ -28,7 +28,8 @@ type t = { data_dir : string ; p2p : p2p ; rpc : rpc ; - log : Logging_unix.cfg ; + log : Lwt_log_sink_unix.cfg ; + internal_events : Internal_event_unix.Configuration.t ; shell : shell ; } @@ -88,7 +89,7 @@ val update: ?cors_origins:string list -> ?cors_headers:string list -> ?rpc_tls:tls -> - ?log_output:Logging_unix.Output.t -> + ?log_output:Lwt_log_sink_unix.Output.t -> ?bootstrap_threshold:int -> t -> t tzresult Lwt.t diff --git a/src/bin_node/node_logging.ml b/src/bin_node/node_logging.ml index 808ccf519349..ec5fadcc58dd 100644 --- a/src/bin_node/node_logging.ml +++ b/src/bin_node/node_logging.ml @@ -23,4 +23,6 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make(struct let name = "node.main" end) +include Internal_event.Legacy_logging.Make(struct + let name = "node.main" + end) diff --git a/src/bin_node/node_logging.mli b/src/bin_node/node_logging.mli index ede719e2c916..5279e8ee9c3b 100644 --- a/src/bin_node/node_logging.mli +++ b/src/bin_node/node_logging.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.LOG +include Internal_event.Legacy_logging.LOG diff --git a/src/bin_node/node_run_command.ml b/src/bin_node/node_run_command.ml index 5178be1447c5..4b70a76f5bfc 100644 --- a/src/bin_node/node_run_command.ml +++ b/src/bin_node/node_run_command.ml @@ -259,7 +259,8 @@ let run ?verbosity ?sandbox ?checkpoint (config : Node_config_file.t) = match verbosity with | None -> config.log | Some default_level -> { config.log with default_level } in - Logging_unix.init ~cfg:log_cfg () >>= fun () -> + Internal_event_unix.init ~lwt_log_sink:log_cfg + ~configuration:config.internal_events () >>= fun () -> Updater.init (protocol_dir config.data_dir) ; lwt_log_notice "Starting the Tezos node..." >>= fun () -> init_node ?sandbox ?checkpoint config >>=? fun node -> @@ -271,15 +272,16 @@ let run ?verbosity ?sandbox ?checkpoint (config : Node_config_file.t) = lwt_log_notice "Shutting down the RPC server..." >>= fun () -> Lwt_list.iter_s RPC_server.shutdown rpc >>= fun () -> lwt_log_notice "BYE (%d)" x >>= fun () -> - Logging_unix.close () >>= fun () -> + Internal_event_unix.close () >>= fun () -> return_unit let process sandbox verbosity checkpoint args = let verbosity = + let open Internal_event in match verbosity with | [] -> None - | [_] -> Some Logging.Info - | _ -> Some Logging.Debug in + | [_] -> Some Info + | _ -> Some Debug in let run = Node_shared_arg.read_and_patch_config_file ~ignore_bootstrap_peers:(match sandbox with @@ -394,7 +396,9 @@ module Manpage = struct ] let debug = - let log_sections = String.concat " " (List.rev !Logging.sections) in + let log_sections = + String.concat " " + (List.rev !Internal_event.Legacy_logging.sections) in [ `S "DEBUG" ; `P ("The environment variable $(b,TEZOS_LOG) is used to fine-tune \ diff --git a/src/bin_node/node_shared_arg.ml b/src/bin_node/node_shared_arg.ml index 57f70d8d283b..d2b864c83643 100644 --- a/src/bin_node/node_shared_arg.ml +++ b/src/bin_node/node_shared_arg.ml @@ -51,7 +51,7 @@ type t = { cors_origins: string list ; cors_headers: string list ; rpc_tls: Node_config_file.tls option ; - log_output: Logging_unix.Output.t option ; + log_output: Lwt_log_sink_unix.Output.t option ; bootstrap_threshold: int option ; } @@ -139,10 +139,10 @@ end module Term = struct let log_output_converter = - (fun s -> match Logging_unix.Output.of_string s with + (fun s -> match Lwt_log_sink_unix.Output.of_string s with | Some res -> `Ok res | None -> `Error s), - Logging_unix.Output.pp + Lwt_log_sink_unix.Output.pp (* misc args *) diff --git a/src/bin_node/node_shared_arg.mli b/src/bin_node/node_shared_arg.mli index 24b4d1ec8b37..8fb1a0bbc907 100644 --- a/src/bin_node/node_shared_arg.mli +++ b/src/bin_node/node_shared_arg.mli @@ -46,7 +46,7 @@ type t = { cors_origins: string list ; cors_headers: string list ; rpc_tls: Node_config_file.tls option ; - log_output: Logging_unix.Output.t option ; + log_output: Lwt_log_sink_unix.Output.t option ; bootstrap_threshold: int option ; } diff --git a/src/bin_signer/signer_logging.ml b/src/bin_signer/signer_logging.ml index 488e8ee9566d..ffecf903ce73 100644 --- a/src/bin_signer/signer_logging.ml +++ b/src/bin_signer/signer_logging.ml @@ -23,7 +23,8 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.signer" end) +include Internal_event.Legacy_logging.Make_semantic + (struct let name = "client.signer" end) let host_name = Tag.def ~doc:"Host name" "host" Format.pp_print_text let service_name = Tag.def ~doc:"Service name" "service" Format.pp_print_text diff --git a/src/bin_signer/signer_logging.mli b/src/bin_signer/signer_logging.mli index 0d7b2d0e5696..0f90dc6b68f1 100644 --- a/src/bin_signer/signer_logging.mli +++ b/src/bin_signer/signer_logging.mli @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.SEMLOG +include Internal_event.Legacy_logging.SEMLOG val host_name: string Tag.def val service_name: string Tag.def diff --git a/src/lib_base/base_logging.ml b/src/lib_base/base_logging.ml index 0c8a6b140404..51098430177e 100644 --- a/src/lib_base/base_logging.ml +++ b/src/lib_base/base_logging.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make_semantic(struct let name = "base" end) +include Internal_event.Legacy_logging.Make_semantic(struct let name = "base" end) let pp_exn_trace ppf backtrace = if String.length backtrace <> 0 then diff --git a/src/lib_base/base_logging.mli b/src/lib_base/base_logging.mli index f269167ce82a..2b8b5bd4127a 100644 --- a/src/lib_base/base_logging.mli +++ b/src/lib_base/base_logging.mli @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.SEMLOG +include Internal_event.Legacy_logging.SEMLOG val pid : int Tag.def val exn_trace : string Tag.def diff --git a/src/lib_base/lwt_exit.ml b/src/lib_base/lwt_exit.ml index 8fa30b78cd82..aaf20b3b44dc 100644 --- a/src/lib_base/lwt_exit.ml +++ b/src/lib_base/lwt_exit.ml @@ -34,10 +34,16 @@ let () = | Exit -> () | e -> let backtrace = Printexc.get_backtrace () in - Base_logging.(fatal_error Tag.DSL.(fun f -> - f "@[@[Uncaught (asynchronous) exception (%d):@ %a@]%a@]" - -% t event "uncaught_async_exception" - -% s pid (Unix.getpid ()) - -% a exn e - -% a exn_trace backtrace)) ; + let pp_exn_trace ppf backtrace = + if String.length backtrace <> 0 then + Format.fprintf ppf + "@,Backtrace:@, @[%a@]" + Format.pp_print_text backtrace + in + (* TODO Improve this *) + Format.eprintf + "@[@[Uncaught (asynchronous) exception (%d):@ %s@]%a@]@.%!" + (Unix.getpid ()) + (Printexc.to_string e) + pp_exn_trace backtrace ; Lwt.wakeup exit_wakener 1) diff --git a/src/lib_base/p2p_peer_id.ml b/src/lib_base/p2p_peer_id.ml index 66fd43125685..3d9c4bda7429 100644 --- a/src/lib_base/p2p_peer_id.ml +++ b/src/lib_base/p2p_peer_id.ml @@ -36,8 +36,8 @@ let pp_source ppf = function | 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) + include Internal_event.Legacy_logging.Make_semantic + (struct let name = "node.distributed_db.p2p_peer_id" 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 diff --git a/src/lib_base/p2p_peer_id.mli b/src/lib_base/p2p_peer_id.mli index b33239d138b2..0162577226d4 100644 --- a/src/lib_base/p2p_peer_id.mli +++ b/src/lib_base/p2p_peer_id.mli @@ -26,6 +26,7 @@ include Tezos_crypto.S.HASH with type t = Crypto_box.Public_key_hash.t module Logging: sig + include Internal_event.Legacy_logging.SEMLOG val tag: t Tag.def val tag_opt: t option Tag.def val tag_source: t option Tag.def diff --git a/src/lib_base/tzPervasives.ml b/src/lib_base/tzPervasives.ml index de459c1b78e3..6e9c546ba362 100644 --- a/src/lib_base/tzPervasives.ml +++ b/src/lib_base/tzPervasives.ml @@ -69,4 +69,4 @@ module Lwt_exit = Lwt_exit include Utils.Infix include Error_monad -module Internal_event = Internal_event \ No newline at end of file +module Internal_event = Internal_event diff --git a/src/lib_shell/worker_logging.ml b/src/lib_clic/scriptable.mli similarity index 61% rename from src/lib_shell/worker_logging.ml rename to src/lib_clic/scriptable.mli index 253c2c8c0ee1..1ccd667c3875 100644 --- a/src/lib_shell/worker_logging.ml +++ b/src/lib_clic/scriptable.mli @@ -23,4 +23,38 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make_semantic(struct let name = "node.worker" end) +open Error_monad + +(** Manage a common ["--for-script "] option to make the + output of certain commands script-friendly. *) + +type output_format +(** A representation of the output format. *) + +val clic_arg : unit -> (output_format option, _) Clic.arg +(** Command line argument for {!Clic.command} (and the [Clic.args*] + functions). *) + +val output : + ?channel: Lwt_io.output_channel -> + output_format option -> + for_human:(unit -> unit tzresult Lwt.t) -> + for_script:(unit -> string list list) -> + unit tzresult Lwt.t +(** Output a list of rows of data (the result of [for_script ()]) to + [formatter] (default: {!Format.std_formatter}) if the ["--for-script"] + option has been set (is [Some _]), if the format is [None] the function + [~for_human] is called instead. *) + +val output_row : + ?channel: Lwt_io.output_channel -> + output_format option -> + for_human:(unit -> unit tzresult Lwt.t) -> + for_script:(unit -> string list) -> + unit tzresult Lwt.t +(** Same as {!output} but for a single row of data. *) + +val output_for_human : + output_format option -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t +(** [output_for_human fmt_opt for_human] calls [for_human] when + [fmt_opt] is [None]. *) diff --git a/src/lib_client_base_unix/client_context_unix.ml b/src/lib_client_base_unix/client_context_unix.ml index 04c19c12fa68..f82eda20eb01 100644 --- a/src/lib_client_base_unix/client_context_unix.ml +++ b/src/lib_client_base_unix/client_context_unix.ml @@ -25,7 +25,8 @@ (*****************************************************************************) open Client_context -include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.context.unix" end) +include Internal_event.Legacy_logging.Make_semantic + (struct let name = "client.context.unix" end) let filename_tag = Tag.def ~doc:"Filename" "filename" Format.pp_print_string diff --git a/src/lib_client_base_unix/client_main_run.ml b/src/lib_client_base_unix/client_main_run.ml index ff7895b7a672..8c5f08f5ff63 100644 --- a/src/lib_client_base_unix/client_main_run.ml +++ b/src/lib_client_base_unix/client_main_run.ml @@ -92,9 +92,8 @@ let main (if Unix.isatty Unix.stdout then Ansi else Plain) Short) ; ignore Clic.(setup_formatter Format.err_formatter (if Unix.isatty Unix.stderr then Ansi else Plain) Short) ; - Logging_unix.init () >>= fun () -> - Lwt.catch begin fun () -> - begin + Internal_event_unix.init () >>= fun () -> + Lwt.catch begin fun () -> begin C.parse_config_args (new unix_full ~chain:C.default_chain @@ -260,7 +259,7 @@ let main end >>= fun retcode -> Format.pp_print_flush Format.err_formatter () ; Format.pp_print_flush Format.std_formatter () ; - Logging_unix.close () >>= fun () -> + Internal_event_unix.close () >>= fun () -> Lwt.return retcode diff --git a/src/lib_shell/worker_logging.mli b/src/lib_client_commands/client_event_logging_commands.mli similarity index 97% rename from src/lib_shell/worker_logging.mli rename to src/lib_client_commands/client_event_logging_commands.mli index 9626d959f5ba..d50cc7538fbf 100644 --- a/src/lib_shell/worker_logging.mli +++ b/src/lib_client_commands/client_event_logging_commands.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.SEMLOG +val commands: unit -> Client_commands.command list diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index 062823f04364..c28b51cbb8c8 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -23,10 +23,7 @@ (* *) (*****************************************************************************) -(* open TzPervasives → circular dependencies because of legacy-logging usage *) -open Tezos_error_monad open Error_monad -module Data_encoding = Tezos_data_encoding.Data_encoding module List = struct include List include Tezos_stdlib.TzList diff --git a/src/lib_p2p/moving_average.ml b/src/lib_p2p/moving_average.ml index a657fd246458..b93bec9721a9 100644 --- a/src/lib_p2p/moving_average.ml +++ b/src/lib_p2p/moving_average.ml @@ -70,6 +70,7 @@ let worker = lazy begin Lwt.async begin fun () -> Lwt_utils.worker "counter" + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:worker_loop ~cancel:(fun _ -> Lwt.return_unit) end diff --git a/src/lib_p2p/p2p.ml b/src/lib_p2p/p2p.ml index c4c1358af1c8..07c8053e37c5 100644 --- a/src/lib_p2p/p2p.ml +++ b/src/lib_p2p/p2p.ml @@ -24,7 +24,9 @@ (* *) (*****************************************************************************) -include Logging.Make(struct let name = "p2p" end) +include Internal_event.Legacy_logging.Make(struct + let name = "p2p" + end) type 'peer_meta peer_meta_config = 'peer_meta P2p_pool.peer_meta_config = { peer_meta_encoding : 'peer_meta Data_encoding.t ; diff --git a/src/lib_p2p/p2p_discovery.ml b/src/lib_p2p/p2p_discovery.ml index 4cf268e7d9c3..78654d4270da 100644 --- a/src/lib_p2p/p2p_discovery.ml +++ b/src/lib_p2p/p2p_discovery.ml @@ -24,7 +24,9 @@ (* *) (*****************************************************************************) -include Logging.Make (struct let name = "p2p.discovery" end) +include Internal_event.Legacy_logging.Make(struct + let name = "p2p.discovery" + end) type pool = Pool : ('msg, 'meta, 'meta_conn) P2p_pool.t -> pool @@ -138,6 +140,7 @@ module Answer = struct let activate st = st.worker <- Lwt_utils.worker "discovery_answer" + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop st) ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) @@ -243,6 +246,7 @@ module Sender = struct let activate st = st.worker <- Lwt_utils.worker "discovery_sender" + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:begin fun () -> worker_loop Config.initial st end ~cancel:begin fun () -> Lwt_canceler.cancel st.canceler end diff --git a/src/lib_p2p/p2p_fd.ml b/src/lib_p2p/p2p_fd.ml index b1a6c241b871..b56605a30aa6 100644 --- a/src/lib_p2p/p2p_fd.ml +++ b/src/lib_p2p/p2p_fd.ml @@ -35,7 +35,7 @@ let () = Sys.(set_signal sigpipe Signal_ignore) (* Logging facility for the P2P layer *) -module Log = Logging.Make(struct let name = "p2p.fd" end) +module Log = Internal_event.Legacy_logging.Make(struct let name = "p2p.fd" end) type t = { fd : Lwt_unix.file_descr ; diff --git a/src/lib_p2p/p2p_io_scheduler.ml b/src/lib_p2p/p2p_io_scheduler.ml index 0d7d3fc9aeda..fe1578dcc3a8 100644 --- a/src/lib_p2p/p2p_io_scheduler.ml +++ b/src/lib_p2p/p2p_io_scheduler.ml @@ -25,7 +25,9 @@ (* TODO decide whether we need to preallocate buffers or not. *) -include Logging.Make (struct let name = "p2p.io-scheduler" end) +include Internal_event.Legacy_logging.Make (struct + let name = "p2p.io-scheduler" + end) let alpha = 0.2 @@ -178,6 +180,7 @@ module Scheduler(IO : IO) = struct } in st.worker <- Lwt_utils.worker IO.name + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop st) ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ; st diff --git a/src/lib_p2p/p2p_maintenance.ml b/src/lib_p2p/p2p_maintenance.ml index c03e6fd49962..1b152c60199b 100644 --- a/src/lib_p2p/p2p_maintenance.ml +++ b/src/lib_p2p/p2p_maintenance.ml @@ -24,7 +24,7 @@ (* *) (*****************************************************************************) -include Logging.Make (struct let name = "p2p.maintenance" end) +include Internal_event.Legacy_logging.Make (struct let name = "p2p.maintenance" end) type bounds = { min_threshold: int ; @@ -236,6 +236,7 @@ let create ?discovery config bounds pool = { let activate st = st.maintain_worker <- Lwt_utils.worker "maintenance" + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop st) ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ; Option.iter st.discovery ~f:P2p_discovery.activate diff --git a/src/lib_p2p/p2p_pool.ml b/src/lib_p2p/p2p_pool.ml index b03a25f1ba43..95db0c7b45dc 100644 --- a/src/lib_p2p/p2p_pool.ml +++ b/src/lib_p2p/p2p_pool.ml @@ -32,7 +32,7 @@ (* TODO allow to track "requested peer_ids" when we reconnect to a point. *) -include Logging.Make (struct let name = "p2p.connection-pool" end) +include Internal_event.Legacy_logging.Make (struct let name = "p2p.connection-pool" end) type 'msg encoding = Encoding : { tag: int ; @@ -175,6 +175,7 @@ module Answerer = struct } in st.worker <- Lwt_utils.worker "answerer" + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop st) ~cancel:(fun () -> Lwt_canceler.cancel canceler) ; st diff --git a/src/lib_p2p/p2p_socket.ml b/src/lib_p2p/p2p_socket.ml index 99c0db1e7813..f148ce145854 100644 --- a/src/lib_p2p/p2p_socket.ml +++ b/src/lib_p2p/p2p_socket.ml @@ -26,7 +26,7 @@ (* TODO test `close ~wait:true`. *) -include Logging.Make(struct let name = "p2p.connection" end) +include Internal_event.Legacy_logging.Make(struct let name = "p2p.connection" end) module Crypto = struct @@ -408,6 +408,7 @@ module Reader = struct end ; st.worker <- Lwt_utils.worker "reader" + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop st None) ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ; st @@ -533,6 +534,7 @@ module Writer = struct end ; st.worker <- Lwt_utils.worker "writer" + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop st) ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ; st diff --git a/src/lib_p2p/p2p_welcome.ml b/src/lib_p2p/p2p_welcome.ml index f0edecc0a342..29184a65f80f 100644 --- a/src/lib_p2p/p2p_welcome.ml +++ b/src/lib_p2p/p2p_welcome.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -include Logging.Make (struct let name = "p2p.welcome" end) +include Internal_event.Legacy_logging.Make (struct let name = "p2p.welcome" end) type pool = Pool : ('msg, 'meta, 'meta_conn) P2p_pool.t -> pool @@ -86,6 +86,7 @@ let create ?addr ~backlog pool port = let activate st = st.worker <- Lwt_utils.worker "welcome" + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop st) ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) diff --git a/src/lib_p2p/test/test_p2p_banned_peers.ml b/src/lib_p2p/test/test_p2p_banned_peers.ml index 94eccdc73df8..3022935d1082 100644 --- a/src/lib_p2p/test/test_p2p_banned_peers.ml +++ b/src/lib_p2p/test/test_p2p_banned_peers.ml @@ -23,7 +23,10 @@ (* *) (*****************************************************************************) -include Logging.Make (struct let name = "test-p2p-banned_peers" end) +include + Internal_event.Legacy_logging.Make (struct + let name = "test-p2p-banned_peers" + end) let assert_equal_bool ~msg a b = if a <> b then Alcotest.fail msg diff --git a/src/lib_p2p/test/test_p2p_io_scheduler.ml b/src/lib_p2p/test/test_p2p_io_scheduler.ml index cb7a687565af..9ae1a480050f 100644 --- a/src/lib_p2p/test/test_p2p_io_scheduler.ml +++ b/src/lib_p2p/test/test_p2p_io_scheduler.ml @@ -23,7 +23,9 @@ (* *) (*****************************************************************************) -include Logging.Make (struct let name = "test-p2p-io-scheduler" end) +include Internal_event.Legacy_logging.Make (struct + let name = "test-p2p-io-scheduler" + end) exception Error of error list @@ -157,7 +159,7 @@ let run ?max_download_speed ?max_upload_speed ~read_buffer_size ?read_queue_size ?write_queue_size addr port time n = - Logging_unix.init () >>= fun () -> + Internal_event_unix.init () >>= fun () -> listen ?port addr >>= fun (main_socket, port) -> Process.detach ~prefix:"server: " begin fun _ -> server diff --git a/src/lib_p2p/test/test_p2p_ipv6set.ml b/src/lib_p2p/test/test_p2p_ipv6set.ml index 2cb96445e7c1..a72fa948873c 100644 --- a/src/lib_p2p/test/test_p2p_ipv6set.ml +++ b/src/lib_p2p/test/test_p2p_ipv6set.ml @@ -23,7 +23,9 @@ (* *) (*****************************************************************************) -include Logging.Make (struct let name = "test-p2p-banned_ip" end) +include + Internal_event.Legacy_logging.Make + (struct let name = "test-p2p-banned_ip" end) let assert_equal ?(eq = (=)) ?prn ~msg a b = let msg = match prn with diff --git a/src/lib_p2p/test/test_p2p_peerset.ml b/src/lib_p2p/test/test_p2p_peerset.ml index 9fce3940d8c1..84991283f00f 100644 --- a/src/lib_p2p/test/test_p2p_peerset.ml +++ b/src/lib_p2p/test/test_p2p_peerset.ml @@ -23,7 +23,9 @@ (* *) (*****************************************************************************) -include Logging.Make (struct let name = "test-p2p-banned_peers" end) +include + Internal_event.Legacy_logging.Make + (struct let name = "test-p2p-banned_peers" end) let assert_equal_bool ~msg a b = if a <> b then Alcotest.fail msg diff --git a/src/lib_p2p/test/test_p2p_pool.ml b/src/lib_p2p/test/test_p2p_pool.ml index 2cc0609fe8bc..239b53a2291a 100644 --- a/src/lib_p2p/test/test_p2p_pool.ml +++ b/src/lib_p2p/test/test_p2p_pool.ml @@ -24,7 +24,9 @@ (* *) (*****************************************************************************) -include Logging.Make (struct let name = "test.p2p.connection-pool" end) +include + Internal_event.Legacy_logging.Make + (struct let name = "test.p2p.connection-pool" end) type message = | Ping diff --git a/src/lib_p2p/test/test_p2p_socket.ml b/src/lib_p2p/test/test_p2p_socket.ml index 6d363db299de..d6986733f747 100644 --- a/src/lib_p2p/test/test_p2p_socket.ml +++ b/src/lib_p2p/test/test_p2p_socket.ml @@ -24,7 +24,9 @@ (* *) (*****************************************************************************) -include Logging.Make (struct let name = "test.p2p.connection" end) +include + Internal_event.Legacy_logging.Make + (struct let name = "test.p2p.connection" end) let addr = ref Ipaddr.V6.localhost diff --git a/src/lib_protocol_environment/tezos_protocol_environment.ml b/src/lib_protocol_environment/tezos_protocol_environment.ml index 54c85d8138ce..d5c014d66377 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.ml +++ b/src/lib_protocol_environment/tezos_protocol_environment.ml @@ -605,7 +605,7 @@ module Make (Context : CONTEXT) = struct let canonical_encoding_v1 = canonical_encoding_v1 let canonical_encoding = canonical_encoding_v0 end - module Logging = Logging.Make(Param) + module Logging = Internal_event.Legacy_logging.Make(Param) module Updater = struct diff --git a/src/lib_protocol_updater/updater_logging.ml b/src/lib_protocol_updater/updater_logging.ml index 7178afd62e6f..85882d4062c0 100644 --- a/src/lib_protocol_updater/updater_logging.ml +++ b/src/lib_protocol_updater/updater_logging.ml @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make(struct let name = "updater" end) +include Internal_event.Legacy_logging.Make(struct let name = "updater" end) diff --git a/src/lib_protocol_updater/updater_logging.mli b/src/lib_protocol_updater/updater_logging.mli index ede719e2c916..5279e8ee9c3b 100644 --- a/src/lib_protocol_updater/updater_logging.mli +++ b/src/lib_protocol_updater/updater_logging.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.LOG +include Internal_event.Legacy_logging.LOG diff --git a/src/lib_rpc_http/RPC_logging.ml b/src/lib_rpc_http/RPC_logging.ml index 3c324264dfd0..26ab83b33dff 100644 --- a/src/lib_rpc_http/RPC_logging.ml +++ b/src/lib_rpc_http/RPC_logging.ml @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make(struct let name = "rpc" end) +include Internal_event.Legacy_logging.Make(struct let name = "rpc" end) diff --git a/src/lib_rpc_http/RPC_logging.mli b/src/lib_rpc_http/RPC_logging.mli index ede719e2c916..5279e8ee9c3b 100644 --- a/src/lib_rpc_http/RPC_logging.mli +++ b/src/lib_rpc_http/RPC_logging.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.LOG +include Internal_event.Legacy_logging.LOG diff --git a/src/lib_shell/bench/helpers/test.ml b/src/lib_shell/bench/helpers/test.ml index 63d2563887c7..0482df845ffb 100644 --- a/src/lib_shell/bench/helpers/test.ml +++ b/src/lib_shell/bench/helpers/test.ml @@ -29,7 +29,7 @@ let tztest name speed f = f () >>= function | Ok () -> Lwt.return_unit | Error err -> - Tezos_stdlib_unix.Logging_unix.close () >>= fun () -> + Tezos_stdlib_unix.Internal_event_unix.close () >>= fun () -> Format.eprintf "WWW %a@." pp_print_error err ; Lwt.fail Alcotest.Test_error end diff --git a/src/lib_shell/block_validator.mli b/src/lib_shell/block_validator.mli index b3d104e9ab8c..f58a2c8fcb01 100644 --- a/src/lib_shell/block_validator.mli +++ b/src/lib_shell/block_validator.mli @@ -61,4 +61,4 @@ val status: t -> Worker_types.worker_status val pending_requests : t -> (Time.t * Block_validator_worker_state.Request.view) list val current_request : t -> (Time.t * Time.t * Block_validator_worker_state.Request.view) option -val last_events : t -> (Lwt_log_core.level * Block_validator_worker_state.Event.t list) list +val last_events : t -> (Internal_event.level * Block_validator_worker_state.Event.t list) list diff --git a/src/lib_shell/block_validator_process.ml b/src/lib_shell/block_validator_process.ml index 58a699b323bf..eb8ea1507c72 100644 --- a/src/lib_shell/block_validator_process.ml +++ b/src/lib_shell/block_validator_process.ml @@ -32,7 +32,9 @@ let get_context index hash = (** The standard block validation method *) module Seq_validator = struct - include Logging.Make (struct let name = "validation_process.sequential" end) + include Internal_event.Legacy_logging.Make (struct + let name = "validation_process.sequential" + end) type validation_context = { context_index : Context.index ; diff --git a/src/lib_shell/bootstrap_pipeline.ml b/src/lib_shell/bootstrap_pipeline.ml index c5f0a18c1473..5d1ae73628c8 100644 --- a/src/lib_shell/bootstrap_pipeline.ml +++ b/src/lib_shell/bootstrap_pipeline.ml @@ -23,7 +23,8 @@ (* *) (*****************************************************************************) -include Logging.Make_semantic(struct let name = "node.validator.bootstrap_pipeline" end) +include Internal_event.Legacy_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 @@ -316,18 +317,21 @@ let create Lwt_utils.worker (Format.asprintf "bootstrap_pipeline-headers_fetch.%a.%a" P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash) + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> headers_fetch_worker_loop pipeline) ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ; pipeline.operations_fetch_worker <- Lwt_utils.worker (Format.asprintf "bootstrap_pipeline-operations_fetch.%a.%a" P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash) + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> operations_fetch_worker_loop pipeline) ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ; pipeline.validation_worker <- Lwt_utils.worker (Format.asprintf "bootstrap_pipeline-validation.%a.%a" P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash) + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> validation_worker_loop pipeline) ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ; pipeline diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index c02ead2fe326..145ab261016f 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -26,7 +26,8 @@ open Chain_validator_worker_state -module Log = Tezos_stdlib.Logging.Make(struct let name = "node.chain_validator" end) +module Log = + Internal_event.Legacy_logging.Make(struct let name = "node.chain_validator" end) module Name = struct type t = Chain_id.t diff --git a/src/lib_shell/chain_validator.mli b/src/lib_shell/chain_validator.mli index 3bf90dfaeb91..9b5f51502801 100644 --- a/src/lib_shell/chain_validator.mli +++ b/src/lib_shell/chain_validator.mli @@ -70,4 +70,4 @@ val status: t -> Worker_types.worker_status val pending_requests : t -> (Time.t * Chain_validator_worker_state.Request.view) list val current_request : t -> (Time.t * Time.t * Chain_validator_worker_state.Request.view) option -val last_events : t -> (Lwt_log_core.level * Chain_validator_worker_state.Event.t list) list +val last_events : t -> (Internal_event.level * Chain_validator_worker_state.Event.t list) list diff --git a/src/lib_shell/distributed_db.ml b/src/lib_shell/distributed_db.ml index 645f7f8ee0fe..041973fac685 100644 --- a/src/lib_shell/distributed_db.ml +++ b/src/lib_shell/distributed_db.ml @@ -26,8 +26,6 @@ module Message = Distributed_db_message -include Logging.Make(struct let name = "node.distributed_db" end) - type p2p = (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.net type connection = (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.connection @@ -514,7 +512,8 @@ module P2p_reader = struct f chain_db module Handle_msg_Logging = - Tezos_stdlib.Logging.Make_semantic(struct let name = "node.distributed_db.p2p_reader" end) + Internal_event.Legacy_logging.Make_semantic + (struct let name = "node.distributed_db.p2p_reader" end) let handle_msg global_db state msg = @@ -799,6 +798,7 @@ module P2p_reader = struct Lwt_utils.worker (Format.asprintf "db_network_reader.%a" P2p_peer.Id.pp_short gid) + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop db state) ~cancel:(fun () -> Lwt_canceler.cancel canceler) ; P2p_peer.Table.add db.p2p_readers gid state diff --git a/src/lib_shell/distributed_db_functors.ml b/src/lib_shell/distributed_db_functors.ml index af504254e5e8..f7981d0e4939 100644 --- a/src/lib_shell/distributed_db_functors.ml +++ b/src/lib_shell/distributed_db_functors.ml @@ -365,7 +365,8 @@ module Make_request_scheduler end = struct - include Logging.Make_semantic(struct let name = "node.distributed_db.scheduler." ^ Hash.name end) + include Internal_event.Legacy_logging.Make_semantic + (struct let name = "node.distributed_db.scheduler." ^ Hash.name end) type key = Hash.t @@ -604,6 +605,7 @@ end = struct } in state.worker <- Lwt_utils.worker "db_request_scheduler" + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop state) ~cancel:(fun () -> Lwt_canceler.cancel state.canceler) ; state diff --git a/src/lib_shell/mempool_peer_worker.ml b/src/lib_shell/mempool_peer_worker.ml index 9f7c32000ba4..8c2800d775d8 100644 --- a/src/lib_shell/mempool_peer_worker.ml +++ b/src/lib_shell/mempool_peer_worker.ml @@ -97,7 +97,8 @@ module Make (Static: STATIC) (Mempool_worker: Mempool_worker.T) (function Mempool_result result -> Some result | _ -> None) (fun result -> Mempool_result result) ] - module Log = Tezos_stdlib.Logging.Make(struct + module Log = + Internal_event.Legacy_logging.Make (struct let name = "node.mempool.peer_worker" end) @@ -277,10 +278,11 @@ module Make (Static: STATIC) (Mempool_worker: Mempool_worker.T) | End_error of (Request.view * Worker_types.request_status * error list) let level req = + let open Internal_event in match req with - | Start _ -> Logging.Info - | End_ok _ -> Logging.Info - | End_error _ -> Logging.Error + | Start _ -> Info + | End_ok _ -> Info + | End_error _ -> Error let encoding = let open Data_encoding in diff --git a/src/lib_shell/mempool_worker.ml b/src/lib_shell/mempool_worker.ml index d680a4e86245..ecf3207bf0f4 100644 --- a/src/lib_shell/mempool_worker.ml +++ b/src/lib_shell/mempool_worker.ml @@ -146,7 +146,7 @@ module Make(Static: STATIC)(Proto: Registered_protocol.T) (req "protocol_data" Proto.operation_data_encoding) ) - module Log = Tezos_stdlib.Logging.Make(struct + module Log = Internal_event.Legacy_logging.Make(struct let name = "node.mempool_validator" end) @@ -188,8 +188,8 @@ module Make(Static: STATIC)(Proto: Registered_protocol.T) let level req = match req with - | Debug _ -> Logging.Debug - | Request _ -> Logging.Info + | Debug _ -> Internal_event.Debug + | Request _ -> Internal_event.Info let encoding = let open Data_encoding in diff --git a/src/lib_shell/node.ml b/src/lib_shell/node.ml index 6193d21de3bc..b5f4ffb5c0ce 100644 --- a/src/lib_shell/node.ml +++ b/src/lib_shell/node.ml @@ -25,7 +25,49 @@ (*****************************************************************************) open Lwt.Infix -open Worker_logging +open Tezos_base + +module Initialization_event = struct + type t = { + time_stamp : float ; + status : [ `P2p_layer_disabled | `Bootstrapping | `P2p_maintain_started ] ; + } + let status_names = [ + "p2p_layer_disabled", `P2p_layer_disabled ; + "bootstrapping", `Bootstrapping ; + "p2p_maintain_started", `P2p_maintain_started ; + ] + module Definition = struct + let name = "shell-node" + type nonrec t = t + let encoding = + let open Data_encoding in + let v0_encoding = + conv + (function { time_stamp ; status } -> time_stamp, status) + (fun (time_stamp, status) -> { time_stamp ; status } ) + (obj2 + (req "time-stamp" float) + (req "status" + (string_enum status_names))) in + With_version.(encoding ~name (first_version v0_encoding)) + let pp ppf { status ; _ } = + Format.fprintf ppf "%s initialization: %s" + name (List.find (fun (_, s) -> s = status) status_names |> fst) + let doc = "Status of the initialization of the P2P layer." + let legacy_section _ = Lwt_log_core.Section.make "node.worker" + let level _ = Internal_event.Notice + end + module Event = Internal_event.Make(Definition) + let lwt_emit status = + let time_stamp = Unix.gettimeofday () in + Event.emit (fun () -> { time_stamp ; status }) >>= function + | Ok () -> Lwt.return_unit + | Error el -> + Format.kasprintf Lwt.fail_with "Initialization_event.emit: %a" + pp_print_error el +end + type t = { state: State.t ; @@ -63,14 +105,12 @@ let init_p2p ?(sandboxed = false) p2p_params = match p2p_params with | None -> let c_meta = init_connection_metadata None in - lwt_log_notice Tag.DSL.(fun f -> - f "P2P layer is disabled" -% t event "p2p_disabled") >>= fun () -> + Initialization_event.lwt_emit `P2p_layer_disabled >>= fun () -> return (P2p.faked_network Distributed_db_message.cfg 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 Tag.DSL.(fun f -> - f "bootstrapping chain..." -% t event "bootstrapping_chain") >>= fun () -> + Initialization_event.lwt_emit `Bootstrapping >>= fun () -> let message_cfg = if sandboxed then { Distributed_db_message.cfg with @@ -83,6 +123,7 @@ let init_p2p ?(sandboxed = false) p2p_params = conn_metadata_cfg message_cfg >>=? fun p2p -> Lwt.async (fun () -> P2p.maintain p2p) ; + Initialization_event.lwt_emit `P2p_maintain_started >>= fun () -> return p2p type config = { @@ -123,7 +164,7 @@ let default_block_validator_limits = { protocol_timeout = 120. ; worker_limits = { backlog_size = 1000 ; - backlog_level = Logging.Debug ; + backlog_level = Internal_event.Debug ; zombie_lifetime = 3600. ; zombie_memory = 1800. ; } @@ -133,7 +174,7 @@ let default_prevalidator_limits = { max_refused_operations = 1000 ; worker_limits = { backlog_size = 1000 ; - backlog_level = Logging.Info ; + backlog_level = Internal_event.Info ; zombie_lifetime = 600. ; zombie_memory = 120. ; } @@ -145,7 +186,7 @@ let default_peer_validator_limits = { new_head_request_timeout = 90. ; worker_limits = { backlog_size = 1000 ; - backlog_level = Logging.Info ; + backlog_level = Internal_event.Info ; zombie_lifetime = 600. ; zombie_memory = 120. ; } @@ -154,7 +195,7 @@ let default_chain_validator_limits = { bootstrap_threshold = 4 ; worker_limits = { backlog_size = 1000 ; - backlog_level = Logging.Info ; + backlog_level = Internal_event.Info ; zombie_lifetime = 600. ; zombie_memory = 120. ; } @@ -170,7 +211,12 @@ let may_update_checkpoint chain_state checkpoint = Chain.set_head chain_state new_head >>= fun _old_head -> State.Chain.set_checkpoint chain_state checkpoint +module Local_logging = + Internal_event.Legacy_logging.Make_semantic + (struct let name = "node.worker" end) + let store_known_protocols state = + let open Local_logging in let embedded_protocols = Registered_protocol.list_embedded () in Lwt_list.iter_s (fun protocol_hash -> diff --git a/src/lib_shell/peer_validator.mli b/src/lib_shell/peer_validator.mli index 416a3a6bb8f2..fec0447ae893 100644 --- a/src/lib_shell/peer_validator.mli +++ b/src/lib_shell/peer_validator.mli @@ -54,4 +54,4 @@ val running_workers: unit -> ((Chain_id.t * P2p_peer.Id.t) * t) list val status: t -> Worker_types.worker_status val current_request : t -> (Time.t * Time.t * Peer_validator_worker_state.Request.view) option -val last_events : t -> (Lwt_log_core.level * Peer_validator_worker_state.Event.t list) list +val last_events : t -> (Internal_event.level * Peer_validator_worker_state.Event.t list) list diff --git a/src/lib_shell/prevalidator.mli b/src/lib_shell/prevalidator.mli index e6050486a542..a879e1785523 100644 --- a/src/lib_shell/prevalidator.mli +++ b/src/lib_shell/prevalidator.mli @@ -106,6 +106,6 @@ val parameters: t -> limits * Distributed_db.chain_db val status: t -> Worker_types.worker_status val pending_requests : t -> (Time.t * Prevalidator_worker_state.Request.view) list val current_request : t -> (Time.t * Time.t * Prevalidator_worker_state.Request.view) option -val last_events : t -> (Lwt_log_core.level * Prevalidator_worker_state.Event.t list) list +val last_events : t -> (Internal_event.level * Prevalidator_worker_state.Event.t list) list val rpc_directory : t option RPC_directory.t diff --git a/src/lib_shell/protocol_validator.ml b/src/lib_shell/protocol_validator.ml index 7b0e59949022..385d570828a5 100644 --- a/src/lib_shell/protocol_validator.ml +++ b/src/lib_shell/protocol_validator.ml @@ -25,7 +25,7 @@ open Validation_errors -include Logging.Make_semantic(struct let name = "node.validator.block" end) +include Internal_event.Legacy_logging.Make_semantic(struct let name = "node.validator.block" end) type 'a request = | Request_validation: { @@ -107,6 +107,7 @@ let create db = end ; bv.worker <- Lwt_utils.worker "block_validator" + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop bv) ~cancel:(fun () -> Lwt_canceler.cancel bv.canceler) ; bv diff --git a/src/lib_shell/test/test_state_checkpoint.ml b/src/lib_shell/test/test_state_checkpoint.ml index d92d770d353c..7ac77c0e04dc 100644 --- a/src/lib_shell/test/test_state_checkpoint.ml +++ b/src/lib_shell/test/test_state_checkpoint.ml @@ -509,7 +509,6 @@ let wrap (n, f) = wrap_state_init f dir >>= function | Ok () -> Lwt.return_unit | Error error -> - Tezos_stdlib_unix.Logging_unix.close () >>= fun () -> Format.eprintf "WWW %a@." pp_print_error error ; Lwt.fail Alcotest.Test_error end diff --git a/src/lib_shell/validator.ml b/src/lib_shell/validator.ml index 79fe00d0c9fb..69e56b2a22f3 100644 --- a/src/lib_shell/validator.ml +++ b/src/lib_shell/validator.ml @@ -24,7 +24,7 @@ (* *) (*****************************************************************************) -include Logging.Make_semantic(struct let name = "node.validator" end) +include Internal_event.Legacy_logging.Make_semantic(struct let name = "node.validator" end) type t = { diff --git a/src/lib_shell/worker.ml b/src/lib_shell/worker.ml index 344e9563e3a7..00defee8c9e1 100644 --- a/src/lib_shell/worker.ml +++ b/src/lib_shell/worker.ml @@ -34,7 +34,7 @@ end module type EVENT = sig type t - val level : t -> Logging.level + val level : t -> Internal_event.level val encoding : t Data_encoding.t val pp : Format.formatter -> t -> unit end @@ -228,7 +228,7 @@ module type T = sig val state : _ t -> Types.state (** Access the event backlog. *) - val last_events : _ t -> (Logging.level * Event.t list) list + val last_events : _ t -> (Internal_event.level * Event.t list) list (** Introspect the message queue, gives the times requests were pushed. *) val pending_requests : _ queue t -> (Time.t * Request.view) list @@ -291,8 +291,8 @@ module Make mutable (* only for init *) worker : unit Lwt.t ; mutable (* only for init *) state : Types.state option ; buffer : 'kind buffer ; - event_log : (Logging.level * Event.t Ring.t) list ; - logger : (module Logging.LOG) ; + event_log : (Internal_event.level * Event.t Ring.t) list ; + logger : (module Internal_event.Legacy_logging.LOG) ; canceler : Lwt_canceler.t ; name : Name.t ; id : int ; @@ -537,12 +537,12 @@ module Make let name_s = Format.asprintf "%a" Name.pp name in let full_name = - if name_s = "" then base_name else Format.asprintf "%s(%s)" base_name name_s in + if name_s = "" then base_name else Format.asprintf "%s_%s" base_name name_s in let id = table.last_id <- table.last_id + 1 ; table.last_id in let id_name = - if name_s = "" then base_name else Format.asprintf "%s(%d)" base_name id in + if name_s = "" then base_name else Format.asprintf "%s_%d" base_name id in if Hashtbl.mem table.instances name then invalid_arg (Format.asprintf "Worker.launch: duplicate worker %s" full_name) ; let canceler = Lwt_canceler.create () in @@ -556,9 +556,14 @@ module Make Dropbox_buffer (Lwt_dropbox.create ()) in let event_log = let levels = - [ Logging.Debug ; Info ; Notice ; Warning ; Error ; Fatal ] in + Internal_event.[ + Debug ; Info ; Notice ; Warning ; Error ; Fatal + ] in List.map (fun l -> l, Ring.create limits.backlog_size) levels in - let module Logger = Logging.Make_unregistered(struct let name = id_name end) in + let module Logger = + Internal_event.Legacy_logging.Make(struct + let name = id_name + end) in let w = { limits ; parameters ; name ; canceler ; table ; buffer ; logger = (module Logger) ; state = None ; id ; @@ -579,6 +584,7 @@ module Make w.worker <- Lwt_utils.worker full_name + ~on_event:Internal_event.Lwt_worker_event.on_event ~run:(fun () -> worker_loop (module Handlers) w) ~cancel:(fun () -> Lwt_canceler.cancel w.canceler) ; return w diff --git a/src/lib_shell/worker.mli b/src/lib_shell/worker.mli index 54288e623c31..b73dd108d7e0 100644 --- a/src/lib_shell/worker.mli +++ b/src/lib_shell/worker.mli @@ -58,7 +58,7 @@ module type EVENT = sig Events can be ignored for logging w.r.t. the global node configuration. Events can be ignored for introspection w.r.t. to the worker's {!Worker_types.limits}. *) - val level : t -> Logging.level + val level : t -> Internal_event.level (** Serializer for the introspection RPCs *) val encoding : t Data_encoding.t @@ -271,7 +271,7 @@ module type T = sig val state : _ t -> Types.state (** Access the event backlog. *) - val last_events : _ t -> (Logging.level * Event.t list) list + val last_events : _ t -> (Internal_event.level * Event.t list) list (** Introspect the message queue, gives the times requests were pushed. *) val pending_requests : _ queue t -> (Time.t * Request.view) list diff --git a/src/lib_shell_services/block_validator_worker_state.ml b/src/lib_shell_services/block_validator_worker_state.ml index 4c93d26cd5bb..825d1d11b8ff 100644 --- a/src/lib_shell_services/block_validator_worker_state.ml +++ b/src/lib_shell_services/block_validator_worker_state.ml @@ -58,9 +58,9 @@ module Event = struct let level req = match req with - | Debug _ -> Logging.Debug + | Debug _ -> Internal_event.Debug | Validation_success _ - | Validation_failure _ -> Logging.Notice + | Validation_failure _ -> Internal_event.Notice let encoding = let open Data_encoding in diff --git a/src/lib_shell_services/block_validator_worker_state.mli b/src/lib_shell_services/block_validator_worker_state.mli index 89c0e3578b34..98c6d33e3fbe 100644 --- a/src/lib_shell_services/block_validator_worker_state.mli +++ b/src/lib_shell_services/block_validator_worker_state.mli @@ -38,7 +38,7 @@ module Event : sig | Validation_success of Request.view * Worker_types.request_status | Validation_failure of Request.view * Worker_types.request_status * error list | Debug of string - val level : t -> Logging.level + val level : t -> Internal_event.level val encoding : t Data_encoding.encoding val pp : Format.formatter -> t -> unit end diff --git a/src/lib_shell_services/chain_validator_worker_state.ml b/src/lib_shell_services/chain_validator_worker_state.ml index be545db31ece..317979072e2e 100644 --- a/src/lib_shell_services/chain_validator_worker_state.ml +++ b/src/lib_shell_services/chain_validator_worker_state.ml @@ -46,10 +46,10 @@ module Event = struct let level = function | Processed_block req -> begin match req.update with - | Ignored_head -> Logging.Info - | Branch_switch | Head_incrememt -> Logging.Notice + | Ignored_head -> Internal_event.Info + | Branch_switch | Head_incrememt -> Internal_event.Notice end - | Could_not_switch_testchain _ -> Logging.Error + | Could_not_switch_testchain _ -> Internal_event.Error let encoding = let open Data_encoding in diff --git a/src/lib_shell_services/chain_validator_worker_state.mli b/src/lib_shell_services/chain_validator_worker_state.mli index 5fa936ef74ce..3594f6c5b443 100644 --- a/src/lib_shell_services/chain_validator_worker_state.mli +++ b/src/lib_shell_services/chain_validator_worker_state.mli @@ -41,7 +41,7 @@ module Event : sig update : update ; fitness : Fitness.t } | Could_not_switch_testchain of error list - val level : t -> Logging.level + val level : t -> Internal_event.level val encoding : t Data_encoding.encoding val pp : Format.formatter -> t -> unit end diff --git a/src/lib_shell_services/peer_validator_worker_state.ml b/src/lib_shell_services/peer_validator_worker_state.ml index ee6dba842b94..e447d5b6b3ca 100644 --- a/src/lib_shell_services/peer_validator_worker_state.ml +++ b/src/lib_shell_services/peer_validator_worker_state.ml @@ -60,8 +60,8 @@ module Event = struct let level req = match req with - | Debug _ -> Logging.Debug - | Request _ -> Logging.Info + | Debug _ -> Internal_event.Debug + | Request _ -> Internal_event.Info let encoding = let open Data_encoding in diff --git a/src/lib_shell_services/peer_validator_worker_state.mli b/src/lib_shell_services/peer_validator_worker_state.mli index a9faf9cb7e95..4d696964e39e 100644 --- a/src/lib_shell_services/peer_validator_worker_state.mli +++ b/src/lib_shell_services/peer_validator_worker_state.mli @@ -35,7 +35,7 @@ module Event : sig type t = | Request of (Request.view * Worker_types.request_status * error list option) | Debug of string - val level : t -> Logging.level + val level : t -> Internal_event.level val encoding : t Data_encoding.encoding val pp : Format.formatter -> t -> unit end diff --git a/src/lib_shell_services/prevalidator_worker_state.ml b/src/lib_shell_services/prevalidator_worker_state.ml index e9f6955246a0..b55aaf8531ea 100644 --- a/src/lib_shell_services/prevalidator_worker_state.ml +++ b/src/lib_shell_services/prevalidator_worker_state.ml @@ -109,12 +109,12 @@ module Event = struct let level req = let open Request in match req with - | Debug _ -> Logging.Debug - | Request (View (Flush _), _, _) -> Logging.Notice - | Request (View (Notify _), _, _) -> Logging.Debug - | Request (View (Inject _), _, _) -> Logging.Notice - | Request (View (Arrived _), _, _) -> Logging.Debug - | Request (View Advertise, _, _) -> Logging.Debug + | Debug _ -> Internal_event.Debug + | Request (View (Flush _), _, _) -> Internal_event.Notice + | Request (View (Notify _), _, _) -> Internal_event.Debug + | Request (View (Inject _), _, _) -> Internal_event.Notice + | Request (View (Arrived _), _, _) -> Internal_event.Debug + | Request (View Advertise, _, _) -> Internal_event.Debug let encoding = let open Data_encoding in diff --git a/src/lib_shell_services/prevalidator_worker_state.mli b/src/lib_shell_services/prevalidator_worker_state.mli index b0db4d9be4e2..00d6828587b8 100644 --- a/src/lib_shell_services/prevalidator_worker_state.mli +++ b/src/lib_shell_services/prevalidator_worker_state.mli @@ -40,7 +40,7 @@ module Event : sig type t = | Request of (Request.view * Worker_types.request_status * error list option) | Debug of string - val level : t -> Logging.level + val level : t -> Internal_event.level val encoding : t Data_encoding.t val pp : Format.formatter -> t -> unit end diff --git a/src/lib_shell_services/state_logging.ml b/src/lib_shell_services/state_logging.ml index bf90c297aeee..7c54c431a0cb 100644 --- a/src/lib_shell_services/state_logging.ml +++ b/src/lib_shell_services/state_logging.ml @@ -23,6 +23,6 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make_semantic(struct let name = "node.state" end) +include Internal_event.Legacy_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_services/state_logging.mli b/src/lib_shell_services/state_logging.mli index 787883155802..a529af64c1b9 100644 --- a/src/lib_shell_services/state_logging.mli +++ b/src/lib_shell_services/state_logging.mli @@ -23,6 +23,6 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.SEMLOG +include Internal_event.Legacy_logging.SEMLOG val chain_id: Chain_id.t Tag.def diff --git a/src/lib_shell_services/worker_types.ml b/src/lib_shell_services/worker_types.ml index b65ff7d14ed8..c9df7ee3c480 100644 --- a/src/lib_shell_services/worker_types.ml +++ b/src/lib_shell_services/worker_types.ml @@ -23,30 +23,9 @@ (* *) (*****************************************************************************) -let level_encoding = - let open Logging in - let open Data_encoding in - conv - (function - | Fatal -> "fatal" - | Error -> "error" - | Warning -> "warning" - | Notice -> "notice" - | Info -> "info" - | Debug -> "debug") - (function - | "error" -> Error - | "warn" -> Warning - | "notice" -> Notice - | "info" -> Info - | "debug" -> Debug - | "fatal" -> Fatal - | _ -> invalid_arg "Logging.level") - string - type limits = { backlog_size : int ; - backlog_level : Logging.level ; + backlog_level : Internal_event.level ; zombie_lifetime : float ; zombie_memory : float } @@ -119,7 +98,7 @@ let request_status_encoding = type ('req, 'evt) full_status = { status : worker_status ; pending_requests : (Time.t * 'req) list ; - backlog : (Logging.level * 'evt list) list ; + backlog : (Internal_event.level * 'evt list) list ; current_request : (Time.t * Time.t * 'req) option } let full_status_encoding req_encoding evt_encoding error_encoding = @@ -132,7 +111,7 @@ let full_status_encoding req_encoding evt_encoding error_encoding = let events_encoding = list (obj2 - (req "level" level_encoding) + (req "level" Internal_event.Level.encoding) (req "events" (dynamic_size (list (dynamic_size evt_encoding))))) in let current_request_encoding = obj3 diff --git a/src/lib_shell_services/worker_types.mli b/src/lib_shell_services/worker_types.mli index a9fd9c89ef2b..80bef46e9969 100644 --- a/src/lib_shell_services/worker_types.mli +++ b/src/lib_shell_services/worker_types.mli @@ -27,7 +27,7 @@ type limits = { backlog_size : int (** Number of event stored in the backlog for each debug level. *) ; - backlog_level : Logging.level + backlog_level : Internal_event.level (** Stores events at least as important as this value. *) ; zombie_lifetime : float (** How long dead workers are kept in the introspection table. *) ; @@ -57,7 +57,7 @@ val request_status_encoding : request_status Data_encoding.t type ('req, 'evt) full_status = { status : worker_status ; pending_requests : (Time.t * 'req) list ; - backlog : (Logging.level * 'evt list) list ; + backlog : (Internal_event.level * 'evt list) list ; current_request : (Time.t * Time.t * 'req) option } (** Full worker status serializer for RPCs. *) diff --git a/src/lib_signer_backends/ledger.ml b/src/lib_signer_backends/ledger.ml index b55ae127c7ef..79fe389fa28e 100644 --- a/src/lib_signer_backends/ledger.ml +++ b/src/lib_signer_backends/ledger.ml @@ -25,7 +25,9 @@ open Client_keys -include Tezos_stdlib.Logging.Make(struct let name = "client.signer.ledger" end) +include Internal_event.Legacy_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 deleted file mode 100644 index 7f0a9bbc63ed..000000000000 --- a/src/lib_stdlib/logging.ml +++ /dev/null @@ -1,251 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -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 - -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 ; - level : level ; - text : string option ; - tags : Tag.set ; -} - -type tap_id = int -let next_tap : int ref = ref 0 - -type tap = { - id : tap_id ; - process : log_message -> unit ; -} - -let taps : tap list ref = ref [] - -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 - - type log_section += Section - - module Tag = Tag - - val debug: ('a, unit) log - val log_info: ('a, unit) log - val log_notice: ('a, unit) log - val warn: ('a, unit) log - val log_error: ('a, unit) log - val fatal_error: ('a, unit) log - - val lwt_debug: ('a, unit Lwt.t) log - val lwt_log_info: ('a, unit Lwt.t) log - val lwt_log_notice: ('a, unit Lwt.t) log - val lwt_warn: ('a, unit Lwt.t) log - val lwt_log_error: ('a, unit Lwt.t) log - val lwt_fatal_error: ('a, unit Lwt.t) log - - val event : string Tag.def - val exn : exn Tag.def - -end - -let sections = ref [] - -let event = Tag.def ~doc:"String identifier for the class of event being logged" "event" Format.pp_print_text -let exn = Tag.def ~doc:"Exception which was detected" "exception" (fun f e -> Format.pp_print_text f (Printexc.to_string e)) - -module Make_semantic(S : MESSAGE) : SEMLOG = struct - - include S - - type log_section += Section - - module Tag = Tag - - let () = sections := S.name :: !sections - let section = Lwt_log_core.Section.make S.name - - - let log_f ~level = - 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 ; level ; text = Some text ; tags }; - Lwt_log_core.log ~section ~level text) - format - - 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 ; level ; text = None ; tags }) - Format.std_formatter - format - else - fun format ?(tags=Tag.empty) -> - Format.kasprintf - (fun text -> - call_taps { section = Section ; level ; text = Some text ; tags }; - Lwt_log_core.ign_log ~section ~level text) - 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) - let log_notice f = f (ign_log_f ~level:Lwt_log_core.Notice) ?tags:(Some Tag.empty) - let warn f = f (ign_log_f ~level:Lwt_log_core.Warning) ?tags:(Some Tag.empty) - let log_error f = f (ign_log_f ~level:Lwt_log_core.Error) ?tags:(Some Tag.empty) - let fatal_error f = f (ign_log_f ~level:Lwt_log_core.Fatal) ?tags:(Some Tag.empty) - - let lwt_debug f = f (log_f ~level:Lwt_log_core.Debug) ?tags:(Some Tag.empty) - let lwt_log_info f = f (log_f ~level:Lwt_log_core.Info) ?tags:(Some Tag.empty) - let lwt_log_notice f = f (log_f ~level:Lwt_log_core.Notice) ?tags:(Some Tag.empty) - let lwt_warn f = f (log_f ~level:Lwt_log_core.Warning) ?tags:(Some Tag.empty) - let lwt_log_error f = f (log_f ~level:Lwt_log_core.Error) ?tags:(Some Tag.empty) - let lwt_fatal_error f = f (log_f ~level:Lwt_log_core.Fatal) ?tags:(Some Tag.empty) - - let event = event - let exn = exn - -end - -module type LOG = sig - - type log_section += Section - - val debug: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a - val warn: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a - val fatal_error: ('a, Format.formatter, unit, unit) format4 -> 'a - - val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_fatal_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - -end - -let sections = ref [] - -module Make_unregistered(S : MESSAGE) : LOG = struct - - let section = Lwt_log_core.Section.make S.name - type log_section += Section - - let log_f - ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format = - if level < Lwt_log_core.Section.level section then - Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format - else - Format.kasprintf - (fun msg -> - call_taps { section = Section ; level ; text = Some msg ; tags = Tag.empty }; - Lwt_log_core.log ?exn ~section ?location ?logger ~level msg) - format - - let ign_log_f - ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format = - if level < Lwt_log_core.Section.level section then - Format.ikfprintf (fun _ -> ()) Format.std_formatter format - else - Format.kasprintf - (fun msg -> - call_taps { section = Section ; level ; text = Some msg ; tags = Tag.empty }; - Lwt_log_core.ign_log ?exn ~section ?location ?logger ~level msg) - format - - let debug fmt = ign_log_f ~section ~level:Lwt_log_core.Debug fmt - let log_info fmt = ign_log_f ~section ~level:Lwt_log_core.Info fmt - let log_notice fmt = ign_log_f ~section ~level:Lwt_log_core.Notice fmt - let warn fmt = ign_log_f ~section ~level:Lwt_log_core.Warning fmt - let log_error fmt = ign_log_f ~section ~level:Lwt_log_core.Error fmt - let fatal_error fmt = ign_log_f ~section ~level:Lwt_log_core.Fatal fmt - - let lwt_debug fmt = log_f ~section ~level:Lwt_log_core.Debug fmt - let lwt_log_info fmt = log_f ~section ~level:Lwt_log_core.Info fmt - let lwt_log_notice fmt = log_f ~section ~level:Lwt_log_core.Notice fmt - let lwt_warn fmt = log_f ~section ~level:Lwt_log_core.Warning fmt - let lwt_log_error fmt = log_f ~section ~level:Lwt_log_core.Error fmt - let lwt_fatal_error fmt = log_f ~section ~level:Lwt_log_core.Fatal fmt - -end - -module Make(S : MESSAGE) : LOG = struct - - let () = sections := S.name :: !sections - include Make_unregistered(S) - -end - -module Core = struct - include Make_semantic(struct let name = "core" end) - - let worker = Tag.def ~doc:"Name of affected worker" "worker" Format.pp_print_text -end - -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 deleted file mode 100644 index cd408464c041..000000000000 --- a/src/lib_stdlib/logging.mli +++ /dev/null @@ -1,130 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -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 ; - level : level ; - text : string option ; - tags : Tag.set ; -} - -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 - -module type MESSAGE = sig - val name: string -end - -module type SEMLOG = sig - - type log_section += Section - - module Tag = Tag - - val debug: ('a, unit) log - val log_info: ('a, unit) log - val log_notice: ('a, unit) log - val warn: ('a, unit) log - val log_error: ('a, unit) log - val fatal_error: ('a, unit) log - - val lwt_debug: ('a, unit Lwt.t) log - val lwt_log_info: ('a, unit Lwt.t) log - val lwt_log_notice: ('a, unit Lwt.t) log - val lwt_warn: ('a, unit Lwt.t) log - val lwt_log_error: ('a, unit Lwt.t) log - val lwt_fatal_error: ('a, unit Lwt.t) log - - val event : string Tag.def - val exn : exn Tag.def - -end - -module type LOG = sig - - type log_section += Section - - val debug: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a - val warn: ('a, Format.formatter, unit, unit) format4 -> 'a - val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a - val fatal_error: ('a, Format.formatter, unit, unit) format4 -> 'a - - val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - val lwt_fatal_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a - -end - -module Core : sig - include SEMLOG - - val worker : string Tag.def -end - -module Make(S: MESSAGE) : LOG -module Make_unregistered(S: MESSAGE) : LOG - -module Make_semantic(S: MESSAGE) : SEMLOG - -type template = Lwt_log.template -val default_template : template - -val sections: string list ref diff --git a/src/lib_stdlib/lwt_utils.ml b/src/lib_stdlib/lwt_utils.ml index 35a7d23dab3b..d6f6f831bce8 100644 --- a/src/lib_stdlib/lwt_utils.ml +++ b/src/lib_stdlib/lwt_utils.ml @@ -26,7 +26,6 @@ module LC = Lwt_condition open Lwt.Infix -open Logging.Core let may ~f = function | None -> Lwt.return_unit @@ -64,31 +63,23 @@ let trigger () : (unit -> unit) * (unit -> unit Lwt.t) = trigger, wait (* A worker launcher, takes a cancel callback to call upon *) -let worker name ~run ~cancel = +let worker name ~on_event ~run ~cancel = let stop = LC.create () in let fail e = - log_error Tag.DSL.(fun f -> - f "%s worker failed with %a" - -% t event "worker_failed" - -% s worker name - -% a exn e) ; + on_event name + (`Failed (Printf.sprintf "Exception: %s" (Printexc.to_string e))) + >>= fun () -> cancel () in let waiter = LC.wait stop in - log_info Tag.DSL.(fun f -> - f "%s worker started" - -% t event "worker_started" - -% s worker name) ; + on_event name `Started >>= fun () -> Lwt.async (fun () -> Lwt.catch run fail >>= fun () -> LC.signal stop (); Lwt.return_unit) ; waiter >>= fun () -> - log_info Tag.DSL.(fun f -> - f "%s worker ended" - -% t event "worker_finished" - -% s worker name) ; + on_event name `Ended >>= fun () -> Lwt.return_unit diff --git a/src/lib_stdlib/lwt_utils.mli b/src/lib_stdlib/lwt_utils.mli index 437c7da2eac4..87933586a000 100644 --- a/src/lib_stdlib/lwt_utils.mli +++ b/src/lib_stdlib/lwt_utils.mli @@ -27,10 +27,13 @@ val may: f:('a -> unit Lwt.t) -> 'a option -> unit Lwt.t val never_ending: unit -> 'a Lwt.t -(** [worker name ~run ~cancel] runs worker [run], and logs worker - creation, ending or failure. [cancel] is called if worker fails. *) +(** [worker name ~on_event ~run ~cancel] runs worker [run], and logs worker + creation, ending or failure using [~on_event]. + [cancel] is called if worker fails. *) val worker: string -> + on_event:(string -> + [ `Ended | `Failed of string | `Started ] -> unit Lwt.t) -> run:(unit -> unit Lwt.t) -> cancel:(unit -> unit Lwt.t) -> unit Lwt.t diff --git a/src/lib_stdlib_unix/internal_event_unix.ml b/src/lib_stdlib_unix/internal_event_unix.ml index 83b69829ee59..aa5bcaf43cb5 100644 --- a/src/lib_stdlib_unix/internal_event_unix.ml +++ b/src/lib_stdlib_unix/internal_event_unix.ml @@ -56,7 +56,9 @@ end let env_var_name = "TEZOS_EVENTS_CONFIG" -let init ?(configuration = Configuration.default) () = +let init ?lwt_log_sink ?(configuration = Configuration.default) () = + Lwt_log_sink_unix.initialize ?cfg:lwt_log_sink () + >>= fun () -> begin begin match Sys.(getenv_opt env_var_name) with | None -> diff --git a/src/lib_stdlib_unix/internal_event_unix.mli b/src/lib_stdlib_unix/internal_event_unix.mli index fc5ae9f6187c..4a124addf1f1 100644 --- a/src/lib_stdlib_unix/internal_event_unix.mli +++ b/src/lib_stdlib_unix/internal_event_unix.mli @@ -46,6 +46,7 @@ module Configuration : sig end val init : + ?lwt_log_sink:Lwt_log_sink_unix.cfg -> ?configuration:Configuration.t -> unit -> unit Lwt.t @@ -56,6 +57,9 @@ val init : JSON file (cf. {!Configuration.of_file}), e.g.: [export TEZOS_EVENTS_CONFIG="unix-files:///tmp/events-unix debug://"], or [export TEZOS_EVENTS_CONFIG="debug:// /path/to/config.json"]. + + The function also initializes the {!Lwt_log_sink_unix} module + (corresponding to the ["TEZOS_LOG"] environment variable). *) val close : unit -> unit Lwt.t diff --git a/src/lib_stdlib_unix/logging_unix.ml b/src/lib_stdlib_unix/lwt_log_sink_unix.ml similarity index 89% rename from src/lib_stdlib_unix/logging_unix.ml rename to src/lib_stdlib_unix/lwt_log_sink_unix.ml index 63f52d6a345f..19ba5b09f357 100644 --- a/src/lib_stdlib_unix/logging_unix.ml +++ b/src/lib_stdlib_unix/lwt_log_sink_unix.ml @@ -113,42 +113,23 @@ module Output = struct Format.fprintf fmt "%s" (to_string output) end +let default_template = "$(date) - $(section): $(message)" + type cfg = { output : Output.t ; - default_level : Logging.level ; + default_level : Internal_event.level ; rules : string option ; - template : Logging.template ; + template : Lwt_log_core.template ; } let create_cfg ?(output = Output.Stderr) - ?(default_level = Logging.Notice) - ?rules ?(template = Logging.default_template) () = + ?(default_level = Internal_event.Notice) + ?rules ?(template = default_template) () = { output ; default_level ; rules ; template } let default_cfg = create_cfg () -let level_encoding = - let open Logging in - let open Data_encoding in - conv - (function - | Fatal -> "fatal" - | Error -> "error" - | Warning -> "warning" - | Notice -> "notice" - | Info -> "info" - | Debug -> "debug") - (function - | "error" -> Error - | "warn" -> Warning - | "notice" -> Notice - | "info" -> Info - | "debug" -> Debug - | "fatal" -> Fatal - | _ -> invalid_arg "Logging.level") - string - let cfg_encoding = let open Data_encoding in conv @@ -164,7 +145,7 @@ let cfg_encoding = (dft "level" ~description: "Verbosity level: one of 'fatal', 'error', 'warn',\ 'notice', 'info', 'debug'." - level_encoding default_cfg.default_level) + Internal_event.Level.encoding default_cfg.default_level) (opt "rules" ~description: "Fine-grained logging instructions. Same format as \ described in `tezos-node run --help`, DEBUG section. \ @@ -178,7 +159,7 @@ let cfg_encoding = http://ocsigen.org/lwt/dev/api/Lwt_log_core#2_Logtemplates." string default_cfg.template)) -let init ?(template = Logging.default_template) output = +let init ?(template = default_template) output = let open Output in begin match output with @@ -212,8 +193,9 @@ let find_log_rules default = defined, using TEZOS_LOG.@]@\n@." ; "environment varible TEZOS_LOG", Some rules -let init ?(cfg = default_cfg) () = - Lwt_log_core.add_rule "*" cfg.default_level ; +let initialize ?(cfg = default_cfg) () = + Lwt_log_core.add_rule "*" + (Internal_event.Level.to_lwt_log cfg.default_level) ; let origin, rules = find_log_rules cfg.rules in begin match rules with | None -> Lwt.return_unit @@ -227,5 +209,4 @@ let init ?(cfg = default_cfg) () = end >>= fun () -> init ~template:cfg.template cfg.output -let close () = - Lwt_log.close !Lwt_log.default + diff --git a/src/lib_stdlib_unix/logging_unix.mli b/src/lib_stdlib_unix/lwt_log_sink_unix.mli similarity index 84% rename from src/lib_stdlib_unix/logging_unix.mli rename to src/lib_stdlib_unix/lwt_log_sink_unix.mli index cbb29e017e4b..fb66146e6282 100644 --- a/src/lib_stdlib_unix/logging_unix.mli +++ b/src/lib_stdlib_unix/lwt_log_sink_unix.mli @@ -39,21 +39,23 @@ end type cfg = { output : Output.t ; - default_level : Logging.level ; + default_level : Internal_event.level ; rules : string option ; - template : Logging.template ; + template : Lwt_log_core.template ; } val default_cfg : cfg val create_cfg : ?output:Output.t -> - ?default_level:Logging.level -> + ?default_level:Internal_event.level -> ?rules:string -> - ?template:Logging.template -> unit -> cfg + ?template:Lwt_log_core.template -> unit -> cfg -val level_encoding : Logging.level Data_encoding.t val cfg_encoding : cfg Data_encoding.t -val init: ?cfg:cfg -> unit -> unit Lwt.t -val close: unit -> unit Lwt.t +val initialize: ?cfg:cfg -> unit -> unit Lwt.t +(** Configure the event-logging sink defined in + {!Internal_event.Lwt_log_sink} by merging the contents of [?cfg] + (default: {!default_cfg}) and the value of the ["TEZOS_LOG"] + environment variable. *) diff --git a/src/lib_storage/store_logging.ml b/src/lib_storage/store_logging.ml index f79df4b52d8d..fc8d63dd304f 100644 --- a/src/lib_storage/store_logging.ml +++ b/src/lib_storage/store_logging.ml @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make(struct let name = "db" end) +include Internal_event.Legacy_logging.Make(struct let name = "db" end) diff --git a/src/lib_storage/store_logging.mli b/src/lib_storage/store_logging.mli index ede719e2c916..5279e8ee9c3b 100644 --- a/src/lib_storage/store_logging.mli +++ b/src/lib_storage/store_logging.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.LOG +include Internal_event.Legacy_logging.LOG diff --git a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml index 3d5c4da35716..fd04ae59a430 100644 --- a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.denunciation" end) +include Internal_event.Legacy_logging.Make_semantic(struct let name = "client.denunciation" end) open Proto_alpha open Alpha_context diff --git a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml index 6974b4505d2a..046cacc7776e 100644 --- a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml +++ b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml @@ -26,7 +26,7 @@ open Proto_alpha open Alpha_context -include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.endorsement" end) +include Internal_event.Legacy_logging.Make_semantic(struct let name = "client.endorsement" end) open Logging diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index 20b0c2cb90f5..c2b1c70f6558 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -26,7 +26,7 @@ open Proto_alpha open Alpha_context -include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.baking" end) +include Internal_event.Legacy_logging.Make_semantic(struct let name = "client.baking" end) open Logging (* The index of the different components of the protocol's validation passes *) diff --git a/src/proto_alpha/lib_delegate/client_baking_nonces.ml b/src/proto_alpha/lib_delegate/client_baking_nonces.ml index 048f02460d94..e4418b6f9445 100644 --- a/src/proto_alpha/lib_delegate/client_baking_nonces.ml +++ b/src/proto_alpha/lib_delegate/client_baking_nonces.ml @@ -26,7 +26,7 @@ open Proto_alpha open Alpha_context -include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.nonces" end) +include Internal_event.Legacy_logging.Make_semantic(struct let name = "client.nonces" end) type t = Nonce.t Block_hash.Map.t diff --git a/src/proto_alpha/lib_delegate/client_baking_revelation.ml b/src/proto_alpha/lib_delegate/client_baking_revelation.ml index 03cf9d7fe395..72d16ec0029f 100644 --- a/src/proto_alpha/lib_delegate/client_baking_revelation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_revelation.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.nonce_revelation" end) +include Internal_event.Legacy_logging.Make_semantic(struct let name = "client.nonce_revelation" end) open Proto_alpha diff --git a/src/proto_alpha/lib_delegate/client_baking_scheduling.ml b/src/proto_alpha/lib_delegate/client_baking_scheduling.ml index f841745b6dfa..695f101961a1 100644 --- a/src/proto_alpha/lib_delegate/client_baking_scheduling.ml +++ b/src/proto_alpha/lib_delegate/client_baking_scheduling.ml @@ -23,7 +23,8 @@ (* *) (*****************************************************************************) -include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.scheduling" end) +include Internal_event.Legacy_logging.Make_semantic + (struct let name = "client.scheduling" end) open Logging diff --git a/src/proto_alpha/lib_protocol/test/helpers/test.ml b/src/proto_alpha/lib_protocol/test/helpers/test.ml index dbd4b9967be1..e8c2f3828213 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/test.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/test.ml @@ -29,7 +29,7 @@ let tztest name speed f = f () >>= function | Ok () -> Lwt.return_unit | Error err -> - Tezos_stdlib_unix.Logging_unix.close () >>= fun () -> + Tezos_stdlib_unix.Internal_event_unix.close () >>= fun () -> Format.printf "@.%a@." pp_print_error err ; Lwt.fail Alcotest.Test_error end -- GitLab From f117848d4975bb8f5a3d5c6c049bb39868c0e038 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Sat, 12 Jan 2019 16:26:58 -0500 Subject: [PATCH 10/20] Event-logging: Make section a private string list --- src/lib_event_logging/internal_event.ml | 41 ++++++++++++++---------- src/lib_event_logging/internal_event.mli | 10 ++++-- src/lib_stdlib_unix/file_event_sink.ml | 34 ++++++++++---------- 3 files changed, 48 insertions(+), 37 deletions(-) diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index c28b51cbb8c8..99f4a95fc1aa 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -64,30 +64,37 @@ module Level = struct end module Section: sig - type t = private string - val make : string -> t - val make_sanitized : string -> t + type t = private string list + val empty : t + val make : string list -> t + val make_sanitized : string list -> t val to_lwt_log : t -> Lwt_log_core.section val encoding : t Data_encoding.t - val to_string : t -> string + val to_string_list : t -> string list end = struct - type t = string - let make s = - check_name_exn s (fun name char -> - Printf.ksprintf Pervasives.invalid_arg - "Internal_event.Section: invalid name %S (contains %c)" name char) ; - s + type t = string list + let empty = [] + + let make sl = + List.iter + (fun s -> + check_name_exn s (fun name char -> + Printf.ksprintf Pervasives.invalid_arg + "Internal_event.Section: invalid name %S (contains %c)" name char)) + sl; + sl - let make_sanitized s = - String.map (fun c -> if valid_char c then c else '_') s |> make + let make_sanitized sl = + List.map + (String.map (fun c -> if valid_char c then c else '_')) sl |> make - let to_lwt_log s = Lwt_log_core.Section.make s + let to_lwt_log s = Lwt_log_core.Section.make (String.concat "." s) - let to_string t = t + let to_string_list t = t let encoding = let open Data_encoding in - string + list string end module type EVENT_DEFINITION = sig @@ -436,7 +443,7 @@ module Legacy_logging = struct let level { level ; _ } = level end - let section = Section.make P.name + let section = Section.make (String.split_on_char '.' P.name) let () = sections := P.name :: !sections @@ -645,7 +652,7 @@ module Lwt_worker_event = struct include (Make (Definition) : EVENT with type t := t) let on_event name event = - let section = Printf.ksprintf Section.make_sanitized "lwt-worker-%s" name in + let section = Section.make_sanitized [ "lwt-worker"; name ] in Error_event.to_lwt ~message:(Printf.sprintf "Trying to emit worker event for %S" name) ~severity:`Fatal diff --git a/src/lib_event_logging/internal_event.mli b/src/lib_event_logging/internal_event.mli index 6a967700b950..a2961d217708 100644 --- a/src/lib_event_logging/internal_event.mli +++ b/src/lib_event_logging/internal_event.mli @@ -64,16 +64,20 @@ end (** Sections are a simple way of classifying events at the time of their emission. *) module Section: sig - type t = private string + type t = private string list - val make_sanitized : string -> t + val empty : t + + val make_sanitized : string list -> t (** Build a {!Section.t} by replacing special characters with ['_']. *) val to_lwt_log : t -> Lwt_log_core.section (** Make the equivalent {!Lwt_log} section. *) val encoding : t Data_encoding.t - val to_string : t -> string + + val to_string_list : t -> string list + end (** Parameters defining an inspectable type of events. *) diff --git a/src/lib_stdlib_unix/file_event_sink.ml b/src/lib_stdlib_unix/file_event_sink.ml index 895dc67f3ce5..57c9d919f0b4 100644 --- a/src/lib_stdlib_unix/file_event_sink.ml +++ b/src/lib_stdlib_unix/file_event_sink.ml @@ -61,10 +61,10 @@ module Event_filter = struct | Name of string | Name_matches of Re.re | Level_in of Internal_event.level list - | Section_in of Internal_event.Section.t option list + | Section_in of Internal_event.Section.t list - let rec run ~section_option ~level ~name filter = - let continue = run ~section_option ~level ~name in + let rec run ~section ~level ~name filter = + let continue = run ~section ~level ~name in match filter with | True -> true | False -> false @@ -73,7 +73,7 @@ module Event_filter = struct | Name s -> String.equal s name | Name_matches re -> Re.execp re name | Level_in l -> List.mem level l - | Section_in l -> List.mem section_option l + | Section_in l -> List.mem section l let rec pp fmt filter = let open Format in @@ -94,10 +94,9 @@ module Event_filter = struct | Section_in l -> fprintf fmt "(section-in@ [%a])" (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") - (fun fmt -> function - | None -> fprintf fmt "None" - | Some s -> fprintf fmt "(Some %s)" - (Internal_event.Section.to_string s))) + (fun fmt s -> fprintf fmt "(Some %s)" + (String.concat "," + (Internal_event.Section.to_string_list s)))) l [@@warning "-32"] (* -> The "unused value" warning. *) @@ -139,7 +138,7 @@ type t = { type 'event wrapped = { time_stamp : Micro_seconds.t ; - section : Internal_event.Section.t option ; + section : Internal_event.Section.t ; event : 'event } let wrap time_stamp section event = { time_stamp ; section ; event } @@ -152,16 +151,15 @@ let wrapped_encoding event_encoding = (fun (time_stamp, section, event) -> { time_stamp ; section ; event }) (obj3 (req "time_stamp" Micro_seconds.encoding) - (req "section" (option Internal_event.Section.encoding)) + (req "section" Internal_event.Section.encoding) (req "event" event_encoding)) in With_version.(encoding ~name:"file-event-sink-item" (first_version v0)) module Section_dir = struct - let of_section (section : Internal_event.Section.t option) = - Option.unopt_map (section :> string option) - ~default:"no-section" ~f:(Printf.sprintf "section-%s") + let of_section (section : Internal_event.Section.t) = + String.concat "." (Internal_event.Section.to_string_list section) let section_name = function @@ -198,11 +196,13 @@ module Sink_implementation : Internal_event.SINK with type t = t = struct let sections = let somes = Uri.get_query_param' uri "section" |> Option.unopt ~default:[] - |> List.map (fun s -> Some (Internal_event.Section.make_sanitized s)) + |> List.map (fun s -> + (Internal_event.Section.make_sanitized + (String.split_on_char '.' s))) in let none = match Uri.get_query_param uri "no-section" with - | Some "true" -> [None] + | Some "true" -> [Internal_event.Section.empty] | _ -> [] in match somes @ none with @@ -243,7 +243,7 @@ module Sink_implementation : Internal_event.SINK with type t = t = struct let handle (type a) { path ; lwt_bad_citizen_hack ; event_filter } - m ?section (v : unit -> a) = + m ?(section = Internal_event.Section.empty) (v : unit -> a) = let module M = (val m : Internal_event.EVENT_DEFINITION with type t = a) in let now = Micro_seconds.now () in let date, time = Micro_seconds.date_string now in @@ -251,7 +251,7 @@ module Sink_implementation : Internal_event.SINK with type t = t = struct let level = M.level forced in match Event_filter.run - ~section_option:section ~level ~name:M.name event_filter + ~section:section ~level ~name:M.name event_filter with | true -> let event_json = -- GitLab From b2b3f04ba6acc26bfdef114e9cc50156b648c10c Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Sat, 12 Jan 2019 19:38:21 -0500 Subject: [PATCH 11/20] Event-logging: Forbid '.' in event names --- src/lib_event_logging/internal_event.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index 99f4a95fc1aa..a52521d74559 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -37,7 +37,7 @@ end let valid_char c = match c with | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' - | '.' | '@' | '-' | '_' | '+' | '=' | '~' -> true + | '@' | '-' | '_' | '+' | '=' | '~' -> true | _ -> false let check_name_exn name or_fail = @@ -397,19 +397,21 @@ module Legacy_logging = struct end module Make_event (P : sig val name : string end) = struct + let name_split = String.split_on_char '.' P.name + let section = Section.make name_split module Definition = struct - let name = "legacy-logging-event." ^ P.name + let name = "legacy_logging_event-" ^ String.concat "-" name_split type t = { message : string ; - section : string ; + section : Section.t ; level : level ; tags : Tag.set ; } let make ?(tags = Tag.empty) level message = - { message ; section = P.name ; level ; tags } + { message ; section ; level ; tags } let v0_encoding = @@ -421,7 +423,7 @@ module Legacy_logging = struct { message ; section ; level ; tags }) (obj4 (req "message" string) - (req "section" string) + (req "section" Section.encoding) (req "level" Level.encoding) (dft "tags" (conv @@ -443,7 +445,6 @@ module Legacy_logging = struct let level { level ; _ } = level end - let section = Section.make (String.split_on_char '.' P.name) let () = sections := P.name :: !sections -- GitLab From a1ac99c1ab1a7c4f2c7fc21bd52656eeedb85a19 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Tue, 22 Jan 2019 11:35:34 -0500 Subject: [PATCH 12/20] Event-logging: Make `check_name_exn` safer Cf. comment: --- src/lib_event_logging/internal_event.ml | 26 +++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index a52521d74559..655df2b0d14b 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -40,11 +40,12 @@ let valid_char c = | '@' | '-' | '_' | '+' | '=' | '~' -> true | _ -> false -let check_name_exn name or_fail = - String.iter - (fun c -> if valid_char c then () else or_fail name c) - name ; - () +let check_name_exn : string -> (string -> char -> exn) -> unit = + fun name make_exn -> + String.iter + (fun c -> if valid_char c then () else raise (make_exn name c)) + name ; + () type level = Lwt_log_core.level = @@ -79,7 +80,7 @@ end = struct List.iter (fun s -> check_name_exn s (fun name char -> - Printf.ksprintf Pervasives.invalid_arg + Printf.ksprintf (fun s -> Invalid_argument s) "Internal_event.Section: invalid name %S (contains %c)" name char)) sl; sl @@ -316,20 +317,21 @@ module All_definitions = struct let all : definition list ref = ref [] - let fail_registration fmt = - Format.kasprintf (fun s -> - (* This should be considered a programming error: *) - Pervasives.invalid_arg ("Internal_event registration error: " ^ s)) + let registration_exn fmt = + Format.kasprintf + (fun s -> + (* This should be considered a programming error: *) + Invalid_argument ("Internal_event registration error: " ^ s)) fmt let add (type a) ev = let module E = (val ev : EVENT_DEFINITION with type t = a) in match List.find (function Definition (n, _) -> E.name = n) !all with | _ -> - fail_registration "duplicate Event name: %S" E.name + raise (registration_exn "duplicate Event name: %S" E.name) | exception _ -> check_name_exn E.name - (fail_registration "invalid event name: %S contains '%c'") ; + (registration_exn "invalid event name: %S contains '%c'") ; all := Definition (E.name, ev) :: !all let get () = !all -- GitLab From 8f07970f8a54c248f08931bc81ef14fa1a4295b1 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Tue, 22 Jan 2019 11:39:43 -0500 Subject: [PATCH 13/20] Data-encoding: Fix type signature Cf. --- src/lib_data_encoding/data_encoding.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib_data_encoding/data_encoding.ml b/src/lib_data_encoding/data_encoding.ml index 9ea33f697e74..1d76bd750b0f 100644 --- a/src/lib_data_encoding/data_encoding.ml +++ b/src/lib_data_encoding/data_encoding.ml @@ -147,7 +147,7 @@ struct let next_version encoding upgrade previous = Version_S { encoding ; upgrade ; previous } - let encoding : type a. name: _ -> a t -> a encoding = + let encoding : type a. name : string -> a t -> a encoding = fun ~name version -> match version with | Version_0 e -> -- GitLab From 1f27dbf2bb13b88027dbc5d7ea7e226887d8fd4b Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Tue, 22 Jan 2019 11:41:58 -0500 Subject: [PATCH 14/20] Event-logging: Rename `Error_event.to_lwt` Cf. --- src/lib_event_logging/internal_event.ml | 4 ++-- src/lib_event_logging/internal_event.mli | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index 655df2b0d14b..513f4af437a1 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -552,7 +552,7 @@ module Error_event = struct include (Make (Definition) : EVENT with type t := t) - let to_lwt ?section ?message ?severity f = + let log_error_and_recover ?section ?message ?severity f = f () >>= function | Ok () -> Lwt.return_unit @@ -656,7 +656,7 @@ module Lwt_worker_event = struct let on_event name event = let section = Section.make_sanitized [ "lwt-worker"; name ] in - Error_event.to_lwt + Error_event.log_error_and_recover ~message:(Printf.sprintf "Trying to emit worker event for %S" name) ~severity:`Fatal (fun () -> emit ~section (fun () -> { name ; event })) diff --git a/src/lib_event_logging/internal_event.mli b/src/lib_event_logging/internal_event.mli index a2961d217708..2d740d950ca5 100644 --- a/src/lib_event_logging/internal_event.mli +++ b/src/lib_event_logging/internal_event.mli @@ -228,7 +228,7 @@ module Error_event : sig include EVENT with type t := t - val to_lwt : + val log_error_and_recover : ?section:Section.t -> ?message:string -> ?severity:[ `Fatal | `Recoverable ] -> -- GitLab From 9db735b12ea2a9b26ce1aabcb0de4552cfbb2ea6 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Tue, 22 Jan 2019 12:06:51 -0500 Subject: [PATCH 15/20] Data-encoding: Add implementation comment Cf. --- src/lib_data_encoding/data_encoding.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/lib_data_encoding/data_encoding.ml b/src/lib_data_encoding/data_encoding.ml index 1d76bd750b0f..6c1741734229 100644 --- a/src/lib_data_encoding/data_encoding.ml +++ b/src/lib_data_encoding/data_encoding.ml @@ -155,6 +155,11 @@ struct [ version_case e (fun x -> Some x) (fun x -> x) ] | Version_S { previous ; encoding ; upgrade } -> let rec mk_nones : + (* This function generates encoding cases for all the + outdated versions. + These versions are never encoded to + (hence [fun _ -> None]) but are safely decoded with + the use of the upgrade functions. *) type b. (b -> a) -> b t -> (string -> int -> a case) list = fun upgr -> function | Version_0 e -> -- GitLab From ed5e135df04f6c2badc8879d147d3b339129b3a8 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Tue, 29 Jan 2019 17:59:55 -0500 Subject: [PATCH 16/20] CI: Fix build (dune package version) --- src/lib_event_logging/tezos-event-logging.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib_event_logging/tezos-event-logging.opam b/src/lib_event_logging/tezos-event-logging.opam index 456138424aa2..b878c7910dcd 100644 --- a/src/lib_event_logging/tezos-event-logging.opam +++ b/src/lib_event_logging/tezos-event-logging.opam @@ -8,7 +8,7 @@ dev-repo: "https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ "ocamlfind" { build } - "dune" { build & = "1.0.1" } + "dune" { build & >= "1.0.1" } "tezos-stdlib" "tezos-data-encoding" "tezos-error-monad" -- GitLab From 5de3487f0099314b34270b386b97d6822d5b43f6 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Wed, 6 Mar 2019 15:09:08 -0500 Subject: [PATCH 17/20] Lib_delegate: make logging event names unique --- src/proto_alpha/lib_delegate/client_baking_denunciation.ml | 4 +++- src/proto_alpha/lib_delegate/client_baking_endorsement.ml | 4 +++- src/proto_alpha/lib_delegate/client_baking_forge.ml | 5 ++++- src/proto_alpha/lib_delegate/client_baking_revelation.ml | 4 +++- src/proto_alpha/lib_delegate/client_baking_scheduling.ml | 5 +++-- 5 files changed, 16 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml index fd04ae59a430..3763f18b2c2e 100644 --- a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml @@ -23,7 +23,9 @@ (* *) (*****************************************************************************) -include Internal_event.Legacy_logging.Make_semantic(struct let name = "client.denunciation" end) +include Internal_event.Legacy_logging.Make_semantic(struct + let name = Proto_alpha.Name.name ^ ".client.denunciation" + end) open Proto_alpha open Alpha_context diff --git a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml index 046cacc7776e..ffe2cc7c6376 100644 --- a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml +++ b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml @@ -26,7 +26,9 @@ open Proto_alpha open Alpha_context -include Internal_event.Legacy_logging.Make_semantic(struct let name = "client.endorsement" end) +include Internal_event.Legacy_logging.Make_semantic(struct + let name = Proto_alpha.Name.name ^ ".client.endorsement" + end) open Logging diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index c2b1c70f6558..17941fd1daa4 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -26,7 +26,10 @@ open Proto_alpha open Alpha_context -include Internal_event.Legacy_logging.Make_semantic(struct let name = "client.baking" end) +include Internal_event.Legacy_logging.Make_semantic(struct + let name = Proto_alpha.Name.name ^ ".client.baking" + end) + open Logging (* The index of the different components of the protocol's validation passes *) diff --git a/src/proto_alpha/lib_delegate/client_baking_revelation.ml b/src/proto_alpha/lib_delegate/client_baking_revelation.ml index 72d16ec0029f..25d272c9cc53 100644 --- a/src/proto_alpha/lib_delegate/client_baking_revelation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_revelation.ml @@ -23,7 +23,9 @@ (* *) (*****************************************************************************) -include Internal_event.Legacy_logging.Make_semantic(struct let name = "client.nonce_revelation" end) +include Internal_event.Legacy_logging.Make_semantic(struct + let name = Proto_alpha.Name.name ^ ".client.nonce_revelation" + end) open Proto_alpha diff --git a/src/proto_alpha/lib_delegate/client_baking_scheduling.ml b/src/proto_alpha/lib_delegate/client_baking_scheduling.ml index 695f101961a1..814685e6ff02 100644 --- a/src/proto_alpha/lib_delegate/client_baking_scheduling.ml +++ b/src/proto_alpha/lib_delegate/client_baking_scheduling.ml @@ -23,8 +23,9 @@ (* *) (*****************************************************************************) -include Internal_event.Legacy_logging.Make_semantic - (struct let name = "client.scheduling" end) +include Internal_event.Legacy_logging.Make_semantic (struct + let name = Proto_alpha.Name.name ^ ".client.scheduling" + end) open Logging -- GitLab From 74e85db308ec931f53604630489628de264dde38 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 15 Mar 2019 17:05:27 -0400 Subject: [PATCH 18/20] gitlab-ci: run `./scripts/update_opam_test.sh` --- .gitlab-ci.yml | 72 ++++++++++++++++++++++++-------------------------- 1 file changed, 34 insertions(+), 38 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9d70dfd9d1fd..adab33b283b0 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -441,135 +441,131 @@ opam:39:tezos-baking-alpha: variables: package: tezos-baking-alpha -opam:40:tezos-protocol-genesis: +opam:40:tezos-protocol-demo: + <<: *opam_definition + variables: + package: tezos-protocol-demo + +opam:41:tezos-protocol-genesis: <<: *opam_definition variables: package: tezos-protocol-genesis -opam:41:ocplib-resto-json: +opam:42:ocplib-resto-json: <<: *opam_definition variables: package: ocplib-resto-json -opam:42:tezos-p2p: +opam:43:tezos-p2p: <<: *opam_definition variables: package: tezos-p2p -opam:43:tezos-validation: +opam:44:tezos-validation: <<: *opam_definition variables: package: tezos-validation -opam:44:tezos-baking-alpha-commands: +opam:45:tezos-baking-alpha-commands: <<: *opam_definition variables: package: tezos-baking-alpha-commands -opam:45:tezos-client-alpha-commands: +opam:46:tezos-client-alpha-commands: <<: *opam_definition variables: package: tezos-client-alpha-commands -opam:46:tezos-client-base-unix: +opam:47:tezos-client-base-unix: <<: *opam_definition variables: package: tezos-client-base-unix -opam:47:tezos-client-genesis: +opam:48:tezos-client-demo: + <<: *opam_definition + variables: + package: tezos-client-demo + +opam:49:tezos-client-genesis: <<: *opam_definition variables: package: tezos-client-genesis -opam:48:ocplib-ezresto: +opam:50:ocplib-ezresto: <<: *opam_definition variables: package: ocplib-ezresto -opam:49:tezos-embedded-protocol-alpha: +opam:51:tezos-embedded-protocol-alpha: <<: *opam_definition variables: - package: tezos-shell + package: tezos-embedded-protocol-alpha -opam:50:tezos-embedded-protocol-demo: +opam:52:tezos-embedded-protocol-demo: <<: *opam_definition variables: package: tezos-embedded-protocol-demo -opam:51:tezos-embedded-protocol-genesis: +opam:53:tezos-embedded-protocol-genesis: <<: *opam_definition variables: package: tezos-embedded-protocol-genesis -opam:52:tezos-shell: +opam:54:tezos-shell: <<: *opam_definition variables: package: tezos-shell -opam:53:tezos-endorser-alpha-commands: +opam:55:tezos-endorser-alpha-commands: <<: *opam_definition variables: package: tezos-endorser-alpha-commands -opam:54:tezos-client: +opam:56:tezos-client: <<: *opam_definition variables: package: tezos-client -opam:55:ocplib-ezresto-directory: +opam:57:ocplib-ezresto-directory: <<: *opam_definition variables: package: ocplib-ezresto-directory -opam:56:tezos-accuser-alpha: +opam:58:tezos-accuser-alpha: <<: *opam_definition variables: package: tezos-accuser-alpha -opam:57:tezos-endorser-alpha: +opam:59:tezos-endorser-alpha: <<: *opam_definition variables: package: tezos-endorser-alpha -opam:58:tezos-accuser-alpha-commands: +opam:60:tezos-accuser-alpha-commands: <<: *opam_definition variables: package: tezos-accuser-alpha-commands -opam:59:tezos-baker-alpha: +opam:61:tezos-baker-alpha: <<: *opam_definition variables: package: tezos-baker-alpha -opam:60:tezos-protocol-demo: - <<: *opam_definition - variables: - package: tezos-protocol-demo - -opam:61:tezos-signer: +opam:62:tezos-signer: <<: *opam_definition variables: package: tezos-signer -opam:62:tezos-node: +opam:63:tezos-node: <<: *opam_definition variables: package: tezos-node -opam:63:ocplib-json-typed-browser: +opam:64:ocplib-json-typed-browser: <<: *opam_definition variables: package: ocplib-json-typed-browser -opam:64:tezos-baker-alpha-commands: - <<: *opam_definition - variables: - package: tezos-baker-alpha-commands - -opam:63:tezos-client-demo: - <<: *opam_definition - variables: - package: tezos-client-demo ##END_OPAM## -- GitLab From af3c5222ebe2411046b2562e57d35fd25c9c7dc9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 21 Mar 2019 15:17:40 +0800 Subject: [PATCH 19/20] Event logging: improve mli doc --- src/lib_clic/scriptable.mli | 26 +++++++++++++++++------- src/lib_event_logging/internal_event.mli | 4 ++-- 2 files changed, 21 insertions(+), 9 deletions(-) diff --git a/src/lib_clic/scriptable.mli b/src/lib_clic/scriptable.mli index 1ccd667c3875..a7baf7276a67 100644 --- a/src/lib_clic/scriptable.mli +++ b/src/lib_clic/scriptable.mli @@ -33,7 +33,9 @@ type output_format val clic_arg : unit -> (output_format option, _) Clic.arg (** Command line argument for {!Clic.command} (and the [Clic.args*] - functions). *) + functions). Not that this is the only way to obtain a value of type + [output_format]. On the command line, it appears as [--for-script] with + values [TSV] or [CSV]. *) val output : ?channel: Lwt_io.output_channel -> @@ -41,10 +43,16 @@ val output : for_human:(unit -> unit tzresult Lwt.t) -> for_script:(unit -> string list list) -> unit tzresult Lwt.t -(** Output a list of rows of data (the result of [for_script ()]) to - [formatter] (default: {!Format.std_formatter}) if the ["--for-script"] - option has been set (is [Some _]), if the format is [None] the function - [~for_human] is called instead. *) +(** [output fmt_opt ~for_human ~for_script] behaves in one of two ways. + If [fmt_opt] is [Some _], then it formats the value returned by + [for_script ()]. The function's return value is formatted as lines of + columns of values (list of lists of strings). This is to help scripts to + decode/interpret/parse the output. + Otherwise, if [fmt_opt] is [None], it calls [for_human ()] which is + responsible for the whole formatting. + + The optional argument [channel] is used when automatically formatting the + value returned by [for_script ()]. It has no effect on [for_human ()]. *) val output_row : ?channel: Lwt_io.output_channel -> @@ -56,5 +64,9 @@ val output_row : val output_for_human : output_format option -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t -(** [output_for_human fmt_opt for_human] calls [for_human] when - [fmt_opt] is [None]. *) +(** [output_for_human fmt_opt for_human] behaves in either of two ways. + If [fmt_opt] is [None], then it calls [for_human ()]. + Otherwise, it does nothing. + + Use this function to provide output that is of no interest to automatic + tools. *) diff --git a/src/lib_event_logging/internal_event.mli b/src/lib_event_logging/internal_event.mli index 2d740d950ca5..2c48bdbd99f7 100644 --- a/src/lib_event_logging/internal_event.mli +++ b/src/lib_event_logging/internal_event.mli @@ -233,8 +233,8 @@ module Error_event : sig ?message:string -> ?severity:[ `Fatal | `Recoverable ] -> (unit -> (unit, error list) result Lwt.t) -> unit Lwt.t - (** [to_lwt f] calls [f ()] and emits an {!Error_event.t} event if - it results in an error. It then continues in the [_ Lwt.t] + (** [log_error_and_recover f] calls [f ()] and emits an {!Error_event.t} + event if it results in an error. It then continues in the [_ Lwt.t] monad (e.g. there is no call to [Lwt.fail]). *) end -- GitLab From 7f7c12796f4ef87d623654433789c7e6cc0af46b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 21 Mar 2019 15:29:28 +0800 Subject: [PATCH 20/20] Event logging: use only ascii characters in comments --- src/lib_data_encoding/data_encoding.mli | 4 ++-- src/lib_data_encoding/test/versioned.ml | 10 +++++----- src/lib_event_logging/internal_event.mli | 6 +++--- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/lib_data_encoding/data_encoding.mli b/src/lib_data_encoding/data_encoding.mli index 120b3b9450dc..b9b7cbf3e735 100644 --- a/src/lib_data_encoding/data_encoding.mli +++ b/src/lib_data_encoding/data_encoding.mli @@ -532,7 +532,7 @@ module Encoding: sig 'a lazy_t -> 'b (** Create a {!Data_encoding.t} value which records knowledge of - older versions of a given encoding as long as one can “upgrade” + older versions of a given encoding as long as one can "upgrade" from an older version to the next (if upgrade is impossible one should consider that the encoding is completely different). @@ -553,7 +553,7 @@ module Encoding: sig val next_version : 'a encoding -> ('b -> 'a) -> 'b t -> 'a t (** Make an encoding from an encapsulation of versions; the - argument [~name] is used to prefix the version “tag” in the + argument [~name] is used to prefix the version "tag" in the encoding, it should not change from one version to the next. *) val encoding : name: string -> 'a t -> 'a encoding end diff --git a/src/lib_data_encoding/test/versioned.ml b/src/lib_data_encoding/test/versioned.ml index 0dec21d40efd..7317335f0607 100644 --- a/src/lib_data_encoding/test/versioned.ml +++ b/src/lib_data_encoding/test/versioned.ml @@ -30,7 +30,7 @@ (** This module is a simple example of use of {!With_version}. *) module Documented_example = struct (** - Here we show how to {i “versionize”} a given random encoding (which + Here we show how to {i "versionize"} a given random encoding (which just happens to be very similar to {!Internal_event.Debug_event}). *) (** We are going to provide successive versions of a module @@ -51,7 +51,7 @@ module Documented_example = struct module V0 = struct type t = { message : string ; attachment : (string * string) list } - (** This is the “naked” (i.e. non-versioned) encoding of version-0: *) + (** This is the "naked" (i.e. non-versioned) encoding of version-0: *) let encoding = let open Data_encoding in conv @@ -89,7 +89,7 @@ module Documented_example = struct let make ?(attach = `Null) message () = { message ; attachment = attach } - (** Note the “upgrade” function which can make a {!V1.t} from a {!V0.t}: *) + (** Note the "upgrade" function which can make a {!V1.t} from a {!V0.t}: *) let of_v0 { V0.message ; attachment } = { message ; attachment = `O (List.map (fun (k, v) -> (k, `String v)) attachment) } @@ -123,7 +123,7 @@ module Documented_example = struct end - (** This test “serializes” successively using + (** This test "serializes" successively using {!First_version.encoding} and {!Second_version.encoding}, and then shows that the former's output can be parsed with the later. *) let actual_test () = @@ -159,7 +159,7 @@ module Documented_example = struct Alcotest.failf "Json-v1: %a@ Vs@ %a" Data_encoding.Json.pp json_v1 Data_encoding.Json.pp expected_json_v1 end; - (* Now the {b interesting part}, we decode (“destruct”) the JSON from + (* Now the {b interesting part}, we decode ("destruct") the JSON from {!First_version} with {!Second_version}: *) let v0_decoded_later : Second_version.t = Data_encoding.Json.destruct Second_version.encoding json_v0 in diff --git a/src/lib_event_logging/internal_event.mli b/src/lib_event_logging/internal_event.mli index 2c48bdbd99f7..9c3fc17b7442 100644 --- a/src/lib_event_logging/internal_event.mli +++ b/src/lib_event_logging/internal_event.mli @@ -24,12 +24,12 @@ (*****************************************************************************) (** - This module defines a “structured event logging framework.” + This module defines a "structured event logging framework." Internal-Event streams are like traditional logs but they have a proper {!Data_encoding} format in order to be processed by software. - The module defines “Sinks” {!SINK} as the receptacle for structured + The module defines "Sinks" {!SINK} as the receptacle for structured events: pluggable modules which can absorb (i.e. display, store, forward) the events emitted within the code-base. *) @@ -155,7 +155,7 @@ end (** An implementation of {!SINK} is responsible for handling/storing events, for instance, a sink could be output to a file, to a - database, or a simple “memory-less” forwarding mechanism. *) + database, or a simple "memory-less" forwarding mechanism. *) module type SINK = sig (** A sink can store any required state, e.g. a database handle, in -- GitLab