albatross/client/albatross_client_remote_tls.ml

90 lines
3.2 KiB
OCaml
Raw Normal View History

2017-05-26 14:30:34 +00:00
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
2018-11-12 21:11:06 +00:00
let version = `AV3
2018-10-14 00:18:33 +00:00
let rec read_tls_write_cons t =
2018-10-23 22:10:08 +00:00
Vmm_tls_lwt.read_tls t >>= function
2019-10-10 20:26:36 +00:00
| Error `Eof ->
Logs.warn (fun m -> m "eof from server");
Lwt.return (Ok ())
| Error _ ->
Lwt.return (Error (`Msg ("read failure")))
| Ok wire ->
2019-03-27 23:11:43 +00:00
Albatross_cli.print_result version wire ;
read_tls_write_cons t
2017-05-26 14:30:34 +00:00
2018-10-14 00:18:33 +00:00
let client cas host port cert priv_key =
2017-05-26 14:30:34 +00:00
Nocrypto_entropy_lwt.initialize () >>= fun () ->
let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in
X509_lwt.authenticator auth >>= fun authenticator ->
Lwt.catch (fun () ->
2018-10-25 14:55:54 +00:00
(* TODO TLS certificate verification and gethostbyname:
- allow IP address and hostname
- if IP is specified, use it (and no TLS name verification - or SubjAltName with IP?)
- if hostname is specified
- no ip: gethostbyname
- ip: connecto to ip and verify hostname *)
2017-05-26 14:30:34 +00:00
Lwt_unix.gethostbyname host >>= fun host_entry ->
let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in
2019-10-10 20:26:36 +00:00
let sockaddr = Lwt_unix.ADDR_INET (host_inet_addr, port) in
Vmm_lwt.connect host_entry.Lwt_unix.h_addrtype sockaddr >>= function
| None ->
let err =
Rresult.R.error_msgf "couldn't connect to %a" Vmm_lwt.pp_sockaddr sockaddr
in
Lwt.return err
| Some fd ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
let certificates = `Single cert in
let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t ->
read_tls_write_cons t)
2017-05-26 14:30:34 +00:00
(fun exn ->
2019-10-10 20:26:36 +00:00
let err =
Rresult.R.error_msgf "failed to establish TLS connection: %s"
(Printexc.to_string exn)
in
Lwt.return err)
2017-05-26 14:30:34 +00:00
2018-10-20 22:29:25 +00:00
let run_client _ cas cert key (host, port) =
2017-05-26 14:30:34 +00:00
Printexc.register_printer (function
| Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x)
| Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
| _ -> None) ;
Sys.(set_signal sigpipe Signal_ignore) ;
2018-10-14 00:18:33 +00:00
Lwt_main.run (client cas host port cert key)
2017-05-26 14:30:34 +00:00
open Cmdliner
2019-03-27 23:11:43 +00:00
open Albatross_cli
2017-05-26 14:30:34 +00:00
let cas =
let doc = "The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY." in
2018-10-28 23:32:07 +00:00
Arg.(required & pos 0 (some string) None & info [] ~doc ~docv:"CA")
2017-05-26 14:30:34 +00:00
let client_cert =
let doc = "Use a client certificate chain" in
2018-10-28 23:32:07 +00:00
Arg.(required & pos 1 (some file) None & info [] ~doc ~docv:"CERT")
2017-05-26 14:30:34 +00:00
let client_key =
let doc = "Use a client key" in
2018-10-28 23:32:07 +00:00
Arg.(required & pos 2 (some file) None & info [] ~doc ~docv:"KEY")
2017-05-26 14:30:34 +00:00
let destination =
2018-10-28 23:32:07 +00:00
let doc = "the destination hostname:port to connect to" in
Arg.(required & pos 3 (some host_port) None & info [] ~docv:"HOST:PORT" ~doc)
2017-05-26 14:30:34 +00:00
let cmd =
2019-03-27 23:11:43 +00:00
let doc = "Albatross remote TLS client" in
2017-05-26 14:30:34 +00:00
let man = [
`S "DESCRIPTION" ;
2019-03-27 23:11:43 +00:00
`P "$(tname) connects to an Albatross server and initiates a TLS handshake" ]
2017-05-26 14:30:34 +00:00
in
2018-10-20 22:29:25 +00:00
Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination),
2019-03-27 23:11:43 +00:00
Term.info "albatross_client_remote_tls" ~version:"%%VERSION_NUM%%" ~doc ~man
2017-05-26 14:30:34 +00:00
let () =
match Term.eval cmd
with `Error _ -> exit 1 | _ -> exit 0