Source file `ExitHandler.ml`

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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
let handle_nonzero_exited ~name n =
  let open BindsResult in
  let ecfmt, ecv =
    match ExitCodes.code_to_string n with
    | Either.Left l ->
        ( (fun fmt v ->
            Format.fprintf fmt " code %a.@ Look at the log output to see why.@;"
              Fmt.words v),
          l )
    | Right r ->
        ((fun fmt v -> Format.fprintf fmt "@;@[  @[%a@]@]@." Fmt.lines v), r)
  in
  Errors.Details.add_problem (fun ppf () ->
      Format.fprintf ppf "The %s exited with%a" name ecfmt ecv);
  zero ~msg:"" ()

let handle_sigint ~name n =
  let open BindsResult in
  Errors.Details.add_problem (fun ppf () ->
      Format.fprintf ppf "The %s was interrupted with signal %a." name
        Fmt.Dump.signal n);
  zero ~msg:"" ()

let handle_signaled ~name n =
  let open BindsResult in
  Errors.Details.add_problem (fun ppf () ->
      Format.fprintf ppf "The %s was interrupted with signal %a." name
        Fmt.Dump.signal n);
  Errors.Details.add_suggestion (fun ppf () ->
      Format.fprintf ppf
        "If you are a DkSDK subscriber please contact your support \
         representative and use code '3c437033'.");
  zero ~msg:"" ()

let handle (type a b) ~(success : unit -> (a, b) result) ~name result :
    (a, b) result =
  match result with
  | `Exited 0 -> success ()
  | `Exited n -> handle_nonzero_exited ~name n
  | `Signaled n when Sys.sigint = n -> handle_sigint ~name n
  | `Signaled n -> handle_signaled ~name n

let maybe_add_error s_opt =
  match s_opt with
  | Some s when s <> "" ->
      Errors.Details.add_error (fun ppf () ->
          Format.fprintf ppf "@[<hov 2>%a@]@;" Fmt.text s)
  | _ -> ()

let add_backtrace = function
  | None -> ()
  | Some (backtrace : Printexc.raw_backtrace) ->
      Errors.Details.add_error (fun ppf () ->
          (* let entries = Printexc.raw_backtrace_entries backtrace in
             let x =
               Array.map
                 (fun entry ->
                   match Printexc.backtrace_slots_of_raw_entry entry with
                   | None -> []
                   | Some slot -> Printexc.Slot.format slot)
                 entries
             in *)
          Format.fprintf ppf "@[<v 2>Inner backtrace:@;%a@]@;" Fmt.lines
            (Printexc.raw_backtrace_to_string backtrace))

let proc ~problem f =
  let on_err s_opt =
    Errors.Details.add_problem_if_none (fun ppf () ->
        Format.fprintf ppf "@[<hov 2>%a@]@;" Fmt.text (problem ()));
    maybe_add_error s_opt
  in
  Errors.Details.protect ~finally:Fun.id (fun () ->
      try
        match f () with
        | Ok v -> v
        | Error `ErrorCaptured ->
            on_err None;
            raise (BindsResult.ResultFailed None)
        | Error (`Msg s) ->
            on_err (Some s);
            raise (BindsResult.ResultFailed None)
      with
      | BindsResult.ResultFailed (Some e) | Errors.Errored (Some e) ->
          on_err (Some e);
          Printexc.raise_with_backtrace (Errors.Errored None)
            (Printexc.get_raw_backtrace ())
      | BindsResult.ResultFailed None | Errors.Errored None ->
          on_err None;
          Printexc.raise_with_backtrace (Errors.Errored None)
            (Printexc.get_raw_backtrace ()))

let main ?on_err ~(errlog : 'a Logs.log) ~action ~code f =
  let fallback_on_err ?backtrace s_opt =
    Errors.Details.add_problem_if_none (fun ppf () ->
        Format.fprintf ppf "@[<hov 2>Failed@ to@ %a.@ Code: %s.@]@;" Fmt.text
          (action ()) code);
    add_backtrace backtrace;
    maybe_add_error s_opt;
    errlog (fun l -> l "@[<v>%a@]" Errors.Details.pp ());
    exit 1
  in
  let on_err ?backtrace s_opt =
    match on_err with
    | None -> fallback_on_err ?backtrace s_opt
    | Some on_err -> on_err ?backtrace ~kontinue:fallback_on_err s_opt
  in
  Errors.Details.protect ~finally:Fun.id (fun () ->
      try
        match f () with
        | Ok () -> ()
        | Error `ErrorCaptured -> on_err None
        | Error (`Msg s) -> on_err (Some s)
      with
      | BindsResult.ResultFailed (Some e) | Errors.Errored (Some e) ->
          let backtrace = Printexc.get_raw_backtrace () in
          on_err ~backtrace (Some e)
      | BindsResult.ResultFailed None | Errors.Errored None ->
          let backtrace = Printexc.get_raw_backtrace () in
          on_err ~backtrace None)