From a064c7f58eebd40ba7031cecd096cbf9c999a05c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 24 Oct 2018 00:10:08 +0200 Subject: [PATCH] move more stuff around --- _tags | 3 +- app/vmm_client.ml | 2 +- app/vmm_tls_endpoint.ml | 6 +- app/vmmd.ml | 10 ++-- src/albatross.mllib | 4 +- src/vmm_tls.ml | 88 +++++++++------------------- src/vmm_tls.mli | 8 +-- src/vmm_tls_lwt.ml | 64 ++++++++++++++++++++ src/vmm_tls_lwt.mli | 5 ++ src/{vmm_engine.ml => vmm_vmmd.ml} | 0 src/{vmm_engine.mli => vmm_vmmd.mli} | 0 src/vmm_x509.ml | 32 ---------- stats/vmm_stats.ml | 4 +- 13 files changed, 115 insertions(+), 111 deletions(-) create mode 100644 src/vmm_tls_lwt.ml create mode 100644 src/vmm_tls_lwt.mli rename src/{vmm_engine.ml => vmm_vmmd.ml} (100%) rename src/{vmm_engine.mli => vmm_vmmd.mli} (100%) delete mode 100644 src/vmm_x509.ml diff --git a/_tags b/_tags index 45dcadd..07bee85 100644 --- a/_tags +++ b/_tags @@ -6,7 +6,8 @@ true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring : package(decompress) : package(asn1-combinators) : package(lwt lwt.unix) -: package(lwt tls.lwt) +: package(lwt tls.lwt) +: package(x509) : package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress) : package(nocrypto tls.lwt nocrypto.lwt) diff --git a/app/vmm_client.ml b/app/vmm_client.ml index f38b58c..1083b08 100644 --- a/app/vmm_client.ml +++ b/app/vmm_client.ml @@ -3,7 +3,7 @@ open Lwt.Infix let rec read_tls_write_cons t = - Vmm_tls.read_tls t >>= function + Vmm_tls_lwt.read_tls t >>= function | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit | Ok wire -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire) ; diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index 8c8f8f6..cb1a230 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -45,7 +45,7 @@ let read fd tls = | 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.write_tls tls wire >>= function + Vmm_tls_lwt.write_tls tls wire >>= function | Ok () -> loop () | Error `Exception -> Lwt.return (Error (`Msg "exception")) in @@ -56,13 +56,13 @@ let process fd tls = | Error _ -> Lwt.return (Error (`Msg "read error")) | Ok wire -> Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ; - Vmm_tls.write_tls tls wire >|= function + 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_x509.handle addr chain with + match Vmm_tls.handle addr my_version chain with | Error (`Msg m) -> Lwt.fail_with m | Ok (name, cmd) -> let sock, next = Vmm_commands.endpoint cmd in diff --git a/app/vmmd.ml b/app/vmmd.ml index 5a22172..83e1fba 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -18,7 +18,7 @@ open Lwt.Infix let version = `AV2 -let state = ref (Vmm_engine.init version) +let state = ref (Vmm_vmmd.init version) let create c_fd process cont = Vmm_lwt.read_wire c_fd >>= function @@ -55,13 +55,13 @@ let create c_fd process cont = s := { !s with vm_created = succ !s.vm_created } ; Lwt.async (fun () -> Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> - let state', out' = Vmm_engine.handle_shutdown !state name vm r in + let state', out' = Vmm_vmmd.handle_shutdown !state name vm r in s := { !s with vm_destroyed = succ !s.vm_destroyed } ; state := state' ; process out' >|= fun () -> Lwt.wakeup wakeme ()) ; process out >>= fun () -> - let state', out = Vmm_engine.setup_stats !state name vm in + let state', out = Vmm_vmmd.setup_stats !state name vm in state := state' ; process out (* TODO: need to read from stats socket! *) @@ -83,7 +83,7 @@ let handle out c_fd fd addr = *) let process xs = Lwt_list.iter_p (function - | #Vmm_engine.service_out as o -> out o + | #Vmm_vmmd.service_out as o -> out o | `Data cs -> (* rather: terminate connection *) Vmm_lwt.write_wire fd cs >|= fun _ -> ()) xs @@ -95,7 +95,7 @@ let handle out c_fd fd addr = Lwt.return_unit | Ok wire -> Logs.debug (fun m -> m "read sth") ; - let state', data, next = Vmm_engine.handle_command !state wire in + let state', data, next = Vmm_vmmd.handle_command !state wire in state := state' ; process data >>= fun () -> match next with diff --git a/src/albatross.mllib b/src/albatross.mllib index 5aebb70..42c6b00 100644 --- a/src/albatross.mllib +++ b/src/albatross.mllib @@ -1,10 +1,10 @@ Vmm_asn Vmm_lwt +Vmm_tls_lwt Vmm_tls -Vmm_engine +Vmm_vmmd Vmm_commands Vmm_core -Vmm_engine Vmm_resources Vmm_trie Vmm_unix diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 4bd3daf..a7c41df 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -1,64 +1,30 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) +open Rresult.R.Infix -open Lwt.Infix +open Vmm_core -let read_tls t = - let rec r_n buf off tot = - let l = tot - off in - if l = 0 then - Lwt.return (Ok ()) - else - Lwt.catch (fun () -> - Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function - | 0 -> - Logs.err (fun m -> m "TLS: end of file") ; - Lwt.return (Error `Eof) - | x when x == l -> Lwt.return (Ok ()) - | x when x < l -> r_n buf (off + x) tot - | _ -> - Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ; - Lwt.return (Error `Toomuch)) - (function - | Tls_lwt.Tls_failure a -> - Logs.err (fun m -> m "TLS read failure: %s" (Tls.Engine.string_of_failure a)) ; - Lwt.return (Error `Exception) - | e -> - Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ; - Lwt.return (Error `Exception)) - in - let buf = Cstruct.create 4 in - r_n buf 0 4 >>= function - | Error e -> Lwt.return (Error e) - | Ok () -> - let len = Cstruct.BE.get_uint32 buf 0 in - if len > 0l then - let b = Cstruct.create (Int32.to_int len) in - r_n b 0 (Int32.to_int len) >|= function - | Error e -> Error e - | Ok () -> - (* Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a" - hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag - Cstruct.hexdump_pp b) ; *) - match Vmm_asn.wire_of_cstruct b with - | Ok w -> Ok w - | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s while parsing data" msg) ; - Error `Exception - else - Lwt.return (Error `Eof) +(* let check_policy = + (* get names and static resources *) + List.fold_left (fun acc ca -> + acc >>= fun acc -> + Vmm_asn.delegation_of_cert asn_version ca >>= fun res -> + let name = id ca in + Ok ((name, res) :: acc)) + (Ok []) chain >>= fun policies -> + (* check static policies *) + Logs.debug (fun m -> m "now checking static policies") ; + check_policies vm_config (List.map snd policies) >>= fun () -> +*) -let write_tls s wire = - let data = Vmm_asn.wire_to_cstruct wire in - let dlen = Cstruct.create 4 in - Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ; - let buf = Cstruct.(append dlen data) in - (* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *) - Lwt.catch - (fun () -> Tls_lwt.Unix.write s buf >|= fun () -> Ok ()) - (function - | Tls_lwt.Tls_failure a -> - Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ; - Lwt.return (Error `Exception) - | e -> - Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ; - Lwt.return (Error `Exception)) +let handle _addr version chain = + separate_chain chain >>= fun (leaf, chain) -> + let prefix = List.map name chain in + let name = prefix @ [ name leaf ] in + Logs.debug (fun m -> m "leaf is %s, chain %a" + (X509.common_name_to_string leaf) + Fmt.(list ~sep:(unit " -> ") string) + (List.map X509.common_name_to_string chain)) ; + (* TODO: inspect top-level-cert of chain. *) + (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) + (* TODO: update policies! *) + Vmm_asn.wire_command_of_cert version leaf >>| fun wire -> + (name, wire) diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli index b72e093..8880c37 100644 --- a/src/vmm_tls.mli +++ b/src/vmm_tls.mli @@ -1,5 +1,5 @@ -val read_tls : Tls_lwt.Unix.t -> - (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t -val write_tls : - Tls_lwt.Unix.t -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t +val handle : + 'a -> Vmm_commands.version -> + X509.t list -> + (string list * Vmm_commands.t, [> `Msg of string ]) Result.result diff --git a/src/vmm_tls_lwt.ml b/src/vmm_tls_lwt.ml new file mode 100644 index 0000000..4bd3daf --- /dev/null +++ b/src/vmm_tls_lwt.ml @@ -0,0 +1,64 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Lwt.Infix + +let read_tls t = + let rec r_n buf off tot = + let l = tot - off in + if l = 0 then + Lwt.return (Ok ()) + else + Lwt.catch (fun () -> + Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function + | 0 -> + Logs.err (fun m -> m "TLS: end of file") ; + Lwt.return (Error `Eof) + | x when x == l -> Lwt.return (Ok ()) + | x when x < l -> r_n buf (off + x) tot + | _ -> + Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ; + Lwt.return (Error `Toomuch)) + (function + | Tls_lwt.Tls_failure a -> + Logs.err (fun m -> m "TLS read failure: %s" (Tls.Engine.string_of_failure a)) ; + Lwt.return (Error `Exception) + | e -> + Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ; + Lwt.return (Error `Exception)) + in + let buf = Cstruct.create 4 in + r_n buf 0 4 >>= function + | Error e -> Lwt.return (Error e) + | Ok () -> + let len = Cstruct.BE.get_uint32 buf 0 in + if len > 0l then + let b = Cstruct.create (Int32.to_int len) in + r_n b 0 (Int32.to_int len) >|= function + | Error e -> Error e + | Ok () -> + (* Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a" + hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag + Cstruct.hexdump_pp b) ; *) + match Vmm_asn.wire_of_cstruct b with + | Ok w -> Ok w + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while parsing data" msg) ; + Error `Exception + else + Lwt.return (Error `Eof) + +let write_tls s wire = + let data = Vmm_asn.wire_to_cstruct wire in + let dlen = Cstruct.create 4 in + Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ; + let buf = Cstruct.(append dlen data) in + (* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *) + Lwt.catch + (fun () -> Tls_lwt.Unix.write s buf >|= fun () -> Ok ()) + (function + | Tls_lwt.Tls_failure a -> + Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ; + Lwt.return (Error `Exception) + | e -> + Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ; + Lwt.return (Error `Exception)) diff --git a/src/vmm_tls_lwt.mli b/src/vmm_tls_lwt.mli new file mode 100644 index 0000000..b72e093 --- /dev/null +++ b/src/vmm_tls_lwt.mli @@ -0,0 +1,5 @@ +val read_tls : Tls_lwt.Unix.t -> + (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t + +val write_tls : + Tls_lwt.Unix.t -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t diff --git a/src/vmm_engine.ml b/src/vmm_vmmd.ml similarity index 100% rename from src/vmm_engine.ml rename to src/vmm_vmmd.ml diff --git a/src/vmm_engine.mli b/src/vmm_vmmd.mli similarity index 100% rename from src/vmm_engine.mli rename to src/vmm_vmmd.mli diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml deleted file mode 100644 index 4e3e3d9..0000000 --- a/src/vmm_x509.ml +++ /dev/null @@ -1,32 +0,0 @@ -open Rresult.R.Infix - -open Vmm_core - -let asn_version = `AV2 - -(* let check_policy = - (* get names and static resources *) - List.fold_left (fun acc ca -> - acc >>= fun acc -> - Vmm_asn.delegation_of_cert asn_version ca >>= fun res -> - let name = id ca in - Ok ((name, res) :: acc)) - (Ok []) chain >>= fun policies -> - (* check static policies *) - Logs.debug (fun m -> m "now checking static policies") ; - check_policies vm_config (List.map snd policies) >>= fun () -> -*) - -let handle _addr chain = - separate_chain chain >>= fun (leaf, chain) -> - let prefix = List.map name chain in - let name = prefix @ [ name leaf ] in - Logs.debug (fun m -> m "leaf is %s, chain %a" - (X509.common_name_to_string leaf) - Fmt.(list ~sep:(unit " -> ") string) - (List.map X509.common_name_to_string chain)) ; - (* TODO: inspect top-level-cert of chain. *) - (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) - (* TODO: update policies! *) - Vmm_asn.wire_command_of_cert asn_version leaf >>| fun wire -> - (name, wire) diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index 7363440..bc21c40 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -133,8 +133,8 @@ let add_pid t vmid pid nics = let rec go cnt acc id = if id > 0 && cnt > 0 then match wrap sysctl_ifdata id with - | Some ifd when List.mem ifd.name nics -> - go (pred cnt) ((id, ifd.name) :: acc) (pred id) + | Some ifd when List.mem ifd.Vmm_core.Stats.name nics -> + go (pred cnt) ((id, ifd.Vmm_core.Stats.name) :: acc) (pred id) | _ -> go cnt acc (pred id) else List.rev acc