Source file core_command.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
120
let log_src = Logs.Src.create "sihl.core.command"

module Logs = (val Logs.src_log log_src : Logs.LOG)

exception Exception of string

type t =
  { name : string
  ; usage : string option
  ; description : string
  ; dependencies : Core_lifecycle.lifecycle list
  ; fn : string list -> unit option Lwt.t
  }

let make ~name ?help ~description ?(dependencies = []) fn =
  { name; usage = help; description; dependencies; fn }
;;

let find_command_by_args commands args =
  let ( let* ) = Option.bind in
  try
    let* name = CCList.head_opt args in
    List.find_opt (fun command -> String.equal command.name name) commands
  with
  | _ -> None
;;

let print_all commands =
  let version =
    match Build_info.V1.version () with
    | None -> ""
    | Some version -> Build_info.V1.Version.to_string version
  in
  let command_list =
    commands
    |> List.map (fun command -> command.name)
    |> List.sort String.compare
    |> String.concat "\n"
  in
  print_endline
  @@ Printf.sprintf
       {|
Sihl %s

Run one of the following commands with the argument "help" for more information.

%s
|}
       version
       command_list
;;

let print_help (command : t) =
  let usage = Option.map (Printf.sprintf "%s %s" command.name) command.usage in
  print_endline
  @@
  match usage with
  | None -> String.concat "\n" [ command.name; command.description ]
  | Some usage -> String.concat "\n" [ usage; command.description ]
;;

let run commands args =
  let args =
    match args with
    | Some args -> args
    | None ->
      (try Sys.argv |> Array.to_list |> List.tl with
      | _ -> [])
  in
  let command = find_command_by_args commands args in
  match command with
  | Some command ->
    (* We use the first argument to find the command, the command itself
       receives the rest arguments. *)
    let rest_args =
      try args |> List.tl with
      | _ -> []
    in
    (match rest_args with
    | [ "help" ] -> Lwt.return @@ print_help command
    | rest_args ->
      let start = Mtime_clock.now () in
      Lwt.catch
        (fun () ->
          let%lwt _ =
            Lwt_list.iter_s (fun (lifecycle : Core_lifecycle.lifecycle) ->
                lifecycle.start ())
            @@ Core_lifecycle.top_sort_lifecycles command.dependencies
          in
          let%lwt result = command.fn rest_args in
          match result with
          | Some () ->
            let stop = Mtime_clock.now () in
            let span = Mtime.span start stop in
            print_endline
              (Format.asprintf
                 "Command '%s' ran successfully in %a"
                 command.name
                 Mtime.Span.pp
                 span);
            Lwt.return ()
          | None -> Lwt.return @@ print_help command)
        (fun exn ->
          let stop = Mtime_clock.now () in
          let span = Mtime.span start stop in
          let msg = Printexc.to_string exn in
          let stack = Printexc.get_backtrace () in
          print_endline
            (Format.asprintf
               "Command '%s' aborted after %a: '%s'"
               command.name
               Mtime.Span.pp
               span
               msg);
          print_endline stack;
          Lwt.return ()))
  | None ->
    print_all commands;
    Lwt.return ()
;;