make dbdir and tmpdir platform-specific and overwritable by all command line utilities

This commit is contained in:
Hannes Mehnert 2019-10-29 23:37:42 +01:00
parent 56aa5545f8
commit 6206e8681a
15 changed files with 103 additions and 46 deletions

View file

@ -40,7 +40,8 @@ let handle opt_socket name (cmd : Vmm_commands.t) =
Vmm_lwt.safe_close fd >|= fun () -> Vmm_lwt.safe_close fd >|= fun () ->
Ok () Ok ()
let jump opt_socket name cmd = let jump opt_socket name cmd tmpdir =
Albatross_cli.set_tmpdir tmpdir;
Lwt_main.run (handle opt_socket name cmd) Lwt_main.run (handle opt_socket name cmd)
let info_policy _ opt_socket name = let info_policy _ opt_socket name =
@ -59,9 +60,9 @@ let info_ _ opt_socket name =
let destroy _ opt_socket name = let destroy _ opt_socket name =
jump opt_socket name (`Unikernel_cmd `Unikernel_destroy) jump opt_socket name (`Unikernel_cmd `Unikernel_destroy)
let create _ opt_socket force name image cpuid memory argv block network compression restart_on_fail exit_code = let create _ opt_socket force name image cpuid memory argv block network compression restart_on_fail exit_code tmpdir =
match Albatross_cli.create_vm force image cpuid memory argv block network compression restart_on_fail exit_code with match Albatross_cli.create_vm force image cpuid memory argv block network compression restart_on_fail exit_code with
| Ok cmd -> jump opt_socket name (`Unikernel_cmd cmd) | Ok cmd -> jump opt_socket name (`Unikernel_cmd cmd) tmpdir
| Error (`Msg msg) -> Error (`Msg msg) | Error (`Msg msg) -> Error (`Msg msg)
let console _ opt_socket name since count = let console _ opt_socket name since count =
@ -106,7 +107,7 @@ let destroy_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Destroy a virtual machine."] `P "Destroy a virtual machine."]
in in
Term.(term_result (const destroy $ setup_log $ socket $ vm_name)), Term.(term_result (const destroy $ setup_log $ socket $ vm_name $ tmpdir)),
Term.info "destroy" ~doc ~man Term.info "destroy" ~doc ~man
let remove_policy_cmd = let remove_policy_cmd =
@ -115,7 +116,7 @@ let remove_policy_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Removes a policy."] `P "Removes a policy."]
in in
Term.(term_result (const remove_policy $ setup_log $ socket $ opt_vm_name)), 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
let info_cmd = let info_cmd =
@ -124,7 +125,7 @@ let info_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Shows information about VMs."] `P "Shows information about VMs."]
in in
Term.(term_result (const info_ $ setup_log $ socket $ opt_vm_name)), Term.(term_result (const info_ $ setup_log $ socket $ opt_vm_name $ tmpdir)),
Term.info "info" ~doc ~man Term.info "info" ~doc ~man
let policy_cmd = let policy_cmd =
@ -133,7 +134,7 @@ let policy_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Shows information about policies."] `P "Shows information about policies."]
in in
Term.(term_result (const info_policy $ setup_log $ socket $ opt_vm_name)), Term.(term_result (const info_policy $ setup_log $ socket $ opt_vm_name $ tmpdir)),
Term.info "policy" ~doc ~man Term.info "policy" ~doc ~man
let add_policy_cmd = let add_policy_cmd =
@ -142,7 +143,7 @@ let add_policy_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Adds a policy."] `P "Adds a policy."]
in in
Term.(term_result (const add_policy $ setup_log $ socket $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)), 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
let create_cmd = let create_cmd =
@ -151,7 +152,7 @@ let create_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Creates a virtual machine."] `P "Creates a virtual machine."]
in 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)), 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
let console_cmd = let console_cmd =
@ -160,7 +161,7 @@ let console_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Shows console output of a VM."] `P "Shows console output of a VM."]
in in
Term.(term_result (const console $ setup_log $ socket $ vm_name $ since $ count)), Term.(term_result (const console $ setup_log $ socket $ vm_name $ since $ count $ tmpdir)),
Term.info "console" ~doc ~man Term.info "console" ~doc ~man
let stats_subscribe_cmd = let stats_subscribe_cmd =
@ -169,7 +170,7 @@ let stats_subscribe_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Shows statistics of VMs."] `P "Shows statistics of VMs."]
in in
Term.(term_result (const stats_subscribe $ setup_log $ socket $ opt_vm_name)), Term.(term_result (const stats_subscribe $ setup_log $ socket $ opt_vm_name $ tmpdir)),
Term.info "stats" ~doc ~man Term.info "stats" ~doc ~man
let stats_remove_cmd = let stats_remove_cmd =
@ -178,7 +179,7 @@ let stats_remove_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Removes statistics of VM."] `P "Removes statistics of VM."]
in in
Term.(term_result (const stats_remove $ setup_log $ socket $ opt_vm_name)), 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
let stats_add_cmd = let stats_add_cmd =
@ -187,7 +188,7 @@ let stats_add_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Add VM to statistics gathering."] `P "Add VM to statistics gathering."]
in in
Term.(term_result (const stats_add $ setup_log $ socket $ opt_vm_name $ vmm_dev_req0 $ pid_req1 $ bridge_taps)), 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
let log_cmd = let log_cmd =
@ -196,7 +197,7 @@ let log_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Shows event log of VM."] `P "Shows event log of VM."]
in in
Term.(term_result (const event_log $ setup_log $ socket $ opt_vm_name $ since $ count)), 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
let block_info_cmd = let block_info_cmd =
@ -205,7 +206,7 @@ let block_info_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Block device information."] `P "Block device information."]
in in
Term.(term_result (const block_info $ setup_log $ socket $ opt_block_name)), Term.(term_result (const block_info $ setup_log $ socket $ opt_block_name $ tmpdir)),
Term.info "block" ~doc ~man Term.info "block" ~doc ~man
let block_create_cmd = let block_create_cmd =
@ -214,7 +215,7 @@ let block_create_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Creation of a block device."] `P "Creation of a block device."]
in in
Term.(term_result (const block_create $ setup_log $ socket $ block_name $ block_size)), 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
let block_destroy_cmd = let block_destroy_cmd =
@ -223,7 +224,7 @@ let block_destroy_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Destroys a block device."] `P "Destroys a block device."]
in in
Term.(term_result (const block_destroy $ setup_log $ socket $ block_name)), Term.(term_result (const block_destroy $ setup_log $ socket $ block_name $ tmpdir)),
Term.info "destroy_block" ~doc ~man Term.info "destroy_block" ~doc ~man
let help_cmd = let help_cmd =

