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
parent
9bc4d478d5
commit
0932d06c41
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue