initial commit

.gitignore

@@ -0,0 +1 @@
+/_build

README.md

@@ -0,0 +1,22 @@
+# xlog
+
+logging library for cats written in ocaml
+
+original code (most of the code here) from: <https://git.lain.faith/iitalics/talircd>, which is
+released under LGPL-2.0-or-later. all modifications to the code in this repo are released under the
+same license
+
+## usage
+
+```ocaml
+include (val Xlog.logs __FUNCTION__)
+
+let () =
+  info (fun m -> m "meow meow meow")
+
+module Submodule = struct
+  include (val Xlog.logs __FUNCTION__)
+
+  (* ... *)
+end
+```

dune-project

@@ -0,0 +1,20 @@
+(lang dune 3.15)
+
+(name xlog)
+(version 0.0.1)
+
+(generate_opam_files true)
+
+(package
+ (name xlog)
+ (synopsis "logging library")
+ (description "logging library for cats written in ocaml")
+ (license "LGPL-2.0-or-later")
+ (homepage "https://git.lain.faith/haskal/xlog")
+ (bug_reports "https://git.lain.faith/haskal/xlog")
+ (authors "iitalics <git.lain.faith/iitalics>" "xenia <xenia@awoo.systems>")
+ (maintainers "iitalics <git.lain.faith/iitalics>" "xenia <xenia@awoo.systems>")
+ (source
+  (uri "https://git.lain.faith/haskal/xlog.git"))
+ (depends ocaml dune
+  (ptime (>= 1.1))))

lib/core.ml

@@ -0,0 +1,19 @@
+type level =
+  | TRACE (* 0 *)
+  | DEBUG (* 1 *)
+  | INFO  (* 2 *)
+  | WARN  (* 3 *)
+  | ERROR (* 4 *)
+
+external int_of_level : level -> int = "%identity"
+
+type writer =
+  ts:Time.t ->
+  ns:string ->
+  lvl:level ->
+  string ->
+  unit
+
+let ( +++ ) w1 w2 ~ts ~ns ~lvl msg =
+  w1 ~ts ~ns ~lvl msg;
+  w2 ~ts ~ns ~lvl msg

lib/dune

@@ -0,0 +1,4 @@
+(library
+ (name xlog)
+ (public_name xlog)
+ (libraries ptime ptime.clock.os str unix))

lib/journald.ml

@@ -0,0 +1,53 @@
+open Core
+
+let default_socket_path = "/run/systemd/journal/socket"
+
+type t = {
+  mutex : Mutex.t;
+  sock_fd : Unix.file_descr;
+  dest : Unix.sockaddr;
+  buf : Buffer.t;
+}
+
+let should_upgrade () =
+  let stderr = Unix.fstat Unix.stderr in
+  let dev_ino = Printf.sprintf "%d:%d" stderr.st_dev stderr.st_ino in
+  Sys.getenv_opt "JOURNAL_STREAM" = Some dev_ino
+
+let make ?(path = default_socket_path) () = {
+  mutex = Mutex.create ();
+  sock_fd = Unix.socket PF_UNIX SOCK_DGRAM 0 ~cloexec:true;
+  dest = ADDR_UNIX path;
+  buf = Buffer.create 256;
+}
+
+let add_field dgram key value =
+  if String.contains value '\n' then
+    begin
+      Buffer.add_string dgram key;
+      Buffer.add_char dgram '\n';
+      Buffer.add_int64_le dgram (Int64.of_int (String.length value));
+      Buffer.add_string dgram value;
+      Buffer.add_char dgram '\n';
+    end
+  else
+    Printf.bprintf dgram "%s=%s\n" key value
+
+let syslog_priority = function
+  | TRACE
+  | DEBUG -> "7" (* LOG_DEBUG *)
+  | INFO  -> "6" (* LOG_INFO *)
+  | WARN  -> "4" (* LOG_WARNING *)
+  | ERROR -> "3" (* LOG_ERR *)
+
+let writer t ~ts ~ns ~lvl msg =
+  Mutex.lock t.mutex;
+  let dgram =
+    Buffer.clear t.buf;
+    ignore ts;
+    add_field t.buf "MESSAGE" (Printf.sprintf "%s: %s" ns msg);
+    add_field t.buf "PRIORITY" (syslog_priority lvl);
+    Buffer.to_bytes t.buf
+  in
+  Mutex.unlock t.mutex;
+  Unix.sendto t.sock_fd dgram 0 (Bytes.length dgram) [] t.dest |> ignore

