From 667bd757de5b7cb253a8b1cc39ab9e98ff45ae94 Mon Sep 17 00:00:00 2001 From: xenia Date: Mon, 22 Apr 2024 22:36:13 -0400 Subject: [PATCH] initial commit --- .gitignore | 1 + README.md | 22 +++++++ dune-project | 20 +++++++ lib/core.ml | 19 ++++++ lib/dune | 4 ++ lib/journald.ml | 53 +++++++++++++++++ lib/mutex.ml | 5 ++ lib/pretty.ml | 115 +++++++++++++++++++++++++++++++++++ lib/time.ml | 5 ++ lib/util.ml | 9 +++ lib/xlog.ml | 149 ++++++++++++++++++++++++++++++++++++++++++++++ lib/xlog.mli | 40 +++++++++++++ package.nix | 36 +++++++++++ test/dune | 3 + test/test_xlog.ml | 2 + xlog.opam | 33 ++++++++++ 16 files changed, 516 insertions(+) create mode 100644 .gitignore create mode 100644 README.md create mode 100644 dune-project create mode 100644 lib/core.ml create mode 100644 lib/dune create mode 100644 lib/journald.ml create mode 100644 lib/mutex.ml create mode 100644 lib/pretty.ml create mode 100644 lib/time.ml create mode 100644 lib/util.ml create mode 100644 lib/xlog.ml create mode 100644 lib/xlog.mli create mode 100644 package.nix create mode 100644 test/dune create mode 100644 test/test_xlog.ml create mode 100644 xlog.opam diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a485625 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/_build diff --git a/README.md b/README.md new file mode 100644 index 0000000..544b8e0 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +# xlog + +logging library for cats written in ocaml + +original code (most of the code here) from: , 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 +``` diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..98fbe9c --- /dev/null +++ b/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 " "xenia ") + (maintainers "iitalics " "xenia ") + (source + (uri "https://git.lain.faith/haskal/xlog.git")) + (depends ocaml dune + (ptime (>= 1.1)))) diff --git a/lib/core.ml b/lib/core.ml new file mode 100644 index 0000000..8f6482f --- /dev/null +++ b/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 diff --git a/lib/dune b/lib/dune new file mode 100644 index 0000000..525f9ee --- /dev/null +++ b/lib/dune @@ -0,0 +1,4 @@ +(library + (name xlog) + (public_name xlog) + (libraries ptime ptime.clock.os str unix)) diff --git a/lib/journald.ml b/lib/journald.ml new file mode 100644 index 0000000..574d679 --- /dev/null +++ b/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 diff --git a/lib/mutex.ml b/lib/mutex.ml new file mode 100644 index 0000000..7f95264 --- /dev/null +++ b/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" diff --git a/lib/pretty.ml b/lib/pretty.ml new file mode 100644 index 0000000..c8adbb7 --- /dev/null +++ b/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 + diff --git a/lib/time.ml b/lib/time.ml new file mode 100644 index 0000000..00e0b46 --- /dev/null +++ b/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 diff --git a/lib/util.ml b/lib/util.ml new file mode 100644 index 0000000..5eec823 --- /dev/null +++ b/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 diff --git a/lib/xlog.ml b/lib/xlog.ml new file mode 100644 index 0000000..48b3a5e --- /dev/null +++ b/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) + ("@[" ^^ 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: \n%!"; + if root_logger.child == root_logger then + () + else + dt root_logger root_logger.child ">" + +let _dump_tree = dump_tree diff --git a/lib/xlog.mli b/lib/xlog.mli new file mode 100644 index 0000000..4993eed --- /dev/null +++ b/lib/xlog.mli @@ -0,0 +1,40 @@ +type logger + +type level = + | TRACE + | DEBUG + | INFO + | WARN + | ERROR + +(* log_function (fun m -> m "" ); *) +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 diff --git a/package.nix b/package.nix new file mode 100644 index 0000000..6075dfd --- /dev/null +++ b/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 + ]; +} diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..5e417ce --- /dev/null +++ b/test/dune @@ -0,0 +1,3 @@ +(test + (name test_xlog) + (libraries xlog)) diff --git a/test/test_xlog.ml b/test/test_xlog.ml new file mode 100644 index 0000000..202558c --- /dev/null +++ b/test/test_xlog.ml @@ -0,0 +1,2 @@ +let () = + Printf.eprintf "TODO\n%!" diff --git a/xlog.opam b/xlog.opam new file mode 100644 index 0000000..94e44cf --- /dev/null +++ b/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 " "xenia " +] +authors: ["iitalics " "xenia "] +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"