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

client: provide exit code depending on failure 

fixes #31, piggy-backs on the 'a in type 'a result = [ `Ok of 'a | ... ]
the code uses Ok Albatross_cli.Remote_command_failed to signal "exit 123"
This commit is contained in:
Hannes Mehnert 2020-04-25 16:28:48 +02:00
parent 9bc4d478d5
commit 0932d06c41
7 changed files with 199 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
client/albatross_client_bistro.ml
View File

@ -10,11 +10,13 @@ let read fd =
Vmm_tls_lwt.read_tls fd >>= function
| Error `Eof ->
Logs.debug (fun m -> m "eof from server");
Lwt.return (Ok ())
| Error _ -> Lwt.return (Error (`Msg ("read failure")))
Lwt.return Albatross_cli.Success
| Error _ ->
Lwt.return Albatross_cli.Communication_failed
| Ok wire ->
Albatross_cli.print_result wire ;
loop ()
match Albatross_cli.output_result wire with
| Ok () -> loop ()
| Error e -> Lwt.return e
in
loop ()
@ -73,7 +75,7 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
Rresult.R.error_to_msg ~pp_error:X509.Validation.pp_signature_error
(Signing_request.sign csr ~valid_from ~valid_until ~extensions key issuer)
with
| Error _ as e -> Lwt.return e
| Error `Msg m -> Lwt.fail_with m
| Ok mycert ->
let certificates = `Single ([ mycert ; cert ], tmpkey) in
X509_lwt.authenticator (`Ca_file ca) >>= fun authenticator ->
@ -82,19 +84,20 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
let sockaddr = Lwt_unix.ADDR_INET (host_inet_addr, port) in
Vmm_lwt.connect host_entry.h_addrtype sockaddr >>= function
| None ->
let err =
Rresult.R.error_msgf "connection failed to %a" Vmm_lwt.pp_sockaddr sockaddr
in
Lwt.return err
Logs.err (fun m -> m "connection failed to %a"
Vmm_lwt.pp_sockaddr sockaddr);
Lwt.return Albatross_cli.Connect_failed
| Some fd ->
Logs.debug (fun m -> m "connecting to remote host") ;
Logs.debug (fun m -> m "connected to remote host") ;
(* reneg true to allow re-negotiation over the server-authenticated TLS
channel (to transport client certificate encrypted), once TLS 1.3 is in
(and required) be removed! *)
let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
Tls_lwt.Unix.client_of_fd client (* TODO ~host *) fd >>= fun t ->
Logs.debug (fun m -> m "finished tls handshake") ;
read t
Lwt.catch (fun () ->
Tls_lwt.Unix.client_of_fd client (* TODO ~host *) fd >>= fun t ->
Logs.debug (fun m -> m "finished tls handshake") ;
read t)
(fun exn -> Lwt.return (Albatross_tls_common.classify_tls_error exn))
let jump endp cert key ca name cmd =
Lwt_main.run (handle endp cert key ca name cmd)
@ -118,7 +121,7 @@ let destroy _ endp cert key ca name =
let create _ endp cert key ca force name image cpuid memory argv block network compression restart_on_fail exit_code =
match Albatross_cli.create_vm force image cpuid memory argv block network compression restart_on_fail exit_code with
| Ok cmd -> jump endp cert key ca name (`Unikernel_cmd cmd)
| Error (`Msg msg) -> Error (`Msg msg)
| Error (`Msg msg) -> failwith msg
let console _ endp cert key ca name since count =
jump endp cert key ca name (`Console_cmd (`Console_subscribe (Albatross_cli.since_count since count)))
@ -141,11 +144,16 @@ let block_destroy _ endp cert key ca block_name =
let help _ _ man_format cmds = function
| None -> `Help (`Pager, None)
| Some t when List.mem t cmds -> `Help (man_format, Some t)
| Some _ -> List.iter print_endline cmds; `Ok ()
| Some x ->
print_endline ("unknown command '" ^ x ^ "', available commands:");
List.iter print_endline cmds;
`Ok Albatross_cli.Cli_failed
open Cmdliner
open Albatross_cli
let exits = auth_exits @ exits
let server_ca =
let doc = "The certificate authority used to verify the remote server." in
Arg.(value & opt string "cacert.pem" & info [ "server-ca" ] ~doc)
@ -168,8 +176,8 @@ let destroy_cmd =
[`S "DESCRIPTION";
`P "Destroy a virtual machine."]
in
Term.(term_result (const destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name)),
Term.info "destroy" ~doc ~man
Term.(const destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name),
Term.info "destroy" ~doc ~man ~exits
let remove_policy_cmd =
let doc = "removes a policy" in
@ -177,8 +185,8 @@ let remove_policy_cmd =
[`S "DESCRIPTION";
`P "Removes a policy."]
in
Term.(term_result (const remove_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
Term.info "remove_policy" ~doc ~man
Term.(const remove_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name),
Term.info "remove_policy" ~doc ~man ~exits
let info_cmd =
let doc = "information about VMs" in
@ -186,8 +194,8 @@ let info_cmd =
[`S "DESCRIPTION";
`P "Shows information about VMs."]
in
Term.(term_result (const info_ $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
Term.info "info" ~doc ~man
Term.(const info_ $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name),
Term.info "info" ~doc ~man ~exits
let policy_cmd =
let doc = "active policies" in
@ -195,8 +203,8 @@ let policy_cmd =
[`S "DESCRIPTION";
`P "Shows information about policies."]
in
Term.(term_result (const info_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
Term.info "policy" ~doc ~man
Term.(const info_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name),
Term.info "policy" ~doc ~man ~exits
let add_policy_cmd =
let doc = "Add a policy" in
@ -204,8 +212,8 @@ let add_policy_cmd =
[`S "DESCRIPTION";
`P "Adds a policy."]
in
Term.(term_result (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)),
Term.info "add_policy" ~doc ~man
Term.(const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge),
Term.info "add_policy" ~doc ~man ~exits
let create_cmd =
let doc = "creates a virtual machine" in
@ -213,8 +221,8 @@ let create_cmd =
[`S "DESCRIPTION";
`P "Creates a virtual machine."]
in
Term.(term_result (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level 9 $ restart_on_fail $ exit_code)),
Term.info "create" ~doc ~man
Term.(const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level 9 $ restart_on_fail $ exit_code),
Term.info "create" ~doc ~man ~exits
let console_cmd =
let doc = "console of a VM" in
@ -222,8 +230,8 @@ let console_cmd =
[`S "DESCRIPTION";
`P "Shows console output of a VM."]
in
Term.(term_result (const console $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ since $ count)),
Term.info "console" ~doc ~man
Term.(const console $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ since $ count),
Term.info "console" ~doc ~man ~exits
let stats_cmd =
let doc = "statistics of VMs" in
@ -231,8 +239,8 @@ let stats_cmd =
[`S "DESCRIPTION";
`P "Shows statistics of VMs."]
in
Term.(term_result (const stats $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
Term.info "stats" ~doc ~man
Term.(const stats $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name),
Term.info "stats" ~doc ~man ~exits
let log_cmd =
let doc = "Event log" in
@ -240,8 +248,8 @@ let log_cmd =
[`S "DESCRIPTION";
`P "Shows event log of VM."]
in
Term.(term_result (const event_log $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ since $ count)),
Term.info "log" ~doc ~man
Term.(const event_log $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ since $ count),
Term.info "log" ~doc ~man ~exits
let block_info_cmd =
let doc = "Information about block devices" in
@ -249,8 +257,8 @@ let block_info_cmd =
[`S "DESCRIPTION";
`P "Block device information."]
in
Term.(term_result (const block_info $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_block_name)),
Term.info "block" ~doc ~man
Term.(const block_info $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_block_name),
Term.info "block" ~doc ~man ~exits
let block_create_cmd =
let doc = "Create a block device" in
@ -258,8 +266,8 @@ let block_create_cmd =
[`S "DESCRIPTION";
`P "Creation of a block device."]
in
Term.(term_result (const block_create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ block_name $ block_size)),
Term.info "create_block" ~doc ~man
Term.(const block_create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ block_name $ block_size),
Term.info "create_block" ~doc ~man ~exits
let block_destroy_cmd =
let doc = "Destroys a block device" in
@ -267,8 +275,8 @@ let block_destroy_cmd =
[`S "DESCRIPTION";
`P "Destroys a block device."]
in
Term.(term_result (const block_destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ block_name)),
Term.info "destroy_block" ~doc ~man
Term.(const block_destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ block_name),
Term.info "destroy_block" ~doc ~man ~exits
let help_cmd =
let topic =
@ -281,7 +289,7 @@ let help_cmd =
`P "Prints help about conex commands and subcommands"]
in
Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ topic)),
Term.info "help" ~doc ~man
Term.info "help" ~doc ~man ~exits
let default_cmd =
let doc = "Albatross client and go to bistro" in
@ -290,7 +298,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 ~doc ~man
Term.info "albatross_client_bistro" ~version ~doc ~man ~exits
let cmds = [ help_cmd ; info_cmd ;
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
@ -299,5 +307,6 @@ let cmds = [ help_cmd ; info_cmd ;
console_cmd ; stats_cmd ; log_cmd ]
let () =
match Term.eval_choice default_cmd cmds
with `Ok () -> exit 0 | _ -> exit 1
match Term.eval_choice default_cmd cmds with
| `Ok x -> exit (exit_status_to_int x)
| y -> exit (Term.exit_status_of_result y)

62
client/albatross_client_local.ml
View File

@ -8,14 +8,14 @@ let socket t = function
let process fd =
Vmm_lwt.read_wire fd >|= function
| Error _ -> Error ()
| Ok wire -> Ok (Albatross_cli.print_result wire)
| Error _ -> Error Albatross_cli.Communication_failed
| Ok wire -> Albatross_cli.output_result wire
let read fd =
(* now we busy read and process output *)
let rec loop () =
process fd >>= function
| Error _ -> Lwt.return ()
| Error _ as e -> Lwt.return e
| Ok () -> loop ()
in
loop ()
@ -25,20 +25,20 @@ let handle opt_socket name (cmd : Vmm_commands.t) =
let sockaddr = Lwt_unix.ADDR_UNIX (socket sock opt_socket) in
Vmm_lwt.connect Lwt_unix.PF_UNIX sockaddr >>= function
| None ->
let err =
Rresult.R.error_msgf "couldn't connect to %a" Vmm_lwt.pp_sockaddr sockaddr
in
Lwt.return err
Logs.err (fun m -> m "couldn't connect to %a"
Vmm_lwt.pp_sockaddr sockaddr);
Lwt.return (Ok Albatross_cli.Connect_failed)
| Some fd ->
let header = Vmm_commands.header name in
Vmm_lwt.write_wire fd (header, `Command cmd) >>= function
| Error `Exception -> Lwt.return (Error (`Msg "exception"))
| Error `Exception ->
Lwt.return (Ok Albatross_cli.Communication_failed)
| Ok () ->
(match next with
| `Read -> read fd
| `End -> process fd >|= ignore) >>= fun () ->
| `End -> process fd) >>= fun r ->
Vmm_lwt.safe_close fd >|= fun () ->
Ok ()
Albatross_cli.exit_status r
let jump opt_socket name cmd tmpdir =
Albatross_cli.set_tmpdir tmpdir;
@ -92,7 +92,10 @@ let block_destroy _ opt_socket block_name =
let help _ _ man_format cmds = function
| None -> `Help (`Pager, None)
| Some t when List.mem t cmds -> `Help (man_format, Some t)
| Some _ -> List.iter print_endline cmds; `Ok ()
| Some x ->
print_endline ("unknown command '" ^ x ^ "', available commands:");
List.iter print_endline cmds;
`Ok Albatross_cli.Cli_failed
open Cmdliner
open Albatross_cli
@ -108,7 +111,7 @@ let destroy_cmd =
`P "Destroy a virtual machine."]
in
Term.(term_result (const destroy $ setup_log $ socket $ vm_name $ tmpdir)),
Term.info "destroy" ~doc ~man
Term.info "destroy" ~doc ~man ~exits
let remove_policy_cmd =
let doc = "removes a policy" in
@ -117,7 +120,7 @@ let remove_policy_cmd =
`P "Removes a policy."]
in
Term.(term_result (const remove_policy $ setup_log $ socket $ opt_vm_name $ tmpdir)),
Term.info "remove_policy" ~doc ~man
Term.info "remove_policy" ~doc ~man ~exits
let info_cmd =
let doc = "information about VMs" in
@ -126,7 +129,7 @@ let info_cmd =
`P "Shows information about VMs."]
in
Term.(term_result (const info_ $ setup_log $ socket $ opt_vm_name $ tmpdir)),
Term.info "info" ~doc ~man
Term.info "info" ~doc ~man ~exits
let policy_cmd =
let doc = "active policies" in
@ -135,7 +138,7 @@ let policy_cmd =
`P "Shows information about policies."]
in
Term.(term_result (const info_policy $ setup_log $ socket $ opt_vm_name $ tmpdir)),
Term.info "policy" ~doc ~man
Term.info "policy" ~doc ~man ~exits
let add_policy_cmd =
let doc = "Add a policy" in
@ -144,7 +147,7 @@ let add_policy_cmd =
`P "Adds a policy."]
in
Term.(term_result (const add_policy $ setup_log $ socket $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge $ tmpdir)),
Term.info "add_policy" ~doc ~man
Term.info "add_policy" ~doc ~man ~exits
let create_cmd =
let doc = "creates a virtual machine" in
@ -153,7 +156,7 @@ let create_cmd =
`P "Creates a virtual machine."]
in
Term.(term_result (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level 0 $ restart_on_fail $ exit_code $ tmpdir)),
Term.info "create" ~doc ~man
Term.info "create" ~doc ~man ~exits
let console_cmd =
let doc = "console of a VM" in
@ -162,7 +165,7 @@ let console_cmd =
`P "Shows console output of a VM."]
in
Term.(term_result (const console $ setup_log $ socket $ vm_name $ since $ count $ tmpdir)),
Term.info "console" ~doc ~man
Term.info "console" ~doc ~man ~exits
let stats_subscribe_cmd =
let doc = "statistics of VMs" in
@ -171,7 +174,7 @@ let stats_subscribe_cmd =
`P "Shows statistics of VMs."]
in
Term.(term_result (const stats_subscribe $ setup_log $ socket $ opt_vm_name $ tmpdir)),
Term.info "stats" ~doc ~man
Term.info "stats" ~doc ~man ~exits
let stats_remove_cmd =
let doc = "remove statistics of VM" in
@ -180,7 +183,7 @@ let stats_remove_cmd =
`P "Removes statistics of VM."]
in
Term.(term_result (const stats_remove $ setup_log $ socket $ opt_vm_name $ tmpdir)),
Term.info "stats_remove" ~doc ~man
Term.info "stats_remove" ~doc ~man ~exits
let stats_add_cmd =
let doc = "Add VM to statistics gathering" in
@ -189,7 +192,7 @@ let stats_add_cmd =
`P "Add VM to statistics gathering."]
in
Term.(term_result (const stats_add $ setup_log $ socket $ opt_vm_name $ vmm_dev_req0 $ pid_req1 $ bridge_taps $ tmpdir)),
Term.info "stats_add" ~doc ~man
Term.info "stats_add" ~doc ~man ~exits
let log_cmd =
let doc = "Event log" in
@ -198,7 +201,7 @@ let log_cmd =
`P "Shows event log of VM."]
in
Term.(term_result (const event_log $ setup_log $ socket $ opt_vm_name $ since $ count $ tmpdir)),
Term.info "log" ~doc ~man
Term.info "log" ~doc ~man ~exits
let block_info_cmd =
let doc = "Information about block devices" in
@ -207,7 +210,7 @@ let block_info_cmd =
`P "Block device information."]
in
Term.(term_result (const block_info $ setup_log $ socket $ opt_block_name $ tmpdir)),
Term.info "block" ~doc ~man
Term.info "block" ~doc ~man ~exits
let block_create_cmd =
let doc = "Create a block device" in
@ -216,7 +219,7 @@ let block_create_cmd =
`P "Creation of a block device."]
in
Term.(term_result (const block_create $ setup_log $ socket $ block_name $ block_size $ tmpdir)),
Term.info "create_block" ~doc ~man
Term.info "create_block" ~doc ~man ~exits
let block_destroy_cmd =
let doc = "Destroys a block device" in
@ -225,7 +228,7 @@ let block_destroy_cmd =
`P "Destroys a block device."]
in
Term.(term_result (const block_destroy $ setup_log $ socket $ block_name $ tmpdir)),
Term.info "destroy_block" ~doc ~man
Term.info "destroy_block" ~doc ~man ~exits
let help_cmd =
let topic =
@ -238,7 +241,7 @@ let help_cmd =
`P "Prints help about albatross local client commands and subcommands"]
in
Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ topic)),
Term.info "help" ~doc ~man
Term.info "help" ~doc ~man ~exits
let default_cmd =
let doc = "VMM local client" in
@ -247,7 +250,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 ~doc ~man
Term.info "albatross_client_local" ~version ~doc ~man ~exits
let cmds = [ help_cmd ; info_cmd ;
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
@ -257,5 +260,6 @@ let cmds = [ help_cmd ; info_cmd ;
stats_subscribe_cmd ; stats_add_cmd ; stats_remove_cmd ; log_cmd ]
let () =
match Term.eval_choice default_cmd cmds
with `Ok () -> exit 0 | _ -> exit 1
match Term.eval_choice default_cmd cmds with
| `Ok x -> exit (exit_status_to_int x)
| y -> exit (Term.exit_status_of_result y)

33
client/albatross_client_remote_tls.ml
View File

@ -6,12 +6,13 @@ let rec read_tls_write_cons t =
Vmm_tls_lwt.read_tls t >>= function
| Error `Eof ->
Logs.warn (fun m -> m "eof from server");
Lwt.return (Ok ())
Lwt.return Albatross_cli.Success
| Error _ ->
Lwt.return (Error (`Msg ("read failure")))
Lwt.return Albatross_cli.Communication_failed
| Ok wire ->
Albatross_cli.print_result wire ;
read_tls_write_cons t
match Albatross_cli.output_result wire with
| Ok () -> read_tls_write_cons t
| Error e -> Lwt.return e
let client cas host port cert priv_key =
let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in
@ -28,22 +29,16 @@ let client cas host port cert priv_key =
let sockaddr = Lwt_unix.ADDR_INET (host_inet_addr, port) in
Vmm_lwt.connect host_entry.Lwt_unix.h_addrtype sockaddr >>= function
| None ->
let err =
Rresult.R.error_msgf "couldn't connect to %a" Vmm_lwt.pp_sockaddr sockaddr
in
Lwt.return err
Logs.err (fun m -> m "couldn't connect to %a"
Vmm_lwt.pp_sockaddr sockaddr);
Lwt.return Albatross_cli.Connect_failed
| Some fd ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
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 ->
read_tls_write_cons t)
(fun exn ->
let err =
Rresult.R.error_msgf "failed to establish TLS connection: %s"
(Printexc.to_string exn)
in
Lwt.return err)
(fun exn -> Lwt.return (Albatross_tls_common.classify_tls_error exn))
let run_client _ cas cert key (host, port) =
Printexc.register_printer (function
@ -79,9 +74,11 @@ let cmd =
`S "DESCRIPTION" ;
`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 ~doc ~man
let exits = auth_exits @ exits in
Term.(const run_client $ setup_log $ cas $ client_cert $ client_key $ destination),
Term.info "albatross_client_remote_tls" ~version ~doc ~man ~exits
let () =
match Term.eval cmd
with `Error _ -> exit 1 | _ -> exit 0
match Term.eval cmd with
| `Ok x -> exit (exit_status_to_int x)
| y -> exit (Term.exit_status_of_result y)

4
client/dune
View File

@ -3,7 +3,7 @@
(public_name albatross-client-bistro)
(package albatross)
(modules albatross_client_bistro)
(libraries albatross.cli albatross albatross.tls))
(libraries albatross.cli albatross albatross.tls albatross_tls_cli))
(executable
(name albatross_client_local)
@ -17,4 +17,4 @@
(public_name albatross-client-remote-tls)
(package albatross)
(modules albatross_client_remote_tls)
(libraries albatross.cli albatross albatross.tls))
(libraries albatross.cli albatross albatross.tls albatross_tls_cli))

