From b1e8c94025becb83beede65f624ac7ec47f65c13 Mon Sep 17 00:00:00 2001 From: EmileTrotignon Date: Tue, 9 Dec 2025 18:41:08 +0100 Subject: [PATCH 1/2] delete logstash --- logstash.ml | 304 --------------------------------------------------- logstash.mli | 41 ------- 2 files changed, 345 deletions(-) delete mode 100644 logstash.ml delete mode 100644 logstash.mli diff --git a/logstash.ml b/logstash.ml deleted file mode 100644 index 49a4e3a..0000000 --- a/logstash.ml +++ /dev/null @@ -1,304 +0,0 @@ -open Printf -open ExtLib -open Prelude - -let log = Log.from "logstash" - -let state = Hashtbl.create 100 - -let dynamic = Hashtbl.create 100 - -let escape k = - if String.contains k ' ' then - String.map (function ' ' -> '_' | c -> c) k - else - k - -let zero = Var.(function Count _ -> Count 0 | Time _ -> Time 0. | Bytes _ -> Bytes 0) - -module J = Yojson.Safe - -type json = [ `Float of float | `Int of int | `String of string ] - -module Dyn = struct - open Var - - type t = (string * json) list - - let show_a = Stre.list (fun (c,_) -> sprintf "%S:''" c) - - let make_family family = - let f = List.unique ~cmp:(fun (a,_) (b,_) -> a = b) family in - if List.length f <> List.length family then log #warn "duplicate attributes : %s" (show_a family); - List.sort ~cmp:(fun (a,_) (b,_) -> String.compare a b) family - - let make ?(attrs=[]) name = - match is_in_families name with - | true -> Exn.fail "static class with this name already exists: %s" name - | false -> make_family (("class", `String name)::attrs) - - let extend dyn attrs = - match attrs with - | [] -> dyn - | attrs -> make_family dyn @ attrs - - let set dyn ?(attrs=[]) v = - let family = extend dyn attrs in - Hashtbl.replace dynamic family v - - let add dyn ?(attrs =[]) v = - let family = extend dyn attrs in - match Hashtbl.find_default dynamic family (zero v),v with - | Count x, Count x' -> - let n = x + x' in - Hashtbl.replace dynamic family (Count n) - | Bytes x, Bytes x' -> - let n = x + x' in - Hashtbl.replace dynamic family (Bytes n) - | Time x, Time x' -> - let n = x +. x' in - Hashtbl.replace dynamic family (Time n) - | Count _, Bytes _ | Count _, Time _ - | Bytes _, Count _ | Bytes _, Time _ - | Time _, Count _ | Time _, Bytes _ -> log #warn "mismatched value type for %s" (show_a family) - - let set_count dyn attrs v = set dyn ~attrs (Count v) - let set_bytes dyn attrs v = set dyn ~attrs (Bytes v) - let set_time dyn attrs v = set dyn ~attrs (Time v) - let add_count dyn attrs v = add dyn ~attrs (Count v) - let add_bytes dyn attrs v = add dyn ~attrs (Bytes v) - let add_time dyn attrs v = add dyn ~attrs (Time v) -end - - -let timestamp_field () = ("timestamp_ms", `Int Time.(to_ms @@ now ())) -let common_fields () = - [ - timestamp_field (); - "pid", `String (Pid.show_self ()); - "from", `String (Pid.self ()).Pid.name; - ] - -let get () = - let open Var in - let l = ref [] in - Var.iter begin fun attr' v -> - let (previous,attr) = - try Hashtbl.find state attr' with - | Not_found -> - let a = List.map (fun (k, s) -> escape k, `String s) attr' in - let x = ref (zero v), a in - Hashtbl.add state attr' x; - x - in - let this = (common_fields () @ attr : (string * json) list :> (string * [> json ]) list) in - match v, !previous with - | Count x, Count x' -> - let delta = x - x' in - if delta <> 0 then begin previous := v; tuck l @@ `Assoc (("count", `Int delta) :: this) end - | Bytes x, Bytes x' -> - let delta = x - x' in - if delta <> 0 then begin previous := v; tuck l @@ `Assoc (("bytes", `Int delta) :: this) end - | Time x, Time x' -> - let delta = x -. x' in - if delta > epsilon_float then begin previous := v; tuck l @@ `Assoc (("seconds", `Float delta) :: this) end - | Count _, Bytes _ | Count _, Time _ - | Bytes _, Count _ | Bytes _, Time _ - | Time _, Count _ | Time _, Bytes _ -> log #warn "the impossible happened : mismatched type for %S" (show_a attr') - end; - dynamic |> Hashtbl.iter begin fun attr v -> - let attr = List.map (fun (k, s) -> escape k, s) attr in - let this = (common_fields () @ attr : (string * json) list :> (string * [> json ]) list) in - let add c = tuck l @@ `Assoc (c :: this) in - match v with - | Count x -> add ("count", `Int x) - | Bytes x -> add ("bytes", `Int x) - | Time x -> add ("seconds", `Float x) - end; - Hashtbl.clear dynamic; - !l - -let get_basename () = - match !Daemon.logfile with - | None -> - log #warn "no logfile, disabling logstash stats too"; - None - | Some logfile -> - let f = try Filename.chop_extension logfile with _ -> logfile in - log #info "will output logstash stats to %s.YYYYMMDD.json" f; - Some f - -let open_logstash_exn basename = - let filename = sprintf "%s.%s.json" basename (Time.format_date8 @@ Unix.gmtime @@ Time.now ()) in - try - Files.open_out_append_text filename - with exn -> - Exn.fail ~exn "failed to open stats file %s" filename - -let write_json activity out nr json = - let bytes = J.to_string ~std:true json ^ "\n" in - try - (* try not to step on the other forks toes, page writes are atomic *) - if (String.length bytes > 4096 - !nr) then (activity := true; flush out; nr := 0); - output_string out bytes; nr := !nr + String.length bytes - with exn -> log #warn ~exn "failed to write event %S" bytes - -let line_writer out = - let nr = ref 0 in - write_json (ref false) out nr - -let setup_ setup = - match get_basename () with - | None -> () - | Some stat_basename -> - setup begin fun () -> - match open_logstash_exn stat_basename with - | exception exn -> log #warn ~exn "disabling output" - | ch -> - Control.bracket ch close_out_noerr begin fun ch -> - let write = line_writer ch in - get () |> List.iter write; - flush ch - end - end - -let default_period = Time.seconds 60 -let setup ?(pause=default_period) events = setup_ (fun f -> at_exit f; Async.setup_periodic_timer_wait events pause f) -let setup_lwt ?(pause=default_period) () = - setup_ (fun f -> - at_exit f; - let rec loop () = - match Daemon.should_exit () with - | true -> Lwt.return_unit - | false -> Lwt.bind (Lwt_unix.sleep pause) (fun () -> f (); loop ()) - in - Lwt.async loop - ) - -let round_to_midnight timestamp = - let ms = Time.to_ms timestamp in - let diff = ms mod (Time.days 1 |> Time.to_ms) in - timestamp -. (Time.msec diff) - -let is_same_day timestamp = - Time.now () -. Time.days 1 < timestamp - -type logger = < - event : (string * Yojson.Safe.t) list -> unit; - write : unit -> unit; - reload : unit -> unit; - flush : unit -> unit; -> - -let null = object method event _j = () method write () = () method reload () = () method flush () = () end - -let log ?autoflush ?(verbose=false) ?(add_timestamp_only=false) ?name () = - let add_fields = if add_timestamp_only then fun l -> timestamp_field () :: l else fun l -> common_fields () @ l in - let name = match name with None -> get_basename () | Some _ -> name in - match name with - | None -> null - | Some stat_basename -> - match open_logstash_exn stat_basename with - | exception exn -> log #warn ~exn "disabling output of %s" stat_basename; null - | out -> - let out = ref out in - let nr = ref 0 in - let activity = ref false in - begin match autoflush with - | None -> () - | Some delay -> - let rec l () = - match Daemon.should_exit () with - | true -> Lwt.return_unit - | false -> - activity := false; - let%lwt () = Lwt_unix.sleep delay in - if !nr > 0 && not !activity then (flush !out; nr := 0); - l () - in - Lwt.async l - end; - object(self) - val mutable timestamp = round_to_midnight @@ Time.now () - - method reload () = - try - if verbose then log #info "rotate log %s" stat_basename; - let new_out = open_logstash_exn stat_basename in - let prev = !out in - out := new_out; - nr := 0; - timestamp <- round_to_midnight @@ Time.now (); - flush prev; - close_out_noerr prev - with exn -> log #warn ~exn "failed to rotate log %s" stat_basename - - method private try_rotate () = - match timestamp with - | t when not @@ is_same_day t -> self#reload () - | _ -> () - - method write () = - self#try_rotate (); - get () |> List.iter (write_json activity !out nr) - - method event j = - self#try_rotate (); - write_json activity !out nr (`Assoc (add_fields j)) - - method flush () = - if !nr > 0 && not !activity then (flush !out; nr := 0) - - end - -let logstash_err = Lazy.from_fun @@ log ~name:"log/errors" - -let setup_error_log () = - Signal.set_reload !!logstash_err#reload; - let chain_hook = !Log.State.hook in - Log.State.hook := begin fun level facil s -> - if level = `Error then - begin - !!logstash_err #event ["facility", `String facil.Logger.name; "message", `String s]; - !!logstash_err #flush (); - end; - chain_hook level facil s - end - -let lifetime ?(extra="") ~events ~version () = - let start = Time.now () in - let text = sprintf "%s start version %s" (Pid.self_name ()) version in - events#event [ - "event", `String "start"; - "text", `String text; - "extra", `String extra; - "cmdline", `String Nix.cmdline; - "cwd", `String (Sys.getcwd ()); - "user", `String (try Unix.(getpwuid @@ geteuid ()).pw_name with _ -> ""); - "version", `String version; - ]; - events#flush (); - Signal.set_exit begin fun () -> - events#event [ - "event", `String "signal.stop"; - "text", `String (sprintf "%s received stop signal" (Pid.self_name ())); - "version", `String version; - "start", `Int (Time.to_ms start); - "uptime", `String (Time.ago_str start); - ]; - events#flush (); - end; - let pid = Unix.getpid () in - at_exit begin fun () -> - match pid = Unix.getpid () with - | false -> () (* forked child *) - | true -> - events#event [ - "event", `String "exit"; - "text", `String (sprintf "%s exit" (Pid.self_name ())); - "version", `String version; - "start", `Int (Time.to_ms start); - "uptime", `String (Time.ago_str start); - ]; - events#flush (); - end diff --git a/logstash.mli b/logstash.mli deleted file mode 100644 index 64bc0a5..0000000 --- a/logstash.mli +++ /dev/null @@ -1,41 +0,0 @@ -type json = [ `Float of float | `Int of int | `String of string ] - -(** Export counters registered with {!Var} as logstash events *) -val get : unit -> [> `Assoc of (string * [> json ]) list ] list - -(** Setup periodic saving of counters as logstash json rows along the logfile *) -val setup : ?pause:Time.t -> Libevent.event_base -> unit -val setup_lwt : ?pause:Time.t -> unit -> unit - -type logger = < - event : (string * Yojson.Safe.t) list -> unit; (** write event manually *) - write : unit -> unit; (** write Var counters explicitly *) - reload : unit -> unit; (** reopen output file *) - flush : unit -> unit; (** force flush *) -> - -(* Setup logger for a stream of events *) -val log : ?autoflush:float -> ?verbose:bool -> ?add_timestamp_only:bool -> ?name:string -> unit -> logger - -val setup_error_log : unit -> unit - -(** Counters with arbitrary attributes *) -module Dyn : sig - type t = private (string * json) list - val make : ?attrs:(string * json) list -> string -> t - (* val add : t -> ?attrs:(string * string) list -> Var.t -> unit *) - (* val set : t -> ?attrs:(string * string) list -> Var.t -> unit *) - val set_count : t -> (string * json) list -> int -> unit - val set_bytes : t -> (string * json) list -> int -> unit - val set_time : t -> (string * json) list -> Time.t -> unit - val add_count : t -> (string * json) list -> int -> unit - val add_bytes : t -> (string * json) list -> int -> unit - val add_time : t -> (string * json) list -> Time.t -> unit -end - -(** Log events related to the life of the program: - - [start] - - [signal.stop] - - [exit] -*) -val lifetime : ?extra:string -> events:logger -> version:string -> unit -> unit From 2f4ce3a40190dca957ad600133831fa71d4e0337 Mon Sep 17 00:00:00 2001 From: EmileTrotignon Date: Wed, 10 Dec 2025 15:42:49 +0100 Subject: [PATCH 2/2] remove pid --- nix.ml | 11 ++++++++- pid.ml | 74 --------------------------------------------------------- pid.mli | 46 ----------------------------------- 3 files changed, 10 insertions(+), 121 deletions(-) delete mode 100644 pid.ml delete mode 100644 pid.mli diff --git a/nix.ml b/nix.ml index 9c10fe1..f4185e9 100644 --- a/nix.ml +++ b/nix.ml @@ -11,10 +11,19 @@ open ExtLib let log = Log.from "nix" +let register_on_fork, call_on_fork = + let on_fork_li = ref [] in + begin fun on_fork -> + on_fork_li := on_fork :: !on_fork_li + end, + begin fun () -> + List.iter (fun f -> f ()) !on_fork_li + end + let fork () = match Lwt_unix.fork () with | -1 -> Exn.fail "failed to fork" - | 0 -> Random.self_init (); Pid.update (); `Child + | 0 -> Random.self_init (); call_on_fork (); `Child | pid -> `Forked pid (** fork off and die *) diff --git a/pid.ml b/pid.ml deleted file mode 100644 index c004e64..0000000 --- a/pid.ml +++ /dev/null @@ -1,74 +0,0 @@ -open ExtLib -open Printf - -type t = { host : string; id : int; name : string; stamp : int; } - -let dummy = { host="*"; id=0; name="*"; stamp=0; } - -let show { id; name; host; stamp=_; } = sprintf "%u:%s@%s" id name host -let to_string { id; name; host; stamp; } = sprintf "%u:%u:%s@%s" stamp id name host -let compare (pid1:t) pid2 = compare pid1 pid2 -let equal pid1 pid2 = 0 = compare pid1 pid2 -let name { name; _ } = name -let host { host; _ } = host - -let get_name s = try fst @@ String.split s "." with _ -> s -let validate_name descr s = - try Scanf.sscanf s "%_[a-zA-Z0-9_.-]%!" () with _ -> Exn.fail "Pid.self: bad %s %S" descr s -let sanitize_name = String.map (function 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' | '-' | '.' as c -> c | _ -> '_') - -let parse_exn s = - (* cf self_pid *) - Scanf.sscanf s "%u:%u:%[a-zA-Z0-9_.-]@@%[a-zA-Z0-9_.-]%!" (fun stamp id name host -> - if host = "" then Exn.fail "empty hostname"; - if name = "" then Exn.fail "empty name"; - { id; host=String.lowercase_ascii host; name=get_name @@ String.lowercase_ascii name; stamp; }) - -let make ~id ~host ~stamp name = - validate_name "name" name; - validate_name "host" host; - { id; host; stamp; name } - -let new_self name stamp = - let id = Unix.getpid () in - let host = String.lowercase_ascii @@ Unix.gethostname () in - (* cf parse_exn *) - validate_name "host" host; - validate_name "name" name; - { host; id; name = get_name @@ String.lowercase_ascii name; stamp; } - -let self = ref @@ dummy -let self_s = ref @@ "" - -let assign_self t = - self := t; - self_s := show t - -let update_self name fresh = assign_self @@ new_self name (if fresh then Time.(int @@ now ()) else (!self).stamp) - -let () = update_self (sanitize_name @@ Filename.basename Sys.executable_name) true - -let fake_id = ref false - -let set_name name = - validate_name "name" name; - update_self name !fake_id; - fake_id := false - -let update () = - match !fake_id with - | true -> () - | false -> - match (!self).id = Unix.getpid () with - | true -> () - | false -> (* fork *) - update_self (!self.name) true - -let set_fake t = - assign_self t; - fake_id := true - -let self () = !self -let self_name () = name @@ self () -let show_self () = !self_s -let self_as name = set_name name; self () diff --git a/pid.mli b/pid.mli deleted file mode 100644 index 9411af9..0000000 --- a/pid.mli +++ /dev/null @@ -1,46 +0,0 @@ -(** Unique process identification *) - -type t = { - host : string; (** machine hostname (no spaces allowed) *) - id : int; (** process id *) - name : string; (** application id (no spaces allowed), for information. *) - stamp : int; (** stamp for uniqueness to guard against pid reuse *) -} - -(** dummy instance, use sparingly *) -val dummy : t - -(** @return pretty-printed pid (human readable) *) -val show : t -> string - -(** @return machine hostname *) -val host : t -> string - -(** @return application name *) -val name : t -> string - -(** @return string representation of pid, can be read back by [parse_pid_exn] *) -val to_string : t -> string - -val make : id:int -> host:string -> stamp:int -> string -> t - -val compare : t -> t -> int -val equal : t -> t -> bool - -val parse_exn : string -> t - -(** {1 Current process identifier} *) - -val sanitize_name : string -> string -val set_name : string -> unit -val self : unit -> t -val self_name : unit -> string -val self_as : string -> t -val show_self : unit -> string - -(** call this to update Pid.self after fork *) -val update : unit -> unit - -(**/**) - -val set_fake : t -> unit