struct
| (**
Encoding of the state of a target:
We use the subtyping of polymorphic variants to encode the state-machine; a given state can come only from certain previous states, those are enforced with the type-parameter of the `history` value. *) |
type run_bookkeeping =
{ plugin_name: string; run_parameters: string } [@@deriving yojson]
type log = {
(* time: Time.t; *)
time: float;
message: string option;
} [@@deriving yojson]
type 'a history = {
log: log;
previous_state: 'a;
} [@@deriving yojson]
type id = string
[@@deriving yojson]
type passive = [ `Passive of log ] [@@deriving yojson]
type active = [
| `Active of (passive history * [ `User | `Dependency of id ])
] [@@deriving yojson]
type evaluating_condition = [
| active
| `Tried_to_eval_condition of evaluating_condition history
] [@@deriving yojson]
type already_done = [
| `Already_done of evaluating_condition history
] [@@deriving yojson]
type building = [
| `Building of evaluating_condition history
| `Still_building of building history
] [@@deriving yojson]
type dependency_failure = [
| `Dependencies_failed of (building history * id list)
] [@@deriving yojson]
type starting = [
| `Starting of building history
| `Tried_to_start of (starting history * run_bookkeeping)
] [@@deriving yojson]
(* let starting_of_yojson yj : ([< starting ], _) Result.t = starting_of_yojson yj *)
type failed_to_start = [
| `Failed_to_eval_condition of evaluating_condition history
| `Failed_to_start of (starting history * run_bookkeeping)
] [@@deriving yojson]
type running = [
| `Started_running of (starting history * run_bookkeeping)
| `Still_running of (running history * run_bookkeeping)
| `Still_running_despite_recoverable_error of
(string * running history * run_bookkeeping)
] [@@deriving yojson]
(*
Successful run is the success of the process, we still have to verify
that the potential condition has been ensured.
*)
type successful_run = [
| `Successfully_did_nothing of starting history
| `Ran_successfully of (running history * run_bookkeeping)
| `Tried_to_reeval_condition of (string * successful_run history)
] [@@deriving yojson]
type process_failure_reason = [
(* | Did_not_ensure_condition of string *)
| `Long_running_failure of string
] [@@deriving yojson]
type failed_run = [
| `Failed_running of
(running history * process_failure_reason * run_bookkeeping)
] [@@deriving yojson]
type verified_run = [
| `Verified_success of successful_run history
] [@@deriving yojson]
type failed_to_verify_success = [
| `Did_not_ensure_condition of successful_run history
] [@@deriving yojson]
type killable_state = [
| passive
| evaluating_condition
| building
| starting
| running
] [@@deriving yojson]
type killing = [
| `Killing of killable_state history
| `Tried_to_kill of killing history
] [@@deriving yojson]
type killed = [
| `Killed of killing history
] [@@deriving yojson]
type failed_to_kill = [
| `Failed_to_kill of killing history
] [@@deriving yojson]
type finishing_state = [
| failed_run
| verified_run
| already_done
| dependency_failure
| failed_to_start
| killed
| failed_to_kill
| failed_to_verify_success
] [@@deriving yojson]
type finished = [
| `Finished of finishing_state history
] [@@deriving yojson]
type t = [
| killing
| killed
| killable_state
| successful_run
| finishing_state
| finished
] [@@deriving yojson]
let of_yojson yj : (t, _) Result.t = of_yojson yj
let make_log ?message () =
{time = Time.now (); message}
let to_history ?log previous_state =
{log = make_log ?message:log (); previous_state}
let rec simplify (t: t) =
match t with
| `Building _
| `Tried_to_start _
| `Started_running _
| `Starting _
| `Still_building _
| `Still_running _
| `Still_running_despite_recoverable_error _
| `Ran_successfully _
| `Successfully_did_nothing _
| `Tried_to_eval_condition _
| `Tried_to_reeval_condition _
| `Active _ -> `In_progress
| `Verified_success _
| `Already_done _ -> `Successful
| `Dependencies_failed _
| `Failed_running _
| `Failed_to_kill _
| `Failed_to_start _
| `Failed_to_eval_condition _
| `Killing _
| `Tried_to_kill _
| `Did_not_ensure_condition _
| `Killed _ -> `Failed
| `Finished s ->
simplify (s.previous_state :> t)
| `Passive _ -> `Activable
let rec passive_time (t: t) =
let continue history =
passive_time (history.previous_state :> t)
in
match t with
| `Building history -> continue history
| `Tried_to_start (history, _) -> continue history
| `Started_running (history, _) -> continue history
| `Starting history -> continue history
| `Still_building history -> continue history
| `Still_running (history, _) -> continue history
| `Still_running_despite_recoverable_error (_, history, _) -> continue history
| `Ran_successfully (history, _) -> continue history
| `Successfully_did_nothing history -> continue history
| `Active (history, _) -> continue history
| `Tried_to_eval_condition history -> continue history
| `Tried_to_reeval_condition (_, history) -> continue history
| `Verified_success history -> continue history
| `Already_done history -> continue history
| `Dependencies_failed (history, _) -> continue history
| `Failed_running (history, _, _) -> continue history
| `Failed_to_kill history -> continue history
| `Failed_to_eval_condition history -> continue history
| `Failed_to_start (history, _) -> continue history
| `Killing history -> continue history
| `Tried_to_kill history -> continue history
| `Did_not_ensure_condition history -> continue history
| `Killed history -> continue history
| `Finished history -> continue history
| `Passive log -> log.time
let finished_time = function
| `Finished {log; _} -> Some log.time
| _ -> None
let name (t: t) =
match t with
| `Building _ -> "Building"
| `Tried_to_start _ -> "Tried_to_start"
| `Started_running _ -> "Started_running"
| `Starting _ -> "Starting"
| `Still_building _ -> "Still_building"
| `Still_running _ -> "Still_running"
| `Still_running_despite_recoverable_error _ ->
"Still_running_despite_recoverable_error"
| `Ran_successfully _ -> "Ran_successfully"
| `Successfully_did_nothing _ -> "Successfully_did_nothing"
| `Active _ -> "Active"
| `Tried_to_eval_condition _ -> "Tried_to_eval_condition"
| `Tried_to_reeval_condition _ -> "Tried_to_reeval_condition"
| `Verified_success _ -> "Verified_success"
| `Already_done _ -> "Already_done"
| `Dependencies_failed _ -> "Dependencies_failed"
| `Failed_running _ -> "Failed_running"
| `Failed_to_kill _ -> "Failed_to_kill"
| `Failed_to_eval_condition _ -> "Failed_to_eval_condition"
| `Failed_to_start _ -> "Failed_to_start"
| `Killing _ -> "Killing"
| `Tried_to_kill _ -> "Tried_to_kill"
| `Did_not_ensure_condition _ -> "Did_not_ensure_condition"
| `Killed _ -> "Killed"
| `Finished _ -> "Finished"
| `Passive _ -> "Passive"
let rec latest_run_bookkeeping (t: t) =
let continue history =
latest_run_bookkeeping (history.previous_state :> t) in
match t with
| `Building history -> None
| `Tried_to_start (hist, book) -> (Some book)
| `Started_running (hist, book) -> (Some book)
| `Starting history -> (None)
| `Still_building history -> (None)
| `Still_running (hist, book) -> (Some book)
| `Still_running_despite_recoverable_error (_, hist, book) -> (Some book)
| `Ran_successfully (hist, book) -> (Some book)
| `Successfully_did_nothing history -> (None)
| `Tried_to_eval_condition _ -> (None)
| `Tried_to_reeval_condition (_, history) -> continue history
| `Active (history, _) -> (None)
| `Verified_success history -> continue history
| `Already_done history -> None
| `Dependencies_failed (history, _) -> (None)
| `Failed_running (hist, _, book) -> (Some book)
| `Failed_to_kill history -> continue history
| `Failed_to_eval_condition history -> continue history
| `Failed_to_start (hist, book) -> (Some book)
| `Killing history -> continue history
| `Tried_to_kill history -> continue history
| `Did_not_ensure_condition history -> continue history
| `Killed history -> continue history
| `Finished history -> continue history
| `Passive log -> (None)
let contents (t: t) =
let some h = Some (h :> t history) in
match t with
| `Building history -> (some history, None)
| `Tried_to_start (hist, book) -> (some hist, Some book)
| `Started_running (hist, book) -> (some hist, Some book)
| `Starting history -> (some history, None)
| `Still_building history -> (some history, None)
| `Still_running (hist, book) -> (some hist, Some book)
| `Still_running_despite_recoverable_error (_, hist, book) ->
(some hist, Some book)
| `Ran_successfully (hist, book) -> (some hist, Some book)
| `Successfully_did_nothing history -> (some history, None)
| `Active (history, _) -> (some history, None)
| `Tried_to_eval_condition history -> (some history, None)
| `Tried_to_reeval_condition (_, history) -> (some history, None)
| `Verified_success history -> (some history, None)
| `Already_done history -> (some history, None)
| `Dependencies_failed (history, _) -> (some history, None)
| `Failed_running (hist, _, book) -> (some hist, Some book)
| `Failed_to_kill history -> (some history, None)
| `Failed_to_eval_condition history -> (some history, None)
| `Failed_to_start (hist, book) -> (some hist, Some book)
| `Killing history -> (some history, None)
| `Tried_to_kill history -> (some history, None)
| `Did_not_ensure_condition history -> (some history, None)
| `Killed history -> (some history, None)
| `Finished history -> (some history, None)
| `Passive log -> (None, None)
let summary t =
let rec count_start_attempts : starting history -> int = fun h ->
match h.previous_state with
| `Starting _ -> 1
| `Tried_to_start (hh, _) -> 1 + (count_start_attempts hh)
in
let rec count_kill_attempts : killing history -> int = fun h ->
match h.previous_state with
| `Killing _ -> 1
| `Tried_to_kill hh -> 1 + (count_kill_attempts hh)
in
let plural_of_int ?(y=false) n =
match y, n with
| true, 1 -> "y"
| true, _ -> "ies"
| _, 1 -> ""
| _, _ -> "s" in
let rec dive (t: t) =
let continue history = dive (history.previous_state :> t) in
match t with
| `Building history -> continue history
| `Tried_to_start (history, book) ->
let attempts = count_start_attempts history in
fmt " %d start-attempt%s" attempts (plural_of_int attempts)
:: continue history
| `Started_running (history, book) -> continue history
| `Starting history -> continue history
| `Still_building history -> continue history
| `Still_running (history, book) -> continue history
| `Still_running_despite_recoverable_error (error, history, book) ->
fmt "non-fatal error %S (check-running)" error :: continue history
| `Ran_successfully (history, book) -> continue history
| `Successfully_did_nothing history -> continue history
| `Active (history, _) -> continue history
| `Tried_to_eval_condition history -> continue history
| `Tried_to_reeval_condition (error, history) ->
fmt "non-fatal error %S (eval-condition)" error :: continue history
| `Verified_success history -> continue history
| `Already_done history ->
"already-done" :: continue history
| `Dependencies_failed (history, deps) ->
let nb_deps = (List.length deps) in
fmt "%d depependenc%s failed" nb_deps (plural_of_int ~y:true nb_deps)
:: continue history
| `Failed_running (history, reason, book) ->
fmt "Reason: %S" (match reason with | `Long_running_failure s -> s)
:: continue history
| `Failed_to_kill history -> continue history
| `Failed_to_eval_condition history -> continue history
| `Failed_to_start (history, book) ->
continue history
| `Killing history ->
fmt "killed from %s" (name (history.previous_state :> t))
:: continue history
| `Tried_to_kill history ->
fmt "%d killing-attempts" (count_kill_attempts history)
:: continue history
| `Did_not_ensure_condition history ->
"Did_not_ensure_condition" :: continue history
| `Killed history ->
"killed" :: continue history
| `Finished history -> continue history
| `Passive log -> []
in
let history_opt, bookkeeping_opt = contents t in
let time, message =
Option.map history_opt ~f:(fun history ->
let { log = {time; message}; previous_state } = history in
(time, message))
|> function
| None -> passive_time t, None
| Some (time, m) -> time, m in
(`Time time, `Log message, `Info (dive t))
let rec to_flat_list (t : t) =
let make_item ?bookkeeping ~history name =
let { log; previous_state } = history in
let bookkeeping_msg =
Option.map bookkeeping ~f:(fun { plugin_name; run_parameters } ->
fmt "[%s] Run-parameters: %d bytes" plugin_name
(String.length run_parameters)) in
(log.time, name, log.message, bookkeeping_msg)
:: to_flat_list (previous_state :> t)
in
let name = name t in
let history_opt, bookkeeping = contents t in
match t with
| `Passive log -> (* passive ! *)
(log.time, name, log.message, None) :: []
| other ->
let history =
Option.value_exn history_opt ~msg:"non-passive got None history" in
make_item ~history ?bookkeeping name
let log ?depth t =
to_flat_list t
|> fun l ->
begin match depth with
| Some d -> List.take l d
| None -> l
end
|> List.map ~f:(fun (time, name, msgopt, bookopt) ->
Log.(s "* " % Time.log time % s ": " % s name
% (match msgopt with None -> empty | Some m -> n % indent (s m))
% (match bookopt with None -> empty | Some m -> n % indent (s m))))
|> Log.(separate n)
module Is = struct
let building = function `Building _ -> true | _ -> false
let tried_to_start = function `Tried_to_start _ -> true | _ -> false
let started_running = function `Started_running _ -> true | _ -> false
let starting = function `Starting _ -> true | _ -> false
let still_building = function `Still_building _ -> true | _ -> false
let still_running = function `Still_running _ -> true | _ -> false
let ran_successfully = function `Ran_successfully _ -> true | _ -> false
let successfully_did_nothing = function `Successfully_did_nothing _ -> true | _ -> false
let active = function `Active _ -> true | _ -> false
let tried_to_eval_condition = function `Tried_to_eval_condition _ -> true | _ -> false
let verified_success = function `Verified_success _ -> true | _ -> false
let already_done = function `Already_done _ -> true | _ -> false
let dependencies_failed = function `Dependencies_failed _ -> true | _ -> false
let failed_running = function `Failed_running _ -> true | _ -> false
let failed_to_kill = function `Failed_to_kill _ -> true | _ -> false
let failed_to_start = function `Failed_to_start _ -> true | _ -> false
let failed_to_eval_condition = function `Failed_to_eval_condition _ -> true | _ -> false
let killing = function `Killing _ -> true | _ -> false
let tried_to_kill = function `Tried_to_kill _ -> true | _ -> false
let did_not_ensure_condition = function `Did_not_ensure_condition _ -> true | _ -> false
let killed = function `Killed _ -> true | _ -> false
let finished = function `Finished _ -> true | _ -> false
let passive = function `Passive _ -> true | _ -> false
let killable = function
| #killable_state -> true
| _ -> false
let finished_because_dependencies_died =
function
| `Finished {previous_state = (`Dependencies_failed _); _ } -> true
| other -> false
end
module Count = struct
module Latest = struct
let make_counter ~continue t =
let rec count v (t: t) =
match continue t with
| Some previous_state ->
count (v + 1) (previous_state :> t)
| _ -> v
in
count 0 t
let tried_to_eval_condition (t: t) =
make_counter ~continue:(function
| `Tried_to_eval_condition { log; previous_state } -> Some previous_state
| _ -> None) t
let tried_to_reeval_condition (t: t) =
make_counter ~continue:(function
| `Tried_to_reeval_condition (_, { log; previous_state }) ->
Some previous_state
| _ -> None) t
let tried_to_kill (t: t) =
make_counter ~continue:(function
| `Tried_to_kill { log; previous_state } -> Some previous_state
| _ -> None) t
let tried_to_start (t: t) =
make_counter ~continue:(function
| `Tried_to_start ({ log; previous_state }, _) -> Some previous_state
| _ -> None) t
end
let consecutive_recent_attempts t =
let (+-+) = max in
let open Latest in
tried_to_start t
+-+ tried_to_kill t
+-+ tried_to_eval_condition t
+-+ tried_to_reeval_condition t
(* let rec count v (t: t) = *)
(* match t with *)
(* | `Tried_to_eval_condition { log; previous_state } -> *)
(* count (v + 1) (previous_state :> t) *)
(* | _ -> v *)
(* in *)
(* count 0 t *)
end
end