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

revive vmm_client

This commit is contained in:
Hannes Mehnert 2018-10-14 02:18:33 +02:00
parent bcb280aa00
commit 2239aafdb7
7 changed files with 176 additions and 353 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
app/vmm_client.ml
View File

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

43
app/vmm_tls_endpoint.ml
View File

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

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

2
pkg/pkg.ml
View File

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

59
src/vmm_commands.ml
View File

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

6
src/vmm_tls.ml
View File

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

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