74
command-line/albatross_cli.ml
View File

@ -48,12 +48,31 @@ let init_influx name data =
in
Lwt.async report
let print_result ((_, reply) as wire) =
type exit_status =
| Success
| Local_authentication_failed
| Remote_authentication_failed
| Communication_failed
| Connect_failed
| Remote_command_failed
| Cli_failed
| Internal_error
let output_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)
| `Success _ ->
Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire);
Ok ()
| `Data _ ->
Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire);
Ok ()
| `Failure _ ->
Logs.warn (fun m -> m "%a" Vmm_commands.pp_wire wire);
Error Remote_command_failed
| `Command _ ->
Logs.err (fun m -> m "received unexpected command %a"
Vmm_commands.pp_wire wire);
Error Internal_error
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
@ -296,3 +315,48 @@ let set_dbdir = function
| Linux -> Fpath.(v "/var" / "lib" / "albatross")
in
Vmm_unix.set_dbdir path
let exit_status = function
| Ok () -> Ok Success
| Error e -> Ok e
(* exit status already in use:
- 0 success
- 2 OCaml exception
- 124 "cli error"
- 125 "internal error"
- 126 (bash) command invoked cannot execute
- 127 (bash) command not found
- 255 OCaml abort
*)
let local_authentication_failed = 119
let remote_authentication_failed = 120
let communication_failed = 121
let connect_failed = 122
let remote_command_failed = 123
let exit_status_to_int = function
| Success -> 0
| Local_authentication_failed -> local_authentication_failed
| Remote_authentication_failed -> remote_authentication_failed
| Communication_failed -> communication_failed
| Connect_failed -> connect_failed
| Remote_command_failed -> remote_command_failed
| Cli_failed -> Term.exit_status_cli_error
| Internal_error -> Term.exit_status_internal_error
let exits =
Term.exit_info ~doc:"on communication (read or write) failure"
communication_failed ::
Term.exit_info ~doc:"on connection failure" connect_failed ::
Term.exit_info ~doc:"on remote command execution failure"
remote_command_failed ::
Term.default_exits
let auth_exits =
[ Term.exit_info ~doc:"on local authentication failure \
(certificate not accepted by remote)"
local_authentication_failed ;
Term.exit_info ~doc:"on remote authentication failure \
(couldn't validate trust anchor)"
remote_authentication_failed ]

