patrick.sirref.org
this repo has no description
vendor
+2000
+22
vendor/void/.github/workflows/test.yml
+22
vendor/void/.github/workflows/test.yml
···
1
+
name: Void Test
2
+
on:
3
+
- push
4
+
- pull_request
5
+
permissions: read-all
6
+
jobs:
7
+
build:
8
+
strategy:
9
+
fail-fast: false
10
+
runs-on: ubuntu-latest
11
+
steps:
12
+
- name: Checkout tree
13
+
uses: actions/checkout@v4
14
+
15
+
- name: Set-up OCaml
16
+
uses: ocaml/setup-ocaml@v3
17
+
with:
18
+
ocaml-compiler: 5
19
+
20
+
- run: opam install . --deps-only --with-test
21
+
- run: opam exec -- dune build
22
+
- run: sudo ./_build/default/examples/hey.exe
+1
vendor/void/.ocamlformat
+1
vendor/void/.ocamlformat
···
1
+
version=0.27.0
+14
vendor/void/LICENSE.md
+14
vendor/void/LICENSE.md
···
1
+
Copyright (C) 2024 Patrick Ferris
2
+
3
+
Permission to use, copy, modify, and 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.
4
+
5
+
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.
6
+
7
+
Much of the codebase is borrowed directly from Eio, with the following license:
8
+
9
+
Copyright (C) 2021 Anil Madhavapeddy
10
+
Copyright (C) 2022 Thomas Leonard
11
+
12
+
Permission to use, copy, modify, and 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.
13
+
14
+
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.
+29
vendor/void/dune-project
+29
vendor/void/dune-project
···
1
+
(lang dune 3.15)
2
+
3
+
(name void)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(source
8
+
(github patricoferris/void))
9
+
10
+
(authors "Patrick Ferris")
11
+
12
+
(maintainers "Patrick Ferris")
13
+
14
+
(license MIT)
15
+
16
+
(documentation https://ocaml.org/p/void)
17
+
18
+
(package
19
+
(name void)
20
+
(synopsis "Void Processes in Eio_linux")
21
+
(description "A longer description")
22
+
(depends
23
+
ocaml
24
+
dune
25
+
eio_posix)
26
+
(tags
27
+
(linux process spawn)))
28
+
29
+
; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project
+69
vendor/void/examples/alpine.ml
+69
vendor/void/examples/alpine.ml
···
1
+
open Eio.Std
2
+
3
+
let ( / ) = Eio.Path.( / )
4
+
5
+
let test_data fs data =
6
+
let tempdir = Filename.temp_dir "void-" "-alpine" in
7
+
Eio.Path.(save ~create:(`If_missing 0o644) (fs / tempdir / "data.txt") data);
8
+
Eio.traceln "Test data in %s" tempdir;
9
+
tempdir
10
+
11
+
let get_alpine_image ~fs ~proc =
12
+
let tmpdir = Filename.temp_dir "void" "alpine" in
13
+
Eio.traceln "Extracting alpine to %s..." tmpdir;
14
+
let container_id =
15
+
Eio.Process.parse_out proc Eio.Buf_read.take_all
16
+
[ "docker"; "run"; "-d"; "alpine" ]
17
+
|> String.trim
18
+
in
19
+
Eio.traceln "Container %s" container_id;
20
+
let () =
21
+
Eio.Process.run proc
22
+
[
23
+
"docker";
24
+
"export";
25
+
container_id;
26
+
"-o";
27
+
Filename.concat tmpdir "alpine.tar.gz";
28
+
]
29
+
in
30
+
Eio.traceln "Untarring...";
31
+
Eio.Path.mkdir ~perm:0o777 (fs / tmpdir / "rootfs");
32
+
let () =
33
+
Eio.Process.run proc
34
+
[
35
+
"tar";
36
+
"-xf";
37
+
Filename.concat tmpdir "alpine.tar.gz";
38
+
"-C";
39
+
Filename.concat tmpdir "rootfs";
40
+
]
41
+
in
42
+
Filename.concat tmpdir "rootfs"
43
+
44
+
(* This example read-only mounts a copy of busybox
45
+
into the root-filesystem of the process. *)
46
+
let () =
47
+
Eio_posix.run @@ fun env ->
48
+
Switch.run @@ fun sw ->
49
+
let fs = env#fs in
50
+
let proc = env#process_mgr in
51
+
let alpine_img = get_alpine_image ~fs ~proc in
52
+
let mount_src = test_data fs "Hello, World!" in
53
+
let open Void in
54
+
let args =
55
+
let l = Array.length Sys.argv in
56
+
if l <= 1 then
57
+
[
58
+
"/bin/ash"; "-c"; "/bin/echo hello > /hello.txt && /bin/cat /hello.txt";
59
+
]
60
+
else Array.sub Sys.argv 1 (l - 1) |> Array.to_list
61
+
in
62
+
let void =
63
+
empty |> rootfs ~mode:RW alpine_img
64
+
|> mount ~mode:R ~src:mount_src ~tgt:"data"
65
+
|> exec args
66
+
in
67
+
let t = Void.spawn ~sw void in
68
+
let status = Promise.await (Void.exit_status t) in
69
+
Eio.traceln "Status: %s" (Void.exit_status_to_string status)
+55
vendor/void/examples/curl.ml
+55
vendor/void/examples/curl.ml
···
1
+
open Eio.Std
2
+
3
+
let ( / ) = Eio.Path.( / )
4
+
5
+
let get_alpine_image ~fs ~proc =
6
+
let tmpdir = Filename.temp_dir "void-" "-alpine-curl" in
7
+
Eio.traceln "Extracting alpine/curl to %s..." tmpdir;
8
+
let container_id =
9
+
Eio.Process.parse_out proc Eio.Buf_read.take_all
10
+
[ "docker"; "run"; "-d"; "alpine/curl" ]
11
+
|> String.trim
12
+
in
13
+
Eio.traceln "Container %s" container_id;
14
+
let () =
15
+
Eio.Process.run proc
16
+
[
17
+
"docker";
18
+
"export";
19
+
container_id;
20
+
"-o";
21
+
Filename.concat tmpdir "alpine-curl.tar.gz";
22
+
]
23
+
in
24
+
Eio.traceln "Untarring...";
25
+
Eio.Path.mkdir ~perm:0o777 (fs / tmpdir / "rootfs");
26
+
let () =
27
+
Eio.Process.run proc
28
+
[
29
+
"tar";
30
+
"-xf";
31
+
Filename.concat tmpdir "alpine-curl.tar.gz";
32
+
"-C";
33
+
Filename.concat tmpdir "rootfs";
34
+
]
35
+
in
36
+
Filename.concat tmpdir "rootfs"
37
+
38
+
(* This example read-only mounts a copy of busybox
39
+
into the root-filesystem of the process. *)
40
+
let () =
41
+
Eio_posix.run @@ fun env ->
42
+
Switch.run @@ fun sw ->
43
+
let fs = env#fs in
44
+
let proc = env#process_mgr in
45
+
let alpine_img = get_alpine_image ~fs ~proc in
46
+
let open Void in
47
+
let args =
48
+
let l = Array.length Sys.argv in
49
+
if l <= 1 then [ "/bin/ls"; "-l" ]
50
+
else Array.sub Sys.argv 1 (l - 1) |> Array.to_list
51
+
in
52
+
let void = empty |> rootfs ~mode:R alpine_img |> exec args in
53
+
let t = Void.spawn ~sw void in
54
+
let status = Promise.await (Void.exit_status t) in
55
+
Eio.traceln "Status: %s" (Void.exit_status_to_string status)
+3
vendor/void/examples/dune
+3
vendor/void/examples/dune
+11
vendor/void/examples/empty.ml
+11
vendor/void/examples/empty.ml
···
1
+
open Eio.Std
2
+
3
+
let () =
4
+
Eio_linux.run @@ fun _env ->
5
+
Switch.run @@ fun sw ->
6
+
let open Void in
7
+
let void = empty |> exec [] in
8
+
Eio.traceln "Spawning the empty void...";
9
+
let t = Void.spawn ~sw void in
10
+
let status = Promise.await (Void.exit_status t) in
11
+
Eio.traceln "Status: %s" (Void.exit_status_to_string status)
vendor/void/examples/hey
vendor/void/examples/hey
This is a binary file and will not be displayed.
+11
vendor/void/examples/hey.c
+11
vendor/void/examples/hey.c
···
1
+
// Based off of Docker's hello-world
2
+
// This is standalone program
3
+
#include <sys/syscall.h>
4
+
#include <unistd.h>
5
+
6
+
const char message[] = "Hello from the Void!\n";
7
+
8
+
int main() {
9
+
syscall(SYS_write, STDOUT_FILENO, message, sizeof(message) - 1);
10
+
return 0;
11
+
}
+22
vendor/void/examples/hey.ml
+22
vendor/void/examples/hey.ml
···
1
+
open Eio.Std
2
+
3
+
let ( / ) = Eio.Path.( / )
4
+
5
+
let copy_hey fs =
6
+
let temp_dir = Filename.temp_dir "void-" "-world" in
7
+
let hey = Eio.Path.load (fs / "./examples/hey") in
8
+
Eio.Path.save ~create:(`If_missing 0o755) (fs / temp_dir / "hey") hey;
9
+
temp_dir
10
+
11
+
(* This mounts the hello-world into the void process. *)
12
+
let () =
13
+
Eio_posix.run @@ fun env ->
14
+
Switch.run @@ fun sw ->
15
+
let hey_dir = copy_hey env#fs in
16
+
let void =
17
+
let open Void in
18
+
empty |> mount ~mode:R ~src:hey_dir ~tgt:"say" |> exec [ "/say/hey" ]
19
+
in
20
+
let t = Void.spawn ~sw void in
21
+
let status = Promise.await (Void.exit_status t) in
22
+
Eio.traceln "Void process: %s" (Void.exit_status_to_string status)
+13
vendor/void/src/dune
+13
vendor/void/src/dune
+57
vendor/void/src/include/discover.ml
+57
vendor/void/src/include/discover.ml
···
1
+
module C = Configurator.V1
2
+
3
+
let () =
4
+
C.main ~name:"discover" (fun c ->
5
+
let defs, mount_flags =
6
+
C.C_define.import c ~c_flags:[ "-D_GNU_SOURCE" ]
7
+
~includes:[ "linux/sched.h"; "sys/mount.h" ]
8
+
C.C_define.Type.
9
+
[
10
+
(* Clone3 Flags *)
11
+
("CLONE_PIDFD", Int);
12
+
("CLONE_NEWPID", Int);
13
+
("CLONE_NEWCGROUP", Int);
14
+
("CLONE_NEWNS", Int);
15
+
("CLONE_NEWIPC", Int);
16
+
("CLONE_NEWNET", Int);
17
+
("CLONE_NEWTIME", Int);
18
+
("CLONE_NEWUSER", Int);
19
+
("CLONE_NEWUTS", Int);
20
+
(* Mount Flags *)
21
+
("MS_RDONLY", Int);
22
+
("MS_REMOUNT", Int);
23
+
("MS_BIND", Int);
24
+
("MS_SHARED", Int);
25
+
]
26
+
|> List.fold_left
27
+
(fun (cls, mnts) -> function
28
+
| name, C.C_define.Value.Int v ->
29
+
let t = (String.lowercase_ascii name, v) in
30
+
if String.starts_with ~prefix:"CLONE" name then
31
+
(t :: cls, mnts)
32
+
else (cls, t :: mnts)
33
+
| _ -> assert false)
34
+
([], [])
35
+
in
36
+
let sigs vs =
37
+
List.map (fun (name, _) -> Printf.sprintf " val %s : t" name) vs
38
+
in
39
+
let structs vs =
40
+
List.map (fun (name, v) -> Printf.sprintf " let %s = 0x%x" name v) vs
41
+
in
42
+
let flags_nspace =
43
+
List.filter (String.starts_with ~prefix:"clone_new") (List.map fst defs)
44
+
in
45
+
let mount =
46
+
[ "module Mount_flags : sig"; " type t = int" ]
47
+
@ sigs mount_flags
48
+
@ [ "end = struct"; " type t = int" ]
49
+
@ structs mount_flags @ [ "end" ]
50
+
in
51
+
C.Flags.write_lines "config.ml"
52
+
([ "module Clone_flags : sig"; " type t = int" ]
53
+
@ sigs defs @ [ "val all : t list" ]
54
+
@ [ "end = struct"; " type t = int" ]
55
+
@ structs defs
56
+
@ [ "let all = [" ^ String.concat ";" flags_nspace ^ "]" ]
57
+
@ [ "end" ] @ mount))
+4
vendor/void/src/include/dune
+4
vendor/void/src/include/dune
+202
vendor/void/src/void.ml
+202
vendor/void/src/void.ml
···
1
+
open Eio.Std
2
+
module Process = Eio_posix.Low_level.Process
3
+
module Trace = Eio.Private.Trace
4
+
module Fd = Eio_unix.Fd
5
+
module Rcfd = Eio_unix.Private.Rcfd
6
+
module Fork_action = Eio_unix.Private.Fork_action
7
+
8
+
type mode = R | RW
9
+
10
+
type void = {
11
+
args : string list;
12
+
rootfs : (string * mode) option;
13
+
mounts : mount list;
14
+
}
15
+
16
+
and mount = { src : string; tgt : string; mode : int [@warning "-69"] }
17
+
18
+
(* Actions for namespacing *)
19
+
module Mount = struct
20
+
module Flags = struct
21
+
include Config.Mount_flags
22
+
23
+
let empty : t = 0
24
+
let ( + ) = ( lor )
25
+
end
26
+
27
+
module Types = struct
28
+
type t = string
29
+
30
+
let btrfs = "btrfs"
31
+
let ext4 = "ext4"
32
+
let auto = "auto"
33
+
end
34
+
end
35
+
36
+
external action_mount : unit -> Fork_action.fork_fn = "void_fork_mount"
37
+
38
+
let action_mount = action_mount ()
39
+
40
+
let _mount ~(src : string) ~(target : string) (type_ : Mount.Types.t)
41
+
(flags : Mount.Flags.t) =
42
+
Fork_action.
43
+
{ run = (fun k -> k (Obj.repr (action_mount, src, target, type_, flags))) }
44
+
45
+
external action_pivot_root : unit -> Fork_action.fork_fn
46
+
= "void_fork_pivot_root"
47
+
48
+
let action_pivot_root = action_pivot_root ()
49
+
50
+
let pivot_root (new_root : string) (new_root_flags : Mount.Flags.t)
51
+
(tmpfs : bool) (mounts : mount list) =
52
+
Fork_action.
53
+
{
54
+
run =
55
+
(fun k ->
56
+
k
57
+
(Obj.repr
58
+
(action_pivot_root, new_root, new_root_flags, tmpfs, mounts)));
59
+
}
60
+
61
+
external action_map_uid_gid : unit -> Fork_action.fork_fn
62
+
= "void_fork_map_uid_gid"
63
+
64
+
let action_map_uid_gid = action_map_uid_gid ()
65
+
66
+
let map_uid_gid ~uid ~gid =
67
+
Fork_action.{ run = (fun k -> k (Obj.repr (action_map_uid_gid, uid, gid))) }
68
+
69
+
module Flags = struct
70
+
include Config.Clone_flags
71
+
72
+
let ( + ) = ( lor )
73
+
end
74
+
75
+
external eio_spawn :
76
+
Unix.file_descr ->
77
+
Flags.t ->
78
+
Eio_unix.Private.Fork_action.c_action list ->
79
+
int * Unix.file_descr = "caml_void_clone3"
80
+
81
+
type t = {
82
+
pid : int;
83
+
pid_fd : Fd.t;
84
+
exit_status : Unix.process_status Promise.t;
85
+
}
86
+
87
+
let exit_status t = t.exit_status
88
+
let pid t = t.pid
89
+
90
+
(* Read a (typically short) error message from a child process. *)
91
+
let rec read_response fd =
92
+
let buf = Cstruct.create 256 in
93
+
match Eio_posix.Low_level.readv fd [| buf |] with
94
+
| 0 | (exception End_of_file) -> ""
95
+
| len -> Cstruct.to_string buf ~len ^ read_response fd
96
+
97
+
let void_flags = List.fold_left Flags.( + ) 0 Flags.all
98
+
99
+
type path = string
100
+
101
+
let empty = { args = []; rootfs = None; mounts = [] }
102
+
103
+
let actions v : Fork_action.t list =
104
+
let root, tmpfs, root_mode =
105
+
match v.rootfs with
106
+
| None -> (Filename.temp_dir "void-" "-tmpdir", true, R)
107
+
| Some (s, m) -> (s, false, m)
108
+
in
109
+
let args = match v.args with [] -> failwith "No exec" | args -> args in
110
+
let e =
111
+
Process.Fork_action.execve (List.hd args) ~env:[||]
112
+
~argv:(Array.of_list args)
113
+
in
114
+
(* Process mount point points *)
115
+
let mounts =
116
+
List.map
117
+
(fun mnt ->
118
+
let src = Filename.concat "/.old_root" mnt.src in
119
+
let tgt = Filename.concat "/" mnt.tgt in
120
+
{ mnt with tgt; src })
121
+
v.mounts
122
+
in
123
+
let root_flags =
124
+
if root_mode = R then Mount.Flags.ms_rdonly else Mount.Flags.empty
125
+
in
126
+
let mounts = pivot_root root root_flags tmpfs mounts in
127
+
let uid, gid = Unix.(getuid (), getgid ()) in
128
+
let user_namespace = map_uid_gid ~uid ~gid in
129
+
[ user_namespace; mounts; e ]
130
+
131
+
let rootfs ~mode path v = { v with rootfs = Some (path, mode) }
132
+
let exec args v = { v with args }
133
+
134
+
let mount ~mode ~src ~tgt v =
135
+
let mode = if mode = R then Mount.Flags.ms_rdonly else Mount.Flags.empty in
136
+
{ v with mounts = { src; tgt; mode } :: v.mounts }
137
+
138
+
(* From eio_linux/eio_posix *)
139
+
let with_pipe fn =
140
+
Switch.run @@ fun sw ->
141
+
let r, w = Eio_posix.Low_level.pipe ~sw in
142
+
fn r w
143
+
144
+
external pidfd_send_signal : Unix.file_descr -> int -> unit
145
+
= "caml_void_pidfd_send_signal"
146
+
147
+
let signal t signum =
148
+
Fd.use t.pid_fd ~if_closed:Fun.id @@ fun pid_fd ->
149
+
pidfd_send_signal pid_fd signum
150
+
151
+
let rec waitpid pid =
152
+
match Unix.waitpid [] pid with
153
+
| p, status ->
154
+
assert (p = pid);
155
+
status
156
+
| exception Unix.Unix_error (EINTR, _, _) -> waitpid pid
157
+
158
+
let spawn ~sw v =
159
+
with_pipe @@ fun errors_r errors_w ->
160
+
Eio_unix.Private.Fork_action.with_actions (actions v) @@ fun c_actions ->
161
+
Switch.check sw;
162
+
let exit_status, set_exit_status = Promise.create () in
163
+
let t =
164
+
let pid, pid_fd =
165
+
Fd.use_exn "errors-w" errors_w @@ fun errors_w ->
166
+
Eio.Private.Trace.with_span "spawn" @@ fun () ->
167
+
let flags = Flags.(clone_pidfd + void_flags) in
168
+
eio_spawn errors_w flags c_actions
169
+
in
170
+
let pid_fd = Fd.of_unix ~sw ~seekable:false ~close_unix:true pid_fd in
171
+
{ pid; pid_fd; exit_status }
172
+
in
173
+
Fd.close errors_w;
174
+
Fiber.fork_daemon ~sw (fun () ->
175
+
let cleanup () =
176
+
Fd.close t.pid_fd;
177
+
Promise.resolve set_exit_status (waitpid t.pid);
178
+
`Stop_daemon
179
+
in
180
+
match Eio_posix.Low_level.await_readable "void_spawn" t.pid_fd with
181
+
| () -> Eio.Cancel.protect cleanup
182
+
| exception Eio.Cancel.Cancelled _ ->
183
+
Eio.Cancel.protect (fun () ->
184
+
Printf.eprintf "Cancelled?";
185
+
signal t Sys.sigkill;
186
+
Eio_posix.Low_level.await_readable "void_spawn" t.pid_fd;
187
+
cleanup ()));
188
+
(* Check for errors starting the process. *)
189
+
match read_response errors_r with
190
+
| "" -> t (* Success! Execing the child closed [errors_w] and we got EOF. *)
191
+
| err -> failwith err
192
+
193
+
let to_eio_status t =
194
+
match t with
195
+
| Unix.WEXITED i -> `Exited i
196
+
| Unix.WSIGNALED i -> `Signaled i
197
+
| Unix.WSTOPPED _ -> assert false
198
+
199
+
let exit_status_to_string = function
200
+
| Unix.WEXITED n -> Printf.sprintf "Exited with %i" n
201
+
| Unix.WSTOPPED n -> Printf.sprintf "Stopped with %i" n
202
+
| Unix.WSIGNALED n -> Printf.sprintf "Signalled with %i" n
+61
vendor/void/src/void.mli
+61
vendor/void/src/void.mli
···
1
+
(** {1 Void}
2
+
3
+
Void is a library to provide {e void processes}. A void process is an
4
+
{e empty} process, one in which most global resources have been removed. As
5
+
a user, you can add back in precisely those pieces you need for your
6
+
process.
7
+
8
+
Void uses Eio's [fork_action]s to provide this mechanism, thus it is only
9
+
available with Eio. *)
10
+
11
+
module Mount : sig
12
+
module Flags : sig
13
+
type t = private int
14
+
15
+
val ms_remount : t
16
+
val ms_bind : t
17
+
val ms_shared : t
18
+
val ( + ) : t -> t -> t
19
+
end
20
+
21
+
module Types : sig
22
+
type t = private string
23
+
24
+
val btrfs : t
25
+
val ext4 : t
26
+
val auto : t
27
+
end
28
+
end
29
+
30
+
type t
31
+
(** A void process *)
32
+
33
+
type path = string
34
+
(** File paths *)
35
+
36
+
type mode = R | RW
37
+
(* Mounting modes *)
38
+
39
+
type void
40
+
(** A configuration for a void process *)
41
+
42
+
val empty : void
43
+
(** The empty void *)
44
+
45
+
val rootfs : mode:mode -> path -> void -> void
46
+
(** Add a new root filesystem *)
47
+
48
+
val mount : mode:mode -> src:path -> tgt:path -> void -> void
49
+
50
+
val exec : string list -> void -> void
51
+
(** Make a void configuration ready to be spawned *)
52
+
53
+
val spawn : sw:Eio.Switch.t -> void -> t
54
+
(** Spawn a void process *)
55
+
56
+
val pid : t -> int
57
+
(** The pid of a running void process *)
58
+
59
+
val exit_status : t -> Unix.process_status Eio.Promise.t
60
+
val exit_status_to_string : Unix.process_status -> string
61
+
val to_eio_status : Unix.process_status -> Eio.Process.exit_status
+399
vendor/void/src/void_action.c
+399
vendor/void/src/void_action.c
···
1
+
#define _GNU_SOURCE
2
+
#define _FILE_OFFSET_BITS 64
3
+
#include <linux/sched.h>
4
+
5
+
#include <sys/stat.h>
6
+
#include <sys/types.h>
7
+
#include <sys/eventfd.h>
8
+
#if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24
9
+
#include <sys/random.h>
10
+
#endif
11
+
#include <sys/syscall.h>
12
+
#include <sys/wait.h>
13
+
#include <sys/mount.h>
14
+
#include <limits.h>
15
+
#include <errno.h>
16
+
#include <dirent.h>
17
+
#include <fcntl.h>
18
+
#include <signal.h>
19
+
#include <unistd.h>
20
+
#include <string.h>
21
+
22
+
23
+
#include <caml/mlvalues.h>
24
+
#include <caml/unixsupport.h>
25
+
#include <caml/memory.h>
26
+
#include <caml/custom.h>
27
+
#include <caml/fail.h>
28
+
29
+
// From Eio
30
+
#include <include/fork_action.h>
31
+
32
+
#ifndef SYS_pidfd_send_signal
33
+
#define SYS_pidfd_send_signal 424
34
+
#endif
35
+
36
+
// struct clone_args isn't defined in linux-lts headers, so define it here
37
+
// Note that this struct is versioned by size. See linux/sched.h for details
38
+
struct caml_void_clone_args
39
+
{
40
+
uint64_t flags;
41
+
uint64_t pidfd;
42
+
uint64_t child_tid;
43
+
uint64_t parent_tid;
44
+
uint64_t exit_signal;
45
+
uint64_t stack;
46
+
uint64_t stack_size;
47
+
uint64_t tls;
48
+
};
49
+
50
+
static int
51
+
pidfd_send_signal (int pidfd, int sig, siginfo_t *info, unsigned int flags)
52
+
{
53
+
return syscall (SYS_pidfd_send_signal, pidfd, sig, info, flags);
54
+
}
55
+
56
+
CAMLprim value
57
+
caml_void_pidfd_send_signal (value v_pidfd, value v_signal)
58
+
{
59
+
CAMLparam0 ();
60
+
int res;
61
+
62
+
res =
63
+
pidfd_send_signal (Int_val (v_pidfd),
64
+
caml_convert_signal_number (Int_val (v_signal)), NULL,
65
+
0);
66
+
if (res == -1)
67
+
uerror ("pidfd_send_signal", Nothing);
68
+
CAMLreturn (Val_unit);
69
+
}
70
+
71
+
static pid_t
72
+
clone3_no_fallback (struct caml_void_clone_args *cl_args)
73
+
{
74
+
int *pidfd = (int *) (uintptr_t) cl_args->pidfd;
75
+
pid_t child_pid =
76
+
syscall (SYS_clone3, cl_args, sizeof (struct caml_void_clone_args));
77
+
78
+
if (child_pid >= 0)
79
+
return child_pid; /* Success! */
80
+
81
+
if (errno != ENOSYS && errno != EPERM)
82
+
{
83
+
uerror ("clone3", Nothing); /* Unknown error */
84
+
}
85
+
86
+
uerror ("clone3", Nothing);
87
+
}
88
+
89
+
CAMLprim value
90
+
caml_void_clone3 (value v_errors, value v_flags, value v_actions)
91
+
{
92
+
CAMLparam1 (v_actions);
93
+
CAMLlocal1 (v_result);
94
+
pid_t child_pid;
95
+
int pidfd = -1; /* Is automatically close-on-exec */
96
+
97
+
struct caml_void_clone_args cl_args = {
98
+
.flags = Int_val (v_flags),
99
+
.pidfd = (uintptr_t) & pidfd,
100
+
.exit_signal = SIGCHLD, /* Needed for wait4 to work if we exit before exec */
101
+
.stack = (uintptr_t) NULL, /* Use copy-on-write parent stack */
102
+
.stack_size = 0,
103
+
};
104
+
105
+
child_pid = clone3_no_fallback (&cl_args);
106
+
if (child_pid == 0)
107
+
{
108
+
/* Run child actions (doesn't return) */
109
+
eio_unix_run_fork_actions (Int_val (v_errors), v_actions);
110
+
}
111
+
112
+
v_result = caml_alloc_tuple (2);
113
+
Store_field (v_result, 0, Val_long (child_pid));
114
+
Store_field (v_result, 1, Val_int (pidfd));
115
+
116
+
CAMLreturn (v_result);
117
+
}
118
+
119
+
120
+
// Actions
121
+
122
+
// MOUNT/UNMOUNT
123
+
static void
124
+
action_mount (int errors, value v_config)
125
+
{
126
+
value v_src = Field (v_config, 1);
127
+
value v_tgt = Field (v_config, 2);
128
+
value v_type = Field (v_config, 3);
129
+
value v_flags = Field (v_config, 4);
130
+
131
+
int r;
132
+
133
+
r =
134
+
mount (String_val (v_src), String_val (v_tgt), String_val (v_type),
135
+
Int_val (v_flags), NULL);
136
+
137
+
if (r != 0)
138
+
{
139
+
eio_unix_fork_error (errors, "mount", strerror (errno));
140
+
_exit (1);
141
+
}
142
+
}
143
+
144
+
CAMLprim value
145
+
void_fork_mount (value v_unit)
146
+
{
147
+
return Val_fork_fn (action_mount);
148
+
}
149
+
150
+
// Writes a single line to a file
151
+
static int
152
+
put_line (const char *filename, const char *line)
153
+
{
154
+
int fd;
155
+
int written;
156
+
157
+
fd = open (filename, O_WRONLY | O_CLOEXEC | O_CREAT | O_TRUNC, 0644);
158
+
159
+
if (fd < 0)
160
+
{
161
+
return fd;
162
+
}
163
+
164
+
written = write (fd, line, strlen (line));
165
+
166
+
close (fd);
167
+
168
+
if (written != strlen (line))
169
+
{
170
+
return -1;
171
+
}
172
+
173
+
return 0;
174
+
}
175
+
176
+
// MAP UID/GID to root
177
+
static void
178
+
action_map_uid_gid (int errors, value v_config)
179
+
{
180
+
value v_uid = Field (v_config, 1);
181
+
value v_gid = Field (v_config, 2);
182
+
int result;
183
+
char uid_line[30];
184
+
char gid_line[30];
185
+
186
+
// We map root onto the calling UID
187
+
snprintf (uid_line, sizeof (uid_line), "0 %i 1\n", Int_val (v_uid));
188
+
result = put_line ("/proc/self/uid_map", uid_line);
189
+
190
+
if (result < 0)
191
+
{
192
+
eio_unix_fork_error (errors, "map_uid_gid-uid", strerror (errno));
193
+
_exit (1);
194
+
}
195
+
196
+
/* From user_namespaces(7)
197
+
*
198
+
* Writing "deny" to the /proc/pid/setgroups file before writing to
199
+
* /proc/pid/gid_map will permanently disable setgroups(2) in a user
200
+
* namespace and allow writing to /proc/pid/gid_map without having
201
+
* the CAP_SETGID capability in the parent user namespace.
202
+
*
203
+
* See also: https://lwn.net/Articles/626665/ */
204
+
205
+
put_line ("/proc/self/setgroups", "deny\n");
206
+
207
+
if (result < 0)
208
+
{
209
+
eio_unix_fork_error (errors, "map_uid_gid-setgroups", strerror (errno));
210
+
_exit (1);
211
+
}
212
+
213
+
result =
214
+
snprintf (gid_line, sizeof (gid_line), "0 %i 1\n", Int_val (v_gid));
215
+
put_line ("/proc/self/gid_map", gid_line);
216
+
217
+
if (result < 0)
218
+
{
219
+
eio_unix_fork_error (errors, "map_uid_gid-gid", strerror (errno));
220
+
_exit (1);
221
+
}
222
+
}
223
+
224
+
225
+
CAMLprim value
226
+
void_fork_map_uid_gid (value v_unit)
227
+
{
228
+
return Val_fork_fn (action_map_uid_gid);
229
+
}
230
+
231
+
// PIVOT ROOT
232
+
//
233
+
static int
234
+
pivot_root (const char *new_root, const char *put_old)
235
+
{
236
+
return syscall (SYS_pivot_root, new_root, put_old);
237
+
}
238
+
239
+
// Is there too much OCaml stuff going on here for a fork_action ?
240
+
static void
241
+
action_pivot_root (int errors, value v_config)
242
+
{
243
+
value v_new_root = Field (v_config, 1);
244
+
value v_root_flags = Field (v_config, 2);
245
+
value v_no_root = Field (v_config, 3);
246
+
value v_mounts = Field (v_config, 4);
247
+
char path[PATH_MAX];
248
+
char old_root_path[PATH_MAX];
249
+
char *new_root = String_val (v_new_root);
250
+
const char *put_old = ".old_root";
251
+
252
+
// From pivot_root example: We want to change the propagation type
253
+
// of root to be private so we can pivot it.
254
+
if (mount (NULL, "/", NULL, MS_REC | MS_PRIVATE, NULL) == -1)
255
+
{
256
+
eio_unix_fork_error (errors, "pivot_root-private", strerror (errno));
257
+
_exit (1);
258
+
}
259
+
260
+
// If no pivot_root was given, then we tmpfs the tmpdir we assume was passed.
261
+
if (Bool_val (v_no_root))
262
+
{
263
+
// Make a temporary directory... can't because it allocates ?
264
+
//if (mkdtemp(new_root) != NULL) {
265
+
// eio_unix_fork_error(errors, new_root, strerror(errno));
266
+
// _exit(1);
267
+
//}
268
+
269
+
if (mount ("tmpfs", new_root, "tmpfs", 0, NULL) <= -1)
270
+
{
271
+
eio_unix_fork_error (errors, "pivot_root-tmpfs", strerror (errno));
272
+
_exit (1);
273
+
}
274
+
}
275
+
else
276
+
{
277
+
// From pivot_root example: we check that new_root is indeed a mountpoint
278
+
if (mount (new_root, new_root, NULL, MS_BIND, NULL) <= -1)
279
+
{
280
+
eio_unix_fork_error (errors, "pivot_root-new_root",
281
+
strerror (errno));
282
+
_exit (1);
283
+
}
284
+
}
285
+
286
+
// Make the place to pivot the old root too, under the new root
287
+
snprintf (old_root_path, sizeof (path), "%s/%s", new_root, put_old);
288
+
289
+
if (mkdir (old_root_path, 0777) == -1)
290
+
{
291
+
eio_unix_fork_error (errors, "pivot_root-mkdir-put_old",
292
+
strerror (errno));
293
+
_exit (1);
294
+
}
295
+
296
+
// Pivot the root
297
+
if (pivot_root (new_root, old_root_path))
298
+
{
299
+
eio_unix_fork_error (errors, "pivot_root", strerror (errno));
300
+
_exit (1);
301
+
}
302
+
303
+
// Add mounts
304
+
value current_mount = v_mounts;
305
+
int mount_result;
306
+
int mode;
307
+
while (current_mount != Val_emptylist)
308
+
{
309
+
// TODO: Mode for mounting
310
+
mode = Int_val (Field (Field (current_mount, 0), 2));
311
+
312
+
// A mount is a record {src; tgt; mode}, we first create the mount point
313
+
// directory target
314
+
if (mkdir (String_val (Field (Field (current_mount, 0), 1)), 0777) ==
315
+
-1)
316
+
{
317
+
eio_unix_fork_error (errors, "pivot_root-mkdir-mount",
318
+
strerror (errno));
319
+
_exit (1);
320
+
}
321
+
322
+
mount_result = mount (String_val (Field (Field (current_mount, 0), 0)),
323
+
String_val (Field (Field (current_mount, 0), 1)),
324
+
NULL, MS_REC | MS_BIND, NULL);
325
+
326
+
// Fail early if a mount fails...
327
+
if (mount_result < 0)
328
+
{
329
+
char error[PATH_MAX];
330
+
snprintf (error, sizeof (error), "mount failed: (%s->%s)",
331
+
String_val (Field (Field (current_mount, 0), 0)),
332
+
String_val (Field (Field (current_mount, 0), 1)));
333
+
eio_unix_fork_error (errors, error, strerror (errno));
334
+
_exit (1);
335
+
}
336
+
337
+
// After mounting for the first time, we can come back and add any
338
+
// extra modes that may have been specified, for example RDONLY.
339
+
if (mode != 0)
340
+
{
341
+
mount_result =
342
+
mount (String_val (Field (Field (current_mount, 0), 0)),
343
+
String_val (Field (Field (current_mount, 0), 1)), NULL,
344
+
MS_REMOUNT | MS_BIND | mode, NULL);
345
+
346
+
if (mount_result < 0)
347
+
{
348
+
eio_unix_fork_error (errors, "remount for mode",
349
+
strerror (errno));
350
+
_exit (1);
351
+
}
352
+
}
353
+
354
+
// Next mount in the list
355
+
current_mount = Field (current_mount, 1);
356
+
}
357
+
358
+
359
+
// Change to the 'new' root
360
+
if (chdir ("/") == -1)
361
+
{
362
+
eio_unix_fork_error (errors, "pivot_root-chdir", strerror (errno));
363
+
_exit (1);
364
+
}
365
+
366
+
// Unmount the old root and remove it
367
+
if (umount2 (put_old, MNT_DETACH) == -1)
368
+
{
369
+
eio_unix_fork_error (errors, put_old, strerror (errno));
370
+
_exit (1);
371
+
}
372
+
373
+
// Remove the old root
374
+
if (rmdir (put_old) == -1)
375
+
{
376
+
eio_unix_fork_error (errors, put_old, strerror (errno));
377
+
_exit (1);
378
+
}
379
+
380
+
381
+
// Apply any flags to the new root, e.g. RDONLY
382
+
if (Int_val (v_root_flags))
383
+
{
384
+
if (mount
385
+
("/", "/", NULL, (MS_REMOUNT | MS_BIND | Int_val (v_root_flags)),
386
+
NULL) <= -1)
387
+
{
388
+
eio_unix_fork_error (errors, "pivot_root-rootflags",
389
+
strerror (errno));
390
+
_exit (1);
391
+
}
392
+
}
393
+
}
394
+
395
+
CAMLprim value
396
+
void_fork_pivot_root (value v_unit)
397
+
{
398
+
return Val_fork_fn (action_pivot_root);
399
+
}
+20
vendor/void/test/main.ml
+20
vendor/void/test/main.ml
···
1
+
open Eio.Std
2
+
3
+
let _root_filesystem =
4
+
"/obuilder-zfs/result/fe532e693c6a86db16b50547aae1345b3515c727b8ed668b3e0c33c1e9a895f9/rootfs"
5
+
6
+
let () =
7
+
Eio_posix.run @@ fun _ ->
8
+
Switch.run @@ fun sw ->
9
+
let open Void in
10
+
let void =
11
+
empty
12
+
|> mount ~mode:R ~src:"/tmp/test" ~tgt:"bin"
13
+
|> exec [ "/bin/busybox"; "ls" ]
14
+
in
15
+
let t = Void.spawn ~sw void in
16
+
match Promise.await (Void.exit_status t) with
17
+
| Unix.WEXITED 0 -> print_endline "done"
18
+
| Unix.WEXITED n -> Printf.printf "Exited with %i\n%!" n
19
+
| Unix.WSTOPPED n -> Printf.printf "Stopped with %i\n%!" n
20
+
| Unix.WSIGNALED n -> Printf.printf "Signalled with %i\n%!" n
+32
vendor/void/void.opam
+32
vendor/void/void.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Void Processes in Eio_linux"
4
+
description: "A longer description"
5
+
maintainer: ["Patrick Ferris"]
6
+
authors: ["Patrick Ferris"]
7
+
license: "MIT"
8
+
tags: ["linux" "process" "spawn"]
9
+
homepage: "https://github.com/patricoferris/void"
10
+
doc: "https://ocaml.org/p/void"
11
+
bug-reports: "https://github.com/patricoferris/void/issues"
12
+
depends: [
13
+
"ocaml"
14
+
"dune" {>= "3.15"}
15
+
"eio_posix"
16
+
"odoc" {with-doc}
17
+
]
18
+
build: [
19
+
["dune" "subst"] {dev}
20
+
[
21
+
"dune"
22
+
"build"
23
+
"-p"
24
+
name
25
+
"-j"
26
+
jobs
27
+
"@install"
28
+
"@runtest" {with-test}
29
+
"@doc" {with-doc}
30
+
]
31
+
]
32
+
dev-repo: "git+https://github.com/patricoferris/void.git"
+1
vendor/zfs/.ocamlformat
+1
vendor/zfs/.ocamlformat
···
1
+
version=0.27.0
+12
vendor/zfs/README.md
+12
vendor/zfs/README.md
···
1
+
ocaml-zfs
2
+
---------
3
+
4
+
Some very partial and very probably broken bindings to `libzfs`.
5
+
6
+
<!-- $MDX file=example/main.ml -->
7
+
```ocaml
8
+
let () =
9
+
let handle = Zfs.init () in
10
+
let props = [ ("compression", `String "lz4") ] in
11
+
Zfs.create ~props handle "obuilder-zfs/hello" Zfs.Types.filesystem
12
+
```
+1
vendor/zfs/dune
+1
vendor/zfs/dune
···
1
+
(mdx)
+31
vendor/zfs/dune-project
+31
vendor/zfs/dune-project
···
1
+
(lang dune 3.15)
2
+
(using mdx 0.4)
3
+
(using ctypes 0.3)
4
+
5
+
(name zfs)
6
+
7
+
(generate_opam_files true)
8
+
9
+
(source
10
+
(github patricoferris/ocaml-zfs))
11
+
12
+
(authors "Patrick Ferris <patrick@sirref.org>")
13
+
14
+
(maintainers "Patrick Ferris <patrick@sirref.org>")
15
+
16
+
(license ISC)
17
+
18
+
19
+
(package
20
+
(name zfs)
21
+
(synopsis "libzfs bindings")
22
+
(description "OCaml bindings to libzfs")
23
+
(depends
24
+
ocaml
25
+
dune
26
+
ctypes
27
+
(mdx :with-test))
28
+
(tags
29
+
("filesystem" "zfs")))
30
+
31
+
; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project
+4
vendor/zfs/example/main.ml
+4
vendor/zfs/example/main.ml
+38
vendor/zfs/src/dune
+38
vendor/zfs/src/dune
···
1
+
(rule
2
+
(targets config.ml c_flags.sexp c_library_flags.sexp)
3
+
(action
4
+
(run ./include/discover.exe)))
5
+
6
+
(library
7
+
(name zfs)
8
+
(public_name zfs)
9
+
(libraries unix)
10
+
(c_library_flags
11
+
(:include c_library_flags.sexp))
12
+
(flags
13
+
(:standard -w -9-27))
14
+
(ctypes
15
+
(external_library_name libzfs)
16
+
(build_flags_resolver
17
+
(vendored
18
+
(c_flags
19
+
:standard
20
+
-D_GNU_SOURCE
21
+
(:include c_flags.sexp))))
22
+
(headers
23
+
(include
24
+
"unistd.h"
25
+
"stdio.h"
26
+
"stdint.h"
27
+
"stdbool.h"
28
+
"libzfs_core.h"
29
+
"libzfs.h"))
30
+
(type_description
31
+
(instance Types)
32
+
(functor Type_description))
33
+
(function_description
34
+
(concurrency unlocked)
35
+
(instance Functions)
36
+
(functor Function_description))
37
+
(generated_types Types_generated)
38
+
(generated_entry_point C)))
+99
vendor/zfs/src/function_description.ml
+99
vendor/zfs/src/function_description.ml
···
1
+
open Ctypes
2
+
3
+
(* This Types_generated module is an instantiation of the Types
4
+
functor defined in the type_description.ml file. It's generated by
5
+
a C program that Dune creates and runs behind the scenes. *)
6
+
module Types = Types_generated
7
+
8
+
module Functions (F : Ctypes.FOREIGN) = struct
9
+
open F
10
+
11
+
let init = foreign "libzfs_init" (void @-> returning Types.libzfs_handle_t)
12
+
let errno = foreign "libzfs_errno" (Types.libzfs_handle_t @-> returning int)
13
+
14
+
let debug =
15
+
foreign "libzfs_print_on_error"
16
+
(Types.libzfs_handle_t @-> bool @-> returning void)
17
+
18
+
module Zpool = struct
19
+
let open_ =
20
+
foreign "zpool_open"
21
+
(Types.libzfs_handle_t @-> string @-> returning Types.zpool_handle_t)
22
+
23
+
let close = foreign "zpool_close" (Types.zpool_handle_t @-> returning void)
24
+
25
+
let get_name =
26
+
foreign "zpool_get_name" (Types.zpool_handle_t @-> returning string)
27
+
28
+
let get_state =
29
+
foreign "zpool_get_state" (Types.zpool_handle_t @-> returning int)
30
+
end
31
+
32
+
let create_ancestors =
33
+
foreign "zfs_create_ancestors" (Types.libzfs_handle_t @-> string @-> returning int)
34
+
35
+
let create =
36
+
foreign "zfs_create"
37
+
(Types.libzfs_handle_t @-> string @-> int @-> ptr Types.nvlist_t
38
+
@-> returning int)
39
+
40
+
let open_ =
41
+
foreign "zfs_open"
42
+
(Types.libzfs_handle_t @-> string @-> int @-> returning Types.zfs_handle_t)
43
+
44
+
let mount =
45
+
foreign "zfs_mount" (Types.zfs_handle_t @-> string @-> int @-> returning int)
46
+
47
+
let unmount =
48
+
foreign "zfs_unmount"
49
+
(Types.zfs_handle_t @-> string @-> int @-> returning int)
50
+
51
+
let close = foreign "zfs_close" (Types.zfs_handle_t @-> returning void)
52
+
let get_type = foreign "zfs_get_type" (Types.zfs_handle_t @-> returning int)
53
+
54
+
module Nvlist = struct
55
+
let alloc =
56
+
foreign "nvlist_alloc"
57
+
(ptr (ptr Types.nvlist_t) @-> int @-> int @-> returning int)
58
+
59
+
let free = foreign "nvlist_free" (ptr Types.nvlist_t @-> returning void)
60
+
61
+
let add_bool =
62
+
foreign "nvlist_add_boolean_value"
63
+
(ptr Types.nvlist_t @-> string @-> bool @-> returning int)
64
+
65
+
let add_string =
66
+
foreign "nvlist_add_string"
67
+
(ptr Types.nvlist_t @-> string @-> string @-> returning int)
68
+
69
+
let add_byte =
70
+
foreign "nvlist_add_byte"
71
+
(ptr Types.nvlist_t @-> string @-> uchar @-> returning int)
72
+
73
+
let add_int64 =
74
+
foreign "nvlist_add_int64"
75
+
(ptr Types.nvlist_t @-> string @-> int64_t @-> returning int)
76
+
end
77
+
78
+
let clone =
79
+
foreign "zfs_clone"
80
+
(Types.zfs_handle_t @-> string @-> ptr Types.nvlist_t @-> returning int)
81
+
82
+
let snapshot =
83
+
foreign "zfs_snapshot"
84
+
(Types.libzfs_handle_t @-> string @-> bool @-> ptr Types.nvlist_t
85
+
@-> returning int)
86
+
87
+
let exists =
88
+
foreign "zfs_dataset_exists"
89
+
(Types.libzfs_handle_t @-> string @-> int @-> returning bool)
90
+
91
+
let is_mounted =
92
+
foreign "is_mounted"
93
+
(Types.libzfs_handle_t @-> string @-> ptr string @-> returning bool)
94
+
95
+
let diff =
96
+
foreign "zfs_show_diffs"
97
+
(Types.zfs_handle_t @-> int @-> string @-> string_opt @-> int
98
+
@-> returning int)
99
+
end
+209
vendor/zfs/src/include/discover.ml
+209
vendor/zfs/src/include/discover.ml
···
1
+
module C = Configurator.V1
2
+
3
+
let starts_with ~prefix s =
4
+
try
5
+
String.iteri
6
+
(fun i c -> if Char.equal (String.get s i) c then () else raise Not_found)
7
+
prefix;
8
+
let l = String.length s in
9
+
let o = String.length prefix in
10
+
Some (String.sub s o (l - o))
11
+
with Not_found -> None
12
+
13
+
let () =
14
+
C.main ~name:"discover" (fun c ->
15
+
let pkgconf =
16
+
C.Pkg_config.get c |> function
17
+
| Some p -> p
18
+
| None -> failwith "Need pkgconfig"
19
+
in
20
+
match C.Pkg_config.query pkgconf ~package:"libzfs" with
21
+
| None -> failwith "Pkgconfig failed to find libzfs"
22
+
| Some conf ->
23
+
C.Flags.write_sexp "c_flags.sexp" conf.cflags;
24
+
C.Flags.write_sexp "c_library_flags.sexp" conf.libs;
25
+
let errs, props, types =
26
+
C.C_define.import c
27
+
~c_flags:("-D_GNU_SOURCE" :: conf.cflags)
28
+
~includes:
29
+
[
30
+
"unistd.h";
31
+
"stdio.h";
32
+
"stdint.h";
33
+
"stdbool.h";
34
+
"libzfs_core.h";
35
+
"libzfs.h";
36
+
]
37
+
C.C_define.Type.
38
+
[
39
+
(* Errors *)
40
+
("EZFS_SUCCESS", Int);
41
+
("EZFS_NOMEM", Int);
42
+
("EZFS_BADPROP", Int);
43
+
("EZFS_PROPREADONLY", Int);
44
+
("EZFS_PROPTYPE", Int);
45
+
("EZFS_PROPNONINHERIT", Int);
46
+
("EZFS_PROPSPACE", Int);
47
+
("EZFS_BADTYPE", Int);
48
+
("EZFS_BUSY", Int);
49
+
("EZFS_EXISTS", Int);
50
+
("EZFS_NOENT", Int);
51
+
("EZFS_BADSTREAM", Int);
52
+
("EZFS_DSREADONLY", Int);
53
+
("EZFS_VOLTOOBIG", Int);
54
+
("EZFS_INVALIDNAME", Int);
55
+
("EZFS_BADRESTORE", Int);
56
+
("EZFS_BADBACKUP", Int);
57
+
("EZFS_BADTARGET", Int);
58
+
("EZFS_NODEVICE", Int);
59
+
("EZFS_BADDEV", Int);
60
+
("EZFS_NOREPLICAS", Int);
61
+
("EZFS_RESILVERING", Int);
62
+
("EZFS_BADVERSION", Int);
63
+
("EZFS_POOLUNAVAIL", Int);
64
+
("EZFS_DEVOVERFLOW", Int);
65
+
("EZFS_BADPATH", Int);
66
+
("EZFS_CROSSTARGET", Int);
67
+
("EZFS_ZONED", Int);
68
+
("EZFS_MOUNTFAILED", Int);
69
+
("EZFS_UMOUNTFAILED", Int);
70
+
("EZFS_UNSHARENFSFAILED", Int);
71
+
("EZFS_SHARENFSFAILED", Int);
72
+
("EZFS_PERM", Int);
73
+
("EZFS_NOSPC", Int);
74
+
("EZFS_FAULT", Int);
75
+
("EZFS_IO", Int);
76
+
("EZFS_INTR", Int);
77
+
("EZFS_ISSPARE", Int);
78
+
("EZFS_INVALCONFIG", Int);
79
+
("EZFS_RECURSIVE", Int);
80
+
("EZFS_NOHISTORY", Int);
81
+
("EZFS_POOLPROPS", Int);
82
+
("EZFS_POOL_NOTSUP", Int);
83
+
("EZFS_POOL_INVALARG", Int);
84
+
("EZFS_NAMETOOLONG", Int);
85
+
("EZFS_OPENFAILED", Int);
86
+
("EZFS_NOCAP", Int);
87
+
("EZFS_LABELFAILED", Int);
88
+
("EZFS_BADWHO", Int);
89
+
("EZFS_BADPERM", Int);
90
+
("EZFS_BADPERMSET", Int);
91
+
("EZFS_NODELEGATION", Int);
92
+
("EZFS_UNSHARESMBFAILED", Int);
93
+
("EZFS_SHARESMBFAILED", Int);
94
+
("EZFS_BADCACHE", Int);
95
+
("EZFS_ISL2CACHE", Int);
96
+
("EZFS_VDEVNOTSUP", Int);
97
+
("EZFS_NOTSUP", Int);
98
+
("EZFS_ACTIVE_SPARE", Int);
99
+
("EZFS_UNPLAYED_LOGS", Int);
100
+
("EZFS_REFTAG_RELE", Int);
101
+
("EZFS_REFTAG_HOLD", Int);
102
+
("EZFS_TAGTOOLONG", Int);
103
+
("EZFS_PIPEFAILED", Int);
104
+
("EZFS_THREADCREATEFAILED", Int);
105
+
("EZFS_POSTSPLIT_ONLINE", Int);
106
+
("EZFS_SCRUBBING", Int);
107
+
("EZFS_ERRORSCRUBBING", Int);
108
+
("EZFS_ERRORSCRUB_PAUSED", Int);
109
+
("EZFS_NO_SCRUB", Int);
110
+
("EZFS_DIFF", Int);
111
+
("EZFS_DIFFDATA", Int);
112
+
("EZFS_POOLREADONLY", Int);
113
+
("EZFS_SCRUB_PAUSED", Int);
114
+
("EZFS_SCRUB_PAUSED_TO_CANCEL", Int);
115
+
("EZFS_ACTIVE_POOL", Int);
116
+
("EZFS_CRYPTOFAILED", Int);
117
+
("EZFS_NO_PENDING", Int);
118
+
("EZFS_CHECKPOINT_EXISTS", Int);
119
+
("EZFS_DISCARDING_CHECKPOINT", Int);
120
+
("EZFS_NO_CHECKPOINT", Int);
121
+
("EZFS_DEVRM_IN_PROGRESS", Int);
122
+
("EZFS_VDEV_TOO_BIG", Int);
123
+
("EZFS_IOC_NOTSUPPORTED", Int);
124
+
("EZFS_TOOMANY", Int);
125
+
("EZFS_INITIALIZING", Int);
126
+
("EZFS_NO_INITIALIZE", Int);
127
+
("EZFS_WRONG_PARENT", Int);
128
+
("EZFS_TRIMMING", Int);
129
+
("EZFS_NO_TRIM", Int);
130
+
("EZFS_TRIM_NOTSUP", Int);
131
+
("EZFS_NO_RESILVER_DEFER", Int);
132
+
("EZFS_EXPORT_IN_PROGRESS", Int);
133
+
("EZFS_REBUILDING", Int);
134
+
("EZFS_VDEV_NOTSUP", Int);
135
+
("EZFS_NOT_USER_NAMESPACE", Int);
136
+
("EZFS_CKSUM", Int);
137
+
("EZFS_RESUME_EXISTS", Int);
138
+
("EZFS_SHAREFAILED", Int);
139
+
("EZFS_UNKNOWN", Int);
140
+
(* Properties *)
141
+
("ZFS_PROP_CREATION", Int);
142
+
("ZFS_PROP_USED", Int);
143
+
("ZFS_PROP_AVAILABLE", Int);
144
+
("ZFS_PROP_REFERENCED", Int);
145
+
("ZFS_PROP_COMPRESSRATIO", Int);
146
+
("ZFS_PROP_COMPRESSION", Int);
147
+
("ZFS_PROP_SNAPDIR", Int);
148
+
("ZFS_PROP_ENCRYPTION", Int);
149
+
(* Types *)
150
+
("ZFS_TYPE_INVALID", Int);
151
+
("ZFS_TYPE_FILESYSTEM", Int);
152
+
("ZFS_TYPE_SNAPSHOT", Int);
153
+
("ZFS_TYPE_VOLUME", Int);
154
+
("ZFS_TYPE_POOL", Int);
155
+
("ZFS_TYPE_BOOKMARK", Int);
156
+
("ZFS_TYPE_VDEV", Int);
157
+
("ZFS_TYPE_DATASET", Int);
158
+
]
159
+
|> List.fold_left
160
+
(fun (errs, props, types) -> function
161
+
| name, C.C_define.Value.Int v -> (
162
+
let type_ name =
163
+
Printf.sprintf "val %s : t"
164
+
(String.lowercase_ascii name)
165
+
in
166
+
let definition name =
167
+
Printf.sprintf "let %s : t = 0x%x"
168
+
(String.lowercase_ascii name)
169
+
v
170
+
in
171
+
match starts_with ~prefix:"EZFS_" name with
172
+
| Some r ->
173
+
((type_ r, definition r) :: errs, props, types)
174
+
| None -> (
175
+
match starts_with ~prefix:"ZFS_PROP_" name with
176
+
| Some r ->
177
+
(errs, (type_ r, definition r) :: props, types)
178
+
| None -> (
179
+
match starts_with ~prefix:"ZFS_TYPE_" name with
180
+
| Some t ->
181
+
( errs,
182
+
props,
183
+
(type_ t, definition t) :: types )
184
+
| None -> failwith "Unknown ZFS static value")))
185
+
| _ -> assert false)
186
+
([], [], [])
187
+
in
188
+
let with_module ~name defs =
189
+
[ Printf.sprintf "module %s = struct\n type t = int\n" name ]
190
+
@ defs @ [ "end" ]
191
+
in
192
+
let with_module_type ~name defs =
193
+
[
194
+
Printf.sprintf "module type %s = sig\n type t = private int\n"
195
+
name;
196
+
]
197
+
@ defs @ [ "end" ]
198
+
in
199
+
let defs =
200
+
with_module ~name:"Error" (List.map snd errs)
201
+
@ with_module ~name:"Props" (List.map snd props)
202
+
@ with_module ~name:"Types" (List.map snd types)
203
+
in
204
+
let types =
205
+
with_module_type ~name:"ERROR" (List.map fst errs)
206
+
@ with_module_type ~name:"PROPS" (List.map fst props)
207
+
@ with_module_type ~name:"TYPES" (List.map fst types)
208
+
in
209
+
C.Flags.write_lines "config.ml" (defs @ types))
+4
vendor/zfs/src/include/dune
+4
vendor/zfs/src/include/dune
+31
vendor/zfs/src/type_description.ml
+31
vendor/zfs/src/type_description.ml
···
1
+
module Types (F : Ctypes.TYPE) = struct
2
+
open F
3
+
4
+
type libzfs_handle_t
5
+
6
+
let libzfs_handle_t :
7
+
libzfs_handle_t Ctypes_static.structure Ctypes_static.ptr typ =
8
+
ptr @@ structure "libzfs_handle"
9
+
10
+
type zpool_handle_t
11
+
12
+
let zpool_handle_t :
13
+
zpool_handle_t Ctypes_static.structure Ctypes_static.ptr typ =
14
+
ptr @@ structure "zpool_handle"
15
+
16
+
type zfs_handle_t
17
+
18
+
let zfs_handle_t : zfs_handle_t Ctypes_static.structure Ctypes_static.ptr typ
19
+
=
20
+
ptr @@ structure "zfs_handle"
21
+
22
+
type nvlist_t
23
+
24
+
let nvlist_t : nvlist_t Ctypes_static.structure typ = structure "nvlist"
25
+
let nvl_version = field nvlist_t "nvl_version" int32_t
26
+
let nvl_nvflag = field nvlist_t "nvl_nvflag" uint32_t
27
+
let nvl_priv = field nvlist_t "nvl_priv" uint64_t
28
+
let nvl_flag = field nvlist_t "nvl_flag" uint32_t
29
+
let nvl_pad = field nvlist_t "nvl_pad" int32_t
30
+
let () = seal nvlist_t
31
+
end
+142
vendor/zfs/src/zfs.ml
+142
vendor/zfs/src/zfs.ml
···
1
+
module Error = struct
2
+
include Config.Error
3
+
end
4
+
5
+
module Flags = struct
6
+
type t = int
7
+
8
+
let empty = 0
9
+
let of_int x = x
10
+
let ( + ) = ( lor )
11
+
let mem a b = a land b = a
12
+
end
13
+
14
+
module Types = struct
15
+
include Flags
16
+
17
+
let vdev = Config.Types.vdev
18
+
let pool = Config.Types.pool
19
+
let volume = Config.Types.volume
20
+
let invalid = Config.Types.invalid
21
+
let bookmark = Config.Types.bookmark
22
+
let snapshot = Config.Types.snapshot
23
+
let filesystem = Config.Types.filesystem
24
+
let dataset = Config.Types.dataset
25
+
end
26
+
27
+
module Handle = struct
28
+
type t = C.Types.libzfs_handle_t Ctypes_static.structure Ctypes_static.ptr
29
+
end
30
+
31
+
let init : unit -> Handle.t = C.Functions.init
32
+
let debug : Handle.t -> bool -> unit = C.Functions.debug
33
+
let errno : Handle.t -> int = C.Functions.errno
34
+
35
+
module Zpool = struct
36
+
type t = C.Types.zpool_handle_t Ctypes_static.structure Ctypes_static.ptr
37
+
38
+
let open_ = C.Functions.Zpool.open_
39
+
let close = C.Functions.Zpool.close
40
+
let get_name = C.Functions.Zpool.get_name
41
+
end
42
+
43
+
module Nvlist = struct
44
+
type t = C.Types.nvlist_t Ctypes_static.structure Ctypes_static.ptr
45
+
46
+
type nvlist =
47
+
(string
48
+
* [ `Bool of bool
49
+
| `String of string
50
+
| `Byte of Unsigned.uchar
51
+
| `Int64 of int64 ])
52
+
list
53
+
54
+
let check_return i =
55
+
if i = 22 then invalid_arg "Nvlist.v: add bool" else assert (i = 0)
56
+
57
+
let v (schema : nvlist) : t =
58
+
let open Ctypes in
59
+
let finalise v = C.Functions.Nvlist.free !@v in
60
+
let nv_pp =
61
+
allocate ~finalise (ptr C.Types.nvlist_t)
62
+
(from_voidp C.Types.nvlist_t null)
63
+
in
64
+
(* TODO: Unique names or not... *)
65
+
C.Functions.Nvlist.alloc nv_pp 0x1 0 |> check_return;
66
+
let rec aux = function
67
+
| [] -> !@nv_pp
68
+
| (k, `Bool b) :: rest ->
69
+
C.Functions.Nvlist.add_bool !@nv_pp k b |> check_return;
70
+
aux rest
71
+
| (k, `String s) :: rest ->
72
+
C.Functions.Nvlist.add_string !@nv_pp k s |> check_return;
73
+
aux rest
74
+
| (k, `Int64 i64) :: rest ->
75
+
C.Functions.Nvlist.add_int64 !@nv_pp k i64 |> check_return;
76
+
aux rest
77
+
| (k, `Byte u) :: rest ->
78
+
C.Functions.Nvlist.add_byte !@nv_pp k u |> check_return;
79
+
aux rest
80
+
| _ -> assert false
81
+
in
82
+
aux schema
83
+
84
+
let empty = Ctypes.(coerce (ptr void) (ptr C.Types.nvlist_t) null)
85
+
end
86
+
87
+
type t = C.Types.zfs_handle_t Ctypes_static.structure Ctypes_static.ptr
88
+
89
+
let create_ancestors handle path =
90
+
let i = C.Functions.create_ancestors handle path in
91
+
if i != 0 then failwith "Failed to create ancestors" else ()
92
+
93
+
let create ?(props = []) handle path (type_ : Types.t) =
94
+
let i = C.Functions.create handle path type_ (Nvlist.v props) in
95
+
if i != 0 then failwith "Failed to create" else ()
96
+
97
+
let open_ handle path (type_ : Types.t) = C.Functions.open_ handle path type_
98
+
let close : t -> unit = C.Functions.close
99
+
let get_type : t -> Types.t = C.Functions.get_type
100
+
101
+
let clone ?(options = Nvlist.empty) handle path =
102
+
let res = C.Functions.clone handle path options in
103
+
if res = 0 then () else invalid_arg "clone"
104
+
105
+
let snapshot ?(options = Nvlist.empty) handle path b =
106
+
let res = C.Functions.snapshot handle path b options in
107
+
if res = 0 then () else invalid_arg "snapshot"
108
+
109
+
let exists handle path (type_ : Types.t) = C.Functions.exists handle path type_
110
+
111
+
let is_mounted handle path =
112
+
let where = Ctypes.allocate Ctypes.string "" in
113
+
let v = C.Functions.is_mounted handle path where in
114
+
if not v then None else Some (Ctypes.( !@ ) where)
115
+
116
+
let null_string = Ctypes.(coerce (ptr void) (ptr char) null)
117
+
118
+
let mount ?mount_opts ?(mount_flags = 0) dataset =
119
+
let opts =
120
+
Option.value
121
+
~default:(Ctypes.string_from_ptr null_string ~length:0)
122
+
mount_opts
123
+
in
124
+
let res = C.Functions.mount dataset opts mount_flags in
125
+
if res <> 0 then invalid_arg "mounting dataset"
126
+
127
+
let unmount ?mount_opts ?(mount_flags = 0) dataset =
128
+
let opts =
129
+
Option.value
130
+
~default:(Ctypes.string_from_ptr null_string ~length:0)
131
+
mount_opts
132
+
in
133
+
let res = C.Functions.unmount dataset opts mount_flags in
134
+
if res <> 0 then invalid_arg "unmounting dataset"
135
+
136
+
let show_diff ?to_ handle ~from_ (fd : Unix.file_descr) =
137
+
(* TODO: Other Diff Flags https://github.com/openzfs/zfs/blob/5b0c27cd14bbc07d50304c97735cc105d0258673/include/libzfs.h#L917? *)
138
+
let res = C.Functions.diff handle (Obj.magic fd : int) from_ to_ 1 in
139
+
if res = 0 then () else begin
140
+
Format.printf "Diff got %i\n%!" res;
141
+
invalid_arg "show_diff"
142
+
end
+206
vendor/zfs/src/zfs.mli
+206
vendor/zfs/src/zfs.mli
···
1
+
module Types : sig
2
+
type t = private int
3
+
4
+
val empty : int
5
+
val of_int : 'a -> 'a
6
+
val ( + ) : int -> int -> int
7
+
val mem : int -> int -> bool
8
+
val vdev : t
9
+
val pool : t
10
+
val volume : t
11
+
val invalid : t
12
+
val bookmark : t
13
+
val snapshot : t
14
+
val filesystem : t
15
+
val dataset : t
16
+
end
17
+
18
+
module Handle : sig
19
+
type t
20
+
(** An instance handle for the ZFS library *)
21
+
end
22
+
23
+
val init : unit -> Handle.t
24
+
(** Initialise the library *)
25
+
26
+
val debug : Handle.t -> bool -> unit
27
+
(** Enable/disable printing on error from ZFS *)
28
+
29
+
val errno : Handle.t -> int
30
+
(** Check for errors on the handle *)
31
+
32
+
module Zpool : sig
33
+
type t
34
+
(** A Zpool handle *)
35
+
36
+
val open_ : Handle.t -> string -> t
37
+
(** Open a Zpool *)
38
+
39
+
val close : t -> unit
40
+
(** Close an open Zpool *)
41
+
42
+
val get_name : t -> string
43
+
(** The name of an open Zpool *)
44
+
end
45
+
46
+
module Nvlist : sig
47
+
type t
48
+
(** Generic name-value lists used by ZFS *)
49
+
50
+
type nvlist =
51
+
(string
52
+
* [ `Bool of bool
53
+
| `Byte of Unsigned.uchar
54
+
| `String of string
55
+
| `Int64 of int64 ])
56
+
list
57
+
(** A partial OCaml representation of an NV list *)
58
+
59
+
val v : nvlist -> t
60
+
(** Convert the OCaml representation to the C representation *)
61
+
end
62
+
63
+
type t
64
+
(** A ZFS Dataset *)
65
+
66
+
val create_ancestors : Handle.t -> string -> unit
67
+
(** Often called before {! create} *)
68
+
69
+
val create : ?props:Nvlist.nvlist -> Handle.t -> string -> Types.t -> unit
70
+
(** Create a new ZFS dataset *)
71
+
72
+
val open_ : Handle.t -> string -> Types.t -> t
73
+
(** Open an existing ZFS dataset *)
74
+
75
+
val close : t -> unit
76
+
(** Close a dataset *)
77
+
78
+
val exists : Handle.t -> string -> Types.t -> bool
79
+
(** Check if a dataset of a specific type exists *)
80
+
81
+
val is_mounted : Handle.t -> string -> string option
82
+
(** [is_mounted h d = None] if [d] is not mounted, otherwise
83
+
[is_mounted h d = Some mountpoint]. *)
84
+
85
+
val mount : ?mount_opts:string -> ?mount_flags:int -> t -> unit
86
+
(** Mount a dataset *)
87
+
88
+
val unmount : ?mount_opts:string -> ?mount_flags:int -> t -> unit
89
+
(** Unmount a dataset *)
90
+
91
+
val get_type : t -> Types.t
92
+
(** Get the type of the dataset *)
93
+
94
+
val clone : ?options:Nvlist.t -> t -> string -> unit
95
+
(** Clone an open dataset *)
96
+
97
+
val snapshot : ?options:Nvlist.t -> Handle.t -> string -> bool -> unit
98
+
(** Snapshot a dataset *)
99
+
100
+
val show_diff : ?to_:string -> t -> from_:string -> Unix.file_descr -> unit
101
+
(** Output diff to the file descriptor *)
102
+
103
+
module Error : sig
104
+
type t = int
105
+
106
+
val unknown : t
107
+
val sharefailed : t
108
+
val resume_exists : t
109
+
val cksum : t
110
+
val not_user_namespace : t
111
+
val vdev_notsup : t
112
+
val rebuilding : t
113
+
val export_in_progress : t
114
+
val no_resilver_defer : t
115
+
val trim_notsup : t
116
+
val no_trim : t
117
+
val trimming : t
118
+
val wrong_parent : t
119
+
val no_initialize : t
120
+
val initializing : t
121
+
val toomany : t
122
+
val ioc_notsupported : t
123
+
val vdev_too_big : t
124
+
val devrm_in_progress : t
125
+
val no_checkpoint : t
126
+
val discarding_checkpoint : t
127
+
val checkpoint_exists : t
128
+
val no_pending : t
129
+
val cryptofailed : t
130
+
val active_pool : t
131
+
val scrub_paused_to_cancel : t
132
+
val scrub_paused : t
133
+
val poolreadonly : t
134
+
val diffdata : t
135
+
val diff : t
136
+
val no_scrub : t
137
+
val errorscrub_paused : t
138
+
val errorscrubbing : t
139
+
val scrubbing : t
140
+
val postsplit_online : t
141
+
val threadcreatefailed : t
142
+
val pipefailed : t
143
+
val tagtoolong : t
144
+
val reftag_hold : t
145
+
val reftag_rele : t
146
+
val unplayed_logs : t
147
+
val active_spare : t
148
+
val notsup : t
149
+
val vdevnotsup : t
150
+
val isl2cache : t
151
+
val badcache : t
152
+
val sharesmbfailed : t
153
+
val unsharesmbfailed : t
154
+
val nodelegation : t
155
+
val badpermset : t
156
+
val badperm : t
157
+
val badwho : t
158
+
val labelfailed : t
159
+
val nocap : t
160
+
val openfailed : t
161
+
val nametoolong : t
162
+
val pool_invalarg : t
163
+
val pool_notsup : t
164
+
val poolprops : t
165
+
val nohistory : t
166
+
val recursive : t
167
+
val invalconfig : t
168
+
val isspare : t
169
+
val intr : t
170
+
val io : t
171
+
val fault : t
172
+
val nospc : t
173
+
val perm : t
174
+
val sharenfsfailed : t
175
+
val unsharenfsfailed : t
176
+
val umountfailed : t
177
+
val mountfailed : t
178
+
val zoned : t
179
+
val crosstarget : t
180
+
val badpath : t
181
+
val devoverflow : t
182
+
val poolunavail : t
183
+
val badversion : t
184
+
val resilvering : t
185
+
val noreplicas : t
186
+
val baddev : t
187
+
val nodevice : t
188
+
val badtarget : t
189
+
val badbackup : t
190
+
val badrestore : t
191
+
val invalidname : t
192
+
val voltoobig : t
193
+
val dsreadonly : t
194
+
val badstream : t
195
+
val noent : t
196
+
val exists : t
197
+
val busy : t
198
+
val badtype : t
199
+
val propspace : t
200
+
val propnoninherit : t
201
+
val proptype : t
202
+
val propreadonly : t
203
+
val badprop : t
204
+
val nomem : t
205
+
val success : t
206
+
end
+150
vendor/zfs/src/zfs_stubs.c
+150
vendor/zfs/src/zfs_stubs.c
···
1
+
/*
2
+
* Copyright (C) 2020-2021 Anil Madhavapeddy
3
+
* Copyright (C) 2020-2021 Sadiq Jaffer
4
+
* Copyright (C) 2022 Christiano Haesbaert
5
+
*
6
+
* Permission to use, copy, modify, and distribute this software for any
7
+
* purpose with or without fee is hereby granted, provided that the above
8
+
* copyright notice and this permission notice appear in all copies.
9
+
*
10
+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
11
+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
12
+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
13
+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
14
+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
15
+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
16
+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
17
+
*/
18
+
19
+
#include <unistd.h>
20
+
#include <stdio.h>
21
+
#include <stdint.h>
22
+
#include <stdbool.h>
23
+
24
+
#include <libzfs_core.h>
25
+
#include <libzfs.h>
26
+
#include <caml/alloc.h>
27
+
#include <caml/bigarray.h>
28
+
#include <caml/callback.h>
29
+
#include <caml/custom.h>
30
+
#include <caml/fail.h>
31
+
#include <caml/memory.h>
32
+
#include <caml/mlvalues.h>
33
+
#include <caml/signals.h>
34
+
#include <caml/unixsupport.h>
35
+
#include <caml/socketaddr.h>
36
+
37
+
#undef ZFS_DEBUG
38
+
#ifdef ZFS_DEBUG
39
+
#define dprintf(fmt, ...) fprintf(stderr, fmt, ##__VA_ARGS__)
40
+
#else
41
+
#define dprintf(fmt, ...) ((void)0)
42
+
#endif
43
+
44
+
value ocaml_zfs_prop_is_string(value v_prop){
45
+
int res;
46
+
res = zfs_prop_is_string(Int_val(v_prop));
47
+
if (res < 0) {
48
+
caml_failwith("Error occurred!");
49
+
}
50
+
return Val_bool(res);
51
+
}
52
+
53
+
#define Zfs_list_val(v) (*((struct nv_list **) Data_custom_val(v)))
54
+
#define Zfs_handle_val(v) (*((libzfs_handle_t **) Data_custom_val(v)))
55
+
#define Zfs_pool_val(v) (*((zpool_handle_t **) Data_custom_val(v)))
56
+
57
+
static void finalize_zfs_list(value v) {
58
+
caml_stat_free(Zfs_list_val(v));
59
+
Zfs_list_val(v) = NULL;
60
+
}
61
+
62
+
static struct custom_operations zfs_list_ops = {
63
+
"zfs.zfs_list_ops",
64
+
finalize_zfs_list,
65
+
custom_compare_default,
66
+
custom_hash_default,
67
+
custom_serialize_default,
68
+
custom_deserialize_default,
69
+
custom_compare_ext_default,
70
+
custom_fixed_length_default
71
+
};
72
+
73
+
static void finalize_zfs_handle(value v) {
74
+
caml_stat_free(Zfs_handle_val(v));
75
+
Zfs_handle_val(v) = NULL;
76
+
}
77
+
78
+
static struct custom_operations zfs_handle_ops = {
79
+
"zfs.zfs_handle",
80
+
finalize_zfs_handle,
81
+
custom_compare_default,
82
+
custom_hash_default,
83
+
custom_serialize_default,
84
+
custom_deserialize_default,
85
+
custom_compare_ext_default,
86
+
custom_fixed_length_default
87
+
};
88
+
89
+
static void finalize_zfs_pool(value v) {
90
+
caml_stat_free(Zfs_pool_val(v));
91
+
Zfs_pool_val(v) = NULL;
92
+
}
93
+
94
+
static struct custom_operations zfs_pool_ops = {
95
+
"zfs.zfs_pool",
96
+
finalize_zfs_pool,
97
+
custom_compare_default,
98
+
custom_hash_default,
99
+
custom_serialize_default,
100
+
custom_deserialize_default,
101
+
custom_compare_ext_default,
102
+
custom_fixed_length_default
103
+
};
104
+
105
+
// ZFS Initialisation
106
+
107
+
value
108
+
ocaml_zfs_init(value v_unit) {
109
+
CAMLparam0();
110
+
libzfs_handle_t* res;
111
+
CAMLlocal1(v_handle);
112
+
113
+
v_handle = caml_alloc_custom_mem(&zfs_handle_ops, sizeof(libzfs_handle_t*), 64);
114
+
res = libzfs_init();
115
+
Zfs_handle_val(v_handle) = res;
116
+
117
+
CAMLreturn(v_handle);
118
+
}
119
+
120
+
// ZFS Pools
121
+
122
+
value
123
+
ocaml_zfs_pool_open(value v_handle, value v_path) {
124
+
CAMLparam2(v_handle, v_path);
125
+
zpool_handle_t* res;
126
+
CAMLlocal1(v_pool);
127
+
128
+
if (!caml_string_is_c_safe(v_path))
129
+
caml_invalid_argument("ocaml_zfs_pool_open: path is not C-safe");
130
+
131
+
v_pool = caml_alloc_custom_mem(&zfs_pool_ops, sizeof(zpool_handle_t*), 64);
132
+
res = zpool_open(Zfs_handle_val(v_handle), String_val(v_path));
133
+
Zfs_pool_val(v_handle) = res;
134
+
135
+
CAMLreturn(v_handle);
136
+
}
137
+
138
+
value
139
+
ocaml_zfs_pool_get_name(value v_pool) {
140
+
CAMLparam1(v_pool);
141
+
CAMLlocal1(v_path);
142
+
const char* result;
143
+
144
+
result = zpool_get_name(Zfs_pool_val(v_pool));
145
+
v_path = caml_copy_string(result);
146
+
147
+
CAMLreturn(v_path);
148
+
}
149
+
150
+
+32
vendor/zfs/zfs.opam
+32
vendor/zfs/zfs.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "libzfs bindings"
4
+
description: "OCaml bindings to libzfs"
5
+
maintainer: ["Patrick Ferris <patrick@sirref.org>"]
6
+
authors: ["Patrick Ferris <patrick@sirref.org>"]
7
+
license: "ISC"
8
+
tags: ["filesystem" "zfs"]
9
+
homepage: "https://github.com/patricoferris/ocaml-zfs"
10
+
bug-reports: "https://github.com/patricoferris/ocaml-zfs/issues"
11
+
depends: [
12
+
"ocaml"
13
+
"dune" {>= "3.15"}
14
+
"ctypes"
15
+
"mdx" {with-test}
16
+
"odoc" {with-doc}
17
+
]
18
+
build: [
19
+
["dune" "subst"] {dev}
20
+
[
21
+
"dune"
22
+
"build"
23
+
"-p"
24
+
name
25
+
"-j"
26
+
jobs
27
+
"@install"
28
+
"@runtest" {with-test}
29
+
"@doc" {with-doc}
30
+
]
31
+
]
32
+
dev-repo: "git+https://github.com/patricoferris/ocaml-zfs.git"