diff --git a/bin/dune b/bin/dune index 5b45705..ab01c45 100644 --- a/bin/dune +++ b/bin/dune @@ -2,5 +2,5 @@ (public_name talircd) (name main) (libraries - lwt lwt.unix logs fmt - server)) + lwt lwt.unix fmt + logging server)) diff --git a/bin/main.ml b/bin/main.ml index 759e628..be5c0f2 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,5 +1,5 @@ -Logs.set_level (Some Debug); -Logs.set_reporter (Logs.format_reporter ()); +Logging.init_pretty_writer stderr + ~min_level:DEBUG; Lwt_main.run (Server.run { diff --git a/lib/logging/dune b/lib/logging/dune new file mode 100644 index 0000000..aa02075 --- /dev/null +++ b/lib/logging/dune @@ -0,0 +1,4 @@ +(library + (package talircd) + (name logging) + (libraries unix)) diff --git a/lib/logging/logging.ml b/lib/logging/logging.ml new file mode 100644 index 0000000..ac9bf2f --- /dev/null +++ b/lib/logging/logging.ml @@ -0,0 +1,192 @@ +type level = + | TRACE + | DEBUG + | INFO + | WARN + | ERROR + +let lvl = function + | TRACE -> 0 + | DEBUG -> 1 + | INFO -> 2 + | WARN -> 3 + | ERROR -> 4 + +let max_lvl = 5 + +type writer = + ts:float -> + ns:string -> + lvl:int -> + string -> + unit + +let ( +++ ) w1 w2 ~ts ~ns ~lvl msg = + w1 ~ts ~ns ~lvl msg; + w2 ~ts ~ns ~lvl msg + +type logger = { + namespace : string; + mutable child : logger; + sibling : logger; + mutable min_lvl : int; + mutable writers : writer option; +} + +let rec root_logger = { + namespace = ""; + min_lvl = 0; + child = root_logger; + sibling = root_logger; + writers = None; +} + +let make_logger parent_logger ns = + let namespace = + if parent_logger == root_logger then ns + else String.concat "." [parent_logger.namespace; ns]; + in + let rec logger = { + namespace; + min_lvl = max_lvl; + child = logger; + sibling = parent_logger.child; + writers = None; + } in + parent_logger.child <- logger; + logger + +type 'a log_function = + ((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit + +let write logger lvl msg = + let ts = Unix.gettimeofday () in + let ns = logger.namespace in + Option.iter (fun w -> w ~ts ~ns ~lvl msg) logger.writers + +let[@inline] log_write logger lvl : _ log_function = fun logk -> + if lvl >= logger.min_lvl then + logk (fun fmt -> + Format.kasprintf (write logger lvl) + ("@[" ^^ fmt)) + + +module type Logs = sig + val logger : logger + val trace : _ log_function + val debug : _ log_function + val info : _ log_function + val warn : _ log_function + val error : _ log_function + val log : level -> _ log_function +end + +let make_logs parent_logger ns = + (module struct + let logger = make_logger parent_logger ns + let[@inline] trace k = log_write logger 0 k + let[@inline] debug k = log_write logger 1 k + let[@inline] info k = log_write logger 2 k + let[@inline] warn k = log_write logger 3 k + let[@inline] error k = log_write logger 4 k + let[@inline] log level k = log_write logger (lvl level) k + end : Logs) + +let logs ns = make_logs root_logger ns +let sublogs logger ns = make_logs logger ns + +(* TODO: filters: namespace[*] => min_level *) + +let rec add_writer_rec min_lvl writer parent_logger logger = + if parent_logger != logger then + begin + logger.min_lvl <- min min_lvl logger.min_lvl; + logger.writers <- + (match logger.writers with + | None -> Some writer + | Some writer' -> Some (writer' +++ writer)); + add_writer_rec min_lvl writer logger logger.child; + add_writer_rec min_lvl writer parent_logger logger.sibling + end + +let[@inline] add_writer ~min_lvl writer = + add_writer_rec min_lvl writer root_logger root_logger.child + +module Pretty = struct + type t = { + mutex : Mutex.t; + bp : Buffer.t; + mutable align_to : int; + out : out_channel; + } + + (* TODO: config timestamp *) + (* TODO: config color *) + (* TODO: config namespace *) + + let header = function + | 0 -> "TRACE" + | 1 -> "DEBUG" + | 2 -> "INFO" + | 3 -> "WARN" + | _ -> "ERROR" + + let ansi_color = function + | 0 -> 34 + | 1 -> 36 + | 2 -> 32 + | 3 -> 33 + | _ -> 31 + + let pr_timestamp bp ts = + let ts_ms = int_of_float (ts *. 1000.0) mod 1000 in + let tm = Unix.localtime ts in + Printf.bprintf bp "%04d-%02d-%02d %02d:%02d:%02d.%03d" + (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday + tm.tm_hour tm.tm_min tm.tm_sec ts_ms + + let pr_spaces bp n = + for _ = 1 to n do + Buffer.add_char bp ' ' + done + + let rec pr_lines_rec indent bp s i = + match String.index_from s i '\n' with + | exception Not_found -> + Buffer.add_substring bp s i (String.length s - i) + | k -> + Buffer.add_substring bp s i (k + 1 - i); + pr_spaces bp indent; + pr_lines_rec indent bp s (k + 1) + + let pr_lines ~indent bp s = + pr_lines_rec indent bp s 0 + + let make (out : out_channel) = { + mutex = Mutex.create (); + bp = Buffer.create 512; + align_to = 0; + out; + } + + let writer t ~ts ~ns ~lvl msg = + begin + Mutex.lock t.mutex; + Printf.bprintf t.bp "\x1b[1m%a\x1b[22m %s " pr_timestamp ts ns; + pr_spaces t.bp (t.align_to - Buffer.length t.bp); + t.align_to <- Buffer.length t.bp; + Printf.bprintf t.bp "\x1b[%dm%-5s\x1b[39;1m " (ansi_color lvl) (header lvl); + pr_lines t.bp msg ~indent:(t.align_to - 3); + Printf.bprintf t.bp "\x1b[0m\n"; + Buffer.output_buffer t.out t.bp; + flush t.out; + Buffer.clear t.bp; + Mutex.unlock t.mutex + end +end + +let init_pretty_writer ?min_level out = + Pretty.make out |> + Pretty.writer |> + add_writer ~min_lvl:(Option.fold ~some:lvl ~none:max_lvl min_level) + diff --git a/lib/logging/logging.mli b/lib/logging/logging.mli new file mode 100644 index 0000000..0dd7e30 --- /dev/null +++ b/lib/logging/logging.mli @@ -0,0 +1,29 @@ +type logger + +type level = + | TRACE + | DEBUG + | INFO + | WARN + | ERROR + +(* log_function (fun m -> m "" ); *) +type 'a log_function = + ((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit + +module type Logs = sig + val logger : logger + val trace : _ log_function + val debug : _ log_function + val info : _ log_function + val warn : _ log_function + val error : _ log_function + val log : level -> _ log_function +end + +val logs : string -> (module Logs) +val sublogs : logger -> string -> (module Logs) + +val init_pretty_writer : + ?min_level:level + -> out_channel -> unit diff --git a/lib/server/connection.ml b/lib/server/connection.ml index 4406065..5420c8d 100644 --- a/lib/server/connection.ml +++ b/lib/server/connection.ml @@ -3,6 +3,8 @@ open Result_syntax module User = Router.User module Chan = Router.Chan +include (val Logging.sublogs logger "Connection") + type t = { router : Router.t; addr : sockaddr; @@ -206,7 +208,7 @@ let on_msg_join t name = | `chan -> Ok (Router.find_chan t.router name) | _ -> Error (nosuchchannel name) with Not_found -> - Logs.debug (fun m -> m "making new channel %S" name); + debug (fun m -> m "making new channel %S" name); let chan = Chan.make ~name in Chan.register chan ~router:t.router; (* TODO: make user +o *) @@ -238,7 +240,7 @@ let on_msg_part t name = Router.relay msg ~from:me (`to_chan chan); Chan.part chan me; if Chan.no_members chan then begin - Logs.debug (fun m -> m "recycling channel %S" name); + debug (fun m -> m "recycling channel %S" name); Chan.unregister chan ~router:t.router; end; Ok () @@ -289,13 +291,13 @@ let split_command_params cmd params = [cmd, params] let pp_args ppf (cmd, params) = - Fmt.pf ppf "%s %a" cmd (Fmt.list (Fmt.fmt "%S") ~sep:Fmt.sp) params + Fmt.pf ppf "@[%s@ %a@]" cmd (Fmt.list (Fmt.fmt "%S") ~sep:Fmt.sp) params let on_msg t (msg : Irc.Msg.t) : unit = split_command_params msg.command msg.params |> List.iter (fun args -> - Logs.debug (fun m -> m "%a: %a" pp_sockaddr t.addr pp_args args); + debug (fun m -> m "@[%a:@ %a@]" pp_sockaddr t.addr pp_args args); match dispatch t args with | Ok () -> () | Error err -> reply t err) diff --git a/lib/server/dune b/lib/server/dune index c7a24eb..93cf03f 100644 --- a/lib/server/dune +++ b/lib/server/dune @@ -2,4 +2,5 @@ (package talircd) (name server) (libraries - lwt lwt.unix lwt-dllist logs fmt irc)) + lwt lwt.unix lwt-dllist fmt + logging irc)) diff --git a/lib/server/import.ml b/lib/server/import.ml index f565dd7..404e355 100644 --- a/lib/server/import.ml +++ b/lib/server/import.ml @@ -19,3 +19,5 @@ module Result_syntax = struct let ( let* ) = Result.bind let ( let+ ) r f = Result.map f r end + +include (val Logging.logs "Irc") diff --git a/lib/server/outbox.ml b/lib/server/outbox.ml index ca27782..7281af7 100644 --- a/lib/server/outbox.ml +++ b/lib/server/outbox.ml @@ -1,5 +1,7 @@ open! Import +(* include (val Logging.sublogs logger "Outbox") *) + type t = { stream : Irc.Msg.t Lwt_stream.t; push : Irc.Msg.t option -> unit; diff --git a/lib/server/server.ml b/lib/server/server.ml index 218d3c4..500158a 100644 --- a/lib/server/server.ml +++ b/lib/server/server.ml @@ -2,6 +2,8 @@ open! Import open Lwt.Syntax open Lwt.Infix +include (val Logging.sublogs logger "Server") + let listener ~(port : int) ~(backlog : int) : (fd * sockaddr) Lwt_stream.t = let sock : fd Lwt.t = let fd = Lwt_unix.socket PF_INET SOCK_STREAM 0 in @@ -10,7 +12,7 @@ let listener ~(port : int) ~(backlog : int) : (fd * sockaddr) Lwt_stream.t = let srv_adr = Unix.ADDR_INET (Unix.inet_addr_any, port) in let* () = Lwt_unix.bind fd srv_adr in Lwt_unix.listen fd backlog; - Logs.info (fun m -> m "listening on %a" pp_sockaddr srv_adr); + info (fun m -> m "listening on %a" pp_sockaddr srv_adr); Lwt.return fd in let accept () = sock >>= Lwt_unix.accept >|= Option.some in @@ -58,7 +60,7 @@ let writer (fd : fd) (obox : Irc.Msg.t Lwt_stream.t) : unit Lwt.t = | exn -> Lwt.fail exn) let handle_client (router : Router.t) (conn_fd : fd) (conn_addr : sockaddr) = - Logs.info (fun m -> m "new connection %a" pp_sockaddr conn_addr); + info (fun m -> m "new connection %a" pp_sockaddr conn_addr); let conn : Connection.t = Connection.make ~router @@ -73,7 +75,7 @@ let handle_client (router : Router.t) (conn_fd : fd) (conn_addr : sockaddr) = (fun () -> writer) (fun () -> Lwt_unix.close conn_fd >|= fun () -> - Logs.info (fun m -> m "connection closed %a" pp_sockaddr conn_addr)) + info (fun m -> m "connection closed %a" pp_sockaddr conn_addr)) type config = { port : int; @@ -89,7 +91,7 @@ let run (cfg : config) : unit Lwt.t = Lwt.on_failure (handle_client router fd adr) (fun exn -> - Logs.err (fun m -> m "%a: %a" pp_sockaddr adr Fmt.exn exn)) + error (fun m -> m "%a: %a" pp_sockaddr adr Fmt.exn exn)) in Lwt_stream.iter