From 0932d06c41f2bf7e5f2f7f7e4a0d9227608a3c88 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 25 Apr 2020 16:28:48 +0200 Subject: [PATCH] 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" --- client/albatross_client_bistro.ml | 95 +++++++++++++++------------ client/albatross_client_local.ml | 62 +++++++++-------- client/albatross_client_remote_tls.ml | 33 +++++----- client/dune | 4 +- command-line/albatross_cli.ml | 74 +++++++++++++++++++-- tls/albatross_tls_common.ml | 19 ++++++ tls/vmm_tls_lwt.ml | 26 +++----- 7 files changed, 199 insertions(+), 114 deletions(-) diff --git a/client/albatross_client_bistro.ml b/client/albatross_client_bistro.ml index 729d6fe..1423f25 100644 --- a/client/albatross_client_bistro.ml +++ b/client/albatross_client_bistro.ml @@ -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) diff --git a/client/albatross_client_local.ml b/client/albatross_client_local.ml index b678999..d4a13fc 100644 --- a/client/albatross_client_local.ml +++ b/client/albatross_client_local.ml @@ -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) diff --git a/client/albatross_client_remote_tls.ml b/client/albatross_client_remote_tls.ml index efa4607..8259f32 100644 --- a/client/albatross_client_remote_tls.ml +++ b/client/albatross_client_remote_tls.ml @@ -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) diff --git a/client/dune b/client/dune index d7c4c48..70d8921 100644 --- a/client/dune +++ b/client/dune @@ -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)) diff --git a/command-line/albatross_cli.ml b/command-line/albatross_cli.ml index c275d1d..50d2205 100644 --- a/command-line/albatross_cli.ml +++ b/command-line/albatross_cli.ml @@ -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 ] diff --git a/tls/albatross_tls_common.ml b/tls/albatross_tls_common.ml index 7240147..b4a06f8 100644 --- a/tls/albatross_tls_common.ml +++ b/tls/albatross_tls_common.ml @@ -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 = diff --git a/tls/vmm_tls_lwt.ml b/tls/vmm_tls_lwt.ml index 8955ed0..54514e4 100644 --- a/tls/vmm_tls_lwt.ml +++ b/tls/vmm_tls_lwt.ml @@ -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