Source file common.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
open Core
open Async
open Async_smtp


module Command : sig
  include module type of Command

  val rpc
    :  summary:string
    -> ?readme:(unit -> string)
    -> (Rpc.Connection.t -> unit Deferred.t) Param.t
    -> t

  val configs_or_rpc
    :  summary:string
    -> ?readme:(unit -> string)
    -> ([ `Configs of Smtp_server.Config.t * Smtp_spool.Config.t
        | `Rpc of Rpc.Connection.t
        ]
        -> unit Deferred.t)
         Param.t
    -> t
end = struct
  include Command

  let rpc_client_command0 ~host_and_port ~f =
    let open Deferred.Let_syntax in
    match%map
      Rpc.Connection.with_client
        (Tcp.Where_to_connect.of_host_and_port host_and_port)
        (fun conn -> f conn)
    with
    | Ok a -> a
    | Error exn -> raise exn
  ;;

  let rpc_server_or_configs_flag =
    let open Command.Let_syntax in
    [%map_open
      let rpc_server =
        flag
          "rpc-server"
          (optional host_and_port)
          ~doc:"HOST:PORT mailcore instance to query"
      and server_config_path =
        flag
          "server-config"
          (optional Filename.arg_type)
          ~doc:"CONFIG Async_smtp server config file"
      and spool_config_path =
        flag
          "spool-config"
          (optional Filename.arg_type)
          ~doc:"CONFIG Async_smtp spool config file"
      in
      let server_config =
        Option.map server_config_path ~f:(fun c ->
          Thread_safe.block_on_async_exn (fun () -> Smtp_server.Config.load_exn c))
      in
      let spool_config =
        Option.map spool_config_path ~f:(fun c ->
          Thread_safe.block_on_async_exn (fun () -> Smtp_spool.Config.load_exn c))
      in
      let rpc_server =
        match rpc_server, server_config, spool_config with
        | Some v, (_ : Smtp_server.Config.t option), (_ : Smtp_spool.Config.t option) ->
          v
        | None, None, None ->
          failwith
            "At least one of (-rpc-server) or (-server-config and -spool-config) required"
        | None, Some _, None | None, None, Some _ ->
          failwith "Both -server-config and -spool-config required, or use -rpc-server"
        | None, Some server_config, Some _ ->
          let port = Smtp_server.Config.rpc_port server_config in
          Host_and_port.create ~host:"localhost" ~port
      in
      rpc_server, server_config, spool_config]
  ;;

  let rpc ~summary ?readme main =
    let open Command.Let_syntax in
    Command.async
      ~summary
      ?readme
      [%map_open
        let main = main
        and rpc_server, _server_config, _spool_config = rpc_server_or_configs_flag in
        fun () -> rpc_client_command0 ~host_and_port:rpc_server ~f:main]
  ;;

  let configs_or_rpc ~summary ?readme main =
    let open Command.Let_syntax in
    Command.async
      ~summary
      ?readme
      [%map_open
        let main = main
        and rpc_server, server_config, spool_config = rpc_server_or_configs_flag in
        fun () ->
          match server_config, spool_config with
          | Some server_config, Some spool_config ->
            main (`Configs (server_config, spool_config))
          | None, None ->
            rpc_client_command0 ~host_and_port:rpc_server ~f:(fun client ->
              main (`Rpc client))
          | _ ->
            (* Other cases should be prevented in rpc_server_or_configs_flag *)
            assert false]
  ;;
end