(**************************************************************************) (* *) (* Copyright (c) 2014 - 2016. *) (* Dynamic Ledger Solutions, Inc. *) (* *) (* All rights reserved. No warranty, explicit or implicit, provided. *) (* *) (**************************************************************************) 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, 'b) 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 end let log_f ?exn ?(section = Lwt_log.Section.main) ?location ?logger ~level format = if level < Lwt_log.Section.level section then Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format else Format.kasprintf (Lwt_log.log ?exn ~section ?location ?logger ~level) format let ign_log_f ?exn ?(section = Lwt_log.Section.main) ?location ?logger ~level format = if level < Lwt_log.Section.level section then Format.ikfprintf (fun _ -> ()) Format.std_formatter format else Format.kasprintf (fun s -> Lwt_log.ign_log ?exn ~section ?location ?logger ~level s) format module Make(S : sig val name: string end) : LOG = struct let section = Lwt_log.Section.make S.name let debug fmt = ign_log_f ~section ~level:Lwt_log.Debug fmt let log_info fmt = ign_log_f ~section ~level:Lwt_log.Info fmt let log_notice fmt = ign_log_f ~section ~level:Lwt_log.Notice fmt let warn fmt = ign_log_f ~section ~level:Lwt_log.Warning fmt let log_error fmt = ign_log_f ~section ~level:Lwt_log.Error fmt let fatal_error fmt = Format.kasprintf (fun s -> Lwt_log.ign_fatal ~section s; Utils.exit 1) fmt let lwt_debug fmt = log_f ~section ~level:Lwt_log.Debug fmt let lwt_log_info fmt = log_f ~section ~level:Lwt_log.Info fmt let lwt_log_notice fmt = log_f ~section ~level:Lwt_log.Notice fmt let lwt_warn fmt = log_f ~section ~level:Lwt_log.Warning fmt let lwt_log_error fmt = log_f ~section ~level:Lwt_log.Error fmt end module Core = Make(struct let name = "core" end) module Net = Make(struct let name = "net" end) module RPC = Make(struct let name = "rpc" end) module Db = Make(struct let name = "db" end) module Updater = Make(struct let name = "updater" end) module Node = struct module State = Make(struct let name = "node.state" end) module Validator = Make(struct let name = "node.validator" end) module Prevalidator = Make(struct let name = "node.prevalidator" end) module Discoverer = Make(struct let name = "node.discoverer" end) module Worker = Make(struct let name = "node.worker" end) module Main = Make(struct let name = "node.main" end) end module Client = struct module Blocks = Make(struct let name = "client.blocks" end) module Mining = Make(struct let name = "client.mining" end) module Endorsement = Make(struct let name = "client.endorsement" end) module Revelation = Make(struct let name = "client.revealation" end) module Denunciation = Make(struct let name = "client.denunciation" end) end let default_logger () = Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr () type kind = | Null | Stdout | Stderr | File of string | Syslog let init kind = let logger = match kind with | Stderr -> default_logger () | Stdout -> Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stdout () | File file_name -> Lwt_main.run (Lwt_log.file ~file_name ()) | Null -> Lwt_log.null | Syslog -> Printf.eprintf "Warning: log_kind \"syslog\" not yet implemented.\n%!"; default_logger () in Lwt_log.default := logger