lib/mutex.ml

@@ -0,0 +1,5 @@
+(* stub implementation since we actually aren't multithreaded *)
+type t = unit
+external create : unit -> t = "%identity"
+external lock : t -> unit = "%identity"
+external unlock : t -> unit = "%identity"

lib/pretty.ml

@@ -0,0 +1,115 @@
+open Core
+
+type t = {
+  mutex : Mutex.t;
+  bp : Buffer.t;
+  mutable align_to : int;
+  out : out_channel;
+  flags : int;
+}
+
+type config = {
+  color : bool;
+  timestamp : bool;
+  namespace : bool;
+  level : bool;
+}
+
+let _fl_c = 1 (* color *)
+let _fl_t = 2 (* timestamp *)
+let _fl_n = 4 (* namespace *)
+let _fl_l = 8 (* level *)
+let _fl_ct = _fl_c + _fl_t
+let _fl_cl = _fl_c + _fl_l
+
+let header = function
+  | TRACE -> "TRACE"
+  | DEBUG -> "DEBUG"
+  | INFO  -> "INFO"
+  | WARN  -> "WARN"
+  | ERROR -> "ERROR"
+
+let ansi_header = function
+  | TRACE -> "\x1b[34m"
+  | DEBUG -> "\x1b[36m"
+  | INFO  -> "\x1b[32m"
+  | WARN  -> "\x1b[33m"
+  | ERROR -> "\x1b[31m"
+
+let ansi_dim  = "\x1b[2m"
+let ansi_bold = "\x1b[1m"
+let ansi_off  = "\x1b[0m"
+
+let pr_timestamp bp ts =
+  Buffer.add_string bp (Time.to_string ts)
+
+let pr_spaces bp n =
+  for _ = 1 to n do
+    Buffer.add_char bp ' '
+  done
+
+let rec pr_lines_rec indent bp s i =
+  match String.index_from s i '\n' with
+  | exception Not_found ->
+    Buffer.add_substring bp s i (String.length s - i)
+  | k ->
+    Buffer.add_substring bp s i (k + 1 - i);
+    pr_spaces bp indent;
+    pr_lines_rec indent bp s (k + 1)
+
+let pr_lines ~indent bp s =
+  pr_lines_rec indent bp s 0
+
+let make (out : out_channel) (cfg : config) = {
+  mutex = Mutex.create ();
+  bp = Buffer.create 512;
+  align_to = 0;
+  out;
+  flags = (if cfg.color     then _fl_c else 0) +
+          (if cfg.timestamp then _fl_t else 0) +
+          (if cfg.namespace then _fl_n else 0) +
+          (if cfg.level     then _fl_l else 0)
+}
+
+let pr_msg bp msg ts ns lvl ~align ~indent ~f =
+  begin
+    if f _fl_ct then Buffer.add_string bp ansi_dim;
+    if f _fl_t  then Printf.bprintf bp "%a " pr_timestamp ts;
+    if f _fl_ct then Buffer.add_string bp ansi_off;
+
+    if f _fl_n then Printf.bprintf bp "%s " ns;
+    if f _fl_n then pr_spaces bp (align bp);
+
+    if f _fl_cl then Buffer.add_string bp (ansi_header lvl);
+    if f _fl_l then Printf.bprintf bp "%-5s " (header lvl);
+    if f _fl_cl then Buffer.add_string bp ansi_off;
+
+    if f _fl_c then Buffer.add_string bp ansi_bold;
+    pr_lines bp msg ~indent:(indent bp);
+    if f _fl_c then Buffer.add_string bp ansi_off;
+
+    Buffer.add_string bp "\n";
+  end
+
+let writer t ~ts ~ns ~lvl msg =
+  let f mask = t.flags land mask = mask in
+  let align bp =
+    let n = t.align_to - Buffer.length bp in
+    t.align_to <- max t.align_to (Buffer.length bp);
+    n
+  in
+  let indent bp =
+    Buffer.length bp
+    - (if f _fl_c  then 4 else 0)
+    - (if f _fl_ct then 8 else 0)
+    - (if f _fl_cl then 9 else 0)
+  in
+  begin
+    Mutex.lock t.mutex;
+    pr_msg t.bp msg ts ns lvl ~align ~indent ~f;
+    Buffer.output_buffer t.out t.bp;
+    flush t.out;
+    Buffer.clear t.bp;
+    Mutex.unlock t.mutex
+  end
+

lib/time.ml

@@ -0,0 +1,5 @@
+type t = Ptime.t
+let stamp = Ptime_clock.now
+let pp = Ptime.pp_rfc3339 ()
+           ?tz_offset_s:(Ptime_clock.current_tz_offset_s ())
+let to_string x = Format.asprintf "%a" pp x

lib/util.ml

@@ -0,0 +1,9 @@
+let dune_exe_rx = Str.regexp "^Dune__exe__"
+let dune_underscore_rx = Str.regexp "__"
+
+let parse_module_name (name : string) : string list =
+  match String.split_on_char '.' name with
+  | [] -> []
+  | fst::rst ->
+    let fst = Str.global_replace dune_exe_rx "[EXE]" fst in
+    (Str.split dune_underscore_rx fst) @ rst

lib/xlog.ml

@@ -0,0 +1,149 @@
+include Core
+
+type logger = {
+  namespace : string;
+  pnamespace : string list;
+  mutable child : logger;
+  sibling : logger;
+  mutable min_level : int;
+  mutable writers : writer option;
+}
+
+let rec root_logger = {
+  namespace = "";
+  pnamespace = [];
+  min_level = 0;
+  child = root_logger;
+  sibling = root_logger;
+  writers = None;
+}
+
+let rec find_logger parent_logger child_logger ns =
+  if child_logger == parent_logger then
+    None
+  else if List.nth_opt child_logger.pnamespace 0 = Some ns then
+    Some child_logger
+  else
+    find_logger parent_logger child_logger.sibling ns
+
+let make_logger parent_logger ns =
+  let pnamespace = ns::parent_logger.pnamespace in
+  let rec logger = {
+    namespace = String.concat "." (List.rev pnamespace);
+    pnamespace = pnamespace;
+    min_level = Int.max_int;
+    child = logger;
+    sibling = parent_logger.child;
+    writers = None;
+  } in
+  parent_logger.child <- logger;
+  logger
+
+let rec find_or_make_logger parent_logger ns =
+  match ns with
+  | [] -> parent_logger
+  | [""] -> parent_logger
+  | fst::rst -> begin
+      match find_logger parent_logger parent_logger.child fst with
+      | Some logger -> find_or_make_logger logger rst
+      | None -> find_or_make_logger (make_logger parent_logger fst) rst
+    end
+
+type 'a log_function =
+  ((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit
+
+let write logger lvl msg =
+  let ts = Time.stamp () in
+  let ns = logger.namespace in
+  Option.iter (fun w -> w ~ts ~ns ~lvl msg) logger.writers
+
+let[@inline] logf logger lvl : _ log_function = fun logk ->
+  if int_of_level lvl >= logger.min_level then
+    logk (fun fmt ->
+           Format.kasprintf (write logger lvl)
+             ("@[<hov>" ^^ fmt))
+
+
+module type Logs = sig
+  val logger : logger
+  val trace : _ log_function
+  val debug : _ log_function
+  val info  : _ log_function
+  val warn  : _ log_function
+  val error : _ log_function
+  val log   : level -> _ log_function
+end
+
+let make_logs parent_logger ns =
+  (module struct
+    let logger = find_or_make_logger parent_logger ns
+    let[@inline] trace k = logf logger TRACE k
+    let[@inline] debug k = logf logger DEBUG k
+    let[@inline] info  k = logf logger INFO  k
+    let[@inline] warn  k = logf logger WARN  k
+    let[@inline] error k = logf logger ERROR k
+    let[@inline] log level k = logf logger level k
+  end : Logs)
+
+let logs ns = make_logs root_logger (Util.parse_module_name ns)
+let sublogs logger ns = make_logs logger [ns]
+
+(* TODO: filters: namespace[*] => min_level *)
+
+let rec add_writer_rec min_level writer parent_logger logger =
+  if parent_logger != logger then
+    begin
+      logger.min_level <- min min_level logger.min_level;
+      logger.writers <-
+        (match logger.writers with
+         | None -> Some writer
+         | Some writer' -> Some (writer' +++ writer));
+      add_writer_rec min_level writer logger logger.child;
+      add_writer_rec min_level writer parent_logger logger.sibling
+    end
+
+let[@inline] add_writer ?(min_level = WARN) writer =
+  add_writer_rec (int_of_level min_level) writer root_logger root_logger.child
+
+let init_pretty_writer
+      ?min_level
+      ?(color = true)
+      ?(timestamp = true)
+      ?(namespace = true)
+      ?(level = true)
+      out
+  =
+  Pretty.make out { color; timestamp; namespace; level } |>
+  Pretty.writer |>
+  add_writer ?min_level
+
+let init_journald_writer
+      ?min_level
+      ?path
+      ()
+  =
+  Journald.make () ?path |>
+  Journald.writer |>
+  add_writer ?min_level
+
+let should_upgrade_to_journald = Journald.should_upgrade
+
+let dump_tree () =
+  let rec dt (parent : logger) (child : logger) (ts : string) : unit =
+    Printf.eprintf "%slogger: %s\n%!" ts child.namespace;
+    if child.child == child then
+      ()
+    else
+      dt child child.child (String.concat "" [ts; ">"]);
+    if child.sibling == parent then
+      ()
+    else
+      dt parent child.sibling ts
+  in
+  Printf.eprintf "logger: <root>\n%!";
+  if root_logger.child == root_logger then
+    ()
+  else
+    dt root_logger root_logger.child ">"
+
+let _dump_tree = dump_tree

lib/xlog.mli

@@ -0,0 +1,40 @@
+type logger
+
+type level =
+  | TRACE
+  | DEBUG
+  | INFO
+  | WARN
+  | ERROR
+
+(* log_function (fun m -> m "<fmt>" <args>); *)
+type 'a log_function =
+  ((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit
+
+module type Logs = sig
+  val logger : logger
+  val trace : _ log_function
+  val debug : _ log_function
+  val info  : _ log_function
+  val warn  : _ log_function
+  val error : _ log_function
+  val log   : level -> _ log_function
+end
+
+val logs : string -> (module Logs)
+val sublogs : logger -> string -> (module Logs)
+
+val init_pretty_writer :
+  ?min_level:level ->
+  ?color:bool ->
+  ?timestamp:bool ->
+  ?namespace:bool ->
+  ?level:bool ->
+  out_channel -> unit
+
+val init_journald_writer :
+  ?min_level:level ->
+  ?path:string ->
+  unit -> unit
+
+val should_upgrade_to_journald : unit -> bool

package.nix

@@ -0,0 +1,36 @@
+{
+  lib,
+  mkShell,
+
+  buildDunePackage,
+  ptime,
+
+  ocaml,
+  dune_3,
+  odoc,
+  utop,
+
+  enableShell ? false
+}:
+
+let
+  sourceRoot = ./.;
+  fs = lib.fileset;
+  sourceFiles = fs.difference
+    (fs.gitTracked sourceRoot)
+    (fs.fileFilter (file: file.hasExt "nix") sourceRoot);
+  sourceSet = fs.toSource { root = sourceRoot; fileset = sourceFiles; };
+in buildDunePackage rec {
+  pname = "xlog";
+  version = "0.0.1";
+  src = sourceSet;
+
+  minimalOCamlVersion = "5.1";
+  dontStrip = true;
+
+  propagatedBuildInputs = [ ptime ];
+
+  nativeBuildInputs = lib.optionals enableShell [
+    ocaml dune_3 odoc utop
+  ];
+}

test/dune

@@ -0,0 +1,3 @@
+(test
+ (name test_xlog)
+ (libraries xlog))

test/test_xlog.ml

@@ -0,0 +1,2 @@
+let () =
+  Printf.eprintf "TODO\n%!"

xlog.opam

@@ -0,0 +1,33 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+version: "0.0.1"
+synopsis: "logging library"
+description: "logging library for cats written in ocaml"
+maintainer: [
+  "iitalics <git.lain.faith/iitalics>" "xenia <xenia@awoo.systems>"
+]
+authors: ["iitalics <git.lain.faith/iitalics>" "xenia <xenia@awoo.systems>"]
+license: "LGPL-2.0-or-later"
+homepage: "https://git.lain.faith/haskal/xlog"
+bug-reports: "https://git.lain.faith/haskal/xlog"
+depends: [
+  "ocaml"
+  "dune" {>= "3.15"}
+  "ptime" {>= "1.1"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "https://git.lain.faith/haskal/xlog.git"