Source file syslog.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
open! Import

module Open_option = struct
  type t =
    (* THESE MUST STAY IN THE SAME ORDER AS IN syslog_stubs.c!!! *)
    | PID
    | CONS
    | ODELAY
    | NDELAY
    | NOWAIT
    | PERROR
  [@@deriving sexp]

  external to_int : t -> int = "core_syslog_open_option_to_int"

  let collect_mask i t = to_int t lor i
  let mask ts = List.fold ~f:collect_mask ~init:0 ts
end

module Facility = struct
  module T = struct
    type t =
      (* THESE MUST STAY IN THE SAME ORDER AS IN syslog_stubs.c!!! *)
      | KERN
      | USER
      | MAIL
      | DAEMON
      | AUTH
      | SYSLOG
      | LPR
      | NEWS
      | UUCP
      | CRON
      | AUTHPRIV
      | FTP
      | LOCAL0
      | LOCAL1
      | LOCAL2
      | LOCAL3
      | LOCAL4
      | LOCAL5
      | LOCAL6
      | LOCAL7
    [@@deriving sexp]

    external to_int : t -> int = "core_syslog_facility_to_int"
  end

  include T
  include Sexpable.To_stringable (T)

  let%test_unit _ = [%test_result: string] ~expect:"KERN" (to_string KERN)
  let%test_unit _ = [%test_result: t] ~expect:LOCAL7 (of_string "LOCAL7")
end

module Level = struct
  module T = struct
    type t =
      (* THESE MUST STAY IN THE SAME ORDER AS IN syslog_stubs.c!!! *)
      | EMERG
      | ALERT
      | CRIT
      | ERR
      | WARNING
      | NOTICE
      | INFO
      | DEBUG
    [@@deriving sexp, enumerate, compare]

    let compare a b = compare b a (* listed in descending order *)
    let%test_unit _ = [%test_result: int] ~expect:1 (compare EMERG DEBUG)

    external to_int : t -> int = "core_syslog_level_to_int"

    let collect_mask i t = to_int t lor i
    let mask ts = List.fold ~f:collect_mask ~init:0 ts
  end

  include T
  include Sexpable.To_stringable (T)

  let%test_unit _ = [%test_result: string] ~expect:"EMERG" (to_string EMERG)
  let%test_unit _ = [%test_result: t] ~expect:DEBUG (of_string "DEBUG")
end

external core_syslog_openlog : string option -> int -> int -> unit = "core_syslog_openlog"
external core_syslog_syslog : int -> string -> unit = "core_syslog_syslog"
external core_syslog_closelog : unit -> unit = "core_syslog_closelog" [@@noalloc]
external core_syslog_setlogmask : int -> unit = "core_syslog_setlogmask" [@@noalloc]

let openlog ?id ?(options = []) ?(facility = Facility.USER) () =
  core_syslog_openlog id (Open_option.mask options) (Facility.to_int facility)
;;

let syslog ?(facility = Facility.USER) ?(level = Level.INFO) message =
  core_syslog_syslog (Level.to_int level lor Facility.to_int facility) message
;;

let syslogf ?facility ?level format =
  ksprintf (fun message -> syslog ?facility ?level message) format
;;

let logmask_range ?(to_level = Level.EMERG) from_level =
  List.fold Level.all ~init:0 ~f:(fun logmask level ->
    if Level.compare from_level level < 1 && Level.compare level to_level < 1
    then Level.to_int level lor logmask
    else logmask)
;;

let setlogmask ?(allowed_levels = []) ?(from_level = Level.DEBUG) ?to_level () =
  core_syslog_setlogmask (Level.mask allowed_levels lor logmask_range ?to_level from_level)
;;

let closelog = core_syslog_closelog