(* Thread-safe flexible message/log facility                        *)
(* by Travis Bemann                                                 *)
(*                                                                  *)
(* This program is free software; you can redistribute it and/or    *)
(* modify it under the terms of the GNU Lesser General Public       *)
(* License as published by the Free Software Foundation; either     *)
(* version 2 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 Lesser General Public License for more details.              *)

open Str

type msg_type =
    Msg_info of int
  | Msg_error
  | Msg_debug

class type log_type =
  object
    method log : msg_type -> string -> unit
  end

class log_null_core =
  object (self)
    method log (_ : msg_type) (_ : string) = ()
  end

class log_null = (log_null_core : log_type)

let line_regexp = regexp "\n"

(* Format list of lines with prefix for each line. *)
let format_prefix_lines prefix lines =
  List.rev_map
      (fun line -> prefix ^ line ^ "\n")
      (List.rev lines)

(* Format a message with a prefix and text. *)
let format_msg prefix text =
  let lines = split line_regexp text
  and prefix_blank = String.make (String.length prefix) ' ' in
  match lines with
    first :: rest ->
      let first_line = prefix ^ first ^ "\n"
      and rest_lines = format_prefix_lines prefix_blank rest in
      String.concat "" (first_line :: rest_lines)
  | [] -> ""

(* Format a message with a prefix, a stamp, and text. *)
let format_stamp_msg prefix stamp text =
  format_msg (prefix ^ stamp) text

(* Output a string to a channel and then immediately flush it. *)
let push_string channel string =
  output_string channel string;
  flush channel

class log_channel_core ~channel ~verbosity ~debug ~prefix_info
    ~prefix_error ~prefix_debug =
  object (self)
    val mutex = Mutex.create ()

    (* Log message. *)
    method log sort text =
      Mutex.lock mutex;
      begin match sort with
	Msg_info level ->
	  if verbosity > level then
	    push_string channel (format_msg prefix_info text)
	  else ()
      | Msg_error ->
	  push_string channel (format_msg prefix_error text)
      | Msg_debug ->
	  if debug then
	    push_string channel (format_msg prefix_debug text)
	  else ()
      end;
      Mutex.unlock mutex
  end

class log_channel ~channel ~verbosity ~debug ~prefix_info
  ~prefix_error ~prefix_debug =
  (log_channel_core ~channel:channel ~verbosity:verbosity ~debug:debug
     ~prefix_info:prefix_info ~prefix_error:prefix_error
     ~prefix_debug:prefix_debug : log_type)

class log_stamp_channel_core ~channel ~verbosity ~debug ~prefix_info
    ~prefix_error ~prefix_debug =
  object (self)
    val mutex = Mutex.create ()

    (* Generate a timestamp. *)
    method private stamp =
      let time = Unix.gmtime (Unix.time ()) in
      Printf.sprintf "%i-%i-%i %02i:%02i:%02i UTC "
	(time.Unix.tm_year + 1900) (time.Unix.tm_mon + 1)
	time.Unix.tm_mday time.Unix.tm_hour time.Unix.tm_min
	time.Unix.tm_sec

    (* Log a message. *)
    method log sort text =
      Mutex.lock mutex;
      begin match sort with
	Msg_info level ->
	  if verbosity > level then
	    push_string channel
	      (format_stamp_msg prefix_info self#stamp text)
	  else ()
      | Msg_error ->
	  push_string channel
	    (format_stamp_msg prefix_error self#stamp text)
      | Msg_debug ->
	  if debug then
	    push_string channel
	      (format_stamp_msg prefix_debug self#stamp text)
	  else ()
      end;
      Mutex.unlock mutex
  end

class log_stamp_channel ~channel ~verbosity ~debug ~prefix_info
    ~prefix_error ~prefix_debug =
  (log_stamp_channel_core ~channel:channel ~verbosity:verbosity
     ~debug:debug ~prefix_info:prefix_info ~prefix_error:prefix_error
     ~prefix_debug:prefix_debug : log_type)