revive vmm_client
This commit is contained in:
Hannes Mehnert
parent
bcb280aa00
commit
2239aafdb7
|
|
@ -4,85 +4,20 @@ open Lwt.Infix
|
|||
|
||||
open Vmm_core
|
||||
|
||||
let my_version = `WV2
|
||||
let command = ref 1
|
||||
|
||||
let process db hdr data =
|
||||
let open Vmm_wire in
|
||||
let open Rresult.R.Infix in
|
||||
if not (version_eq hdr.version my_version) then
|
||||
Logs.err (fun m -> m "unknown wire protocol version")
|
||||
else
|
||||
let r =
|
||||
match hdr.tag with
|
||||
| x when x = Client.stat_msg_tag ->
|
||||
Client.decode_stat data >>= fun (ru, vmm, ifd) ->
|
||||
Logs.app (fun m -> m "statistics: %a %a %a"
|
||||
pp_rusage ru
|
||||
Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string uint64)) vmm
|
||||
Fmt.(list ~sep:(unit ", ") pp_ifdata) ifd) ;
|
||||
Ok ()
|
||||
| x when x = Client.log_msg_tag ->
|
||||
Client.decode_log data >>= fun log ->
|
||||
Logs.app (fun m -> m "log: %a" (Vmm_core.Log.pp db) log) ;
|
||||
Ok ()
|
||||
| x when x = Client.console_msg_tag ->
|
||||
Client.decode_console data >>= fun (name, ts, msg) ->
|
||||
Logs.app (fun m -> m "console %s: %a %s" (translate_serial db name) (Ptime.pp_human ~tz_offset_s:0 ()) ts msg) ;
|
||||
Ok ()
|
||||
| x when x = Client.info_msg_tag ->
|
||||
Client.decode_info data >>= fun vms ->
|
||||
List.iter (fun (name, cmd, pid, taps) ->
|
||||
Logs.app (fun m -> m "info %s: %s %d taps %a" (translate_serial db name)
|
||||
cmd pid Fmt.(list ~sep:(unit ", ") string) taps))
|
||||
vms ;
|
||||
Ok ()
|
||||
| x when x = fail_tag ->
|
||||
decode_str data >>= fun (msg, _) ->
|
||||
Logs.err (fun m -> m "failed %s" msg) ;
|
||||
Ok ()
|
||||
| x when x = success_tag ->
|
||||
decode_str data >>= fun (msg, _) ->
|
||||
Logs.app (fun m -> m "success %s" msg) ;
|
||||
Ok ()
|
||||
| x -> Rresult.R.error_msgf "unknown header tag %02X" x
|
||||
in
|
||||
match r with
|
||||
| Ok () -> ()
|
||||
| Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg)
|
||||
|
||||
let rec read_tls_write_cons db t =
|
||||
let rec read_tls_write_cons t =
|
||||
Vmm_tls.read_tls t >>= function
|
||||
| Error (`Msg msg) ->
|
||||
Logs.err (fun m -> m "error while reading %s" msg) ;
|
||||
read_tls_write_cons db t
|
||||
read_tls_write_cons t
|
||||
| Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit
|
||||
| Ok (hdr, data) ->
|
||||
process db hdr data ;
|
||||
read_tls_write_cons db t
|
||||
| Ok data ->
|
||||
match Vmm_commands.log_pp_reply data with
|
||||
| Ok () -> read_tls_write_cons t
|
||||
| Error (`Msg msg) ->
|
||||
Logs.warn (fun m -> m "error %s while logging message" msg) ;
|
||||
read_tls_write_cons t
|
||||
|
||||
let rec read_cons_write_tls db t =
|
||||
Lwt.catch (fun () ->
|
||||
Lwt_io.read_line Lwt_io.stdin >>= fun line ->
|
||||
let cmd, arg = match Astring.String.cut ~sep:" " line with
|
||||
| None -> line, None
|
||||
| Some (a, b) -> a, Some (translate_name db b)
|
||||
in
|
||||
match Vmm_core.cmd_of_string cmd with
|
||||
| None -> Logs.err (fun m -> m "unknown command") ; read_cons_write_tls db t
|
||||
| Some cmd ->
|
||||
let out = Vmm_wire.Client.cmd ?arg cmd !command my_version in
|
||||
command := succ !command ;
|
||||
Vmm_tls.write_tls t out >>= function
|
||||
| Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return_unit
|
||||
| Ok () ->
|
||||
Logs.debug (fun m -> m "wrote %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
|
||||
read_cons_write_tls db t)
|
||||
(fun e ->
|
||||
Logs.err (fun m -> m "exception %s in read_cons_write_tls" (Printexc.to_string e)) ;
|
||||
Lwt.return_unit)
|
||||
|
||||
let client cas host port cert priv_key db =
|
||||
let client cas host port cert priv_key =
|
||||
Nocrypto_entropy_lwt.initialize () >>= fun () ->
|
||||
let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in
|
||||
X509_lwt.authenticator auth >>= fun authenticator ->
|
||||
|
|
@ -99,12 +34,7 @@ let client cas host port cert priv_key db =
|
|||
let certificates = `Single cert in
|
||||
let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
|
||||
Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t ->
|
||||
|
||||
if Vmm_asn.contains_vm leaf || Vmm_asn.contains_crl leaf then
|
||||
read_tls_write_cons db t
|
||||
else
|
||||
(Logs.debug (fun m -> m "read/write games!") ;
|
||||
Lwt.join [ read_tls_write_cons db t ; read_cons_write_tls db t ]))
|
||||
read_tls_write_cons t)
|
||||
(fun exn ->
|
||||
Logs.err (fun m -> m "failed to establish TLS connection: %s"
|
||||
(Printexc.to_string exn)) ;
|
||||
|
|
@ -116,16 +46,7 @@ let run_client _ cas cert key (host, port) db =
|
|||
| Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
|
||||
| _ -> None) ;
|
||||
Sys.(set_signal sigpipe Signal_ignore) ;
|
||||
let db =
|
||||
let open Rresult.R.Infix in
|
||||
match db with
|
||||
| None -> []
|
||||
| Some db ->
|
||||
match Bos.OS.File.read_lines (Fpath.v db) >>= parse_db with
|
||||
| Ok db -> db
|
||||
| Error (`Msg m) -> Logs.warn (fun f -> f "couldn't parse database %s" m) ; []
|
||||
in
|
||||
Lwt_main.run (client cas host port cert key db)
|
||||
Lwt_main.run (client cas host port cert key)
|
||||
|
||||
let setup_log style_renderer level =
|
||||
Fmt_tty.setup_std_outputs ?style_renderer ();
|
||||
|
|
|
|||
|
|
@ -34,10 +34,45 @@ let client_auth ca tls addr =
|
|||
Tls_lwt.Unix.close tls >>= fun () ->
|
||||
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 (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop ()
|
||||
| Error _ -> Lwt.return (Error (`Msg "exception while reading"))
|
||||
| Ok (hdr, data) ->
|
||||
let full = Cstruct.append (Vmm_wire.encode_header hdr) data in
|
||||
Vmm_tls.write_tls tls full >>= function
|
||||
| Ok () -> loop ()
|
||||
| Error `Exception -> Lwt.return (Error (`Msg "exception"))
|
||||
in
|
||||
loop ()
|
||||
|
||||
let process fd tls =
|
||||
Vmm_lwt.read_wire fd >>= function
|
||||
| Error (`Msg m) -> Lwt.return (Error (`Msg m))
|
||||
| Error _ -> Lwt.return (Error (`Msg "read error"))
|
||||
| Ok (hdr, data) ->
|
||||
let full = Cstruct.append (Vmm_wire.encode_header hdr) data in
|
||||
Vmm_tls.write_tls tls full >|= function
|
||||
| Ok () -> Ok ()
|
||||
| Error `Exception -> Error (`Msg "exception on write")
|
||||
|
||||
let handle ca (tls, addr) =
|
||||
client_auth ca tls addr >>= fun chain ->
|
||||
let _ = Vmm_x509.handle_initial tls addr chain ca in
|
||||
Lwt.return_unit
|
||||
match Vmm_x509.handle addr chain with
|
||||
| Error (`Msg m) -> Lwt.fail_with m
|
||||
| Ok cmd ->
|
||||
let sock, next, cmd = Vmm_commands.handle cmd in
|
||||
connect (Vmm_core.socket_path sock) >>= fun fd ->
|
||||
Vmm_lwt.write_wire fd cmd >>= function
|
||||
| Error `Exception -> 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
|
||||
|
|
@ -72,7 +107,9 @@ let jump _ cacert cert priv_key port =
|
|||
Lwt.fail exn) >>= fun t ->
|
||||
Lwt.async (fun () ->
|
||||
Lwt.catch
|
||||
(fun () -> handle ca t)
|
||||
(fun () -> handle ca t >|= function
|
||||
| Error (`Msg msg) -> Logs.err (fun m -> m "error in handle %s" msg)
|
||||
| Ok () -> ())
|
||||
(fun e ->
|
||||
Logs.err (fun m -> m "error while handle() %s"
|
||||
(Printexc.to_string e)) ;
|
||||
|
|
|
|||
112
app/vmmc.ml
112
app/vmmc.ml
|
|
@ -22,76 +22,56 @@ let connect socket_path =
|
|||
Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
|
||||
c
|
||||
|
||||
let read fd f =
|
||||
let read fd =
|
||||
(* now we busy read and process output *)
|
||||
let rec loop () =
|
||||
Vmm_lwt.read_wire fd >>= function
|
||||
| Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop ()
|
||||
| Error _ -> Lwt.return (Error (`Msg "exception while reading"))
|
||||
| Ok (hdr, data) ->
|
||||
Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ;
|
||||
if Vmm_wire.is_fail hdr then
|
||||
let msg = match Vmm_wire.decode_string data with
|
||||
| Error _ -> ""
|
||||
| Ok (m, _) -> m
|
||||
in
|
||||
Lwt.return (Error (`Msg ("operation failed " ^ msg)))
|
||||
else if Vmm_wire.is_reply hdr then
|
||||
let msg = match Vmm_wire.decode_string data with
|
||||
| Error _ -> None
|
||||
| Ok (m, _) -> Some m
|
||||
in
|
||||
Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ;
|
||||
loop ()
|
||||
else
|
||||
match f (hdr, data) with
|
||||
| Ok () -> loop ()
|
||||
| Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
|
||||
| Ok data -> match Vmm_commands.handle_reply data with
|
||||
| Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
|
||||
| Ok (hdr, data) ->
|
||||
if Vmm_wire.is_reply hdr then
|
||||
let msg = match Vmm_wire.decode_string data with
|
||||
| Error _ -> None
|
||||
| Ok (m, _) -> Some m
|
||||
in
|
||||
Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ;
|
||||
loop ()
|
||||
else
|
||||
match Vmm_commands.log_pp_reply (hdr, data) with
|
||||
| Ok () -> loop ()
|
||||
| Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
|
||||
in
|
||||
loop ()
|
||||
|
||||
let handle opt_socket (cmd : Vmm_commands.t) f =
|
||||
let handle opt_socket (cmd : Vmm_commands.t) =
|
||||
let sock, next, cmd = Vmm_commands.handle cmd in
|
||||
connect (socket sock opt_socket) >>= fun fd ->
|
||||
Vmm_lwt.write_wire fd cmd >>= function
|
||||
| Error `Exception -> Lwt.return (Error (`Msg "couldn't write"))
|
||||
| Ok () ->
|
||||
(match next with
|
||||
| `Read -> read fd f
|
||||
| `Read -> read fd
|
||||
| `End ->
|
||||
process fd >|= function
|
||||
| Error e -> Error e
|
||||
| Ok data -> f data) >>= fun res ->
|
||||
| Ok data -> Vmm_commands.log_pp_reply data) >>= fun res ->
|
||||
Vmm_lwt.safe_close fd >|= fun () ->
|
||||
res
|
||||
|
||||
let jump opt_socket cmd f =
|
||||
let jump opt_socket cmd =
|
||||
match
|
||||
Lwt_main.run (handle opt_socket cmd f)
|
||||
Lwt_main.run (handle opt_socket cmd)
|
||||
with
|
||||
| Ok () -> `Ok ()
|
||||
| Error (`Msg m) -> `Error (false, m)
|
||||
|
||||
let info_ _ opt_socket name =
|
||||
jump opt_socket (`Info name) (fun (_, data) ->
|
||||
let open Rresult.R.Infix in
|
||||
Vmm_wire.Vm.decode_vms data >>| fun (vms, _) ->
|
||||
List.iter (fun (id, memory, cmd, pid, taps) ->
|
||||
Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a"
|
||||
pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps))
|
||||
vms)
|
||||
let info_ _ opt_socket name = jump opt_socket (`Info name)
|
||||
|
||||
let policy _ opt_socket name =
|
||||
jump opt_socket (`Policy name) (fun (_, data) ->
|
||||
let open Rresult.R.Infix in
|
||||
Vmm_wire.Vm.decode_policies data >>| fun (policies, _) ->
|
||||
List.iter (fun (id, policy) ->
|
||||
Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy))
|
||||
policies)
|
||||
let policy _ opt_socket name = jump opt_socket (`Policy name)
|
||||
|
||||
let remove_policy _ opt_socket name =
|
||||
jump opt_socket (`Remove_policy name) (fun _ ->
|
||||
Ok (Logs.app (fun m -> m "removed policy")))
|
||||
let remove_policy _ opt_socket name = jump opt_socket (`Remove_policy name)
|
||||
|
||||
let add_policy _ opt_socket name vms memory cpus block bridges =
|
||||
let bridges = match bridges with
|
||||
|
|
@ -104,12 +84,10 @@ let add_policy _ opt_socket name vms memory cpus block bridges =
|
|||
and cpuids = IS.of_list cpus
|
||||
in
|
||||
let policy = { vms ; cpuids ; memory ; block ; bridges } in
|
||||
jump opt_socket (`Add_policy (name, policy)) (fun _ ->
|
||||
Ok (Logs.app (fun m -> m "added policy")))
|
||||
jump opt_socket (`Add_policy (name, policy))
|
||||
|
||||
let destroy _ opt_socket name =
|
||||
jump opt_socket (`Destroy_vm name) (fun _ ->
|
||||
Ok (Logs.app (fun m -> m "destroyed VM")))
|
||||
jump opt_socket (`Destroy_vm name)
|
||||
|
||||
let create _ opt_socket force name image cpuid requested_memory boot_params block_device network =
|
||||
let image' = match Bos.OS.File.read (Fpath.v image) with
|
||||
|
|
@ -132,45 +110,13 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc
|
|||
else
|
||||
`Create_vm vm_config
|
||||
in
|
||||
let succ _ = Ok (Logs.app (fun m -> m "successfully started VM")) in
|
||||
jump opt_socket cmd succ
|
||||
jump opt_socket cmd
|
||||
|
||||
let console _ opt_socket name =
|
||||
jump opt_socket (`Console name) (fun (hdr, data) ->
|
||||
let open Rresult.R.Infix in
|
||||
match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with
|
||||
| Some Vmm_wire.Console.Data ->
|
||||
Vmm_wire.decode_id_ts data >>= fun ((name, ts), off) ->
|
||||
Vmm_wire.decode_string (Cstruct.shift data off) >>= fun (msg, _) ->
|
||||
Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts Vmm_core.pp_id name msg) ;
|
||||
Ok ()
|
||||
| _ ->
|
||||
Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag)))
|
||||
let console _ opt_socket name = jump opt_socket (`Console name)
|
||||
|
||||
let stats _ opt_socket name =
|
||||
jump opt_socket (`Statistics name) (fun (hdr, data) ->
|
||||
let open Rresult.R.Infix in
|
||||
match Vmm_wire.Stats.int_to_op hdr.Vmm_wire.tag with
|
||||
| Some Vmm_wire.Stats.Data ->
|
||||
Vmm_wire.decode_strings data >>= fun (name', off) ->
|
||||
Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun (ru, vmm, ifs) ->
|
||||
Logs.app (fun m -> m "stats %a@.%a@.%a@.%a@."
|
||||
pp_id name' Vmm_core.pp_rusage ru
|
||||
Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm
|
||||
Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifs) ;
|
||||
| _ ->
|
||||
Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag)))
|
||||
let stats _ opt_socket name = jump opt_socket (`Statistics name)
|
||||
|
||||
let event_log _ opt_socket name =
|
||||
jump opt_socket (`Log name) (fun (hdr, data) ->
|
||||
let open Rresult.R.Infix in
|
||||
match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with
|
||||
| Some Vmm_wire.Log.Broadcast ->
|
||||
Vmm_wire.Log.decode_log_hdr data >>= fun (loghdr, logdata) ->
|
||||
Vmm_wire.Log.decode_event logdata >>| fun event ->
|
||||
Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event))
|
||||
| _ ->
|
||||
Ok (Logs.warn (fun m -> m "unknown operation %lx" hdr.Vmm_wire.tag)))
|
||||
let event_log _ opt_socket name = jump opt_socket (`Log name)
|
||||
|
||||
let help _ _ man_format cmds = function
|
||||
| None -> `Help (`Pager, None)
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ let () =
|
|||
Pkg.bin "app/vmmd" ;
|
||||
Pkg.bin "app/vmm_console" ;
|
||||
Pkg.bin "app/vmm_log" ;
|
||||
(* Pkg.bin "app/vmm_client" ; *)
|
||||
Pkg.bin "app/vmm_client" ;
|
||||
Pkg.bin "app/vmm_tls_endpoint" ;
|
||||
Pkg.bin "app/vmmc" ;
|
||||
Pkg.bin "provision/vmm_req_command" ;
|
||||
|
|
|
|||
|
|
@ -16,6 +16,9 @@ type t = [
|
|||
| `Statistics of id
|
||||
| `Console of id
|
||||
| `Log of id
|
||||
| `Crl (* TODO *)
|
||||
| `Create_block of id * int
|
||||
| `Destroy_block of id
|
||||
]
|
||||
|
||||
let handle = function
|
||||
|
|
@ -49,11 +52,9 @@ let handle = function
|
|||
| `Log name ->
|
||||
let cmd = Vmm_wire.Log.subscribe c ver name in
|
||||
`Log, `Read, cmd
|
||||
(* | `Crl _ -> assert false
|
||||
(* write_to_file_unless_serial_smaller ; potentially destroy vms *)
|
||||
| `Crl -> assert false
|
||||
| `Create_block (name, size) -> assert false
|
||||
| `Destroy_block name -> assert false
|
||||
*)
|
||||
|
||||
let handle_reply (hdr, data) =
|
||||
if not (Vmm_wire.version_eq hdr.Vmm_wire.version ver) then
|
||||
|
|
@ -69,3 +70,55 @@ let handle_reply (hdr, data) =
|
|||
Ok (hdr, data)
|
||||
else
|
||||
Error (`Msg "received unexpected data")
|
||||
|
||||
let log_pp_reply (hdr, data) =
|
||||
let open Vmm_wire in
|
||||
let tag' = Int32.logxor reply_tag hdr.tag in
|
||||
let open Rresult.R.Infix in
|
||||
match Vm.int_to_op tag' with
|
||||
| Some Vm.Info ->
|
||||
Vm.decode_vms data >>| fun (vms, _) ->
|
||||
List.iter (fun (id, memory, cmd, pid, taps) ->
|
||||
Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a"
|
||||
pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps))
|
||||
vms
|
||||
| Some Vm.Policy ->
|
||||
Vm.decode_policies data >>| fun (policies, _) ->
|
||||
List.iter (fun (id, policy) ->
|
||||
Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy))
|
||||
policies
|
||||
| Some Vm.Insert_policy ->
|
||||
Ok (Logs.app (fun m -> m "added policy"))
|
||||
| Some Vm.Remove_policy ->
|
||||
Ok (Logs.app (fun m -> m "removed policy"))
|
||||
| Some Vm.Destroy ->
|
||||
Ok (Logs.app (fun m -> m "destroyed VM"))
|
||||
| Some Vm.Create ->
|
||||
Ok (Logs.app (fun m -> m "successfully started VM"))
|
||||
| Some Vm.Force_create ->
|
||||
Ok (Logs.app (fun m -> m "successfully forcefully started VM"))
|
||||
| None -> match Console.int_to_op tag' with
|
||||
| Some Console.Data ->
|
||||
decode_id_ts data >>= fun ((name, ts), off) ->
|
||||
decode_string (Cstruct.shift data off) >>| fun (msg, _) ->
|
||||
Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts pp_id name msg)
|
||||
| Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag))
|
||||
| None -> match Stats.int_to_op tag' with
|
||||
| Some Stats.Data ->
|
||||
decode_strings data >>= fun (name', off) ->
|
||||
Stats.decode_stats (Cstruct.shift data off) >>| fun (ru, vmm, ifs) ->
|
||||
Logs.app (fun m -> m "stats %a@.%a@.%a@.%a@."
|
||||
pp_id name' pp_rusage ru
|
||||
Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm
|
||||
Fmt.(list ~sep:(unit "@.") pp_ifdata) ifs)
|
||||
| Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag))
|
||||
| None -> match Log.int_to_op tag' with
|
||||
| Some Log.Broadcast ->
|
||||
Log.decode_log_hdr data >>= fun (loghdr, logdata) ->
|
||||
Log.decode_event logdata >>| fun event ->
|
||||
Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event))
|
||||
| Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag))
|
||||
| None -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -42,14 +42,14 @@ let read_tls t =
|
|||
(* 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) ; *)
|
||||
Ok (hdr, Cstruct.to_string b)
|
||||
Ok (hdr, b)
|
||||
else
|
||||
Lwt.return (Ok (hdr, ""))
|
||||
Lwt.return (Ok (hdr, Cstruct.empty))
|
||||
|
||||
let write_tls s buf =
|
||||
(* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *)
|
||||
Lwt.catch
|
||||
(fun () -> Tls_lwt.Unix.write s (Cstruct.of_string buf) >|= fun () -> Ok ())
|
||||
(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)) ;
|
||||
|
|
|
|||
206
src/vmm_x509.ml
206
src/vmm_x509.ml
|
|
@ -5,142 +5,7 @@ open Vmm_core
|
|||
|
||||
let asn_version = `AV1
|
||||
|
||||
(*
|
||||
let handle_single_revocation t prefix serial =
|
||||
let id = identifier serial in
|
||||
(match Vmm_resources.find t.resources (prefix @ [ id ]) with
|
||||
| None -> ()
|
||||
| Some e -> Vmm_resources.iter Vmm_unix.destroy e) ;
|
||||
(* also revoke all active sessions!? *)
|
||||
(* TODO: maybe we need a vmm_resources like structure for sessions as well!? *)
|
||||
let log_attached, kill =
|
||||
let pid = string_of_id prefix in
|
||||
match String.Map.find pid t.log_attached with
|
||||
| None -> t.log_attached, []
|
||||
| Some xs ->
|
||||
(* those where snd v = serial: drop *)
|
||||
let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in
|
||||
String.Map.add pid keep t.log_attached, drop
|
||||
in
|
||||
(* two things:
|
||||
1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above]
|
||||
2 revoked CA certs need to wipe subtree (all entries where k starts with prefix @ serial) *)
|
||||
let log_attached, kill =
|
||||
String.Map.fold (fun k' v (l, k) ->
|
||||
if is_sub_id ~super:(prefix@[id]) ~sub:(id_of_string k') then
|
||||
(l, v @ k)
|
||||
else
|
||||
(String.Map.add k' v l, k))
|
||||
log_attached
|
||||
(String.Map.empty, kill)
|
||||
in
|
||||
let state, out =
|
||||
List.fold_left (fun (s, out) (t, _) ->
|
||||
let s', out' = handle_disconnect s t in
|
||||
s', out @ out')
|
||||
({ t with log_attached }, [])
|
||||
kill
|
||||
in
|
||||
(state,
|
||||
List.map (fun x -> `Raw x) out,
|
||||
List.map fst kill)
|
||||
*)
|
||||
|
||||
(*
|
||||
let handle_revocation t s leaf chain ca prefix =
|
||||
Vmm_asn.crl_of_cert leaf >>= fun crl ->
|
||||
(* verify data (must be signed by the last cert of the chain (or cacert if chain is empty))! *)
|
||||
let issuer = match chain with
|
||||
| subca::_ -> subca
|
||||
| [] -> ca
|
||||
in
|
||||
let time = Ptime_clock.now () in
|
||||
(if X509.CRL.verify crl ~time issuer then Ok () else Error (`Msg "couldn't verify CRL")) >>= fun () ->
|
||||
(* the this_update must be > now, next_update < now, this_update > <local>.this_update, number > <local>.number *)
|
||||
(* TODO: can we have something better for uniqueness of CRL? *)
|
||||
let local = try Some (List.find (fun crl -> X509.CRL.verify crl issuer) t.crls) with Not_found -> None in
|
||||
(match local with
|
||||
| None -> Ok ()
|
||||
| Some local -> match X509.CRL.crl_number local, X509.CRL.crl_number crl with
|
||||
| None, _ -> Ok ()
|
||||
| Some _, None -> Error (`Msg "CRL number not present")
|
||||
| Some x, Some y -> if y > x then Ok () else Error (`Msg "CRL number not increased")) >>= fun () ->
|
||||
(* filename should be whatever_dir / crls / <id> *)
|
||||
let filename = Fpath.(dbdir / "crls" / string_of_id prefix) in
|
||||
Bos.OS.File.delete filename >>= fun () ->
|
||||
Bos.OS.File.write filename (Cstruct.to_string (X509.Encoding.crl_to_cstruct crl)) >>= fun () ->
|
||||
(* remove crl with same issuer from crls, and inject this one into state *)
|
||||
let crls =
|
||||
match local with
|
||||
| None -> crl :: t.crls
|
||||
| Some _ -> crl :: List.filter (fun c -> c <> crl) t.crls
|
||||
in
|
||||
(* iterate over revoked serials, find active resources, and kill them *)
|
||||
let newly_revoked =
|
||||
let old = match local with
|
||||
| Some x -> List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates x)
|
||||
| None -> []
|
||||
in
|
||||
let new_rev = List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates crl) in
|
||||
List.filter (fun n -> not (List.mem n old)) new_rev
|
||||
in
|
||||
let t, out, close =
|
||||
List.fold_left (fun (t, out, close) serial ->
|
||||
let t', out', close' = handle_single_revocation t prefix serial in
|
||||
(t', out @ out', close @ close'))
|
||||
(t, [], []) newly_revoked
|
||||
in
|
||||
let tls_out = Vmm_wire.success ~msg:"updated revocation list" 0 t.client_version in
|
||||
Ok ({ t with crls }, `Tls (s, tls_out) :: out, `Close close)
|
||||
*)
|
||||
|
||||
let my_command = 1L
|
||||
let my_version = `WV2
|
||||
|
||||
|
||||
let handle_initial s addr chain ca =
|
||||
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 here: inspect top-level-cert of chain.
|
||||
may need to create bridges and/or block device subdirectory (zfs create) *)
|
||||
(* let login_hdr, login_ev = Log.hdr name, `Login addr in *)
|
||||
Ok ()
|
||||
(* Vmm_asn.command_of_cert asn_version leaf >>= function
|
||||
| `Info ->
|
||||
let cmd = Vmm_wire.Vm.info my_command my_version name in
|
||||
Ok (`Vmmd, cmd)
|
||||
| `Create_vm ->
|
||||
Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
|
||||
let cmd = Vmm_wire.Vm.create my_command my_version vm_config in
|
||||
(* TODO: update acl *)
|
||||
Ok (`Vmmd, cmd)
|
||||
| `Force_create_vm ->
|
||||
Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
|
||||
let cmd = Vmm_wire.Vm.force_create my_command my_version vm_config in
|
||||
(* TODO: update acl *)
|
||||
Ok (`Vmmd, cmd)
|
||||
| `Destroy_vm ->
|
||||
let cmd = Vmm_wire.Vm.destroy my_command my_version name in
|
||||
Ok (`Vmmd, cmd)
|
||||
| `Statistics ->
|
||||
let cmd = Vmm_wire.Stats.subscribe my_command my_version name in
|
||||
Ok (`Stats, cmd)
|
||||
| `Console -> `Cons, Vmm_wire.Console.attach ; read there and write to tls
|
||||
| `Log -> `Log, Vmm_wire.Log.subscribe ; read there and write to tls
|
||||
| `Crl -> write_to_file_unless_serial_smaller ; potentially destroy vms
|
||||
| `Create_block -> ??
|
||||
| `Destroy_block -> ??
|
||||
|
||||
|
||||
(if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then
|
||||
(* convert certificate to vm_config *)
|
||||
Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
|
||||
Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ;
|
||||
(* let check_policy =
|
||||
(* get names and static resources *)
|
||||
List.fold_left (fun acc ca ->
|
||||
acc >>= fun acc ->
|
||||
|
|
@ -151,37 +16,38 @@ let handle_initial s addr chain ca =
|
|||
(* check static policies *)
|
||||
Logs.debug (fun m -> m "now checking static policies") ;
|
||||
check_policies vm_config (List.map snd policies) >>= fun () ->
|
||||
let t, task =
|
||||
let force = List.mem `Force_create perms in
|
||||
if force then
|
||||
let fid = vm_id vm_config in
|
||||
match String.Map.find fid t.tasks with
|
||||
| None -> t, None
|
||||
| Some task ->
|
||||
let kill () =
|
||||
match Vmm_resources.find_vm t.resources (fullname vm_config) with
|
||||
| None ->
|
||||
Logs.err (fun m -> m "found a task, but no vm for %a (%s)"
|
||||
pp_id (fullname vm_config) fid)
|
||||
| Some vm ->
|
||||
Logs.debug (fun m -> m "killing %a now" pp_vm vm) ;
|
||||
Vmm_unix.destroy vm
|
||||
in
|
||||
let tasks = String.Map.remove fid t.tasks in
|
||||
({ t with tasks }, Some (kill, task))
|
||||
else
|
||||
t, None
|
||||
in
|
||||
let next t sleeper =
|
||||
handle_create t vm_config policies >>= fun cont ->
|
||||
let id = vm_id vm_config in
|
||||
let cons = Vmm_wire.Console.add t.console_counter t.console_version id in
|
||||
let tasks = String.Map.add id sleeper t.tasks in
|
||||
Ok ({ t with console_counter = succ t.console_counter ; tasks },
|
||||
[ `Raw (t.console_socket, cons) ],
|
||||
cont)
|
||||
in
|
||||
Ok (t, [], `Create (task, next))
|
||||
(* else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then
|
||||
handle_revocation t s leaf chain ca prefix *)
|
||||
*)
|
||||
*)
|
||||
|
||||
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 here: inspect top-level-cert of chain.
|
||||
may need to create bridges and/or block device subdirectory (zfs create) *)
|
||||
(* let login_hdr, login_ev = Log.hdr name, `Login addr in *)
|
||||
Vmm_asn.command_of_cert asn_version leaf >>= function
|
||||
| `Info -> Ok (`Info name)
|
||||
| `Create_vm ->
|
||||
(* TODO: update acl *)
|
||||
Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config ->
|
||||
`Create_vm vm_config
|
||||
| `Force_create_vm ->
|
||||
(* TODO: update acl *)
|
||||
Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config ->
|
||||
`Force_create_vm vm_config
|
||||
| `Destroy_vm -> Ok (`Destroy_vm name)
|
||||
| `Statistics -> Ok (`Statistics name)
|
||||
| `Console -> Ok (`Console name)
|
||||
| `Log -> Ok (`Log name)
|
||||
| `Crl -> Ok `Crl
|
||||
| `Create_block ->
|
||||
Vmm_asn.block_device_of_cert asn_version leaf >>= fun block_name ->
|
||||
Vmm_asn.block_size_of_cert asn_version leaf >>| fun block_size ->
|
||||
`Create_block (block_name, block_size)
|
||||
| `Destroy_block ->
|
||||
Vmm_asn.block_device_of_cert asn_version leaf >>| fun block_name ->
|
||||
`Destroy_block block_name
|
||||
|
|
|
|||
Loading…
Reference in a new issue