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

versioning: revise it all, use a 'current' in Vmm_commands, all daemons reply with the received version on that particular stream

Browse source
This commit is contained in:
Hannes Mehnert 2019-11-11 21:49:51 +01:00
parent 365a569b25
commit 784429744c
27 changed files with 337 additions and 384 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
client/albatross_client_bistro.ml
View file

@ -3,8 +3,6 @@
open Lwt.Infix
open X509
let version = `AV4
let read fd =
(* now we busy read and process output *)
Logs.debug (fun m -> m "reading tls stream") ;
@ -15,7 +13,7 @@ let read fd =
Lwt.return (Ok ())
| Error _ -> Lwt.return (Error (`Msg ("read failure")))
| Ok wire ->
Albatross_cli.print_result version wire ;
Albatross_cli.print_result wire ;
loop ()
in
loop ()
@ -37,6 +35,10 @@ let timestamps validity =
| Some now, Some exp -> (now, exp)
let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
Printexc.register_printer (function
| Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x)
| Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
| _ -> None) ;
Vmm_lwt.read_from_file cert >>= fun cert_cs ->
Vmm_lwt.read_from_file key >>= fun key_cs ->
match Certificate.decode_pem cert_cs, Private_key.decode_pem key_cs with
@ -48,7 +50,7 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
let tmpkey = Nocrypto.Rsa.generate 4096 in
let name = Vmm_core.Name.to_string id in
let extensions =
let v = Vmm_asn.cert_extension_to_cstruct (version, cmd) in
let v = Vmm_asn.to_cert_extension cmd in
Extension.(add Key_usage (true, [ `Digital_signature ; `Key_encipherment ])
(add Basic_constraints (true, (false, None))
(add Ext_key_usage (true, [ `Client_auth ])
@ -285,7 +287,7 @@ let default_cmd =
`P "$(tname) executes the provided subcommand on a remote albatross" ]
in
Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "albatross_client_bistro" ~version:"%%VERSION_NUM%%" ~doc ~man
Term.info "albatross_client_bistro" ~version ~doc ~man
let cmds = [ help_cmd ; info_cmd ;
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;

8
client/albatross_client_local.ml
View file

@ -2,8 +2,6 @@
open Lwt.Infix
let version = `AV4
let socket t = function
| Some x -> x
| None -> Vmm_core.socket_path t
@ -11,7 +9,7 @@ let socket t = function
let process fd =
Vmm_lwt.read_wire fd >|= function
| Error _ -> Error ()
| Ok wire -> Ok (Albatross_cli.print_result version wire)
| Ok wire -> Ok (Albatross_cli.print_result wire)
let read fd =
(* now we busy read and process output *)
@ -32,7 +30,7 @@ let handle opt_socket name (cmd : Vmm_commands.t) =
in
Lwt.return err
| Some fd ->
let header = Vmm_commands.{ version ; sequence = 0L ; name } in
let header = Vmm_commands.header name in
Vmm_lwt.write_wire fd (header, `Command cmd) >>= function
| Error `Exception -> Lwt.return (Error (`Msg "exception"))
| Ok () ->
@ -248,7 +246,7 @@ let default_cmd =
`P "$(tname) connects to albatrossd via a local socket" ]
in
Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "albatross_client_local" ~version:"%%VERSION_NUM%%" ~doc ~man
Term.info "albatross_client_local" ~version ~doc ~man
let cmds = [ help_cmd ; info_cmd ;
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;

6
client/albatross_client_remote_tls.ml
View file

@ -2,8 +2,6 @@
open Lwt.Infix
let version = `AV4
let rec read_tls_write_cons t =
Vmm_tls_lwt.read_tls t >>= function
| Error `Eof ->
@ -12,7 +10,7 @@ let rec read_tls_write_cons t =
| Error _ ->
Lwt.return (Error (`Msg ("read failure")))
| Ok wire ->
Albatross_cli.print_result version wire ;
Albatross_cli.print_result wire ;
read_tls_write_cons t
let client cas host port cert priv_key =
@ -82,7 +80,7 @@ let cmd =
`P "$(tname) connects to an Albatross server and initiates a TLS handshake" ]
in
Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination),
Term.info "albatross_client_remote_tls" ~version:"%%VERSION_NUM%%" ~doc ~man
Term.info "albatross_client_remote_tls" ~version ~doc ~man
let () =
match Term.eval cmd

18
command-line/albatross_cli.ml
View file

@ -48,14 +48,12 @@ let init_influx name data =
in
Lwt.async report
let print_result version (header, reply) =
if not (Vmm_commands.version_eq header.Vmm_commands.version version) then
Logs.err (fun m -> m "version not equal")
else match reply with
| `Success _ -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
| `Data _ -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
| `Failure _ -> Logs.warn (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
| `Command _ -> Logs.err (fun m -> m "unexpected command %a" Vmm_commands.pp_wire (header, reply))
let print_result ((_, reply) as wire) =
match reply with
| `Success _ -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire)
| `Data _ -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire)
| `Failure _ -> Logs.warn (fun m -> m "%a" Vmm_commands.pp_wire wire)
| `Command _ -> Logs.err (fun m -> m "unexpected command %a" Vmm_commands.pp_wire wire)
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
@ -252,3 +250,7 @@ let count =
let since_count since count = match since with
| None -> `Count count
| Some since -> `Since since
let version =
Fmt.strf "version %%VERSION%% protocol version %a"
Vmm_commands.pp_version Vmm_commands.current

41
daemon/albatross_console.ml
View file

@ -14,8 +14,6 @@ open Lwt.Infix
open Astring
let my_version = `AV4
let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
let active = ref String.Map.empty
@ -31,8 +29,8 @@ let read_console id name ring fd =
Vmm_ring.write ring (t, line) ;
(match String.Map.find name !active with
| None -> Lwt.return_unit
| Some fd ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = id } in
| Some (version, fd) ->
let header = Vmm_commands.header ~version id in
Vmm_lwt.write_wire fd (header, `Data (`Console_data (t, line))) >>= function
| Error _ ->
Vmm_lwt.safe_close fd >|= fun () ->
@ -87,21 +85,21 @@ let add_fifo id =
Lwt.async (fun () -> read_console id name ring f >|= fun () -> fifos `Close) ;
Ok ()
let subscribe s id =
let subscribe s version id =
let name = Vmm_core.Name.to_string id in
Logs.debug (fun m -> m "attempting to subscribe %a" Vmm_core.Name.pp id) ;
match String.Map.find name !t with
| None ->
active := String.Map.add name s !active ;
active := String.Map.add name (version, s) !active ;
Lwt.return (None, "waiting for VM")
| Some r ->
(match String.Map.find name !active with
| None -> Lwt.return_unit
| Some s -> Vmm_lwt.safe_close s) >|= fun () ->
active := String.Map.add name s !active ;
| Some (_, s) -> Vmm_lwt.safe_close s) >|= fun () ->
active := String.Map.add name (version, s) !active ;
(Some r, "subscribed")
let send_history s r id since =
let send_history s version r id since =
let entries =
match since with
| `Count n -> Vmm_ring.read_last r n
@ -109,7 +107,7 @@ let send_history s r id since =
in
Logs.debug (fun m -> m "%a found %d history" Vmm_core.Name.pp id (List.length entries)) ;
Lwt_list.iter_s (fun (i, v) ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = id } in
let header = Vmm_commands.header ~version id in
Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >>= function
| Ok () -> Lwt.return_unit
| Error _ -> Vmm_lwt.safe_close s)
@ -123,10 +121,7 @@ let handle s addr =
Logs.err (fun m -> m "exception while reading") ;
Lwt.return_unit
| Ok (header, `Command (`Console_cmd cmd)) ->
if not (Vmm_commands.version_eq header.Vmm_commands.version my_version) then begin
Logs.err (fun m -> m "ignoring data with bad version") ;
Lwt.return_unit
end else begin
begin
let name = header.Vmm_commands.name in
match cmd with
| `Console_add ->
@ -135,21 +130,21 @@ let handle s addr =
let reply = match res with
| Ok () -> `Success `Empty
| Error (`Msg msg) -> `Failure msg
in
Vmm_lwt.write_wire s (header, reply) >>= function
| Ok () -> loop ()
| Error _ ->
Logs.err (fun m -> m "error while writing") ;
Lwt.return_unit
in
Vmm_lwt.write_wire s (header, reply) >>= function
| Ok () -> loop ()
| Error _ ->
Logs.err (fun m -> m "error while writing") ;
Lwt.return_unit
end
| `Console_subscribe ts ->
subscribe s name >>= fun (ring, res) ->
subscribe s header.Vmm_commands.version name >>= fun (ring, res) ->
Vmm_lwt.write_wire s (header, `Success (`String res)) >>= function
| Error _ -> Vmm_lwt.safe_close s
| Ok () ->
(match ring with
| None -> Lwt.return_unit
| Some r -> send_history s r name ts) >>= fun () ->
| Some r -> send_history s header.Vmm_commands.version r name ts) >>= fun () ->
(* now we wait for the next read and terminate*)
Vmm_lwt.read_wire s >|= fun _ -> ()
end
@ -182,6 +177,6 @@ open Albatross_cli
let cmd =
Term.(term_result (const jump $ setup_log $ influx)),
Term.info "albatross_console" ~version:"%%VERSION_NUM%%"
Term.info "albatross_console" ~version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

