diff --git a/_tags b/_tags index 6c676b9..83d849c 100644 --- a/_tags +++ b/_tags @@ -13,7 +13,7 @@ true : package(rresult logs ipaddr bos hex ptime astring duration cstruct decomp : package(ptime.clock.os) : package(ptime.clock.os) : package(ptime.clock.os) -: package(tls.lwt ptime.clock.os) +: package(tls.lwt ptime.clock.os) : link_vmm_stats : package(nocrypto tls.lwt nocrypto.lwt) diff --git a/app/vmmc_bistro.ml b/app/vmmc_bistro.ml index 3080398..73a7392 100644 --- a/app/vmmc_bistro.ml +++ b/app/vmmc_bistro.ml @@ -6,6 +6,7 @@ let version = `AV3 let read fd = (* now we busy read and process output *) + Logs.debug (fun m -> m "reading tls stream") ; let rec loop () = Vmm_tls_lwt.read_tls fd >>= function | Error _ -> Lwt.return () @@ -55,9 +56,11 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) = Lwt_unix.gethostbyname host >>= fun host_entry -> let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in + Logs.debug (fun m -> m "connecting to remote host") ; Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun () -> let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in Tls_lwt.Unix.client_of_fd client (* TODO ~host *) fd >>= fun t -> + Logs.debug (fun m -> m "finished tls handshake") ; read t let jump endp cert key ca name cmd = diff --git a/app/vmmd_tls.ml b/app/vmmd_tls.ml index ffeead9..d08faaa 100644 --- a/app/vmmd_tls.ml +++ b/app/vmmd_tls.ml @@ -2,118 +2,7 @@ open Lwt.Infix -let my_version = `AV3 - -let command = ref 0L - -let pp_sockaddr ppf = function - | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str - | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d" - (Unix.string_of_inet_addr addr) port - -let connect socket_path = - let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in - Lwt_unix.set_close_on_exec c ; - Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () -> - c - -let client_auth ca tls addr = - Logs.debug (fun m -> m "connection from %a" pp_sockaddr addr) ; - let authenticator = - let time = Ptime_clock.now () in - X509.Authenticator.chain_of_trust ~time (* ~crls:!state.Vmm_engine.crls *) [ca] - in - Lwt.catch - (fun () -> Tls_lwt.Unix.reneg ~authenticator tls) - (fun e -> - (match e with - | Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a)) - | Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f)) - | exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ; - Lwt.fail e) >>= fun () -> - (match Tls_lwt.Unix.epoch tls with - | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain - | `Error -> Lwt.fail_with "error while getting epoch") - -let read fd tls = - (* now we busy read and process output *) - let rec loop () = - Vmm_lwt.read_wire fd >>= function - | Error _ -> Lwt.return (Error (`Msg "exception while reading")) - | Ok wire -> - Logs.debug (fun m -> m "read proxying %a" Vmm_commands.pp_wire wire) ; - Vmm_tls_lwt.write_tls tls wire >>= function - | Ok () -> loop () - | Error `Exception -> Lwt.return (Error (`Msg "exception")) - in - loop () - -let process fd tls = - Vmm_lwt.read_wire fd >>= function - | Error _ -> Lwt.return (Error (`Msg "read error")) - | Ok wire -> - (* TODO check version *) - Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ; - Vmm_tls_lwt.write_tls tls wire >|= function - | Ok () -> Ok () - | Error `Exception -> Error (`Msg "exception on write") - -let handle ca (tls, addr) = - client_auth ca tls addr >>= fun chain -> - match Vmm_tls.handle addr my_version chain with - | Error (`Msg m) -> Lwt.fail_with m - | Ok (name, policies, cmd) -> - let sock, next = Vmm_commands.endpoint cmd in - connect (Vmm_core.socket_path sock) >>= fun fd -> - (match sock with - | `Vmmd -> - Lwt_list.fold_left_s (fun r (id, policy) -> - match r with - | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) - | Ok () -> - Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.Name.pp id Vmm_core.Policy.pp policy) ; - let header = Vmm_commands.{version = my_version ; sequence = !command ; name = id } in - command := Int64.succ !command ; - Vmm_lwt.write_wire fd (header, `Command (`Policy_cmd (`Policy_add policy))) >>= function - | Error `Exception -> Lwt.return (Error (`Msg "failed to write policy")) - | Ok () -> - Vmm_lwt.read_wire fd >|= function - | Error _ -> Error (`Msg "read error after writing policy") - | Ok (_, `Success _) -> Ok () - | Ok wire -> - (* TODO check version *) - Rresult.R.error_msgf - "expected success when adding policy, got: %a" - Vmm_commands.pp_wire wire) - (Ok ()) policies - | _ -> Lwt.return (Ok ())) >>= function - | Error (`Msg msg) -> - begin - Logs.warn (fun m -> m "error while applying policies %s" msg) ; - let wire = - let header = Vmm_commands.{version = my_version ; sequence = 0L ; name } in - header, `Failure msg - in - Vmm_tls_lwt.write_tls tls wire >>= fun _ -> - Vmm_lwt.safe_close fd >>= fun () -> - Lwt.fail_with msg - end - | Ok () -> - let wire = - let header = Vmm_commands.{version = my_version ; sequence = !command ; name } in - command := Int64.succ !command ; - (header, `Command cmd) - in - Vmm_lwt.write_wire fd wire >>= function - | Error `Exception -> - Vmm_lwt.safe_close fd >>= fun () -> - Lwt.return (Error (`Msg "couldn't write")) - | Ok () -> - (match next with - | `Read -> read fd tls - | `End -> process fd tls) >>= fun res -> - Vmm_lwt.safe_close fd >|= fun () -> - res +open Vmmd_tls_common let server_socket port = let open Lwt_unix in @@ -129,20 +18,12 @@ let jump _ cacert cert priv_key port = Lwt_main.run (Nocrypto_entropy_lwt.initialize () >>= fun () -> server_socket port >>= fun socket -> - X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert -> - X509_lwt.certs_of_pem cacert >>= (function - | [ ca ] -> Lwt.return ca - | _ -> Lwt.fail_with "expect single ca as cacert") >>= fun ca -> - let config = - Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2) - ~reneg:true ~certificates:(`Single cert) ()) - in + tls_config cacert cert priv_key >>= fun (config, ca) -> let rec loop () = Lwt.catch (fun () -> Lwt_unix.accept socket >>= fun (fd, addr) -> - Lwt_unix.set_close_on_exec fd ; Lwt.catch - (fun () -> Tls_lwt.Unix.server_of_fd config fd >|= fun t -> (t, addr)) + (fun () -> Tls_lwt.Unix.server_of_fd config fd) (fun exn -> Vmm_lwt.safe_close fd >>= fun () -> Lwt.fail exn) >>= fun t -> @@ -152,10 +33,10 @@ let jump _ cacert cert priv_key port = (handle ca t >|= function | Error (`Msg msg) -> Logs.err (fun m -> m "error in handle %s" msg) | Ok () -> ()) >>= fun () -> - Vmm_tls_lwt.close (fst t)) + Vmm_tls_lwt.close t) (fun e -> Logs.err (fun m -> m "error while handle() %s" (Printexc.to_string e)) ; - Vmm_tls_lwt.close (fst t))) ; + Vmm_tls_lwt.close t)) ; loop ()) (function | Unix.Unix_error (e, f, _) -> @@ -173,18 +54,6 @@ let jump _ cacert cert priv_key port = open Cmdliner open Vmm_cli -let cacert = - let doc = "CA certificate" in - Arg.(required & pos 0 (some file) None & info [] ~doc ~docv:"CA") - -let cert = - let doc = "Certificate" in - Arg.(required & pos 1 (some file) None & info [] ~doc ~docv:"CERT") - -let key = - let doc = "Private key" in - Arg.(required & pos 2 (some file) None & info [] ~doc ~docv:"KEY") - let port = let doc = "TCP listen port" in Arg.(value & opt int 1025 & info [ "port" ] ~doc) diff --git a/app/vmmd_tls_common.ml b/app/vmmd_tls_common.ml new file mode 100644 index 0000000..7abc9a3 --- /dev/null +++ b/app/vmmd_tls_common.ml @@ -0,0 +1,132 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + +open Lwt.Infix + +let my_version = `AV3 + +let command = ref 0L + +let tls_config cacert cert priv_key = + X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert -> + X509_lwt.certs_of_pem cacert >>= (function + | [ ca ] -> Lwt.return ca + | _ -> Lwt.fail_with "expect single ca as cacert") >|= fun ca -> + (Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2) + ~reneg:true ~certificates:(`Single cert) ()), + ca) + +let connect socket_path = + let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () -> + c + +let client_auth ca tls = + let authenticator = + let time = Ptime_clock.now () in + X509.Authenticator.chain_of_trust ~time (* ~crls:!state.Vmm_engine.crls *) [ca] + in + Lwt.catch + (fun () -> Tls_lwt.Unix.reneg ~authenticator tls) + (fun e -> + (match e with + | Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a)) + | Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f)) + | exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ; + Lwt.fail e) >>= fun () -> + (match Tls_lwt.Unix.epoch tls with + | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain + | `Error -> Lwt.fail_with "error while getting epoch") + +let read fd tls = + (* now we busy read and process output *) + let rec loop () = + Vmm_lwt.read_wire fd >>= function + | Error _ -> Lwt.return (Error (`Msg "exception while reading")) + | Ok wire -> + Logs.debug (fun m -> m "read proxying %a" Vmm_commands.pp_wire wire) ; + Vmm_tls_lwt.write_tls tls wire >>= function + | Ok () -> loop () + | Error `Exception -> Lwt.return (Error (`Msg "exception")) + in + loop () + +let process fd tls = + Vmm_lwt.read_wire fd >>= function + | Error _ -> Lwt.return (Error (`Msg "read error")) + | Ok wire -> + (* TODO check version *) + Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ; + Vmm_tls_lwt.write_tls tls wire >|= function + | Ok () -> Ok () + | Error `Exception -> Error (`Msg "exception on write") + +let handle ca tls = + client_auth ca tls >>= fun chain -> + match Vmm_tls.handle my_version chain with + | Error (`Msg m) -> Lwt.fail_with m + | Ok (name, policies, cmd) -> + let sock, next = Vmm_commands.endpoint cmd in + connect (Vmm_core.socket_path sock) >>= fun fd -> + (match sock with + | `Vmmd -> + Lwt_list.fold_left_s (fun r (id, policy) -> + match r with + | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) + | Ok () -> + Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.Name.pp id Vmm_core.Policy.pp policy) ; + let header = Vmm_commands.{version = my_version ; sequence = !command ; name = id } in + command := Int64.succ !command ; + Vmm_lwt.write_wire fd (header, `Command (`Policy_cmd (`Policy_add policy))) >>= function + | Error `Exception -> Lwt.return (Error (`Msg "failed to write policy")) + | Ok () -> + Vmm_lwt.read_wire fd >|= function + (* TODO check version *) + | Error _ -> Error (`Msg "read error after writing policy") + | Ok (_, `Success _) -> Ok () + | Ok wire -> + Rresult.R.error_msgf + "expected success when adding policy, got: %a" + Vmm_commands.pp_wire wire) + (Ok ()) policies + | _ -> Lwt.return (Ok ())) >>= function + | Error (`Msg msg) -> + begin + Logs.warn (fun m -> m "error while applying policies %s" msg) ; + let wire = + let header = Vmm_commands.{version = my_version ; sequence = 0L ; name } in + header, `Failure msg + in + Vmm_tls_lwt.write_tls tls wire >>= fun _ -> + Vmm_lwt.safe_close fd >>= fun () -> + Lwt.fail_with msg + end + | Ok () -> + let wire = + let header = Vmm_commands.{version = my_version ; sequence = !command ; name } in + command := Int64.succ !command ; + (header, `Command cmd) + in + Vmm_lwt.write_wire fd wire >>= function + | Error `Exception -> + Vmm_lwt.safe_close fd >>= fun () -> + Lwt.return (Error (`Msg "couldn't write")) + | Ok () -> + (match next with + | `Read -> read fd tls + | `End -> process fd tls) >>= fun res -> + Vmm_lwt.safe_close fd >|= fun () -> + res + +open Cmdliner + +let cacert = + let doc = "CA certificate" in + Arg.(required & pos 0 (some file) None & info [] ~doc ~docv:"CA") + +let cert = + let doc = "Certificate" in + Arg.(required & pos 1 (some file) None & info [] ~doc ~docv:"CERT") + +let key = + let doc = "Private key" in + Arg.(required & pos 2 (some file) None & info [] ~doc ~docv:"KEY") diff --git a/app/vmmd_tls_inetd.ml b/app/vmmd_tls_inetd.ml new file mode 100644 index 0000000..4bf2e01 --- /dev/null +++ b/app/vmmd_tls_inetd.ml @@ -0,0 +1,35 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + +open Lwt.Infix +open Vmmd_tls_common + +let jump cacert cert priv_key = + Sys.(set_signal sigpipe Signal_ignore) ; + Lwt_main.run + (Nocrypto_entropy_lwt.initialize () >>= fun () -> + tls_config cacert cert priv_key >>= fun (config, ca) -> + let fd = Lwt_unix.of_unix_file_descr Unix.stdin in + Lwt.catch + (fun () -> Tls_lwt.Unix.server_of_fd config fd) + (fun exn -> + Vmm_lwt.safe_close fd >>= fun () -> + Lwt.fail exn) >>= fun t -> + Lwt.catch + (fun () -> + (handle ca t >|= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error in handle %s" msg) + | Ok () -> ()) >>= fun () -> + Vmm_tls_lwt.close t) + (fun e -> + Logs.err (fun m -> m "error while handle() %s" (Printexc.to_string e)) ; + Vmm_tls_lwt.close t)) ; + `Ok () + +open Cmdliner +open Vmm_cli + +let cmd = + Term.(ret (const jump $ cacert $ cert $ key)), + Term.info "vmmd_tls_inetd" ~version:"%%VERSION_NUM%%" + +let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/packaging/MANIFEST b/packaging/MANIFEST index 1c133d1..7bab7dd 100644 --- a/packaging/MANIFEST +++ b/packaging/MANIFEST @@ -75,7 +75,13 @@ messages [ add path 'vmm/solo5*' mode 0660 group albatross - * install solo5-hvt.net solo5-hvt.none in /var/db/albatross + * start TLS endpoint via inetd on port 49, add to /etc/inetd.conf: +tacacs stream tcp nowait albatross /usr/local/libexec/albatross/vmmd_tls_inetd vmmd_tls_inetd /usr/local/etc/albatross/cacert.pem /usr/local/etc/albatross/server.pem /usr/local/etc/albatross/server.key + + and add cacert.pem server.pem and server.key to /usr/local/etc/albatross + + * install solo5-hvt.net solo5-hvt.block solo5-hvt.block-net solo5-hvt.none + in /var/db/albatross =================================================================== EOD; diff --git a/packaging/create_package.sh b/packaging/create_package.sh index a1f1a83..c701977 100755 --- a/packaging/create_package.sh +++ b/packaging/create_package.sh @@ -25,7 +25,7 @@ for f in albatross_log \ do install -U $basedir/packaging/rc.d/$f $rootdir/usr/local/etc/rc.d/$f; done # stage albatross app binaries -for f in vmmd vmmd_log vmmd_console vmmd_stats vmmd_influx vmmd_tls; do +for f in vmmd vmmd_log vmmd_console vmmd_stats vmmd_influx vmmd_tls vmmd_tls_inetd; do install -U $basedir/_build/app/$f.native \ $rootdir/usr/local/libexec/albatross/$f; done diff --git a/pkg/pkg.ml b/pkg/pkg.ml index d9df305..1a80c8b 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -11,6 +11,7 @@ let () = Pkg.bin "app/vmmd_log" ; Pkg.bin "app/vmmd_stats" ; Pkg.bin "app/vmmd_tls" ; + Pkg.bin "app/vmmd_tls_inetd" ; Pkg.bin "app/vmmd_influx" ; Pkg.bin "app/vmmc_local" ; Pkg.bin "app/vmmc_remote" ; diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index dc20647..3e28d54 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -310,7 +310,7 @@ let block_cmd = let version = let f data = match data with | 3 -> `AV3 - | _ -> Asn.S.error (`Parse "unknown version number") + | x -> Asn.S.error (`Parse (Printf.sprintf "unknown version number 0x%X" x)) and g = function | `AV3 -> 3 in diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 67efd04..768ef18 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -79,7 +79,7 @@ let extract_policies version chain = R.error_msgf "unexpected wire %a" Vmm_commands.pp wire) (Ok (Vmm_core.Name.root, [])) chain -let handle _addr version chain = +let handle version chain = separate_chain chain >>= fun (leaf, rest) -> name chain >>= fun name -> Logs.debug (fun m -> m "leaf is %s, chain %a" diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli index 807e590..619a8ca 100644 --- a/src/vmm_tls.mli +++ b/src/vmm_tls.mli @@ -4,7 +4,7 @@ val wire_command_of_cert : Vmm_commands.version -> X509.t -> (Vmm_commands.t, [> `Parse of string | `Not_present | `Version of Vmm_commands.version ]) result val handle : - 'a -> Vmm_commands.version -> + Vmm_commands.version -> X509.t list -> (Vmm_core.Name.t * (Vmm_core.Name.t * Vmm_core.Policy.t) list * Vmm_commands.t, [> `Msg of string ]) Result.result