56 lines
1.4 KiB
OCaml
56 lines
1.4 KiB
OCaml
|
|
||
|
|
open Lwt
|
||
|
|
|
||
|
|
let o f g x = f (g x)
|
||
|
|
|
||
|
|
let ca_cert_dir = "./certificates"
|
||
|
|
let server_cert = "./certificates/server.pem"
|
||
|
|
let server_key = "./certificates/server.key"
|
||
|
|
let server_ec_cert = "./certificates/server-ec.pem"
|
||
|
|
let server_ec_key = "./certificates/server-ec.key"
|
||
|
|
|
||
|
|
let yap ~tag msg = Lwt_io.printf "(%s %s)\n%!" tag msg
|
||
|
|
|
||
|
|
let lines ic =
|
||
|
|
Lwt_stream.from @@ fun () ->
|
||
|
|
Lwt_io.read_line_opt ic >>= function
|
||
|
|
| None -> Lwt_io.close ic >>= fun () -> return_none
|
||
|
|
| line -> return line
|
||
|
|
|
||
|
|
let print_alert where alert =
|
||
|
|
Printf.eprintf "(TLS ALERT (%s): %s)\n%!"
|
||
|
|
where (Tls.Packet.alert_type_to_string alert)
|
||
|
|
|
||
|
|
let print_fail where fail =
|
||
|
|
Printf.eprintf "(TLS FAIL (%s): %s)\n%!"
|
||
|
|
where (Tls.Engine.string_of_failure fail)
|
||
|
|
|
||
|
|
let null_auth ?ip:_ ~host:_ _ = Ok None
|
||
|
|
|
||
|
|
let auth ?ca ?fp () =
|
||
|
|
match ca with
|
||
|
|
| Some "NONE" when fp = None -> Lwt.return null_auth
|
||
|
|
| _ ->
|
||
|
|
let a = match ca, fp with
|
||
|
|
| None, Some fp -> `Hex_key_fingerprint (`SHA256, fp)
|
||
|
|
| None, _ -> `Ca_dir ca_cert_dir
|
||
|
|
| Some f, _ -> `Ca_file f
|
||
|
|
in
|
||
|
|
X509_lwt.authenticator a
|
||
|
|
|
||
|
|
let setup_log style_renderer level =
|
||
|
|
Fmt_tty.setup_std_outputs ?style_renderer ();
|
||
|
|
Logs.set_level level;
|
||
|
|
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
|
||
|
|
|
||
|
|
open Cmdliner
|
||
|
|
|
||
|
|
let setup_log =
|
||
|
|
Term.(const setup_log
|
||
|
|
$ Fmt_cli.style_renderer ()
|
||
|
|
$ Logs_cli.level ())
|
||
|
|
|
||
|
|
let get_ok = function
|
||
|
|
| Ok cfg -> cfg
|
||
|
|
| Error `Msg msg -> invalid_arg msg
|