56
daemon/albatross_influx.ml
View file

@ -156,8 +156,6 @@ module P = struct
vm ifd.bridge (String.concat ~sep:"," fields)
end
let my_version = `AV4
let command = ref 1L
let str_of_e = function
@ -199,36 +197,30 @@ let rec read_sock_write_tcp drop c ?fd addr =
safe_close c >|= fun () ->
true
| Ok (hdr, `Data (`Stats_data (ru, mem, vmm, ifs))) ->
let name =
let orig = hdr.Vmm_commands.name
and f = if drop then Name.drop_front else (fun a -> a)
in
let n = f orig in
let safe = if Name.is_root n then orig else n in
Name.to_string safe
in
let ru = P.encode_ru name ru in
let mem = match mem with None -> [] | Some m -> [ P.encode_kinfo_mem name m ] in
let vmm = match vmm with None -> [] | Some vmm -> [ P.encode_vmm name vmm ] in
let taps = List.map (P.encode_if name) ifs in
let out = (String.concat ~sep:"\n" (ru :: mem @ vmm @ taps)) ^ "\n" in
Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ;
begin
if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
Logs.err (fun m -> m "unknown wire protocol version") ;
safe_close fd >>= fun () ->
safe_close c >|= fun () ->
Vmm_lwt.write_raw fd (Bytes.unsafe_of_string out) >>= function
| Ok () ->
Logs.debug (fun m -> m "wrote successfully") ;
read_sock_write_tcp drop c ~fd addr
| Error e ->
Logs.err (fun m -> m "error %s while writing to tcp (%s)"
(str_of_e e) name) ;
safe_close fd >|= fun () ->
false
end else
let name =
let orig = hdr.Vmm_commands.name
and f = if drop then Name.drop_front else (fun a -> a)
in
let n = f orig in
let safe = if Name.is_root n then orig else n in
Name.to_string safe
in
let ru = P.encode_ru name ru in
let mem = match mem with None -> [] | Some m -> [ P.encode_kinfo_mem name m ] in
let vmm = match vmm with None -> [] | Some vmm -> [ P.encode_vmm name vmm ] in
let taps = List.map (P.encode_if name) ifs in
let out = (String.concat ~sep:"\n" (ru :: mem @ vmm @ taps)) ^ "\n" in
Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ;
Vmm_lwt.write_raw fd (Bytes.unsafe_of_string out) >>= function
| Ok () ->
Logs.debug (fun m -> m "wrote successfully") ;
read_sock_write_tcp drop c ~fd addr
| Error e ->
Logs.err (fun m -> m "error %s while writing to tcp (%s)"
(str_of_e e) name) ;
safe_close fd >|= fun () ->
false
end
| Ok wire ->
Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ;
@ -236,7 +228,7 @@ let rec read_sock_write_tcp drop c ?fd addr =
read_sock_write_tcp drop c ?fd addr
let query_sock vm c =
let header = Vmm_commands.{ version = my_version ; sequence = !command ; name = vm } in
let header = Vmm_commands.header ~sequence:!command vm in
command := Int64.succ !command ;
Logs.debug (fun m -> m "%Lu requesting %a via socket" !command Name.pp vm) ;
Vmm_lwt.write_wire c (header, `Command (`Stats_cmd `Stats_subscribe))
@ -306,7 +298,7 @@ let cmd =
`P "$(tname) connects to a albatross stats socket, pulls statistics and pushes them via TCP to influxdb" ]
in
Term.(term_result (const run_client $ setup_log $ influx $ opt_vm_name $ drop_label)),
Term.info "albatross_influx" ~version:"%%VERSION_NUM%%" ~doc ~man
Term.info "albatross_influx" ~version ~doc ~man
let () =
match Term.eval cmd

63
daemon/albatross_log.ml
View file

@ -10,11 +10,10 @@
open Lwt.Infix
let my_version = `AV4
let broadcast prefix wire t =
Lwt_list.fold_left_s (fun t (id, s) ->
Vmm_lwt.write_wire s wire >|= function
Lwt_list.fold_left_s (fun t (id, (version, s)) ->
let hdr = Vmm_commands.header ~version prefix in
Vmm_lwt.write_wire s (hdr, wire) >|= function
| Ok () -> t
| Error `Exception -> Vmm_trie.remove id t)
t (Vmm_trie.collect prefix t)
@ -47,7 +46,7 @@ let write_to_file mvar file =
get_fd () >>= fun fd ->
loop ~log_entry:(Ptime_clock.now (), `Hup) fd
| `Entry log_entry -> Lwt.return log_entry) >>= fun log_entry ->
let data = Vmm_asn.log_to_disk my_version log_entry in
let data = Vmm_asn.log_to_disk log_entry in
Lwt.catch
(fun () ->
write_complete fd data >>= fun () ->
@ -67,7 +66,7 @@ let write_to_file mvar file =
loop fd >|= fun _ ->
()
let send_history s ring id what =
let send_history s version ring id what =
let tst event =
let sub = Vmm_core.Log.name event in
Vmm_core.Name.is_sub ~super:id ~sub
@ -81,7 +80,7 @@ let send_history s ring id what =
Lwt_list.fold_left_s (fun r (ts, event) ->
match r with
| Ok () ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = id } in
let header = Vmm_commands.header ~version id in
Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event)))
| Error e -> Lwt.return (Error e))
(Ok ()) elements
@ -89,17 +88,12 @@ let send_history s ring id what =
let tree = ref Vmm_trie.empty
let handle_data s mvar ring hdr entry =
if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
Logs.warn (fun m -> m "unsupported version") ;
Lwt.return_unit
end else begin
Vmm_lwt.write_wire s (hdr, `Success `Empty) >>= fun _ ->
Vmm_ring.write ring entry ;
Lwt_mvar.put mvar (`Entry entry) >>= fun () ->
let data' = (hdr, `Data (`Log_data entry)) in
broadcast hdr.Vmm_commands.name data' !tree >|= fun tree' ->
tree := tree'
end
Vmm_lwt.write_wire s (hdr, `Success `Empty) >>= fun _ ->
Vmm_ring.write ring entry ;
Lwt_mvar.put mvar (`Entry entry) >>= fun () ->
let data' = `Data (`Log_data entry) in
broadcast hdr.Vmm_commands.name data' !tree >|= fun tree' ->
tree := tree'
let read_data mvar ring s =
let rec loop () =
@ -122,27 +116,24 @@ let handle mvar ring s addr =
| Error _ ->
Logs.err (fun m -> m "error while reading") ;
Lwt.return_unit
| Ok (hdr, `Data (`Log_data entry)) ->
| Ok (hdr, `Data `Log_data entry) ->
handle_data s mvar ring hdr entry >>= fun () ->
read_data mvar ring s
| Ok (hdr, `Command (`Log_cmd lc)) ->
if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
Logs.warn (fun m -> m "unsupported version") ;
Lwt.return_unit
end else begin
match lc with
| `Log_subscribe ts ->
let tree', ret = Vmm_trie.insert hdr.Vmm_commands.name s !tree in
tree := tree' ;
(match ret with
| None -> Lwt.return_unit
| Some s' -> Vmm_lwt.safe_close s') >>= fun () ->
let out = `Success `Empty in
Vmm_lwt.write_wire s (hdr, out) >>= function
| Ok (hdr, `Command `Log_cmd `Log_subscribe ts) ->
let tree', ret =
Vmm_trie.insert hdr.Vmm_commands.name (hdr.Vmm_commands.version, s) !tree
in
tree := tree' ;
(match ret with
| None -> Lwt.return_unit
| Some (_, s') -> Vmm_lwt.safe_close s') >>= fun () ->
let out = `Success `Empty in
begin
Vmm_lwt.write_wire s (hdr, out) >>= function
| Error _ -> Logs.err (fun m -> m "error while sending reply for subscribe") ;
Lwt.return_unit
| Ok () ->
send_history s ring hdr.Vmm_commands.name ts >>= function
send_history s hdr.Vmm_commands.version ring hdr.Vmm_commands.name ts >>= function
| Error _ -> Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit
| Ok () ->
(* command processing is finished, but we leave the socket open
@ -150,7 +141,7 @@ let handle mvar ring s addr =
Vmm_lwt.read_wire s >|= fun _ -> ()
end
| Ok wire ->
Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ;
Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire);
Lwt.return_unit
end >>= fun () ->
Vmm_lwt.safe_close s
@ -201,6 +192,6 @@ let read_only =
let cmd =
Term.(const jump $ setup_log $ file $ read_only $ influx),
Term.info "albatross_log" ~version:"%%VERSION_NUM%%"
Term.info "albatross_log" ~version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

64
daemon/albatrossd.ml
View file

@ -6,11 +6,8 @@ open Vmm_core
open Lwt.Infix
let version = `AV4
let state = ref (Vmm_vmmd.init ())
let state = ref (Vmm_vmmd.init version)
let stub_hdr = Vmm_commands.{ version ; sequence = 0L ; name = Name.root }
let stub_data_out _ = Lwt.return_unit
let create_lock = Lwt_mutex.create ()
@ -18,11 +15,11 @@ let create_lock = Lwt_mutex.create ()
Vmm_vmmd.handle is getting called, and while communicating via log /
console / stat socket communication. *)
let rec create stat_out log_out cons_out data_out hdr name config =
(match Vmm_vmmd.handle_create !state hdr name config with
let rec create stat_out log_out cons_out data_out name config =
(match Vmm_vmmd.handle_create !state name config with
| Error `Msg msg ->
Logs.err (fun m -> m "failed to create %a: %s" Name.pp name msg) ;
Lwt.return (None, (hdr, `Failure msg))
Lwt.return (None, `Failure msg)
| Ok (state', (cons, succ_cont, fail_cont)) ->
state := state';
cons_out "create" cons >>= function
@ -43,7 +40,7 @@ let rec create stat_out log_out cons_out data_out hdr name config =
if should_restart config name r then
Lwt_mutex.with_lock create_lock (fun () ->
create stat_out log_out cons_out stub_data_out
stub_hdr name vm.Unikernel.config)
name vm.Unikernel.config)
else
Lwt.return_unit));
stat_out "setting up stat" stat >>= fun () ->
@ -68,29 +65,28 @@ let rec create stat_out log_out cons_out data_out hdr name config =
let handle log_out cons_out stat_out fd addr =
Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ;
let out wire =
(* TODO should we terminate the connection on write failure? *)
Vmm_lwt.write_wire fd wire >|= fun _ -> ()
in
let rec loop () =
Logs.debug (fun m -> m "now reading") ;
Vmm_lwt.read_wire fd >>= function
| Error _ ->
Logs.err (fun m -> m "error while reading") ;
Lwt.return_unit
| Ok wire ->
Logs.debug (fun m -> m "read %a" Vmm_commands.pp_wire wire) ;
| Ok (hdr, wire) ->
let out wire' =
(* TODO should we terminate the connection on write failure? *)
Vmm_lwt.write_wire fd (hdr, wire') >|= fun _ -> ()
in
Logs.debug (fun m -> m "read %a" Vmm_commands.pp_wire (hdr, wire));
Lwt_mutex.lock create_lock >>= fun () ->
match Vmm_vmmd.handle_command !state wire with
| Error wire -> Lwt_mutex.unlock create_lock; out wire
match Vmm_vmmd.handle_command !state (hdr, wire) with
| Error wire' -> Lwt_mutex.unlock create_lock; out wire'
| Ok (state', next) ->
state := state' ;
match next with
| `Loop wire -> Lwt_mutex.unlock create_lock; out wire >>= loop
| `End wire -> Lwt_mutex.unlock create_lock; out wire
| `Create (hdr, id, vm) ->
create stat_out log_out cons_out out hdr id vm >|= fun () ->
| `Create (id, vm) ->
create stat_out log_out cons_out out id vm >|= fun () ->
Lwt_mutex.unlock create_lock
| `Wait (who, data) ->
let state', task = Vmm_vmmd.register !state who Lwt.task in
@ -98,38 +94,32 @@ let handle log_out cons_out stat_out fd addr =
Lwt_mutex.unlock create_lock;
task >>= fun r ->
out (data r)
| `Wait_and_create (who, (hdr, id, vm)) ->
| `Wait_and_create (who, (id, vm)) ->
let state', task = Vmm_vmmd.register !state who Lwt.task in
state := state';
Lwt_mutex.unlock create_lock;
task >>= fun r ->
Logs.info (fun m -> m "wait returned %a" pp_process_exit r);
Lwt_mutex.with_lock create_lock (fun () ->
create stat_out log_out cons_out out hdr id vm)
create stat_out log_out cons_out out id vm)
in
loop () >>= fun () ->
Vmm_lwt.safe_close fd
let write_reply name fd txt (header, cmd) =
Vmm_lwt.write_wire fd (header, cmd) >>= function
| Error `Exception -> invalid_arg ("exception during " ^ txt ^ " while writing to " ^ name)
let write_reply name fd txt (hdr, cmd) =
Vmm_lwt.write_wire fd (hdr, cmd) >>= function
| Error `Exception ->
invalid_arg ("exception during " ^ txt ^ " while writing to " ^ name)
| Ok () ->
Vmm_lwt.read_wire fd >|= function
| Ok (header', reply) ->
if not Vmm_commands.(version_eq header.version header'.version) then begin
Logs.err (fun m -> m "%s: wrong version (got %a, expected %a) in reply from %s"
txt
Vmm_commands.pp_version header'.Vmm_commands.version
Vmm_commands.pp_version header.Vmm_commands.version
name) ;
invalid_arg "bad version received"
end else if not Vmm_commands.(Int64.equal header.sequence header'.sequence) then begin
| Ok (hdr', reply) ->
if not Vmm_commands.(Int64.equal hdr.sequence hdr'.sequence) then begin
Logs.err (fun m -> m "%s: wrong id %Lu (expected %Lu) in reply from %s"
txt header'.Vmm_commands.sequence header.Vmm_commands.sequence name) ;
txt hdr'.Vmm_commands.sequence hdr.Vmm_commands.sequence name) ;
invalid_arg "wrong sequence number received"
end else begin
Logs.debug (fun m -> m "%s: received valid reply from %s %a (request %a)"
txt name Vmm_commands.pp_wire (header', reply) Vmm_commands.pp_wire (header,cmd)) ;
txt name Vmm_commands.pp_wire (hdr', reply) Vmm_commands.pp_wire (hdr, cmd)) ;
match reply with
| `Success _ -> Ok ()
| `Failure msg ->
@ -187,7 +177,7 @@ let jump _ influx =
in
Lwt_list.iter_s (fun (name, config) ->
create stat_out log_out cons_out stub_data_out stub_hdr name config)
create stat_out log_out cons_out stub_data_out name config)
(Vmm_trie.all old_unikernels) >>= fun () ->
Lwt.catch (fun () ->
@ -209,6 +199,6 @@ open Cmdliner
let cmd =
Term.(const jump $ setup_log $ influx),
Term.info "albatrossd" ~version:"%%VERSION_NUM%%"
Term.info "albatrossd" ~version:Albatross_cli.version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

2
provision/albatross_provision.ml
View file

@ -1,7 +1,5 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
let asn_version = `AV4
let timestamps validity =
let now = Ptime_clock.now () in
match Ptime.add_span now (Ptime.Span.of_int_s (Duration.to_sec validity)) with

10
provision/albatross_provision_ca.ml
View file

@ -40,10 +40,10 @@ let sign_csr dbname cacert key csr days =
(* TODO: check delegation! verify whitelisted commands!? *)
match albatross_extension csr with
| Ok v ->
Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) ->
if not (Vmm_commands.version_eq asn_version version) then
Vmm_asn.of_cert_extension v >>= fun (version, cmd) ->
if not Vmm_commands.(is_current version) then
Logs.warn (fun m -> m "version in request (%a) different from our version %a, using ours"
Vmm_commands.pp_version version Vmm_commands.pp_version asn_version);
Vmm_commands.pp_version version Vmm_commands.pp_version Vmm_commands.current);
let exts, default_days = match cmd with
| `Policy_cmd (`Policy_add _) -> d_exts (), 365
| _ -> l_exts, 1
@ -53,7 +53,7 @@ let sign_csr dbname cacert key csr days =
(* the "false" is here since X509 validation bails on exts marked as
critical (as required), but has no way to supply which extensions
are actually handled by the application / caller *)
let v' = Vmm_asn.cert_extension_to_cstruct (asn_version, cmd) in
let v' = Vmm_asn.to_cert_extension cmd in
let extensions = Extension.(add (Unsupported Vmm_asn.oid) (false, v') exts) in
sign ~dbname extensions issuer key csr (Duration.of_day days)
| Error e -> Error e
@ -157,7 +157,7 @@ let default_cmd =
`P "$(tname) does CA operations (creation, sign, etc.)" ]
in
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "albatross_provision_ca" ~version:"%%VERSION_NUM%%" ~doc ~man
Term.info "albatross_provision_ca" ~version ~doc ~man
let cmds = [ help_cmd ; sign_cmd ; generate_cmd ; (* TODO revoke_cmd *)]

6
provision/albatross_provision_request.ml
View file

@ -5,11 +5,9 @@ open Vmm_asn
open Rresult.R.Infix
let version = `AV4
let csr priv name cmd =
let ext =
let v = cert_extension_to_cstruct (version, cmd) in
let v = to_cert_extension cmd in
X509.Extension.(singleton (Unsupported oid) (false, v))
and name =
[ X509.Distinguished_name.(Relative_distinguished_name.singleton (CN name)) ]
@ -199,7 +197,7 @@ let default_cmd =
`P "$(tname) creates a certificate signing request for Albatross" ]
in
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "albatross_provision_request" ~version:"%%VERSION_NUM%%" ~doc ~man
Term.info "albatross_provision_request" ~version ~doc ~man
let cmds = [ help_cmd ; info_cmd ;
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;

12
src/vmm_asn.ml
View file

@ -455,12 +455,10 @@ let version =
let f data = match data with
| 4 -> `AV4
| 3 -> `AV3
| 2 -> `AV2
| x -> Asn.S.error (`Parse (Printf.sprintf "unknown version number 0x%X" x))
and g = function
| `AV4 -> 4
| `AV3 -> 3
| `AV2 -> 2
in
Asn.S.map f g Asn.S.int
@ -602,8 +600,7 @@ let log_disk_of_cstruct, log_disk_to_cstruct =
let c = Asn.codec Asn.der log_disk in
(Asn.decode c, Asn.encode c)
let log_to_disk version entry =
log_disk_to_cstruct (version, entry)
let log_to_disk entry = log_disk_to_cstruct (current, entry)
let logs_of_disk buf =
let rec next acc buf =
@ -655,12 +652,11 @@ let unikernels =
let unikernels_of_cstruct, unikernels_to_cstruct = projections_of unikernels
type cert_extension = version * t
let cert_extension =
Asn.S.(sequence2
(required ~label:"version" version)
(required ~label:"command" wire_command))
let cert_extension_of_cstruct, cert_extension_to_cstruct =
projections_of cert_extension
let of_cert_extension, to_cert_extension =
let a, b = projections_of cert_extension in
a, (fun d -> b (current, d))

9
src/vmm_asn.mli
View file

@ -17,14 +17,13 @@ val log_entry_to_cstruct : Log.t -> Cstruct.t
val log_entry_of_cstruct : Cstruct.t -> (Log.t, [> `Msg of string ]) result
val log_to_disk : Vmm_commands.version -> Log.t -> Cstruct.t
val log_to_disk : Log.t -> Cstruct.t
val logs_of_disk : Cstruct.t -> Log.t list
type cert_extension = Vmm_commands.version * Vmm_commands.t
val cert_extension_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result
val cert_extension_to_cstruct : cert_extension -> Cstruct.t
val of_cert_extension :
Cstruct.t -> (Vmm_commands.version * Vmm_commands.t, [> `Msg of string ]) result
val to_cert_extension : Vmm_commands.t -> Cstruct.t
val unikernels_to_cstruct : Unikernel.config Vmm_trie.t -> Cstruct.t
val unikernels_of_cstruct : Cstruct.t -> (Unikernel.config Vmm_trie.t, [> `Msg of string ]) result

25
src/vmm_commands.ml
View file

@ -3,22 +3,24 @@
(* the wire protocol *)
open Vmm_core
type version = [ `AV2 | `AV3 | `AV4 ]
type version = [ `AV3 | `AV4 ]
let current = `AV4
let pp_version ppf v =
Fmt.int ppf
(match v with
| `AV4 -> 4
| `AV3 -> 3
| `AV2 -> 2)
| `AV3 -> 3)
let version_eq a b =
match a, b with
| `AV4, `AV4 -> true
| `AV3, `AV3 -> true
| `AV2, `AV2 -> true
| _ -> false
let is_current = version_eq current
type since_count = [ `Since of Ptime.t | `Count of int ]
let pp_since_count ppf = function
@ -124,6 +126,8 @@ type header = {
name : Name.t ;
}
let header ?(version = current) ?(sequence = 0L) name = { version ; sequence ; name }
type success = [
| `Empty
| `String of string
@ -142,11 +146,14 @@ let pp_success ppf = function
| `Unikernels vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Unikernel.pp_config)) ppf vms
| `Block_devices blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks
type wire = header * [
| `Command of t
| `Success of success
| `Failure of string
| `Data of data ]
type res = [
| `Command of t
| `Success of success
| `Failure of string
| `Data of data
]
type wire = header * res
let pp_wire ppf (header, data) =
let name = header.name in

23
src/vmm_commands.mli
View file

@ -3,10 +3,12 @@
open Vmm_core
(** The type of versions of the grammar defined below. *)
type version = [ `AV2 | `AV3 | `AV4 ]
type version = [ `AV3 | `AV4 ]
(** [version_eq a b] is true if [a] and [b] are equal. *)
val version_eq : version -> version -> bool
(** [current] is the current version. *)
val current : version
val is_current : version -> bool
(** [pp_version ppf version] pretty prints [version] onto [ppf]. *)
val pp_version : version Fmt.t
@ -72,6 +74,8 @@ type header = {
name : Name.t ;
}
val header : ?version:version -> ?sequence:int64 -> Name.t -> header
type success = [
| `Empty
| `String of string
@ -80,11 +84,14 @@ type success = [
| `Block_devices of (Name.t * int * bool) list
]
type wire = header * [
| `Command of t
| `Success of success
| `Failure of string
| `Data of data ]
type res = [
| `Command of t
| `Success of success
| `Failure of string
| `Data of data
]
type wire = header * res
val pp_wire : wire Fmt.t

7
src/vmm_lwt.ml
View file

@ -104,10 +104,15 @@ let read_wire s =
Cstruct.hexdump_pp (Cstruct.of_bytes buf)
Cstruct.hexdump_pp (Cstruct.of_bytes b)) ; *)
match Vmm_asn.wire_of_cstruct (Cstruct.of_bytes b) with
| Ok w -> Ok w
| Error (`Msg msg) ->
Logs.err (fun m -> m "error %s while parsing data" msg) ;
Error `Exception
| (Ok (hdr, _)) as w ->
if not Vmm_commands.(is_current hdr.version) then
Logs.warn (fun m -> m "version mismatch, received %a current %a"
Vmm_commands.pp_version hdr.Vmm_commands.version
Vmm_commands.pp_version Vmm_commands.current);
w
end else begin
Lwt.return (Error `Eof)
end

63
src/vmm_vmmd.ml
View file

@ -8,7 +8,6 @@ open Rresult
open R.Infix
type 'a t = {
wire_version : Vmm_commands.version ;
console_counter : int64 ;
stats_counter : int64 ;
log_counter : int64 ;
@ -64,9 +63,8 @@ let register_restart t id create =
| Some _ -> Logs.err (fun m -> m "restart attempted to overwrite waiter"); None
| _ -> Some (register t id create)
let init wire_version =
let init () =
let t = {
wire_version ;
console_counter = 1L ;
stats_counter = 1L ;
log_counter = 1L ;
@ -91,12 +89,12 @@ let init wire_version =
type 'a create =
Vmm_commands.wire *
('a t -> ('a t * Vmm_commands.wire * Vmm_commands.wire * Vmm_commands.wire * Name.t * Unikernel.t, [ `Msg of string ]) result) *
(unit -> Vmm_commands.wire)
('a t -> ('a t * Vmm_commands.wire * Vmm_commands.wire * Vmm_commands.res * Name.t * Unikernel.t, [ `Msg of string ]) result) *
(unit -> Vmm_commands.res)
let log t name event =
let data = (Ptime_clock.now (), event) in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.log_counter ; name } in
let header = Vmm_commands.header ~sequence:t.log_counter name in
let log_counter = Int64.succ t.log_counter in
Logs.debug (fun m -> m "log %a" Log.pp data) ;
({ t with log_counter }, (header, `Data (`Log_data data)))
@ -123,16 +121,16 @@ let setup_stats t name vm =
in
`Stats_add (name, vm.Unikernel.pid, ifs)
in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; name } in
let header = Vmm_commands.header ~sequence:t.stats_counter name in
let t = { t with stats_counter = Int64.succ t.stats_counter } in
t, (header, `Command (`Stats_cmd stat_out))
let remove_stats t name =
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; name } in
let header = Vmm_commands.header ~sequence:t.stats_counter name in
let t = { t with stats_counter = Int64.succ t.stats_counter } in
(t, (header, `Command (`Stats_cmd `Stats_remove)))
let handle_create t hdr name vm_config =
let handle_create t name vm_config =
(match Vmm_resources.find_vm t.resources name with
| Some _ -> Error (`Msg "VM with same name is already running")
| None -> Ok ()) >>= fun () ->
@ -142,7 +140,7 @@ let handle_create t hdr name vm_config =
Vmm_unix.prepare name vm_config >>= fun taps ->
Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
let cons_out =
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.console_counter ; name } in
let header = Vmm_commands.header ~sequence:t.console_counter name in
(header, `Command (`Console_cmd `Console_add))
in
let success t =
@ -170,13 +168,13 @@ let handle_create t hdr name vm_config =
log t name start
in
let t, stat_out = setup_stats t name vm in
(t, stat_out, log_out, (hdr, `Success (`String "created VM")), name, vm)
(t, stat_out, log_out, `Success (`String "created VM"), name, vm)
and fail () =
match Vmm_unix.free_system_resources name taps with
| Ok () -> (hdr, `Failure "could not create VM: console failed")
| Ok () -> `Failure "could not create VM: console failed"
| Error (`Msg msg) ->
let m = "could not create VM: console failed, and also " ^ msg ^ " while cleaning resources" in
(hdr, `Failure m)
`Failure m
in
Ok ({ t with console_counter = Int64.succ t.console_counter },
(cons_out, success, fail))
@ -190,11 +188,11 @@ let handle_shutdown t name vm r =
let t, stat_out = remove_stats t name in
(t, stat_out, log_out)
let handle_policy_cmd t reply id = function
let handle_policy_cmd t id = function
| `Policy_remove ->
Logs.debug (fun m -> m "remove policy %a" Name.pp id) ;
Vmm_resources.remove_policy t.resources id >>= fun resources ->
Ok ({ t with resources }, `End (reply (`String "removed policy")))
Ok ({ t with resources }, `End (`Success (`String "removed policy")))
| `Policy_add policy ->
Logs.debug (fun m -> m "insert policy %a" Name.pp id) ;
let same_policy = match Vmm_resources.find_policy t.resources id with
@ -202,10 +200,10 @@ let handle_policy_cmd t reply id = function
| Some p' -> Policy.equal policy p'
in
if same_policy then
Ok (t, `Loop (reply (`String "no modification of policy")))
Ok (t, `Loop (`Success (`String "no modification of policy")))
else
Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
Ok ({ t with resources }, `Loop (reply (`String "added policy")))
Ok ({ t with resources }, `Loop (`Success (`String "added policy")))
| `Policy_info ->
Logs.debug (fun m -> m "policy %a" Name.pp id) ;
let policies =
@ -218,9 +216,9 @@ let handle_policy_cmd t reply id = function
Logs.debug (fun m -> m "policies: couldn't find %a" Name.pp id) ;
Error (`Msg "policy: not found")
| _ ->
Ok (t, `End (reply (`Policies policies)))
Ok (t, `End (`Success (`Policies policies)))
let handle_unikernel_cmd t reply header id = function
let handle_unikernel_cmd t id = function
| `Unikernel_info ->
Logs.debug (fun m -> m "info %a" Name.pp id) ;
let vms =
@ -233,9 +231,9 @@ let handle_unikernel_cmd t reply header id = function
Logs.debug (fun m -> m "info: couldn't find %a" Name.pp id) ;
Error (`Msg "info: no unikernel found")
| _ ->
Ok (t, `End (reply (`Unikernels vms)))
Ok (t, `End (`Success (`Unikernels vms)))
end
| `Unikernel_create vm_config -> Ok (t, `Create (header, id, vm_config))
| `Unikernel_create vm_config -> Ok (t, `Create (id, vm_config))
| `Unikernel_force_create vm_config ->
begin
let resources =
@ -244,12 +242,12 @@ let handle_unikernel_cmd t reply header id = function
in
Vmm_resources.check_vm resources id vm_config >>= fun () ->
match Vmm_resources.find_vm t.resources id with
| None -> Ok (t, `Create (header, id, vm_config))
| None -> Ok (t, `Create (id, vm_config))
| Some vm ->
(match Vmm_unix.destroy vm with
| exception Unix.Unix_error _ -> ()
| () -> ());
Ok (t, `Wait_and_create (id, (header, id, vm_config)))
Ok (t, `Wait_and_create (id, (id, vm_config)))
end
| `Unikernel_destroy ->
match Vmm_resources.find_vm t.resources id with
@ -263,11 +261,11 @@ let handle_unikernel_cmd t reply header id = function
in
let s ex =
let data = Fmt.strf "%a %s %a" Name.pp id answer pp_process_exit ex in
reply (`String data)
`Success (`String data)
in
Ok (t, `Wait (id, s))
let handle_block_cmd t reply id = function
let handle_block_cmd t id = function
| `Block_remove ->
Logs.debug (fun m -> m "removing block %a" Name.pp id) ;
begin match Vmm_resources.find_block t.resources id with
@ -276,7 +274,7 @@ let handle_block_cmd t reply id = function
| Some (_, false) ->
Vmm_unix.destroy_block id >>= fun () ->
Vmm_resources.remove_block t.resources id >>= fun resources ->
Ok ({ t with resources }, `End (reply (`String "removed block")))
Ok ({ t with resources }, `End (`Success (`String "removed block")))
end
| `Block_add size ->
begin
@ -287,7 +285,7 @@ let handle_block_cmd t reply id = function
Vmm_resources.check_block t.resources id size >>= fun () ->
Vmm_unix.create_block id size >>= fun () ->
Vmm_resources.insert_block t.resources id size >>= fun resources ->
Ok ({ t with resources }, `Loop (reply (`String "added block device")))
Ok ({ t with resources }, `Loop (`Success (`String "added block device")))
end
| `Block_info ->
Logs.debug (fun m -> m "block %a" Name.pp id) ;
@ -301,22 +299,21 @@ let handle_block_cmd t reply id = function
Logs.debug (fun m -> m "block: couldn't find %a" Name.pp id) ;
Error (`Msg "block: not found")
| _ ->
Ok (t, `End (reply (`Block_devices blocks)))
Ok (t, `End (`Success (`Block_devices blocks)))
let handle_command t (header, payload) =
let msg_to_err = function
| Ok x -> Ok x
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while processing command: %s" msg) ;
Error (header, `Failure msg)
and reply x = (header, `Success x)
Error (`Failure msg)
and id = header.Vmm_commands.name
in
msg_to_err (
match payload with
| `Command (`Policy_cmd pc) -> handle_policy_cmd t reply id pc
| `Command (`Unikernel_cmd vc) -> handle_unikernel_cmd t reply header id vc
| `Command (`Block_cmd bc) -> handle_block_cmd t reply id bc
| `Command (`Policy_cmd pc) -> handle_policy_cmd t id pc
| `Command (`Unikernel_cmd vc) -> handle_unikernel_cmd t id vc
| `Command (`Block_cmd bc) -> handle_block_cmd t id bc
| _ ->
Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ;
Error (`Msg "unknown command"))

22
src/vmm_vmmd.mli
View file

@ -4,7 +4,7 @@ open Vmm_core
type 'a t
val init : Vmm_commands.version -> 'a t
val init : unit -> 'a t
val waiter : 'a t -> Name.t -> 'a t * 'a option
@ -14,25 +14,23 @@ val register_restart : 'a t -> Name.t -> (unit -> 'b * 'a) -> ('a t * 'b) option
type 'a create =
Vmm_commands.wire *
('a t -> ('a t * Vmm_commands.wire * Vmm_commands.wire * Vmm_commands.wire *
Name.t * Unikernel.t, [ `Msg of string ]) result) *
(unit -> Vmm_commands.wire)
('a t -> ('a t * Vmm_commands.wire * Vmm_commands.wire * Vmm_commands.res * Name.t * Unikernel.t, [ `Msg of string ]) result) *
(unit -> Vmm_commands.res)
val handle_shutdown : 'a t -> Name.t -> Unikernel.t ->
[ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * Vmm_commands.wire * Vmm_commands.wire
val handle_create : 'a t -> Vmm_commands.header ->
Name.t -> Unikernel.config ->
val handle_create : 'a t -> Name.t -> Unikernel.config ->
('a t * 'a create, [> `Msg of string ]) result
val handle_command : 'a t -> Vmm_commands.wire ->
('a t *
[ `Create of Vmm_commands.header * Name.t * Unikernel.config
| `Loop of Vmm_commands.wire
| `End of Vmm_commands.wire
| `Wait of Name.t * (process_exit -> Vmm_commands.wire)
| `Wait_and_create of Name.t * (Vmm_commands.header * Name.t * Unikernel.config) ],
Vmm_commands.wire) result
[ `Create of Name.t * Unikernel.config
| `Loop of Vmm_commands.res
| `End of Vmm_commands.res
| `Wait of Name.t * (process_exit -> Vmm_commands.res)
| `Wait_and_create of Name.t * (Name.t * Unikernel.config) ],
Vmm_commands.res) result
val killall : 'a t -> bool

2
stats/albatross_stat_client.ml
View file

@ -69,6 +69,6 @@ let vmname =
let cmd =
Term.(term_result (const jump $ setup_log $ pid $ vmname $ interval)),
Term.info "albatross_stat_client" ~version:"%%VERSION_NUM%%"
Term.info "albatross_stat_client" ~version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

4
stats/albatross_stats.ml
View file

@ -40,7 +40,7 @@ let handle s addr =
Vmm_lwt.write_wire s (fst wire, `Success (`String out)) >>= function
| Ok () ->
(match close with
| Some s' ->
| Some (_, s') ->
Vmm_lwt.safe_close s' >>= fun () ->
(* read the next *)
loop ()
@ -90,6 +90,6 @@ let interval =
let cmd =
Term.(term_result (const jump $ setup_log $ interval $ influx)),
Term.info "albatross_stats" ~version:"%%VERSION_NUM%%"
Term.info "albatross_stats" ~version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

52
stats/albatross_stats_pure.ml
View file

@ -17,8 +17,6 @@ external vmmapi_close : vmctx -> unit = "vmmanage_vmmapi_close"
external vmmapi_statnames : vmctx -> string list = "vmmanage_vmmapi_statnames"
external vmmapi_stats : vmctx -> int64 list = "vmmanage_vmmapi_stats"
let my_version = `AV4
let descr = ref []
type 'a t = {
@ -139,11 +137,11 @@ let tick t =
ru', mem, vmm', ifd
in
let outs =
List.fold_left (fun out (id, socket) ->
List.fold_left (fun out (id, (version, socket)) ->
match Vmm_core.Name.drop_super ~super:id ~sub:vmid with
| None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.Name.pp id Vmm_core.Name.pp vmid) ; out
| Some real_id ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = real_id } in
let header = Vmm_commands.header ~version real_id in
((socket, id, (header, `Data (`Stats_data stats))) :: out))
out xs
in
@ -178,28 +176,24 @@ let add_pid t vmid vmmdev pid nics =
assert (ret = None) ;
Ok { t with pid_nic ; vmid_pid }
let handle t socket (header, wire) =
if not (Vmm_commands.version_eq my_version header.Vmm_commands.version) then begin
Logs.err (fun m -> m "invalid version %a (mine is %a)"
Vmm_commands.pp_version header.Vmm_commands.version
Vmm_commands.pp_version my_version) ;
Error (`Msg "cannot handle version")
end else
match wire with
| `Command (`Stats_cmd cmd) ->
begin
let id = header.Vmm_commands.name in
match cmd with
| `Stats_add (vmmdev, pid, taps) ->
add_pid t id vmmdev pid taps >>= fun t ->
Ok (t, None, "added")
| `Stats_remove ->
let t = remove_vmid t id in
Ok (t, None, "removed")
| `Stats_subscribe ->
let name_sockets, close = Vmm_trie.insert id socket t.name_sockets in
Ok ({ t with name_sockets }, close, "subscribed")
end
| _ ->
Logs.err (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire (header, wire)) ;
Error (`Msg "unexpected command")
let handle t socket (hdr, wire) =
match wire with
| `Command (`Stats_cmd cmd) ->
begin
let id = hdr.Vmm_commands.name in
match cmd with
| `Stats_add (vmmdev, pid, taps) ->
add_pid t id vmmdev pid taps >>= fun t ->
Ok (t, None, "added")
| `Stats_remove ->
let t = remove_vmid t id in
Ok (t, None, "removed")
| `Stats_subscribe ->
let name_sockets, close =
Vmm_trie.insert id (hdr.Vmm_commands.version, socket) t.name_sockets
in
Ok ({ t with name_sockets }, close, "subscribed")
end
| _ ->
Logs.err (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire (hdr, wire)) ;
Error (`Msg "unexpected command")

143
tls/albatross_tls_common.ml
View file

@ -2,8 +2,6 @@
open Lwt.Infix
let my_version = `AV4
let command = ref 0L
let tls_config cacert cert priv_key =
@ -32,92 +30,87 @@ let client_auth ca tls =
| `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain
| `Error -> Lwt.fail_with "error while getting epoch")
let read fd tls =
let read version 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) ;
| Error _ -> Lwt.return (`Failure "exception while reading from fd")
| Ok (hdr, pay) ->
Logs.debug (fun m -> m "read proxying %a" Vmm_commands.pp_wire (hdr, pay)) ;
let wire = { hdr with version }, pay in
Vmm_tls_lwt.write_tls tls wire >>= function
| Ok () -> loop ()
| Error `Exception -> Lwt.return (Error (`Msg "exception"))
| Error `Exception -> Lwt.return (`Failure "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 process fd =
Vmm_lwt.read_wire fd >|= function
| Error _ -> `Failure "error reading from fd"
| Ok (hdr, pay) ->
Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire (hdr, pay));
pay
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
let sockaddr = Lwt_unix.ADDR_UNIX (Vmm_core.socket_path sock) in
Vmm_lwt.connect Lwt_unix.PF_UNIX sockaddr >>= function
| None ->
let err =
Rresult.R.error_msgf "failed to connect to %a" Vmm_lwt.pp_sockaddr sockaddr
in
Lwt.return err
| Some 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"))
match Vmm_tls.handle chain with
| Error `Msg msg ->
Logs.err (fun m -> m "failed to handle TLS connection %s" msg);
Lwt.return_unit
| Ok (name, policies, version, cmd) ->
begin
let sock, next = Vmm_commands.endpoint cmd in
let sockaddr = Lwt_unix.ADDR_UNIX (Vmm_core.socket_path sock) in
Vmm_lwt.connect Lwt_unix.PF_UNIX sockaddr >>= function
| None ->
Logs.warn (fun m -> m "failed to connect to %a" Vmm_lwt.pp_sockaddr sockaddr);
Lwt.return (`Failure "couldn't reach service")
| Some 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 () ->
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 ->
Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.Name.pp id Vmm_core.Policy.pp policy) ;
let header = Vmm_commands.header ~sequence:!command 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 ->
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) ->
Vmm_lwt.safe_close fd >|= fun () ->
res
Logs.warn (fun m -> m "error while applying policies %s" msg) ;
`Failure msg
| Ok () ->
let wire =
let header = Vmm_commands.header ~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 () ->
`Failure "couldn't write unikernel to VMMD"
| Ok () ->
(match next with
| `Read -> read version fd tls
| `End -> process fd) >>= fun res ->
Vmm_lwt.safe_close fd >|= fun () ->
res
end >>= fun reply ->
Vmm_tls_lwt.write_tls tls
(Vmm_commands.header ~version name, reply) >|= fun _ ->
()
open Cmdliner

6
tls/albatross_tls_endpoint.ml
View file

@ -30,9 +30,7 @@ let jump _ cacert cert priv_key port =
Lwt.async (fun () ->
Lwt.catch
(fun () ->
(handle ca t >|= function
| Error (`Msg msg) -> Logs.err (fun m -> m "error in handle %s" msg)
| Ok () -> ()) >>= fun () ->
handle ca t >>= fun () ->
Vmm_tls_lwt.close t)
(fun e ->
Logs.err (fun m -> m "error while handle() %s" (Printexc.to_string e)) ;
@ -60,6 +58,6 @@ let port =
let cmd =
Term.(const jump $ setup_log $ cacert $ cert $ key $ port),
Term.info "albatross_tls_endpoint" ~version:"%%VERSION_NUM%%"
Term.info "albatross_tls_endpoint" ~version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

6
tls/albatross_tls_inetd.ml
View file

@ -16,9 +16,7 @@ let jump cacert cert priv_key =
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 () ->
handle ca t >>= fun () ->
Vmm_tls_lwt.close t)
(fun e ->
Logs.err (fun m -> m "error while handle() %s" (Printexc.to_string e)) ;
@ -28,6 +26,6 @@ open Cmdliner
let cmd =
Term.(const jump $ cacert $ cert $ key),
Term.info "albatross_tls_inetd" ~version:"%%VERSION_NUM%%"
Term.info "albatross_tls_inetd" ~version:Albatross_cli.version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

45
tls/vmm_tls.ml
View file

@ -11,7 +11,7 @@ let cert_name cert =
| Some (_, data) ->
match X509.(Distinguished_name.common_name (Certificate.subject cert)) with
| Some name -> Ok (Some name)
| None -> match Vmm_asn.cert_extension_of_cstruct data with
| None -> match Vmm_asn.of_cert_extension data with
| Error (`Msg _) -> Error (`Msg "couldn't parse albatross extension")
| Ok (_, `Policy_cmd pc) ->
begin match pc with
@ -44,36 +44,33 @@ let separate_chain = function
| [ leaf ] -> Ok (leaf, [])
| leaf :: xs -> Ok (leaf, List.rev xs)
let wire_command_of_cert version cert =
let wire_command_of_cert cert =
match Extension.(find (Unsupported Vmm_asn.oid) (Certificate.extensions cert)) with
| None -> Error `Not_present
| Some (_, data) ->
Vmm_asn.cert_extension_of_cstruct data >>= fun (v, wire) ->
if not (Vmm_commands.version_eq v version) then
Error (`Version v)
else
Ok wire
Vmm_asn.of_cert_extension data >>= fun (v, wire) ->
if not Vmm_commands.(is_current v) then
Logs.warn (fun m -> m "version mismatch, received %a current %a"
Vmm_commands.pp_version v
Vmm_commands.pp_version Vmm_commands.current);
Ok (v, wire)
let extract_policies version chain =
let extract_policies chain =
List.fold_left (fun acc cert ->
match acc, wire_command_of_cert version cert with
match acc, wire_command_of_cert cert with
| Error e, _ -> Error e
| Ok acc, Error `Not_present -> Ok acc
| Ok _, Error (`Msg msg) -> Error (`Msg msg)
| Ok _, Error (`Version received) ->
R.error_msgf "unexpected version %a (expected %a)"
Vmm_commands.pp_version received
Vmm_commands.pp_version version
| Ok (prefix, acc), Ok (`Policy_cmd (`Policy_add p)) ->
| Ok (prefix, acc), Ok (_, `Policy_cmd `Policy_add p) ->
(cert_name cert >>= function
| None -> Ok prefix
| Some x -> Vmm_core.Name.prepend x prefix) >>| fun name ->
(name, (name, p) :: acc)
| _, Ok wire ->
R.error_msgf "unexpected wire %a" Vmm_commands.pp wire)
R.error_msgf "unexpected wire %a" Vmm_commands.pp (snd wire))
(Ok (Vmm_core.Name.root, [])) chain
let handle version chain =
let handle chain =
(if List.length chain < 10 then
Ok ()
else
@ -90,22 +87,18 @@ let handle version chain =
Logs.debug (fun m -> m "name is %a leaf is %a, chain %a"
Vmm_core.Name.pp name Certificate.pp leaf
Fmt.(list ~sep:(unit " -> ") Certificate.pp) rest);
extract_policies version rest >>= fun (_, policies) ->
extract_policies rest >>= fun (_, policies) ->
(* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)
match wire_command_of_cert version leaf with
| Error (`Msg p) -> Error (`Msg p)
| Error (`Not_present) ->
match wire_command_of_cert leaf with
| Error `Msg p -> Error (`Msg p)
| Error `Not_present ->
Error (`Msg "leaf certificate does not contain an albatross extension")
| Error (`Version received) ->
R.error_msgf "unexpected version %a (expected %a)"
Vmm_commands.pp_version received
Vmm_commands.pp_version version
| Ok wire ->
| Ok (v, wire) ->
(* we only allow some commands via certificate *)
match wire with
| `Console_cmd (`Console_subscribe _)
| `Stats_cmd `Stats_subscribe
| `Log_cmd (`Log_subscribe _)
| `Unikernel_cmd _
| `Policy_cmd `Policy_info -> Ok (name, policies, wire)
| `Policy_cmd `Policy_info -> Ok (name, policies, v, wire)
| _ -> Error (`Msg "unexpected command")

9
tls/vmm_tls.mli
View file

@ -1,10 +1,9 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
val wire_command_of_cert : Vmm_commands.version -> X509.Certificate.t ->
(Vmm_commands.t, [> `Msg of string | `Not_present | `Version of Vmm_commands.version ]) result
val wire_command_of_cert : X509.Certificate.t ->
(Vmm_commands.version * Vmm_commands.t, [> `Msg of string | `Not_present ]) result
val handle :
Vmm_commands.version ->
X509.Certificate.t list ->
(Vmm_core.Name.t * (Vmm_core.Name.t * Vmm_core.Policy.t) list * Vmm_commands.t,
[> `Msg of string ]) Result.result
(Vmm_core.Name.t * (Vmm_core.Name.t * Vmm_core.Policy.t) list * Vmm_commands.version * Vmm_commands.t,
[> `Msg of string ]) result

7
tls/vmm_tls_lwt.ml
View file

@ -40,10 +40,15 @@ let read_tls t =
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
| (Ok (hdr, _)) as w ->
if not Vmm_commands.(is_current hdr.version) then
Logs.warn (fun m -> m "version mismatch, received %a current %a"
Vmm_commands.pp_version hdr.Vmm_commands.version
Vmm_commands.pp_version Vmm_commands.current);
w
else
Lwt.return (Error `Eof)