2017-05-26 14:30:34 +00:00
|
|
|
(* (c) 2017 Hannes Mehnert, all rights reserved *)
|
|
|
|
|
|
|
|
open Rresult
|
2019-10-27 19:46:07 +00:00
|
|
|
|
|
|
|
open Vmm_core
|
|
|
|
|
2019-10-29 22:37:42 +00:00
|
|
|
let dbdir = ref (Fpath.v "/nonexisting")
|
|
|
|
|
|
|
|
let set_dbdir path = dbdir := path
|
2019-10-27 19:46:07 +00:00
|
|
|
|
|
|
|
type supported = FreeBSD | Linux
|
|
|
|
|
|
|
|
let uname =
|
|
|
|
let cmd = Bos.Cmd.(v "uname" % "-s") in
|
|
|
|
lazy (match Bos.OS.Cmd.(run_out cmd |> out_string) with
|
|
|
|
| Ok (s, _) when s = "FreeBSD" -> FreeBSD
|
|
|
|
| Ok (s, _) when s = "Linux" -> Linux
|
|
|
|
| Ok (s, _) -> invalid_arg (Printf.sprintf "OS %s not supported" s)
|
|
|
|
| Error (`Msg m) -> invalid_arg m)
|
|
|
|
|
|
|
|
let check_solo5_cmd name =
|
|
|
|
match
|
|
|
|
Bos.OS.Cmd.must_exist (Bos.Cmd.v name),
|
2019-10-29 22:37:42 +00:00
|
|
|
Bos.OS.Cmd.must_exist Bos.Cmd.(v (p Fpath.(!dbdir / name)))
|
2019-10-27 19:46:07 +00:00
|
|
|
with
|
|
|
|
| Ok cmd, _ | _, Ok cmd -> Ok cmd
|
|
|
|
| _ -> R.error_msgf "%s does not exist" name
|
|
|
|
|
|
|
|
(* here we check that the binaries we use in this file are actually present *)
|
|
|
|
let check_commands () =
|
|
|
|
let uname_cmd = Bos.Cmd.v "uname" in
|
|
|
|
Bos.OS.Cmd.must_exist uname_cmd >>= fun _ ->
|
|
|
|
let cmds =
|
|
|
|
match Lazy.force uname with
|
|
|
|
| Linux -> [ "ip" ; "brctl" ; "taskset" ]
|
|
|
|
| FreeBSD -> [ "ifconfig" ; "cpuset" ]
|
|
|
|
in
|
|
|
|
List.fold_left
|
|
|
|
(fun acc cmd -> acc >>= fun _ ->
|
|
|
|
Bos.OS.Cmd.must_exist (Bos.Cmd.v cmd))
|
|
|
|
(Ok uname_cmd) cmds >>= fun _ ->
|
|
|
|
check_solo5_cmd "solo5-elftool" >>| fun _ ->
|
|
|
|
()
|
|
|
|
(* we could check for solo5-hvt OR solo5-spt, but in practise we need
|
|
|
|
to handle either being absent and we get an image of that type anyways *)
|
|
|
|
|
2017-05-26 14:30:34 +00:00
|
|
|
(* bits copied over from Bos *)
|
|
|
|
(*---------------------------------------------------------------------------
|
|
|
|
Copyright (c) 2014 Daniel C. Bünzli
|
|
|
|
|
|
|
|
Permission to use, copy, modify, and/or distribute this software for any
|
|
|
|
purpose with or without fee is hereby granted, provided that the above
|
|
|
|
copyright notice and this permission notice appear in all copies.
|
|
|
|
|
|
|
|
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
|
|
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
|
|
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
|
|
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
|
|
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
|
|
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
|
|
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
|
|
---------------------------------------------------------------------------*)
|
2019-10-27 18:47:37 +00:00
|
|
|
let pp_unix_err ppf e = Fmt.string ppf (Unix.error_message e)
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
let err_empty_line = "no command, empty command line"
|
2019-10-27 18:47:37 +00:00
|
|
|
let err_file f e = R.error_msgf "%a: %a" Fpath.pp f pp_unix_err e
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
let rec openfile fn mode perm = try Unix.openfile fn mode perm with
|
|
|
|
| Unix.Unix_error (Unix.EINTR, _, _) -> openfile fn mode perm
|
|
|
|
|
|
|
|
let fd_for_file flag f =
|
2018-04-29 22:20:28 +00:00
|
|
|
try Ok (openfile (Fpath.to_string f) (Unix.O_CLOEXEC :: flag) 0o644)
|
2017-05-26 14:30:34 +00:00
|
|
|
with Unix.Unix_error (e, _, _) -> err_file f e
|
|
|
|
|
2018-04-29 22:20:28 +00:00
|
|
|
let read_fd_for_file = fd_for_file Unix.[ O_RDONLY ]
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2018-04-29 22:20:28 +00:00
|
|
|
let write_fd_for_file = fd_for_file Unix.[ O_WRONLY ; O_APPEND ]
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
let null = match read_fd_for_file (Fpath.v "/dev/null") with
|
|
|
|
| Ok fd -> fd
|
|
|
|
| Error _ -> invalid_arg "cannot read /dev/null"
|
|
|
|
|
2019-01-18 15:33:27 +00:00
|
|
|
let rec create_process prog args stdout =
|
|
|
|
try Unix.create_process prog args null stdout stdout with
|
2017-05-26 14:30:34 +00:00
|
|
|
| Unix.Unix_error (Unix.EINTR, _, _) ->
|
2019-01-18 15:33:27 +00:00
|
|
|
create_process prog args stdout
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
let rec close fd =
|
|
|
|
try Unix.close fd with
|
|
|
|
| Unix.Unix_error (Unix.EINTR, _, _) -> close fd
|
|
|
|
|
2018-04-03 20:58:31 +00:00
|
|
|
let close_no_err fd = try close fd with _ -> ()
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
(* own code starts here
|
2018-04-25 11:15:53 +00:00
|
|
|
(c) 2017, 2018 Hannes Mehnert, all rights reserved *)
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2019-01-20 21:17:59 +00:00
|
|
|
let dump, restore =
|
|
|
|
let open R.Infix in
|
|
|
|
(fun data ->
|
2019-10-29 22:37:42 +00:00
|
|
|
let state_file = Fpath.(!dbdir / "state") in
|
2019-01-20 21:17:59 +00:00
|
|
|
Bos.OS.File.exists state_file >>= fun exists ->
|
|
|
|
(if exists then begin
|
|
|
|
let bak = Fpath.(state_file + "bak") in
|
|
|
|
Bos.OS.U.(error_to_msg @@ rename state_file bak)
|
|
|
|
end else Ok ()) >>= fun () ->
|
|
|
|
Bos.OS.File.write state_file (Cstruct.to_string data)),
|
|
|
|
(fun () ->
|
2019-10-29 22:37:42 +00:00
|
|
|
let state_file = Fpath.(!dbdir / "state") in
|
2019-01-20 21:17:59 +00:00
|
|
|
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)
|
|
|
|
|
2019-10-29 22:37:42 +00:00
|
|
|
let block_sub = "block"
|
2018-11-11 01:33:00 +00:00
|
|
|
|
|
|
|
let block_file name =
|
|
|
|
let file = Name.to_string name in
|
2019-10-29 22:37:42 +00:00
|
|
|
Fpath.(!dbdir / block_sub / file)
|
2018-11-11 01:33:00 +00:00
|
|
|
|
2017-05-26 14:30:34 +00:00
|
|
|
let rec mkfifo name =
|
2018-01-15 23:55:26 +00:00
|
|
|
try Unix.mkfifo (Fpath.to_string name) 0o640 with
|
2017-05-26 14:30:34 +00:00
|
|
|
| Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
|
|
|
|
|
|
|
|
let rec fifo_exists file =
|
|
|
|
try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
|
|
|
|
| Unix.Unix_error (Unix.ENOENT, _, _) -> Error (`Msg "noent")
|
|
|
|
| Unix.Unix_error (Unix.EINTR, _, _) -> fifo_exists file
|
|
|
|
| Unix.Unix_error (e, _, _) ->
|
|
|
|
R.error_msgf "file %a exists: %s" Fpath.pp file (Unix.error_message e)
|
|
|
|
|
|
|
|
let create_tap bridge =
|
2019-01-20 15:43:18 +00:00
|
|
|
match Lazy.force uname with
|
2019-10-27 18:42:52 +00:00
|
|
|
| FreeBSD ->
|
2017-05-26 14:30:34 +00:00
|
|
|
let cmd = Bos.Cmd.(v "ifconfig" % "tap" % "create") in
|
|
|
|
Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_string >>= fun (name, _) ->
|
|
|
|
Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % bridge % "addm" % name) >>= fun () ->
|
|
|
|
Ok name
|
2019-10-27 18:42:52 +00:00
|
|
|
| Linux ->
|
2017-05-26 14:30:34 +00:00
|
|
|
let prefix = "vmmtap" in
|
|
|
|
let rec find_n x =
|
|
|
|
let nam = prefix ^ string_of_int x in
|
2019-10-27 19:46:07 +00:00
|
|
|
match Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "link" % "show" % nam) with
|
2017-05-26 14:30:34 +00:00
|
|
|
| Error _ -> nam
|
|
|
|
| Ok _ -> find_n (succ x)
|
|
|
|
in
|
|
|
|
let tap = find_n 0 in
|
|
|
|
Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "add" % "mode" % "tap" % tap) >>= fun () ->
|
|
|
|
Bos.OS.Cmd.run Bos.Cmd.(v "brctl" % "addif" % bridge % tap) >>= fun () ->
|
|
|
|
Ok tap
|
|
|
|
|
2019-10-27 18:47:37 +00:00
|
|
|
let destroy_tap tap =
|
|
|
|
let cmd =
|
|
|
|
match Lazy.force uname with
|
|
|
|
| FreeBSD -> Bos.Cmd.(v "ifconfig" % tap % "destroy")
|
|
|
|
| Linux -> Bos.Cmd.(v "ip" % "tuntap" % "del" % "dev" % tap % "mode" % "tap")
|
|
|
|
in
|
|
|
|
Bos.OS.Cmd.run cmd
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2019-10-27 19:46:07 +00:00
|
|
|
type solo5_target = Spt | Hvt
|
|
|
|
|
|
|
|
let solo5_image_target image =
|
|
|
|
check_solo5_cmd "solo5-elftool" >>= fun cmd ->
|
|
|
|
let cmd = Bos.Cmd.(cmd % "query-abi" % p image) in
|
|
|
|
Bos.OS.Cmd.(run_out cmd |> out_string) >>= fun (s, _) ->
|
|
|
|
R.error_to_msg ~pp_error:Jsonm.pp_error
|
|
|
|
(Vmm_json.json_of_string s) >>= fun data ->
|
|
|
|
Vmm_json.find_string_value "target" data >>= function
|
|
|
|
| "spt" -> Ok Spt | "hvt" -> Ok Hvt
|
|
|
|
| x -> R.error_msgf "unsupported solo5 target %s" x
|
|
|
|
|
|
|
|
let solo5_tender = function Spt -> "solo5-spt" | Hvt -> "solo5-hvt"
|
|
|
|
|
2018-10-22 22:54:05 +00:00
|
|
|
let prepare name vm =
|
2019-10-11 21:40:27 +00:00
|
|
|
(match vm.Unikernel.typ with
|
|
|
|
| `Solo5 ->
|
|
|
|
if vm.Unikernel.compressed then
|
2019-10-27 18:47:37 +00:00
|
|
|
match Vmm_compress.uncompress (Cstruct.to_string vm.Unikernel.image) with
|
|
|
|
| Ok blob -> Ok (Cstruct.of_string blob)
|
|
|
|
| Error () -> Error (`Msg "failed to uncompress")
|
2019-10-11 21:40:27 +00:00
|
|
|
else
|
|
|
|
Ok vm.Unikernel.image) >>= fun image ->
|
2019-10-27 19:46:07 +00:00
|
|
|
let filename = Name.image_file name in
|
|
|
|
Bos.OS.File.write filename (Cstruct.to_string image) >>= fun () ->
|
|
|
|
solo5_image_target filename >>= fun target ->
|
|
|
|
check_solo5_cmd (solo5_tender target) >>= fun _ ->
|
2018-11-11 00:21:12 +00:00
|
|
|
let fifo = Name.fifo_file name in
|
2019-10-27 18:47:37 +00:00
|
|
|
begin match fifo_exists fifo with
|
|
|
|
| Ok true -> Ok ()
|
|
|
|
| Ok false -> R.error_msgf "file %a exists and is not a fifo" Fpath.pp fifo
|
|
|
|
| Error _ ->
|
|
|
|
try Ok (mkfifo fifo) with
|
|
|
|
| Unix.Unix_error (e, f, _) ->
|
2019-10-27 19:46:07 +00:00
|
|
|
R.error_msgf "file %a error in %s: %a" Fpath.pp fifo f pp_unix_err e
|
2019-10-27 18:47:37 +00:00
|
|
|
end >>= fun () ->
|
2017-05-26 14:30:34 +00:00
|
|
|
List.fold_left (fun acc b ->
|
|
|
|
acc >>= fun acc ->
|
|
|
|
create_tap b >>= fun tap ->
|
|
|
|
Ok (tap :: acc))
|
2019-09-28 17:09:45 +00:00
|
|
|
(Ok []) vm.Unikernel.bridges >>= fun taps ->
|
revise force-restart: now with wait for kill and resource cleanup before start
allows to cleanup various hacks, such as checking for pid in vmm_resources
or removing temporarily the allocated resources from the resource map in vmm_engine
semantics is now slightly different, but for sure enhanced.
- each VM has a Lwt.wait () task attached in Vmm_engine.t (tasks : 'c String.Map.t)
- normal create shouldn't be much different, apart from memoizing the sleeper
- after waitpid is done in vmmd, and vmm_engine.shutdown succeeded, Lwt.wakeup is called for the sleeper
- force create now:
- checks static policies
- looks for existing VM (and task), if present: kill and wait for task in vmmd
- continue with presence checking of vm name, dynamic policies, allocate resources (tap, img, fifo)
this means the whole randomness in filenames can be removed, and the
communication between vmm_console and vmm_client is working again (attach/detach
could not work since vmm_console knew only about "albatross.AAA.BBB.RANDOM",
whereas vmm_client insisted on "AAA.BBB"
resource overcommitment (and races in e.g. block device closing + opening) are
gone now, only if the old vm is cleanup up, resources for the new one are
allocated and it is executed
2018-04-04 23:02:45 +00:00
|
|
|
Ok (List.rev taps)
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2019-01-20 22:02:01 +00:00
|
|
|
let vm_device vm =
|
|
|
|
match Lazy.force uname with
|
2019-10-27 18:42:52 +00:00
|
|
|
| FreeBSD -> Ok ("solo5-" ^ string_of_int vm.Unikernel.pid)
|
|
|
|
| _ -> Error (`Msg "don't know what you mean (trying to find vm device)")
|
2019-01-20 22:02:01 +00:00
|
|
|
|
2019-10-11 21:04:51 +00:00
|
|
|
let free_system_resources name taps =
|
|
|
|
(* same order as prepare! *)
|
|
|
|
Bos.OS.File.delete (Name.image_file name) >>= fun () ->
|
|
|
|
Bos.OS.File.delete (Name.fifo_file name) >>= fun () ->
|
|
|
|
List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) taps
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
let cpuset cpu =
|
|
|
|
let cpustring = string_of_int cpu in
|
2019-01-20 15:43:18 +00:00
|
|
|
match Lazy.force uname with
|
2019-10-27 18:42:52 +00:00
|
|
|
| FreeBSD -> Ok ([ "cpuset" ; "-l" ; cpustring ])
|
|
|
|
| Linux -> Ok ([ "taskset" ; "-c" ; cpustring ])
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2019-09-28 17:09:45 +00:00
|
|
|
let exec name config bridge_taps blocks =
|
2019-10-11 22:20:58 +00:00
|
|
|
let net, macs =
|
|
|
|
List.split
|
|
|
|
(List.map (fun (bridge, tap) ->
|
|
|
|
let mac = Name.mac name bridge in
|
|
|
|
"--net:" ^ bridge ^ "=" ^ tap,
|
|
|
|
"--net-mac:" ^ bridge ^ "=" ^ Macaddr.to_string mac)
|
|
|
|
bridge_taps)
|
2019-09-28 17:09:45 +00:00
|
|
|
and blocks = List.map (fun (name, dev) -> "--disk:" ^ name ^ "=" ^ Fpath.to_string (block_file dev)) blocks
|
2019-01-20 19:35:26 +00:00
|
|
|
and argv = match config.Unikernel.argv with None -> [] | Some xs -> xs
|
|
|
|
and mem = "--mem=" ^ string_of_int config.Unikernel.memory
|
2018-11-10 00:02:07 +00:00
|
|
|
in
|
2019-01-20 19:35:26 +00:00
|
|
|
cpuset config.Unikernel.cpuid >>= fun cpuset ->
|
2019-10-27 19:46:07 +00:00
|
|
|
let filename = Name.image_file name in
|
|
|
|
solo5_image_target filename >>= fun target ->
|
|
|
|
check_solo5_cmd (solo5_tender target) >>= fun tender ->
|
revise force-restart: now with wait for kill and resource cleanup before start
allows to cleanup various hacks, such as checking for pid in vmm_resources
or removing temporarily the allocated resources from the resource map in vmm_engine
semantics is now slightly different, but for sure enhanced.
- each VM has a Lwt.wait () task attached in Vmm_engine.t (tasks : 'c String.Map.t)
- normal create shouldn't be much different, apart from memoizing the sleeper
- after waitpid is done in vmmd, and vmm_engine.shutdown succeeded, Lwt.wakeup is called for the sleeper
- force create now:
- checks static policies
- looks for existing VM (and task), if present: kill and wait for task in vmmd
- continue with presence checking of vm name, dynamic policies, allocate resources (tap, img, fifo)
this means the whole randomness in filenames can be removed, and the
communication between vmm_console and vmm_client is working again (attach/detach
could not work since vmm_console knew only about "albatross.AAA.BBB.RANDOM",
whereas vmm_client insisted on "AAA.BBB"
resource overcommitment (and races in e.g. block device closing + opening) are
gone now, only if the old vm is cleanup up, resources for the new one are
allocated and it is executed
2018-04-04 23:02:45 +00:00
|
|
|
let cmd =
|
2019-10-27 19:46:07 +00:00
|
|
|
Bos.Cmd.(of_list cpuset %% tender % mem %%
|
2019-10-11 22:20:58 +00:00
|
|
|
of_list net %% of_list macs %% of_list blocks %
|
2018-11-11 00:21:12 +00:00
|
|
|
"--" % p (Name.image_file name) %% of_list argv)
|
revise force-restart: now with wait for kill and resource cleanup before start
allows to cleanup various hacks, such as checking for pid in vmm_resources
or removing temporarily the allocated resources from the resource map in vmm_engine
semantics is now slightly different, but for sure enhanced.
- each VM has a Lwt.wait () task attached in Vmm_engine.t (tasks : 'c String.Map.t)
- normal create shouldn't be much different, apart from memoizing the sleeper
- after waitpid is done in vmmd, and vmm_engine.shutdown succeeded, Lwt.wakeup is called for the sleeper
- force create now:
- checks static policies
- looks for existing VM (and task), if present: kill and wait for task in vmmd
- continue with presence checking of vm name, dynamic policies, allocate resources (tap, img, fifo)
this means the whole randomness in filenames can be removed, and the
communication between vmm_console and vmm_client is working again (attach/detach
could not work since vmm_console knew only about "albatross.AAA.BBB.RANDOM",
whereas vmm_client insisted on "AAA.BBB"
resource overcommitment (and races in e.g. block device closing + opening) are
gone now, only if the old vm is cleanup up, resources for the new one are
allocated and it is executed
2018-04-04 23:02:45 +00:00
|
|
|
in
|
2017-05-26 14:30:34 +00:00
|
|
|
let line = Bos.Cmd.to_list cmd in
|
|
|
|
let prog = try List.hd line with Failure _ -> failwith err_empty_line in
|
|
|
|
let line = Array.of_list line in
|
2018-11-11 00:21:12 +00:00
|
|
|
let fifo = Name.fifo_file name in
|
2017-05-26 14:30:34 +00:00
|
|
|
Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo);
|
|
|
|
write_fd_for_file fifo >>= fun stdout ->
|
|
|
|
Logs.debug (fun m -> m "opened file descriptor!");
|
|
|
|
try
|
|
|
|
Logs.debug (fun m -> m "creating process");
|
2019-01-18 15:33:27 +00:00
|
|
|
let pid = create_process prog line stdout in
|
2017-05-26 14:30:34 +00:00
|
|
|
Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ;
|
2019-01-18 15:33:27 +00:00
|
|
|
(* we gave a copy (well, two copies) of that file descriptor to the solo5
|
|
|
|
process and don't really need it here anymore... *)
|
2019-01-27 15:46:49 +00:00
|
|
|
close_no_err stdout ;
|
2019-09-28 17:09:45 +00:00
|
|
|
let taps = snd (List.split bridge_taps) in
|
2019-01-18 15:33:27 +00:00
|
|
|
Ok Unikernel.{ config ; cmd ; pid ; taps }
|
2017-05-26 14:30:34 +00:00
|
|
|
with
|
|
|
|
Unix.Unix_error (e, _, _) ->
|
|
|
|
close_no_err stdout;
|
2019-10-27 18:47:37 +00:00
|
|
|
R.error_msgf "cmd %a exits: %a" Bos.Cmd.pp cmd pp_unix_err e
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2019-01-20 19:37:30 +00:00
|
|
|
let destroy vm = Unix.kill vm.Unikernel.pid Sys.sigterm
|
2018-11-10 00:02:07 +00:00
|
|
|
|
|
|
|
let bytes_of_mb size =
|
|
|
|
let res = size lsl 20 in
|
|
|
|
if res > size then
|
|
|
|
Ok res
|
|
|
|
else
|
|
|
|
Error (`Msg "overflow while computing bytes")
|
|
|
|
|
|
|
|
let create_block name size =
|
2018-11-11 01:33:00 +00:00
|
|
|
let block_name = block_file name in
|
2018-11-10 00:02:07 +00:00
|
|
|
Bos.OS.File.exists block_name >>= function
|
|
|
|
| true -> Error (`Msg "file already exists")
|
|
|
|
| false ->
|
2018-12-06 23:07:16 +00:00
|
|
|
let fd = Unix.(openfile (Fpath.to_string block_name) [O_CREAT] 0o600) in
|
|
|
|
close_no_err fd ;
|
2018-11-10 00:02:07 +00:00
|
|
|
bytes_of_mb size >>= fun size' ->
|
|
|
|
Bos.OS.File.truncate block_name size'
|
|
|
|
|
|
|
|
let destroy_block name =
|
2018-11-11 01:33:00 +00:00
|
|
|
Bos.OS.File.delete (block_file name)
|
2018-11-10 00:02:07 +00:00
|
|
|
|
|
|
|
let mb_of_bytes size =
|
|
|
|
if size = 0 || size land 0xFFFFF <> 0 then
|
|
|
|
Error (`Msg "size is either 0 or not MB aligned")
|
|
|
|
else
|
|
|
|
Ok (size lsr 20)
|
|
|
|
|
|
|
|
let find_block_devices () =
|
2019-10-29 22:37:42 +00:00
|
|
|
let blockdir = Fpath.(!dbdir / block_sub) in
|
2018-11-10 00:02:07 +00:00
|
|
|
Bos.OS.Dir.contents ~rel:true blockdir >>= fun files ->
|
|
|
|
List.fold_left (fun acc file ->
|
|
|
|
acc >>= fun acc ->
|
|
|
|
let path = Fpath.append blockdir file in
|
|
|
|
Bos.OS.File.exists path >>= function
|
|
|
|
| false ->
|
|
|
|
Logs.warn (fun m -> m "file %a doesn't exist, but was listed" Fpath.pp path) ;
|
|
|
|
Ok acc
|
|
|
|
| true ->
|
|
|
|
Bos.OS.Path.stat path >>= fun stats ->
|
2018-11-11 00:21:12 +00:00
|
|
|
match mb_of_bytes stats.Unix.st_size, Name.of_string (Fpath.to_string file) with
|
|
|
|
| Error (`Msg msg), _ ->
|
|
|
|
Logs.warn (fun m -> m "file %a size error: %s" Fpath.pp path msg) ;
|
|
|
|
Ok acc
|
|
|
|
| _, Error (`Msg msg) ->
|
|
|
|
Logs.warn (fun m -> m "file %a name error: %s" Fpath.pp path msg) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
Ok acc
|
2018-11-11 00:21:12 +00:00
|
|
|
| Ok size, Ok id ->
|
2018-11-10 00:02:07 +00:00
|
|
|
Ok ((id, size) :: acc))
|
|
|
|
(Ok []) files
|