move more stuff around

_tags

@@ -6,7 +6,8 @@ true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring
 <src/vmm_compress.ml>: package(decompress)
 <src/vmm_asn.{ml,mli}>: package(asn1-combinators)
 <src/vmm_lwt.{ml,mli}>: package(lwt lwt.unix)
-<src/vmm_tls.{ml,mli}>: package(lwt tls.lwt)
+<src/vmm_tls_lwt.{ml,mli}>: package(lwt tls.lwt)
+<src/vmm_tls.{ml,mli}>: package(x509)
 
 <app/*>: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress)
 <app/vmm_client.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)

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

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

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

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

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 check_policy =
-  let rec r_n buf off tot =
+     (* get names and static resources *)
-    let l = tot - off in
+     List.fold_left (fun acc ca ->
-    if l = 0 then
+         acc >>= fun acc ->
-      Lwt.return (Ok ())
+         Vmm_asn.delegation_of_cert asn_version ca >>= fun res ->
-    else
+         let name = id ca in
-      Lwt.catch (fun () ->
+         Ok ((name, res) :: acc))
-          Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function
+       (Ok []) chain >>= fun policies ->
-          | 0 ->
+     (* check static policies *)
-            Logs.err (fun m -> m "TLS: end of file") ;
+     Logs.debug (fun m -> m "now checking static policies") ;
-            Lwt.return (Error `Eof)
+     check_policies vm_config (List.map snd policies) >>= fun () ->
-          | 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 handle _addr version chain =
-  let data = Vmm_asn.wire_to_cstruct wire in
+  separate_chain chain >>= fun (leaf, chain) ->
-  let dlen = Cstruct.create 4 in
+  let prefix = List.map name chain in
-  Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ;
+  let name = prefix @ [ name leaf ] in
-  let buf = Cstruct.(append dlen data) in
+  Logs.debug (fun m -> m "leaf is %s, chain %a"
-  (*  Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *)
+                 (X509.common_name_to_string leaf)
-  Lwt.catch
+                 Fmt.(list ~sep:(unit " -> ") string)
-    (fun () -> Tls_lwt.Unix.write s buf >|= fun () -> Ok ())
+                 (List.map X509.common_name_to_string chain)) ;
-    (function
+  (* TODO: inspect top-level-cert of chain. *)
-      | Tls_lwt.Tls_failure a ->
+  (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)
-        Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
+  (* TODO: update policies! *)
-        Lwt.return (Error `Exception)
+  Vmm_asn.wire_command_of_cert version leaf >>| fun wire ->
-      | e ->
+  (name, wire)
-        Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ;
-        Lwt.return (Error `Exception))

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 :
+val handle :
-  Tls_lwt.Unix.t -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t
+  'a -> Vmm_commands.version ->
+  X509.t list ->
+  (string list * Vmm_commands.t, [> `Msg of string ]) Result.result

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

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

src/vmm_x509.ml

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

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 ->
+        | Some ifd when List.mem ifd.Vmm_core.Stats.name nics ->
-          go (pred cnt) ((id, ifd.name) :: acc) (pred id)
+          go (pred cnt) ((id, ifd.Vmm_core.Stats.name) :: acc) (pred id)
         | _ -> go cnt acc (pred id)
       else
         List.rev acc