Source file global.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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
open! Core
open! Async_kernel
open! Import

module type S = Global_intf.S

module Make () = struct
  let published_log = Atomic.make None
  let current_published_log () = Atomic.get published_log

  let log =
    lazy
      (let log =
         Log.create
           ?time_source:None
           ?transform:None
           ()
           ~level:`Info
           ~output:[ force Output.stderr ]
           ~on_error:On_error.send_to_top_level_monitor
       in
       Atomic.set published_log (Some log);
       log)
  ;;

  let level () = Log.level (Lazy.force log)

  let copy ?level ?on_error ?output ?extra_tags () =
    Log.copy ?level ?on_error ?output ?extra_tags (Lazy.force log)
  ;;

  let set_level level = Log.set_level (Lazy.force log) level
  let set_output output = Log.set_output (Lazy.force log) output
  let get_output () = Log.get_output (Lazy.force log)
  let set_on_error handler = Log.set_on_error (Lazy.force log) handler
  let get_time_source () = Log.get_time_source (Lazy.force log)

  let set_time_source time_source =
    Log.set_time_source (Lazy.force log) (Synchronous_time_source.read_only time_source)
  ;;

  module Transform = struct
    type t = Log.Transform.t

    let append' transform = Log.Transform.append' (Lazy.force log) transform
    let append transform = Log.Transform.append (Lazy.force log) transform
    let prepend' transform = Log.Transform.prepend' (Lazy.force log) transform
    let prepend transform = Log.Transform.prepend (Lazy.force log) transform
    let remove_exn t = Log.Transform.remove_exn (Lazy.force log) t
  end

  let add_tags ~tags = Log.add_tags (Lazy.force log) ~tags
  let has_transform () = Log.has_transform (Lazy.force log)
  let clear_transforms () = Log.clear_transforms (Lazy.force log)
  let get_transform () = Log.get_transform (Lazy.force log) [@alert "-deprecated"]
  let set_transform f = Log.set_transform (Lazy.force log) f [@alert "-deprecated"]
  let would_log level = Log.would_log (Lazy.force log) level
  let raw ?time ?tags k = Log.raw ?time ?tags (Lazy.force log) k
  let info ?time ?tags k = Log.info ?time ?tags (Lazy.force log) k
  let warn ?time ?tags k = Log.warn ?time ?tags (Lazy.force log) k
  let error ?time ?tags k = Log.error ?time ?tags (Lazy.force log) k

  module For_async_shutdown = struct
    let error_output_names = ref []

    let register_error_output_name output_name =
      error_output_names := output_name :: !error_output_names
    ;;

    let log_error ?time ?tags fmt =
      ksprintf
        (fun msg ->
          let log = Lazy.force log in
          let outputs =
            List.filter_map !error_output_names ~f:(Log.Private.get_named_output log)
          in
          Log.Private.with_temporary_outputs log outputs ~f:(fun () ->
            Log.string log ~level:`Error ?time ?tags msg))
        fmt
    ;;
  end

  let debug ?time ?tags k = Log.debug ?time ?tags (Lazy.force log) k
  let raw_s ?time ?tags the_sexp = Log.sexp ?time ?tags (Lazy.force log) the_sexp

  let debug_s ?time ?tags the_sexp =
    Log.sexp ~level:`Debug ?time ?tags (Lazy.force log) the_sexp
  ;;

  let info_s ?time ?tags the_sexp =
    Log.sexp ~level:`Info ?time ?tags (Lazy.force log) the_sexp
  ;;

  let warn_s ?time ?tags the_sexp =
    Log.sexp ~level:`Warn ?time ?tags (Lazy.force log) the_sexp
  ;;

  let error_s ?time ?tags the_sexp =
    Log.sexp ~level:`Error ?time ?tags (Lazy.force log) the_sexp
  ;;

  let flushed () = Log.flushed (Lazy.force log)
  let printf ?level ?time ?tags k = Log.printf ?level ?time ?tags (Lazy.force log) k
  let sexp ?level ?time ?tags s = Log.sexp ?level ?time ?tags (Lazy.force log) s
  let string ?level ?time ?tags s = Log.string ?level ?time ?tags (Lazy.force log) s
  let message msg = Log.message (Lazy.force log) msg
  let message_event msg = Log.message_event (Lazy.force log) msg

  let structured_message ?level ?time ?tags =
    Log.structured_message ?level ?time ?tags (Lazy.force log)
  ;;

  let structured_message_wrapped = Capsule.Initial.Data.wrap structured_message

  let execution_context =
    Async_kernel_scheduler.current_execution_context () |> Capsule.Initial.Data.wrap
  ;;

  let enqueue_structured_message ?level ?time ?tags data source =
    match current_published_log () with
    | None ->
      (* Before the lazy global log is forced: enqueue work that forces the log and
         applies the real [would_log] check in the async scheduler. *)
      Async_kernel_scheduler.portable_enqueue_job
        execution_context
        (Capsule.Data.create (fun () #(access, ()) ->
           let structured_message =
             Capsule.Data.unwrap ~access structured_message_wrapped
           in
           structured_message ?level ?time ?tags data source))
        (Capsule.Data.return ())
    | Some log ->
      (* [Log.enqueue_structured_message] checks [would_log] before enqueueing. *)
      Log.enqueue_structured_message ?level ?time ?tags log data source
  ;;

  let surround_s ~on_subsequent_errors ?level ?time ?tags msg f =
    Log.surround_s ~on_subsequent_errors ?level ?time ?tags (Lazy.force log) msg f
  ;;

  let surroundf ~on_subsequent_errors ?level ?time ?tags fmt =
    Log.surroundf ~on_subsequent_errors ?level ?time ?tags (Lazy.force log) fmt
  ;;

  let set_level_via_param ?default () = Log.Private.set_level_via_param_lazy ~default log

  module Private = struct
    let current_published_log = current_published_log
  end

  module For_testing = struct
    let use_test_output
      ?(map_output = Fn.id)
      ?(time : [ `Keep | `Omit ] = `Omit)
      ?(tags : [ `Keep | `Omit ] = `Omit)
      ?(level : [ `Keep | `Omit ] = `Omit)
      ()
      =
      set_output [ Output.For_testing.create ~map_output ~time ~tags ~level () ]
    ;;
  end
end

include Make ()