vmmd_tlS_inetd

_tags

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

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 =

app/vmmd_tls.ml

@@ -2,118 +2,7 @@
 
 open Lwt.Infix
 
-let my_version = `AV3
+open Vmmd_tls_common
-
-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
 
 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 ->
+     tls_config cacert cert priv_key >>= fun (config, ca) ->
-     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
      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)

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

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

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;

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
 

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

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

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"

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