19
tls/albatross_tls_common.ml
View File

@ -112,6 +112,25 @@ let handle ca tls =
(Vmm_commands.header ~version name, reply) >|= fun _ ->
()
let classify_tls_error = function
| Tls_lwt.Tls_alert
(Tls.Packet.BAD_CERTIFICATE
| Tls.Packet.UNSUPPORTED_CERTIFICATE
| Tls.Packet.CERTIFICATE_REVOKED
| Tls.Packet.CERTIFICATE_EXPIRED
| Tls.Packet.CERTIFICATE_UNKNOWN) as exn ->
Logs.err (fun m -> m "local authentication failure %s"
(Printexc.to_string exn));
Albatross_cli.Local_authentication_failed
| Tls_lwt.Tls_failure (`Error (`AuthenticationFailure _)) as exn ->
Logs.err (fun m -> m "remove authentication failure %s"
(Printexc.to_string exn));
Albatross_cli.Remote_authentication_failed
| exn ->
Logs.err (fun m -> m "failed to establish TLS connection: %s"
(Printexc.to_string exn));
Albatross_cli.Communication_failed
open Cmdliner
let cacert =

26
tls/vmm_tls_lwt.ml
View File

@ -8,23 +8,15 @@ let read_tls t =
if l = 0 then
Lwt.return (Ok ())
else
Lwt.catch (fun () ->
Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function
| 0 ->
Logs.debug (fun m -> m "TLS: end of file") ;
Lwt.return (Error `Eof)
| x when x == l -> Lwt.return (Ok ())
| x when x < l -> r_n buf (off + x) tot
| _ ->
Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ;
Lwt.return (Error `Toomuch))
(function
| Tls_lwt.Tls_failure a ->
Logs.err (fun m -> m "TLS read failure: %s" (Tls.Engine.string_of_failure a)) ;
Lwt.return (Error `Exception)
| e ->
Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ;
Lwt.return (Error `Exception))
Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function
| 0 ->
Logs.debug (fun m -> m "TLS: end of file") ;
Lwt.return (Error `Eof)
| x when x == l -> Lwt.return (Ok ())
| x when x < l -> r_n buf (off + x) tot
| _ ->
Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ;
Lwt.return (Error `Toomuch)
in
let buf = Cstruct.create 4 in
r_n buf 0 4 >>= function