Allowing specifying the log facility

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

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

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))

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}

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

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

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 () =

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}

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))

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
 

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))

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
 

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)

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}