View file

@ -254,3 +254,37 @@ let since_count since count = match since with
let version = let version =
Fmt.strf "version %%VERSION%% protocol version %a" Fmt.strf "version %%VERSION%% protocol version %a"
Vmm_commands.pp_version Vmm_commands.current Vmm_commands.pp_version Vmm_commands.current
let tmpdir =
let doc = "Albatross temporary directory (defaults to /var/run/albatross on FreeBSD, /run/albatross on Linux)" in
Arg.(value & opt (some dir) None & info [ "tmpdir" ] ~doc)
let set_tmpdir = function
| Some path ->
begin match Fpath.of_string path with
| Ok path -> Vmm_core.set_tmpdir path
| Error `Msg m -> invalid_arg m
end
| None ->
let path = match Lazy.force Vmm_unix.uname with
| FreeBSD -> Fpath.(v "/var" / "run" / "albatross")
| Linux -> Fpath.(v "/run" / "albatross")
in
Vmm_core.set_tmpdir path
let dbdir =
let doc = "Albatross database directory (defaults to /var/db/albatross on FreeBSD, /run/albatross on Linux)" in
Arg.(value & opt (some dir) None & info [ "dbdir" ] ~doc)
let set_dbdir = function
| Some path ->
begin match Fpath.of_string path with
| Ok path -> Vmm_unix.set_dbdir path
| Error `Msg m -> invalid_arg m
end
| None ->
let path = match Lazy.force Vmm_unix.uname with
| Vmm_unix.FreeBSD -> Fpath.(v "/var" / "db" / "albatross")
| Linux -> Fpath.(v "/var" / "lib" / "albatross")
in
Vmm_unix.set_dbdir path

