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

client/albatross_client_local.ml

@@ -40,7 +40,8 @@ let handle opt_socket name (cmd : Vmm_commands.t) =
       Vmm_lwt.safe_close fd >|= fun () ->
       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)
 
 let info_policy _ opt_socket name =
@@ -59,9 +60,9 @@ let info_ _ opt_socket name =
 let destroy _ opt_socket name =
   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
-  | 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)
 
 let console _ opt_socket name since count =
@@ -106,7 +107,7 @@ let destroy_cmd =
     [`S "DESCRIPTION";
      `P "Destroy a virtual machine."]
   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
 
 let remove_policy_cmd =
@@ -115,7 +116,7 @@ let remove_policy_cmd =
     [`S "DESCRIPTION";
      `P "Removes a policy."]
   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
 
 let info_cmd =
@@ -124,7 +125,7 @@ let info_cmd =
     [`S "DESCRIPTION";
      `P "Shows information about VMs."]
   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
 
 let policy_cmd =
@@ -133,7 +134,7 @@ let policy_cmd =
     [`S "DESCRIPTION";
      `P "Shows information about policies."]
   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
 
 let add_policy_cmd =
@@ -142,7 +143,7 @@ let add_policy_cmd =
     [`S "DESCRIPTION";
      `P "Adds a policy."]
   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
 
 let create_cmd =
@@ -151,7 +152,7 @@ let create_cmd =
     [`S "DESCRIPTION";
      `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)),
+  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
 
 let console_cmd =
@@ -160,7 +161,7 @@ let console_cmd =
     [`S "DESCRIPTION";
      `P "Shows console output of a VM."]
   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
 
 let stats_subscribe_cmd =
@@ -169,7 +170,7 @@ let stats_subscribe_cmd =
     [`S "DESCRIPTION";
      `P "Shows statistics of VMs."]
   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
 
 let stats_remove_cmd =
@@ -178,7 +179,7 @@ let stats_remove_cmd =
     [`S "DESCRIPTION";
      `P "Removes statistics of VM."]
   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
 
 let stats_add_cmd =
@@ -187,7 +188,7 @@ let stats_add_cmd =
     [`S "DESCRIPTION";
      `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)),
+  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
 
 let log_cmd =
@@ -196,7 +197,7 @@ let log_cmd =
     [`S "DESCRIPTION";
      `P "Shows event log of VM."]
   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
 
 let block_info_cmd =
@@ -205,7 +206,7 @@ let block_info_cmd =
     [`S "DESCRIPTION";
      `P "Block device information."]
   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
 
 let block_create_cmd =
@@ -214,7 +215,7 @@ let block_create_cmd =
     [`S "DESCRIPTION";
      `P "Creation of a block device."]
   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
 
 let block_destroy_cmd =
@@ -223,7 +224,7 @@ let block_destroy_cmd =
     [`S "DESCRIPTION";
      `P "Destroys a block device."]
   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
 
 let help_cmd =

command-line/albatross_cli.ml

@@ -254,3 +254,37 @@ let since_count since count = match since with
 let version =
   Fmt.strf "version %%VERSION%% protocol version %a"
     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

daemon/albatross_console.ml

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

daemon/albatross_influx.ml

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

daemon/albatross_log.ml

@@ -148,8 +148,9 @@ let handle mvar ring s addr =
 
 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) ;
+  Albatross_cli.set_tmpdir tmpdir;
   Lwt_main.run
     (read_from_file file >>= fun 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)
 
 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
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

daemon/albatrossd.ml

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

src/vmm_asn.ml

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

src/vmm_core.ml

@@ -19,8 +19,9 @@ let conn_metrics kind =
 
 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 ]
 
@@ -31,7 +32,7 @@ let socket_path t =
     | `Stats -> "stat"
     | `Log -> "log"
   in
-  Fpath.to_string Fpath.(sockdir / path + "sock")
+  Fpath.to_string Fpath.(!tmpdir / "util" / path + "sock")
 
 let pp_socket ppf t =
   let name = socket_path t in
@@ -106,11 +107,11 @@ module Name = struct
 
   let image_file name =
     let file = to_string name in
-    Fpath.(tmpdir / file + "img")
+    Fpath.(!tmpdir / file + "img")
 
   let fifo_file name =
     let file = to_string name in
-    Fpath.(tmpdir / "fifo" / file)
+    Fpath.(!tmpdir / "fifo" / file)
 
   let block_name vm_name dev =
     List.rev (dev :: List.rev (domain vm_name))

src/vmm_core.mli

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

src/vmm_unix.ml

@@ -4,7 +4,9 @@ open Rresult
 
 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
 
@@ -19,7 +21,7 @@ let uname =
 let check_solo5_cmd name =
   match
     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
   | Ok cmd, _ | _, Ok cmd -> Ok cmd
   | _ -> 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 open R.Infix in
-  let state_file = Fpath.(dbdir / "state") in
   (fun data ->
+     let state_file = Fpath.(!dbdir / "state") in
      Bos.OS.File.exists state_file >>= fun exists ->
      (if exists then begin
         let bak = Fpath.(state_file + "bak") in
@@ -103,17 +105,18 @@ let dump, restore =
       end else Ok ()) >>= fun () ->
      Bos.OS.File.write state_file (Cstruct.to_string data)),
   (fun () ->
+     let state_file = Fpath.(!dbdir / "state") in
      Bos.OS.File.exists state_file >>= fun exists ->
      if exists then
        Bos.OS.File.read state_file >>| fun data ->
        Cstruct.of_string data
      else Error `NoFile)
 
-let blockdir = Fpath.(dbdir / "block")
+let block_sub = "block"
 
 let block_file name =
   let file = Name.to_string name in
-  Fpath.(blockdir / file)
+  Fpath.(!dbdir / block_sub / file)
 
 let rec mkfifo name =
   try Unix.mkfifo (Fpath.to_string name) 0o640 with
@@ -285,6 +288,7 @@ let mb_of_bytes size =
     Ok (size lsr 20)
 
 let find_block_devices () =
+  let blockdir = Fpath.(!dbdir / block_sub) in
   Bos.OS.Dir.contents ~rel:true blockdir >>= fun files ->
   List.fold_left (fun acc file ->
       acc >>= fun acc ->

src/vmm_unix.mli

@@ -4,6 +4,12 @@ open Rresult
 
 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 prepare : Name.t -> Unikernel.config -> (string list, [> R.msg ]) result

stats/albatross_stat_client.ml

@@ -31,8 +31,9 @@ let timer pid vmmapi interval =
       let all = List.combine !descr st in
       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) ;
+  Albatross_cli.set_tmpdir tmpdir;
   let interval = Duration.(to_f (of_sec interval)) in
   Lwt_main.run (
     let vmmapi = match name with
@@ -68,7 +69,7 @@ let vmname =
   Arg.(value & opt (some string) None & info [ "name" ] ~doc)
 
 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
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

stats/albatross_stats.ml

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

tls/albatross_tls_endpoint.ml

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

tls/albatross_tls_inetd.ml

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