1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
open Lwt.Infix
type t = {
mutable confirm : Level.t option;
level_cond : unit Lwt_condition.t;
}
let set_confirm t level =
Log.info (fun f -> f "Confirmation threshold is now %a" (Fmt.Dump.option Level.pp) level);
t.confirm <- level;
Lwt_condition.broadcast t.level_cond ()
let get_confirm t = t.confirm
let slow_start_thread t duration =
Lwt.async
(fun () ->
let changed = Lwt_condition.wait t.level_cond in
Lwt.choose [Lwt_unix.sleep (Duration.to_f duration); changed] >|= fun () ->
if Lwt.state changed = Lwt.Sleep then (
Log.info (fun f -> f "Slow start period over; removing limiter");
set_confirm t None;
)
)
let v ?auto_release ?confirm () =
let level_cond = Lwt_condition.create () in
let t = { confirm; level_cond } in
Option.iter (slow_start_thread t) auto_release;
t
let default = v ()
let active_config : t option Current_incr.var = Current_incr.var None
let now = Current_incr.of_var active_config
let rec confirmed l t =
match t.confirm with
| Some threshold when Level.compare l threshold >= 0 ->
Lwt_condition.wait t.level_cond >>= fun () ->
confirmed l t
| _ ->
Lwt.return_unit
open Cmdliner
let cmdliner_confirm =
let levels = List.map (fun l -> Level.to_string l, Some l) Level.values in
let enum = ("none", None) :: levels in
let doc =
Fmt.str
"Confirm before starting operations at or above this level (%s)."
(Arg.doc_alts_enum enum)
in
Arg.opt (Arg.enum enum) None @@
Arg.info ~doc ["confirm"]
let auto_release =
Arg.value @@
Arg.(opt (some int)) None @@
Arg.info
~doc:"Remove confirm threshold after this many seconds from start-up."
~docv:"SEC"
["confirm-auto-release"]
let cmdliner =
let make auto_release confirm =
let auto_release = Option.map Duration.of_sec auto_release in
v ?auto_release ?confirm () in
Term.(const make $ auto_release $ Arg.value cmdliner_confirm)