this repo has no description
patrick.sirref.org
1module Error = struct
2 include Config.Error
3end
4
5module 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
12end
13
14module 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
25end
26
27module Handle = struct
28 type t = C.Types.libzfs_handle_t Ctypes_static.structure Ctypes_static.ptr
29end
30
31let init : unit -> Handle.t = C.Functions.init
32let debug : Handle.t -> bool -> unit = C.Functions.debug
33let errno : Handle.t -> int = C.Functions.errno
34
35module 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
41end
42
43module 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)
85end
86
87type t = C.Types.zfs_handle_t Ctypes_static.structure Ctypes_static.ptr
88
89let 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
93let 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
97let destroy handle recurse =
98 let i = C.Functions.destroy handle recurse in
99 if i != 0 then invalid_arg "destroy" else ()
100
101let open_ handle path (type_ : Types.t) = C.Functions.open_ handle path type_
102let close : t -> unit = C.Functions.close
103let get_type : t -> Types.t = C.Functions.get_type
104
105let clone ?(options = Nvlist.empty) handle path =
106 let res = C.Functions.clone handle path options in
107 if res = 0 then () else invalid_arg "clone"
108
109let snapshot ?(options = Nvlist.empty) handle path b =
110 let res = C.Functions.snapshot handle path b options in
111 if res = 0 then () else invalid_arg "snapshot"
112
113let exists handle path (type_ : Types.t) = C.Functions.exists handle path type_
114
115let null_string = Ctypes.(coerce (ptr void) (ptr char) null)
116
117let is_mounted handle path =
118 let where = Ctypes.(coerce (ptr void) (ptr char) null) in
119 let where_ptr = Ctypes.(allocate (ptr char) where) in
120 let v = C.Functions.is_mounted handle path where_ptr in
121 if not v then None else
122 let v = Ctypes.( !@ ) where_ptr in
123 let s = Ctypes.string_from_ptr v ~length:256 in
124 Some s
125
126let mount ?mount_opts ?(mount_flags = 0) dataset =
127 let res = C.Functions.mount dataset mount_opts mount_flags in
128 if res <> 0 then invalid_arg "mounting dataset"
129
130let unmount ?mount_opts ?(mount_flags = 0) dataset =
131 let res = C.Functions.unmount dataset mount_opts mount_flags in
132 if res <> 0 then invalid_arg "unmounting dataset"
133
134let show_diff ?to_ handle ~from_ (fd : Unix.file_descr) =
135 (* TODO: Other Diff Flags https://github.com/openzfs/zfs/blob/5b0c27cd14bbc07d50304c97735cc105d0258673/include/libzfs.h#L917? *)
136 let res = C.Functions.diff handle (Obj.magic fd : int) from_ to_ 1 in
137 if res = 0 then () else begin
138 invalid_arg "show_diff"
139 end