diff --git a/src/logs_syslog.ml b/src/logs_syslog.ml index 25434df..b65f83f 100644 --- a/src/logs_syslog.ml +++ b/src/logs_syslog.ml @@ -15,10 +15,17 @@ let ppf, flush = in ppf, flush +let facility = + let ppf ppf v = + Syslog_message.string_of_facility v |> Format.pp_print_string ppf + in + Logs.Tag.def ~doc:"Syslog facility" "syslog-facility" ppf + (* TODO: can we derive the facility from the source? *) -let message ?(facility = Syslog_message.System_Daemons) +let message ?facility:(syslog_facility = Syslog_message.System_Daemons) ~host:hostname ~source ~tags ?header level timestamp message = let tags = + let tags = Logs.Tag.rem facility tags in if Logs.Tag.is_empty tags then "" else @@ -29,7 +36,8 @@ let message ?(facility = Syslog_message.System_Daemons) let message = Printf.sprintf "%s%s%s %s" source tags hdr message and severity = slevel level in - { Syslog_message.facility ; severity ; timestamp ; hostname ; message } + { Syslog_message.facility = syslog_facility ; severity ; timestamp ; + hostname ; message } type framing = [ | `LineFeed diff --git a/src/logs_syslog.mli b/src/logs_syslog.mli index b6d7ba4..5e78d9d 100644 --- a/src/logs_syslog.mli +++ b/src/logs_syslog.mli @@ -89,3 +89,7 @@ val ppf : Format.formatter (** [flush ()] flushes the formatter, and return the [text] *) val flush : unit -> string + +(** [facility] is a {!Logs.Tag.def} tag to give a message a different syslog + facility from the reporter's default. *) +val facility : Syslog_message.facility Logs.Tag.def diff --git a/src/logs_syslog_lwt.ml b/src/logs_syslog_lwt.ml index 2bca979..df6b330 100644 --- a/src/logs_syslog_lwt.ml +++ b/src/logs_syslog_lwt.ml @@ -2,7 +2,7 @@ open Lwt.Infix open Logs_syslog_lwt_common open Logs_syslog -let udp_reporter ?hostname ip ?(port = 514) ?(truncate = 65535) () = +let udp_reporter ?hostname ip ?(port = 514) ?(truncate = 65535) ?facility () = let sa = Lwt_unix.ADDR_INET (ip, port) in let s = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in let rec send msg = @@ -20,9 +20,9 @@ let udp_reporter ?hostname ip ?(port = 514) ?(truncate = 65535) () = (match hostname with | Some x -> Lwt.return x | None -> Lwt_unix.gethostname ()) >|= fun host -> - syslog_report_common host truncate Ptime_clock.now send + syslog_report_common facility host truncate Ptime_clock.now send -let tcp_reporter ?hostname ip ?(port = 514) ?(truncate = 0) ?(framing = `Null) () = +let tcp_reporter ?hostname ip ?(port = 514) ?(truncate = 0) ?(framing = `Null) ?facility () = let sa = Lwt_unix.ADDR_INET (ip, port) in let s = ref None in let m = Lwt_mutex.create () in @@ -85,4 +85,5 @@ let tcp_reporter ?hostname ip ?(port = 514) ?(truncate = 0) ?(framing = `Null) ( at_exit (fun () -> match !s with | None -> () | Some x -> Lwt.async (fun () -> Lwt_unix.close x)) ; - Lwt.return (Ok (syslog_report_common host truncate Ptime_clock.now send)) + Lwt.return (Ok (syslog_report_common facility host truncate Ptime_clock.now + send)) diff --git a/src/logs_syslog_lwt.mli b/src/logs_syslog_lwt.mli index 8d5cee2..3567c42 100644 --- a/src/logs_syslog_lwt.mli +++ b/src/logs_syslog_lwt.mli @@ -6,9 +6,11 @@ sends syslog message using the given [hostname] to [remote_ip, remote_port] via UDP. Each message is truncated to [truncate] bytes (defaults to 65535). The [hostname] default to [Lwt_unix.gethostname ()], [port] defaults to - 514. *) + 514. [facility] is the default syslog facility (see + {!logs_syslog.message}). *) val udp_reporter : - ?hostname:string -> Lwt_unix.inet_addr -> ?port:int -> ?truncate:int -> unit -> + ?hostname:string -> Lwt_unix.inet_addr -> ?port:int -> ?truncate:int -> + ?facility:Syslog_message.facility -> unit -> Logs.reporter Lwt.t (** [tcp_reporter ~hostname remote_ip ~port ~truncate ~framing ()] is [Ok @@ -20,10 +22,12 @@ val udp_reporter : [truncate] bytes (defaults to 0, thus no truncation). Each syslog message is framed (using [framing]), the default strategy is to append a single byte containing 0. The [hostname] default to [Lwt_unix.gethostname ()], [port] - to 514. *) + to 514. [facility] is the default syslog facility (see + {!logs_syslog.message}). *) val tcp_reporter : ?hostname:string -> Lwt_unix.inet_addr -> ?port:int -> ?truncate:int -> - ?framing:Logs_syslog.framing -> unit -> + ?framing:Logs_syslog.framing -> + ?facility:Syslog_message.facility -> unit -> (Logs.reporter, string) result Lwt.t (** {1:lwt_example Example usage} diff --git a/src/logs_syslog_lwt_common.ml b/src/logs_syslog_lwt_common.ml index d767a37..7c0004f 100644 --- a/src/logs_syslog_lwt_common.ml +++ b/src/logs_syslog_lwt_common.ml @@ -1,12 +1,16 @@ open Logs_syslog -let syslog_report_common host len now send = +let syslog_report_common facility host len now send = let report src level ~over k msgf = let source = Logs.Src.name src in let timestamp = now () in let k tags ?header _ = + let facility = match Logs.Tag.find Logs_syslog.facility tags with + | None -> facility + | facility -> facility + in let msg = - message ~host ~source ~tags ?header level timestamp (flush ()) + message ?facility ~host ~source ~tags ?header level timestamp (flush ()) in let bytes = Syslog_message.encode ~len msg in let unblock () = over () ; Lwt.return_unit in diff --git a/src/logs_syslog_lwt_common.mli b/src/logs_syslog_lwt_common.mli index e357b77..38f3d89 100644 --- a/src/logs_syslog_lwt_common.mli +++ b/src/logs_syslog_lwt_common.mli @@ -1,2 +1,3 @@ val syslog_report_common : - string -> int -> (unit -> Ptime.t) -> (string -> unit Lwt.t) -> Logs.reporter + Syslog_message.facility option -> string -> int -> (unit -> Ptime.t) -> + (string -> unit Lwt.t) -> Logs.reporter diff --git a/src/logs_syslog_lwt_tls.ml b/src/logs_syslog_lwt_tls.ml index 67aaebe..09949dc 100644 --- a/src/logs_syslog_lwt_tls.ml +++ b/src/logs_syslog_lwt_tls.ml @@ -4,7 +4,7 @@ open Logs_syslog let tcp_tls_reporter ?hostname ip ?(port = 6514) ~cacert ~cert ~priv_key ?(truncate = 0) - ?(framing = `Null) () = + ?(framing = `Null) ?facility () = let sa = Lwt_unix.ADDR_INET (ip, port) in let tls = ref None in let m = Lwt_mutex.create () in @@ -78,7 +78,8 @@ let tcp_tls_reporter at_exit (fun () -> match !tls with | None -> () | Some tls -> Lwt.async (fun () -> Tls_lwt.Unix.close tls)) ; - Lwt.return (Ok (syslog_report_common host truncate Ptime_clock.now send)) + Lwt.return (Ok (syslog_report_common facility host truncate Ptime_clock.now + send)) (* let main () = diff --git a/src/logs_syslog_lwt_tls.mli b/src/logs_syslog_lwt_tls.mli index bd53e51..70f5b8a 100644 --- a/src/logs_syslog_lwt_tls.mli +++ b/src/logs_syslog_lwt_tls.mli @@ -15,11 +15,13 @@ is appended, depending on [framing], its length could be prepended, as specified in {{:https://tools.ietf.org/html/rfc5125}RFC 5125}. The default value for [hostname] is [Lwt_unix.gethostname ()], the default value for - [port] is 6514. *) + [port] is 6514. [facility] is the default syslog facility (see + {!logs_syslog.message}). *) val tcp_tls_reporter : ?hostname:string -> Lwt_unix.inet_addr -> ?port:int -> cacert:string -> cert:string -> priv_key:string -> ?truncate:int -> - ?framing:Logs_syslog.framing -> unit -> + ?framing:Logs_syslog.framing -> + ?facility:Syslog_message.facility -> unit -> (Logs.reporter, string) result Lwt.t (** {1:lwt_tls_example Example usage} diff --git a/src/logs_syslog_mirage.ml b/src/logs_syslog_mirage.ml index b04b633..8a6446d 100644 --- a/src/logs_syslog_mirage.ml +++ b/src/logs_syslog_mirage.ml @@ -3,11 +3,12 @@ open Lwt.Infix module Udp (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mirage_stack_lwt.V4) = struct module UDP = STACK.UDPV4 - let create c clock stack ~hostname dst ?(port = 514) ?(truncate = 65535) () = + let create c clock stack ~hostname dst ?(port = 514) ?(truncate = 65535) ?facility () = let dsts = Printf.sprintf "while writing to %s:%d" (Ipaddr.V4.to_string dst) port in Logs_syslog_lwt_common.syslog_report_common + facility hostname truncate (* This API for PCLOCK is inconvenient (overengineered?) *) @@ -25,7 +26,7 @@ module Tcp (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mir open Logs_syslog module TCP = STACK.TCPV4 - let create c clock stack ~hostname dst ?(port = 514) ?(truncate = 0) ?(framing = `Null) () = + let create c clock stack ~hostname dst ?(port = 514) ?(truncate = 0) ?(framing = `Null) ?facility () = let tcp = STACK.tcpv4 stack in let f = ref None in let dsts = @@ -65,6 +66,7 @@ module Tcp (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mir connect () >|= function | Ok () -> Ok (Logs_syslog_lwt_common.syslog_report_common + facility hostname truncate (fun () -> Ptime.v (CLOCK.now_d_ps clock)) diff --git a/src/logs_syslog_mirage.mli b/src/logs_syslog_mirage.mli index 50bb359..a3acf90 100644 --- a/src/logs_syslog_mirage.mli +++ b/src/logs_syslog_mirage.mli @@ -8,9 +8,11 @@ module Udp (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mir sends log messages to [ip, port] via UDP. Upon failure, a message is emitted to the console [c]. Each message can be truncated: [truncate] defaults to 65535 bytes. The [hostname] is part of each syslog message. - The [port] defaults to 514. *) + The [port] defaults to 514. [facility] is the default syslog facility (see + {!logs_syslog.message}). *) val create : C.t -> CLOCK.t -> STACK.t -> hostname:string -> - STACK.ipv4addr -> ?port:int -> ?truncate:int -> unit -> Logs.reporter + STACK.ipv4addr -> ?port:int -> ?truncate:int -> + ?facility:Syslog_message.facility -> unit -> Logs.reporter end (** TCP syslog *) @@ -23,11 +25,13 @@ module Tcp (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mir connection. Each syslog message can be truncated, depending on [truncate] (defaults to no truncating). The [hostname] is part of each syslog message. The default value of [port] is 514, the default behaviour of - [framing] is to append a 0 byte. *) + [framing] is to append a 0 byte. [facility] is the default syslog + facility (see {!logs_syslog.message}). *) val create : C.t -> CLOCK.t -> STACK.t -> hostname:string -> STACK.ipv4addr -> ?port:int -> ?truncate:int -> - ?framing:Logs_syslog.framing -> unit -> + ?framing:Logs_syslog.framing -> + ?facility:Syslog_message.facility -> unit -> (Logs.reporter, string) result STACK.io end diff --git a/src/logs_syslog_mirage_tls.ml b/src/logs_syslog_mirage_tls.ml index 7cd70fa..36ed356 100644 --- a/src/logs_syslog_mirage_tls.ml +++ b/src/logs_syslog_mirage_tls.ml @@ -6,7 +6,7 @@ module Tls (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mir module TLS = Tls_mirage.Make(TCP) module X509 = Tls_mirage.X509(KV)(CLOCK) - let create c clock stack kv ?keyname ~hostname dst ?(port = 6514) ?(truncate = 0) ?(framing = `Null) () = + let create c clock stack kv ?keyname ~hostname dst ?(port = 6514) ?(truncate = 0) ?(framing = `Null) ?facility () = let tcp = STACK.tcpv4 stack in let f = ref None in let dsts = @@ -61,6 +61,7 @@ module Tls (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mir connect () >|= function | Ok () -> Ok (Logs_syslog_lwt_common.syslog_report_common + facility hostname truncate (fun () -> Ptime.v (CLOCK.now_d_ps clock)) diff --git a/src/logs_syslog_mirage_tls.mli b/src/logs_syslog_mirage_tls.mli index f79d9bc..ffa9cdd 100644 --- a/src/logs_syslog_mirage_tls.mli +++ b/src/logs_syslog_mirage_tls.mli @@ -14,9 +14,11 @@ module Tls (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mir [c], and attempts are made to re-establish the TLS connection. Each message can be truncated (to [truncate] bytes), default is to not truncate. The [hostname] is part of each syslog message. The [port] - defaults to 6514, [framing] to appending a 0 byte. *) + defaults to 6514, [framing] to appending a 0 byte. [facility] is the + default syslog facility (see {!logs_syslog.message}). *) val create : C.t -> CLOCK.t -> STACK.t -> KV.t -> ?keyname:string -> hostname:string -> - STACK.ipv4addr -> ?port:int -> ?truncate:int -> ?framing:Logs_syslog.framing -> unit -> + STACK.ipv4addr -> ?port:int -> ?truncate:int -> ?framing:Logs_syslog.framing -> + ?facility:Syslog_message.facility -> unit -> (Logs.reporter, string) result STACK.io end diff --git a/src/logs_syslog_unix.ml b/src/logs_syslog_unix.ml index 6b2b4e6..e73db36 100644 --- a/src/logs_syslog_unix.ml +++ b/src/logs_syslog_unix.ml @@ -1,12 +1,16 @@ open Logs_syslog -let syslog_report host len send = +let syslog_report facility host len send = let report src level ~over k msgf = let source = Logs.Src.name src in let timestamp = Ptime_clock.now () in let k tags ?header _ = + let facility = match Logs.Tag.find Logs_syslog.facility tags with + | None -> facility + | facility -> facility + in let msg = - message ~host ~source ~tags ?header level timestamp (flush ()) + message ?facility ~host ~source ~tags ?header level timestamp (flush ()) in send (Syslog_message.encode ~len msg) ; over () ; k () in @@ -19,7 +23,8 @@ let udp_reporter ?(hostname = Unix.gethostname ()) ip ?(port = 514) - ?(truncate = 65535) () = + ?(truncate = 65535) + ?facility () = let sa = Unix.ADDR_INET (ip, port) in let s = Unix.(socket PF_INET SOCK_DGRAM 0) in let rec send msg = @@ -32,7 +37,7 @@ let udp_reporter (Ptime.to_rfc3339 (Ptime_clock.now ())) msg in - syslog_report hostname truncate send + syslog_report facility hostname truncate send type state = | Disconnected @@ -46,7 +51,8 @@ let tcp_reporter ip ?(port = 514) ?(truncate = 0) - ?(framing = `Null) () = + ?(framing = `Null) + ?facility () = let sa = Unix.ADDR_INET (ip, port) in let s = ref Disconnected in let connect () = @@ -98,4 +104,4 @@ let tcp_reporter aux 0 in at_exit (fun () -> match !s with Connected x -> Unix.close x | _ -> ()) ; - Ok (syslog_report hostname truncate send) + Ok (syslog_report facility hostname truncate send) diff --git a/src/logs_syslog_unix.mli b/src/logs_syslog_unix.mli index d38020c..5b044aa 100644 --- a/src/logs_syslog_unix.mli +++ b/src/logs_syslog_unix.mli @@ -6,9 +6,11 @@ sends log message to [remote_ip, port] via UDP. Each message is truncated to [truncate] bytes (defaults to 65535). The [hostname] is part of each syslog message, and defaults to [Unix.gethostname ()], the [port] defaults - to 514. *) + to 514. [facility] is the default syslog facility (see + {!logs_syslog.message}). *) val udp_reporter : - ?hostname:string -> Unix.inet_addr -> ?port:int -> ?truncate:int -> unit -> + ?hostname:string -> Unix.inet_addr -> ?port:int -> ?truncate:int -> + ?facility:Syslog_message.facility -> unit -> Logs.reporter (** [tcp_reporter ~hostname remote_ip ~port ~truncate ~framing ()] is [Ok @@ -20,10 +22,12 @@ val udp_reporter : truncated to [truncate] bytes (by default no truncation happens). Each syslog message is framed according to the given [framing] (defaults to a single 0 byte). The [hostname] defaults to [Unix.gethostname ()], [port] to - 514, [framing] to append a 0 byte. *) + 514, [framing] to append a 0 byte. [facility] is the default syslog facility + (see {!logs_syslog.message}). *) val tcp_reporter : ?hostname:string -> Unix.inet_addr -> ?port:int -> ?truncate:int -> - ?framing:Logs_syslog.framing -> unit -> + ?framing:Logs_syslog.framing -> + ?facility:Syslog_message.facility -> unit -> (Logs.reporter, string) result (** {1:unix_example Example usage}