Something went wrong. Try again.
Start a program in a session of its own without forking the caller (posix_spawn SETSID)
Something went wrong. Try again.
6.0 kB · 185 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186let schema = 4let name = "managed-" ^ string_of_int schema
type outcome = | Exited of int | Signaled of int | Timed_out of string | Refused of string
type ending = Ended of float | Killedtype member = { pid : int; command : string; ending : ending }type stop = { grace : float; members : member list }
type facts = { nice_refused : string option; silence : float option; stop : stop option;}
let no_facts = { nice_refused = None; silence = None; stop = None }
type retention = { keeper : int; group : int option; leases : int }
let equal_retention a b = Int.equal a.keeper b.keeper && Option.equal Int.equal a.group b.group && Int.equal a.leases b.leases
type t = | Outcome of outcome * facts | Retained of retention | Drained of retention | Group of int
module Codec = struct open Json.Codec
let refuse fmt = Json.Error.fail_msgf Json.Meta.none fmt
let validate_positive n = if n <= 0 then refuse "process id must be positive" else n
let positive = map int ~enc:validate_positive ~dec:validate_positive
let validate_nonnegative n = if n < 0 then refuse "lease count must not be negative" else n
let nonnegative = map int ~enc:validate_nonnegative ~dec:validate_nonnegative
let validate_silence n = if (not (Float.is_finite n)) || n < 0. then refuse "silence must be finite and non-negative" else n
let finite = map number ~enc:validate_silence ~dec:validate_silence
(* A member's ending: the seconds after TERM it was gone by, or [killed]. *) let ending = let validate n = if (not (Float.is_finite n)) || n < 0. then refuse "an ending must be finite and non-negative" else n in let ended = map number ~enc:validate ~dec:validate in Object.map (fun ended killed -> match (ended, killed) with | Some s, None -> Ended s | None, Some true -> Killed | _ -> refuse "a member ends after TERM or is killed, one of them") |> Object.opt_member "ended" ended ~enc:(function | Ended s -> Some s | Killed -> None) |> Object.opt_member "killed" bool ~enc:(function | Killed -> Some true | Ended _ -> None) |> Object.seal
let member = Object.map (fun pid command ending -> { pid; command; ending }) |> Object.member "pid" positive ~enc:(fun m -> m.pid) |> Object.member "command" string ~enc:(fun m -> m.command) |> Object.member "ending" ending ~enc:(fun m -> m.ending) |> Object.seal
let stop = Object.map (fun grace members -> { grace; members }) |> Object.member "grace" finite ~enc:(fun s -> s.grace) |> Object.member "members" (list member) ~enc:(fun s -> s.members) |> Object.seal
let retention = Object.map (fun keeper group leases -> { keeper; group; leases }) |> Object.member "keeper" positive ~enc:(fun r -> r.keeper) |> Object.opt_member "group" positive ~enc:(fun r -> r.group) |> Object.member "leases" nonnegative ~enc:(fun r -> r.leases) |> Object.seal
let outcome_value ctor project codec = Object.map (fun value nice_refused silence stop -> (ctor value, { nice_refused; silence; stop })) |> Object.member "value" codec ~enc:(fun (outcome, _) -> project outcome) |> Object.opt_member "nice_refused" string ~enc:(fun (_, facts) -> facts.nice_refused) |> Object.opt_member "silence" finite ~enc:(fun (_, facts) -> facts.silence) |> Object.opt_member "stop" stop ~enc:(fun (_, facts) -> facts.stop) |> Object.seal
let exited = Object.Case.map "exited" (outcome_value (fun n -> Exited n) (function Exited n -> n | _ -> invalid_arg "not exited") int) ~dec:(fun (o, f) -> Outcome (o, f))
let signaled = Object.Case.map "signaled" (outcome_value (fun n -> Signaled n) (function Signaled n -> n | _ -> invalid_arg "not signaled") int) ~dec:(fun (o, f) -> Outcome (o, f))
let timeout = Object.Case.map "timeout" (outcome_value (fun n -> Timed_out n) (function Timed_out n -> n | _ -> invalid_arg "not timeout") string) ~dec:(fun (o, f) -> Outcome (o, f))
let refused = Object.Case.map "refused" (outcome_value (fun n -> Refused n) (function Refused n -> n | _ -> invalid_arg "not refused") string) ~dec:(fun (o, f) -> Outcome (o, f))
let retained = Object.Case.map "retained" retention ~dec:(fun r -> Retained r) let drained = Object.Case.map "drained" retention ~dec:(fun r -> Drained r)
let group_codec = Object.map Fun.id |> Object.member "group" positive ~enc:Fun.id |> Object.seal
let group = Object.Case.map "group" group_codec ~dec:(fun p -> Group p)
let enc_case = function | Outcome ((Exited _ as o), f) -> Object.Case.value exited (o, f) | Outcome ((Signaled _ as o), f) -> Object.Case.value signaled (o, f) | Outcome ((Timed_out _ as o), f) -> Object.Case.value timeout (o, f) | Outcome ((Refused _ as o), f) -> Object.Case.value refused (o, f) | Retained r -> Object.Case.value retained r | Drained r -> Object.Case.value drained r | Group p -> Object.Case.value group p
let json = Object.map (fun read message -> if read <> schema then refuse "managed protocol requires schema %d" schema else message) |> Object.member "schema" int ~enc:(fun _ -> schema) |> Object.case_member "kind" string ~enc:Fun.id ~enc_case Object.Case. [ v exited; v signaled; v timeout; v refused; v retained; v drained; v group; ] |> Object.error_unknown |> Object.sealend
let of_string = Json.of_string Codec.jsonlet of_string_exn = Json.of_string_exn Codec.json
let to_string ?buf ?indent ?preserve value = Json.to_string ?buf ?indent ?preserve Codec.json value
let pp = Json.pp_value Codec.json