seppo/lib/logr.ml

(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * logr.ml
 *
 * Copyright (C) The #Seppo contributors. All rights reserved.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

type t = Target of Format.formatter

let output      = ref (Target Format.err_formatter)
let tz_offset_s = ref 0

let min_level   = 1

let kb = 1024
let mb = kb * kb

(* start logging to the file app/var/log/seppo.log like e.g.
 * https://github.com/oxidizing/sihl/blob/c6786f25424c1b9f40ce656e908bd31515f1cd09/sihl/src/core_log.ml#L18
 *
 * keep stdout exclusive for response!
*)
let open_out fn =
  let tz = Timedesc.Time_zone.(local() |> Option.value ~default:utc) in
  tz_offset_s := Ptime_clock.now() |> Rfc3339.tz_offset_s tz;
  if 10 * mb < try (Unix.stat fn).st_size with _ -> 0
  then Unix.rename fn (fn ^ ".0");
  let c = open_out_gen [ Open_wronly; Open_append; Open_creat; Open_binary ] 0o644 fn
          |> Format.formatter_of_out_channel in
  output := Target c

let close_out () =
  let Target lc = !output in
  Format.pp_print_flush lc

let msg' (Target lc) (level : Logs.level) msgf =
  let now = Ptime_clock.now () |> Ptime.to_rfc3339 ~tz_offset_s:!tz_offset_s ~frac_s:3 in
  let w (lvi : int) (lv : string) =
    if min_level <= lvi then (
      Format.fprintf lc "%s %s " now lv;
      msgf (Format.fprintf lc);
      Format.fprintf lc "\n%!"
      (* flush %! here seems necessary, or if run as a CGI under lighttpd/1.4.59 writes
       * are silently dropped. Not so if run from the shell (with sudo -u www-data)
      *)
    )
  in
  (match level with
   | Logs.App     -> ()
   | Logs.Debug   -> w 0 "DEBUG"
   | Logs.Info    -> w 1 "INFO "
   | Logs.Warning -> w 2 "WARN "
   | Logs.Error   -> w 3 "ERROR"
  )

let msg   lv = msg' (!output) lv
let err   fm = msg Logs.Error   fm
let warn  fm = msg Logs.Warning fm
let info  fm = msg Logs.Info    fm
let debug fm = msg Logs.Debug   fm