View file

@ -158,8 +158,9 @@ let handle s addr =
let m = Vmm_core.conn_metrics "unix" let m = Vmm_core.conn_metrics "unix"
let jump _ influx = let jump _ influx tmpdir =
Sys.(set_signal sigpipe Signal_ignore) ; Sys.(set_signal sigpipe Signal_ignore) ;
Albatross_cli.set_tmpdir tmpdir;
Lwt_main.run Lwt_main.run
(Albatross_cli.init_influx "albatross_console" influx; (Albatross_cli.init_influx "albatross_console" influx;
Vmm_lwt.server_socket `Console >>= fun s -> Vmm_lwt.server_socket `Console >>= fun s ->
@ -176,7 +177,7 @@ open Cmdliner
open Albatross_cli open Albatross_cli
let cmd = let cmd =
Term.(term_result (const jump $ setup_log $ influx)), Term.(term_result (const jump $ setup_log $ influx $ tmpdir)),
Term.info "albatross_console" ~version Term.info "albatross_console" ~version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -280,8 +280,9 @@ let client influx vm drop =
in in
loop () loop ()
let run_client _ influx vm drop = let run_client _ influx vm drop tmpdir =
Sys.(set_signal sigpipe Signal_ignore) ; Sys.(set_signal sigpipe Signal_ignore) ;
Albatross_cli.set_tmpdir tmpdir;
Lwt_main.run (client influx vm drop) Lwt_main.run (client influx vm drop)
open Cmdliner open Cmdliner
@ -297,7 +298,7 @@ let cmd =
`S "DESCRIPTION" ; `S "DESCRIPTION" ;
`P "$(tname) connects to a albatross stats socket, pulls statistics and pushes them via TCP to influxdb" ] `P "$(tname) connects to a albatross stats socket, pulls statistics and pushes them via TCP to influxdb" ]
in in
Term.(term_result (const run_client $ setup_log $ influx $ opt_vm_name $ drop_label)), Term.(term_result (const run_client $ setup_log $ influx $ opt_vm_name $ drop_label $ tmpdir)),
Term.info "albatross_influx" ~version ~doc ~man Term.info "albatross_influx" ~version ~doc ~man
let () = let () =

View file

@ -148,8 +148,9 @@ let handle mvar ring s addr =
let m = Vmm_core.conn_metrics "unix" let m = Vmm_core.conn_metrics "unix"
let jump _ file read_only influx = let jump _ file read_only influx tmpdir =
Sys.(set_signal sigpipe Signal_ignore) ; Sys.(set_signal sigpipe Signal_ignore) ;
Albatross_cli.set_tmpdir tmpdir;
Lwt_main.run Lwt_main.run
(read_from_file file >>= fun entries -> (read_from_file file >>= fun entries ->
Logs.app (fun m -> m "read %d entries from disk" (List.length entries)) ; Logs.app (fun m -> m "read %d entries from disk" (List.length entries)) ;
@ -191,7 +192,7 @@ let read_only =
Arg.(value & flag & info [ "read-only" ] ~doc) Arg.(value & flag & info [ "read-only" ] ~doc)
let cmd = let cmd =
Term.(const jump $ setup_log $ file $ read_only $ influx), Term.(const jump $ setup_log $ file $ read_only $ influx $ tmpdir),
Term.info "albatross_log" ~version Term.info "albatross_log" ~version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -135,8 +135,10 @@ let write_reply name fd txt (hdr, cmd) =
let m = conn_metrics "unix" let m = conn_metrics "unix"
let jump _ influx = let jump _ influx tmpdir dbdir =
Sys.(set_signal sigpipe Signal_ignore); Sys.(set_signal sigpipe Signal_ignore);
Albatross_cli.set_tmpdir tmpdir;
Albatross_cli.set_dbdir dbdir;
Rresult.R.error_msg_to_invalid_arg Rresult.R.error_msg_to_invalid_arg
(Vmm_unix.check_commands ()); (Vmm_unix.check_commands ());
match Vmm_vmmd.restore_unikernels () with match Vmm_vmmd.restore_unikernels () with
@ -199,7 +201,7 @@ let jump _ influx =
open Cmdliner open Cmdliner
let cmd = let cmd =
Term.(const jump $ setup_log $ influx), Term.(const jump $ setup_log $ influx $ tmpdir $ dbdir),
Term.info "albatrossd" ~version:Albatross_cli.version Term.info "albatrossd" ~version:Albatross_cli.version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -353,7 +353,7 @@ let v3_unikernel_config =
let typ = `Solo5 let typ = `Solo5
and compressed = match fst image with `Hvt_amd64_compressed -> true | _ -> false and compressed = match fst image with `Hvt_amd64_compressed -> true | _ -> false
and image = snd image and image = snd image
and fail_behaviour = `Quit and fail_behaviour = `Quit (* TODO maybe set to restart by default :) *)
in in
{ typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv } { typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
and g vm = and g vm =

View file

@ -19,8 +19,9 @@ let conn_metrics kind =
open Astring open Astring
let tmpdir = Fpath.(v "/var" / "run" / "albatross") let tmpdir = ref (Fpath.v "/nonexisting")
let sockdir = Fpath.(tmpdir / "util")
let set_tmpdir path = tmpdir := path
type service = [ `Console | `Log | `Stats | `Vmmd ] type service = [ `Console | `Log | `Stats | `Vmmd ]
@ -31,7 +32,7 @@ let socket_path t =
| `Stats -> "stat" | `Stats -> "stat"
| `Log -> "log" | `Log -> "log"
in in
Fpath.to_string Fpath.(sockdir / path + "sock") Fpath.to_string Fpath.(!tmpdir / "util" / path + "sock")
let pp_socket ppf t = let pp_socket ppf t =
let name = socket_path t in let name = socket_path t in
@ -106,11 +107,11 @@ module Name = struct
let image_file name = let image_file name =
let file = to_string name in let file = to_string name in
Fpath.(tmpdir / file + "img") Fpath.(!tmpdir / file + "img")
let fifo_file name = let fifo_file name =
let file = to_string name in let file = to_string name in
Fpath.(tmpdir / "fifo" / file) Fpath.(!tmpdir / "fifo" / file)
let block_name vm_name dev = let block_name vm_name dev =
List.rev (dev :: List.rev (domain vm_name)) List.rev (dev :: List.rev (domain vm_name))

View file

@ -2,6 +2,8 @@
val conn_metrics : string -> [ `Close | `Open ] -> unit val conn_metrics : string -> [ `Close | `Open ] -> unit
val set_tmpdir : Fpath.t -> unit
type service = [ `Console | `Log | `Stats | `Vmmd ] type service = [ `Console | `Log | `Stats | `Vmmd ]
val socket_path : service -> string val socket_path : service -> string

View file

@ -4,7 +4,9 @@ open Rresult
open Vmm_core open Vmm_core
let dbdir = Fpath.(v "/var" / "db" / "albatross") let dbdir = ref (Fpath.v "/nonexisting")
let set_dbdir path = dbdir := path
type supported = FreeBSD | Linux type supported = FreeBSD | Linux
@ -19,7 +21,7 @@ let uname =
let check_solo5_cmd name = let check_solo5_cmd name =
match match
Bos.OS.Cmd.must_exist (Bos.Cmd.v name), Bos.OS.Cmd.must_exist (Bos.Cmd.v name),
Bos.OS.Cmd.must_exist Bos.Cmd.(v (p Fpath.(dbdir / name))) Bos.OS.Cmd.must_exist Bos.Cmd.(v (p Fpath.(!dbdir / name)))
with with
| Ok cmd, _ | _, Ok cmd -> Ok cmd | Ok cmd, _ | _, Ok cmd -> Ok cmd
| _ -> R.error_msgf "%s does not exist" name | _ -> R.error_msgf "%s does not exist" name
@ -94,8 +96,8 @@ let close_no_err fd = try close fd with _ -> ()
let dump, restore = let dump, restore =
let open R.Infix in let open R.Infix in
let state_file = Fpath.(dbdir / "state") in
(fun data -> (fun data ->
let state_file = Fpath.(!dbdir / "state") in
Bos.OS.File.exists state_file >>= fun exists -> Bos.OS.File.exists state_file >>= fun exists ->
(if exists then begin (if exists then begin
let bak = Fpath.(state_file + "bak") in let bak = Fpath.(state_file + "bak") in
@ -103,17 +105,18 @@ let dump, restore =
end else Ok ()) >>= fun () -> end else Ok ()) >>= fun () ->
Bos.OS.File.write state_file (Cstruct.to_string data)), Bos.OS.File.write state_file (Cstruct.to_string data)),
(fun () -> (fun () ->
let state_file = Fpath.(!dbdir / "state") in
Bos.OS.File.exists state_file >>= fun exists -> Bos.OS.File.exists state_file >>= fun exists ->
if exists then if exists then
Bos.OS.File.read state_file >>| fun data -> Bos.OS.File.read state_file >>| fun data ->
Cstruct.of_string data Cstruct.of_string data
else Error `NoFile) else Error `NoFile)
let blockdir = Fpath.(dbdir / "block") let block_sub = "block"
let block_file name = let block_file name =
let file = Name.to_string name in let file = Name.to_string name in
Fpath.(blockdir / file) Fpath.(!dbdir / block_sub / file)
let rec mkfifo name = let rec mkfifo name =
try Unix.mkfifo (Fpath.to_string name) 0o640 with try Unix.mkfifo (Fpath.to_string name) 0o640 with
@ -285,6 +288,7 @@ let mb_of_bytes size =
Ok (size lsr 20) Ok (size lsr 20)
let find_block_devices () = let find_block_devices () =
let blockdir = Fpath.(!dbdir / block_sub) in
Bos.OS.Dir.contents ~rel:true blockdir >>= fun files -> Bos.OS.Dir.contents ~rel:true blockdir >>= fun files ->
List.fold_left (fun acc file -> List.fold_left (fun acc file ->
acc >>= fun acc -> acc >>= fun acc ->

View file

@ -4,6 +4,12 @@ open Rresult
open Vmm_core open Vmm_core
type supported = FreeBSD | Linux
val uname : supported Lazy.t
val set_dbdir : Fpath.t -> unit
val check_commands : unit -> (unit, [> R.msg ]) result val check_commands : unit -> (unit, [> R.msg ]) result
val prepare : Name.t -> Unikernel.config -> (string list, [> R.msg ]) result val prepare : Name.t -> Unikernel.config -> (string list, [> R.msg ]) result

View file

@ -31,8 +31,9 @@ let timer pid vmmapi interval =
let all = List.combine !descr st in let all = List.combine !descr st in
Logs.app (fun m -> m "bhyve stats %a" Stats.pp_vmm_mem all) Logs.app (fun m -> m "bhyve stats %a" Stats.pp_vmm_mem all)
let jump _ pid name interval = let jump _ pid name interval tmpdir =
Sys.(set_signal sigpipe Signal_ignore) ; Sys.(set_signal sigpipe Signal_ignore) ;
Albatross_cli.set_tmpdir tmpdir;
let interval = Duration.(to_f (of_sec interval)) in let interval = Duration.(to_f (of_sec interval)) in
Lwt_main.run ( Lwt_main.run (
let vmmapi = match name with let vmmapi = match name with
@ -68,7 +69,7 @@ let vmname =
Arg.(value & opt (some string) None & info [ "name" ] ~doc) Arg.(value & opt (some string) None & info [ "name" ] ~doc)
let cmd = let cmd =
Term.(term_result (const jump $ setup_log $ pid $ vmname $ interval)), Term.(term_result (const jump $ setup_log $ pid $ vmname $ interval $ tmpdir)),
Term.info "albatross_stat_client" ~version Term.info "albatross_stat_client" ~version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -66,8 +66,9 @@ let timer () =
let m = Vmm_core.conn_metrics "unix" let m = Vmm_core.conn_metrics "unix"
let jump _ interval influx = let jump _ interval influx tmpdir =
Sys.(set_signal sigpipe Signal_ignore); Sys.(set_signal sigpipe Signal_ignore);
Albatross_cli.set_tmpdir tmpdir;
let interval = Duration.(to_f (of_sec interval)) in let interval = Duration.(to_f (of_sec interval)) in
Lwt_main.run Lwt_main.run
(Albatross_cli.init_influx "albatross_stats" influx; (Albatross_cli.init_influx "albatross_stats" influx;
@ -89,7 +90,7 @@ let interval =
Arg.(value & opt int 10 & info [ "interval" ] ~doc) Arg.(value & opt int 10 & info [ "interval" ] ~doc)
let cmd = let cmd =
Term.(term_result (const jump $ setup_log $ interval $ influx)), Term.(term_result (const jump $ setup_log $ interval $ influx $ tmpdir)),
Term.info "albatross_stats" ~version Term.info "albatross_stats" ~version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -13,8 +13,9 @@ let server_socket port =
listen s 10 ; listen s 10 ;
Lwt.return s Lwt.return s
let jump _ cacert cert priv_key port = let jump _ cacert cert priv_key port tmpdir =
Sys.(set_signal sigpipe Signal_ignore); Sys.(set_signal sigpipe Signal_ignore);
Albatross_cli.set_tmpdir tmpdir;
Lwt_main.run Lwt_main.run
(Nocrypto_entropy_lwt.initialize () >>= fun () -> (Nocrypto_entropy_lwt.initialize () >>= fun () ->
server_socket port >>= fun socket -> server_socket port >>= fun socket ->
@ -57,7 +58,7 @@ let port =
Arg.(value & opt int 1025 & info [ "port" ] ~doc) Arg.(value & opt int 1025 & info [ "port" ] ~doc)
let cmd = let cmd =
Term.(const jump $ setup_log $ cacert $ cert $ key $ port), Term.(const jump $ setup_log $ cacert $ cert $ key $ port $ tmpdir),
Term.info "albatross_tls_endpoint" ~version Term.info "albatross_tls_endpoint" ~version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -3,8 +3,9 @@
open Lwt.Infix open Lwt.Infix
open Albatross_tls_common open Albatross_tls_common
let jump cacert cert priv_key = let jump cacert cert priv_key tmpdir =
Sys.(set_signal sigpipe Signal_ignore) ; Sys.(set_signal sigpipe Signal_ignore) ;
Albatross_cli.set_tmpdir tmpdir;
Lwt_main.run Lwt_main.run
(Nocrypto_entropy_lwt.initialize () >>= fun () -> (Nocrypto_entropy_lwt.initialize () >>= fun () ->
tls_config cacert cert priv_key >>= fun (config, ca) -> tls_config cacert cert priv_key >>= fun (config, ca) ->
@ -25,7 +26,7 @@ let jump cacert cert priv_key =
open Cmdliner open Cmdliner
let cmd = let cmd =
Term.(const jump $ cacert $ cert $ key), Term.(const jump $ cacert $ cert $ key $ Albatross_cli.tmpdir),
Term.info "albatross_tls_inetd" ~version:Albatross_cli.version Term.info "albatross_tls_inetd" ~version:Albatross_cli.version
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1