reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

vmmd_tlS_inetd

Browse source
This commit is contained in:
Hannes Mehnert 2018-11-23 20:28:33 +01:00
parent eee1a4cb91
commit b5a068555c
11 changed files with 188 additions and 142 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
_tags
View file

@ -13,7 +13,7 @@ true : package(rresult logs ipaddr bos hex ptime astring duration cstruct decomp
<app/vmmd.{ml,native,byte}>: package(ptime.clock.os)
<app/vmmd_console.{ml,native,byte}>: package(ptime.clock.os)
<app/vmmd_log.{ml,native,byte}>: package(ptime.clock.os)
<app/vmmd_tls.{ml,native,byte}>: package(tls.lwt ptime.clock.os)
<app/vmmd_tls*.{ml,native,byte}>: package(tls.lwt ptime.clock.os)
<app/vmmd_stats.{ml,native,byte}>: link_vmm_stats
<app/vmmc_remote.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)

3
app/vmmc_bistro.ml
View file

@ -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 =

141
app/vmmd_tls.ml
View file

@ -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)

132
app/vmmd_tls_common.ml Normal file
View file

@ -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")

35
app/vmmd_tls_inetd.ml Normal file
View file

@ -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

8
packaging/MANIFEST
View file

@ -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;

2
packaging/create_package.sh
View file

@ -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

1
pkg/pkg.ml
View file

@ -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" ;

2
src/vmm_asn.ml
View file

@ -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

2
src/vmm_tls.ml
View file

@ -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"

2
src/vmm_tls.mli
View file

@ -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