gazagnaire.org
Block device abstraction for OCaml 5 with Eio direct-style I/O and Bytesrw integration
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6type info = { read_write : bool; sector_size : int; sectors : int64 }
7type error = [ `Disconnected | `Read_error of string | `Invalid_sector of int64 ]
8type write_error = [ error | `Write_error of string | `Read_only ]
9
10let pp_error ppf = function
11 | `Disconnected -> Fmt.string ppf "disconnected"
12 | `Read_error s -> Fmt.pf ppf "read error: %s" s
13 | `Invalid_sector n -> Fmt.pf ppf "invalid sector: %Ld" n
14
15let pp_write_error ppf = function
16 | #error as e -> pp_error ppf e
17 | `Write_error s -> Fmt.pf ppf "write error: %s" s
18 | `Read_only -> Fmt.string ppf "read-only device"
19
20module type IMPL = sig
21 type state
22
23 val info : state -> info
24 val read : state -> int64 -> (string, error) result
25 val write : state -> int64 -> string -> (unit, write_error) result
26 val sync : state -> unit
27 val close : state -> unit
28end
29
30type t = T : { state : 'a; impl : (module IMPL with type state = 'a) } -> t
31
32let pp ppf (T { state; impl = (module I) }) =
33 let i = I.info state in
34 Fmt.pf ppf "<block %s sectors=%Ld sector-size=%d>"
35 (if i.read_write then "rw" else "ro")
36 i.sectors i.sector_size
37
38let info (T { state; impl = (module I) }) = I.info state
39let read (T { state; impl = (module I) }) sector = I.read state sector
40
41let write (T { state; impl = (module I) }) sector data =
42 I.write state sector data
43
44let sync (T { state; impl = (module I) }) = I.sync state
45let close (T { state; impl = (module I) }) = I.close state
46
47let read_many t start count =
48 let info = info t in
49 let buf = Buffer.create (count * info.sector_size) in
50 let rec loop i =
51 if i >= count then Ok (Buffer.contents buf)
52 else
53 match read t Int64.(add start (of_int i)) with
54 | Error e -> Error e
55 | Ok data ->
56 Buffer.add_string buf data;
57 loop (i + 1)
58 in
59 loop 0
60
61let write_many t start sectors =
62 let rec loop i = function
63 | [] -> Ok ()
64 | data :: rest -> (
65 match write t Int64.(add start (of_int i)) data with
66 | Error e -> Error e
67 | Ok () -> loop (i + 1) rest)
68 in
69 loop 0 sectors
70
71(* Memory implementation *)
72module Memory = struct
73 type state = {
74 mutable data : bytes;
75 sector_size : int;
76 sectors : int64;
77 mutable closed : bool;
78 }
79
80 let info t =
81 { read_write = true; sector_size = t.sector_size; sectors = t.sectors }
82
83 let read t sector =
84 if t.closed then Error `Disconnected
85 else if sector < 0L || sector >= t.sectors then
86 Error (`Invalid_sector sector)
87 else
88 let off = Int64.to_int sector * t.sector_size in
89 Ok (Bytes.sub_string t.data off t.sector_size)
90
91 let write t sector data =
92 if t.closed then Error `Disconnected
93 else if sector < 0L || sector >= t.sectors then
94 Error (`Invalid_sector sector)
95 else if String.length data <> t.sector_size then
96 Error (`Write_error "data length must equal sector size")
97 else
98 let off = Int64.to_int sector * t.sector_size in
99 Bytes.blit_string data 0 t.data off t.sector_size;
100 Ok ()
101
102 let sync _ = ()
103 let close t = t.closed <- true
104end
105
106let of_memory ~sector_size ~sectors =
107 let size = Int64.to_int sectors * sector_size in
108 let state =
109 {
110 Memory.data = Bytes.make size '\x00';
111 sector_size;
112 sectors;
113 closed = false;
114 }
115 in
116 T { state; impl = (module Memory) }
117
118let of_bigarray ~sector_size ba =
119 let len = Bigarray.Array1.dim ba in
120 if len mod sector_size <> 0 then
121 invalid_arg "bigarray size must be multiple of sector_size";
122 let sectors = Int64.of_int (len / sector_size) in
123 let data = Bytes.create len in
124 for i = 0 to len - 1 do
125 Bytes.set data i (Bigarray.Array1.get ba i)
126 done;
127 let state = { Memory.data; sector_size; sectors; closed = false } in
128 T { state; impl = (module Memory) }
129
130(* Read-only wrapper *)
131module Read_only = struct
132 type state = { inner : t }
133
134 let info t =
135 let i = info t.inner in
136 { i with read_write = false }
137
138 let read t sector = read t.inner sector
139 let write _ _ _ = Error `Read_only
140 let sync t = sync t.inner
141 let close t = close t.inner
142end
143
144let read_only t =
145 let state = { Read_only.inner = t } in
146 T { state; impl = (module Read_only) }
147
148let of_string ~sector_size data =
149 let len = String.length data in
150 if len mod sector_size <> 0 then
151 invalid_arg "string length must be multiple of sector_size";
152 let sectors = Int64.of_int (len / sector_size) in
153 let state =
154 { Memory.data = Bytes.of_string data; sector_size; sectors; closed = false }
155 in
156 (* Return read-only by wrapping *)
157 let t = T { state; impl = (module Memory) } in
158 read_only t
159
160(* File implementation *)
161module File = struct
162 type state = {
163 file : Eio.File.rw_ty Eio.Resource.t;
164 sector_size : int;
165 sectors : int64;
166 mutable closed : bool;
167 }
168
169 let info t =
170 { read_write = true; sector_size = t.sector_size; sectors = t.sectors }
171
172 let read t sector =
173 if t.closed then Error `Disconnected
174 else if sector < 0L || sector >= t.sectors then
175 Error (`Invalid_sector sector)
176 else
177 try
178 let off =
179 Optint.Int63.of_int64 (Int64.mul sector (Int64.of_int t.sector_size))
180 in
181 let buf = Cstruct.create t.sector_size in
182 Eio.File.pread_exact t.file ~file_offset:off [ buf ];
183 Ok (Cstruct.to_string buf)
184 with exn -> Error (`Read_error (Printexc.to_string exn))
185
186 let write t sector data =
187 if t.closed then Error `Disconnected
188 else if sector < 0L || sector >= t.sectors then
189 Error (`Invalid_sector sector)
190 else if String.length data <> t.sector_size then
191 Error (`Write_error "data length must equal sector size")
192 else
193 try
194 let off =
195 Optint.Int63.of_int64 (Int64.mul sector (Int64.of_int t.sector_size))
196 in
197 let buf = Cstruct.of_string data in
198 Eio.File.pwrite_all t.file ~file_offset:off [ buf ];
199 Ok ()
200 with exn -> Error (`Write_error (Printexc.to_string exn))
201
202 let sync t = if not t.closed then Eio.File.sync t.file
203
204 let close t =
205 if not t.closed then (
206 t.closed <- true;
207 Eio.Resource.close t.file)
208end
209
210let of_file ~sw path ~sector_size ?sectors:sectors_override ?create () =
211 if sector_size < 512 || sector_size land (sector_size - 1) <> 0 then
212 invalid_arg "sector_size must be power of 2 and >= 512";
213 let file =
214 match create with
215 | Some sectors ->
216 let size = Int64.mul sectors (Int64.of_int sector_size) in
217 let f = Eio.Path.open_out ~sw path ~create:(`Or_truncate 0o644) in
218 (* Extend file to size *)
219 Eio.File.truncate f (Optint.Int63.of_int64 size);
220 (f :> Eio.File.rw_ty Eio.Resource.t)
221 | None ->
222 Eio.Path.open_out ~sw path ~create:`Never |> fun f ->
223 (f :> Eio.File.rw_ty Eio.Resource.t)
224 in
225 let sectors =
226 match sectors_override with
227 | Some s -> s
228 | None ->
229 let stat = Eio.File.stat file in
230 let size = Optint.Int63.to_int64 stat.size in
231 Int64.div size (Int64.of_int sector_size)
232 in
233 let state = { File.file; sector_size; sectors; closed = false } in
234 T { state; impl = (module File) }
235
236(* Sub-device wrapper *)
237module Sub = struct
238 type state = { inner : t; start : int64; sectors : int64 }
239
240 let info t =
241 let i = info t.inner in
242 { i with sectors = t.sectors }
243
244 let read t sector =
245 if sector < 0L || sector >= t.sectors then Error (`Invalid_sector sector)
246 else read t.inner Int64.(add t.start sector)
247
248 let write t sector data =
249 if sector < 0L || sector >= t.sectors then Error (`Invalid_sector sector)
250 else write t.inner Int64.(add t.start sector) data
251
252 let sync t = sync t.inner
253 let close _ = () (* Don't close underlying device *)
254end
255
256let sub t ~start ~sectors =
257 let i = info t in
258 if start < 0L || sectors < 0L || Int64.add start sectors > i.sectors then
259 invalid_arg "sub: invalid range";
260 let state = { Sub.inner = t; start; sectors } in
261 T { state; impl = (module Sub) }
262
263(* CRC32C wrapper *)
264module With_crc = struct
265 type state = { inner : t; data_size : int }
266
267 let crc32c data =
268 (* Simple CRC32C implementation - in production use Wal.crc32c *)
269 let crc = ref 0xFFFFFFFFl in
270 for i = 0 to String.length data - 1 do
271 let byte = Char.code data.[i] in
272 crc := Int32.logxor !crc (Int32.of_int byte);
273 for _ = 0 to 7 do
274 let mask = Int32.neg (Int32.logand !crc 1l) in
275 crc :=
276 Int32.logxor
277 (Int32.shift_right_logical !crc 1)
278 (Int32.logand 0x82F63B78l mask)
279 done
280 done;
281 Int32.logxor !crc 0xFFFFFFFFl
282
283 let encode_crc crc =
284 let b = Bytes.create 4 in
285 Bytes.set b 0 (Char.chr (Int32.to_int (Int32.logand crc 0xFFl)));
286 Bytes.set b 1
287 (Char.chr
288 (Int32.to_int (Int32.logand (Int32.shift_right_logical crc 8) 0xFFl)));
289 Bytes.set b 2
290 (Char.chr
291 (Int32.to_int (Int32.logand (Int32.shift_right_logical crc 16) 0xFFl)));
292 Bytes.set b 3 (Char.chr (Int32.to_int (Int32.shift_right_logical crc 24)));
293 Bytes.to_string b
294
295 let decode_crc s off =
296 let b0 = Int32.of_int (Char.code s.[off]) in
297 let b1 = Int32.of_int (Char.code s.[off + 1]) in
298 let b2 = Int32.of_int (Char.code s.[off + 2]) in
299 let b3 = Int32.of_int (Char.code s.[off + 3]) in
300 Int32.logor b0
301 (Int32.logor (Int32.shift_left b1 8)
302 (Int32.logor (Int32.shift_left b2 16) (Int32.shift_left b3 24)))
303
304 let info t =
305 let i = info t.inner in
306 { i with sector_size = t.data_size }
307
308 let read t sector =
309 match read t.inner sector with
310 | Error e -> Error e
311 | Ok raw ->
312 let data = String.sub raw 0 t.data_size in
313 let stored_crc = decode_crc raw t.data_size in
314 let computed_crc = crc32c data in
315 if stored_crc <> computed_crc then
316 Error
317 (`Read_error
318 (Fmt.str "CRC mismatch: stored=%lx computed=%lx" stored_crc
319 computed_crc))
320 else Ok data
321
322 let write t sector data =
323 if String.length data <> t.data_size then
324 Error (`Write_error (Fmt.str "data length must be %d" t.data_size))
325 else
326 let crc = crc32c data in
327 let raw = data ^ encode_crc crc in
328 write t.inner sector raw
329
330 let sync t = sync t.inner
331 let close t = close t.inner
332end
333
334let with_crc32c t =
335 let i = info t in
336 let data_size = i.sector_size - 4 in
337 if data_size < 1 then invalid_arg "sector_size too small for CRC";
338 let state = { With_crc.inner = t; data_size } in
339 T { state; impl = (module With_crc) }
340
341(* Bytesrw integration *)
342let to_reader t ~offset ~length =
343 let i = info t in
344 if Int64.rem offset (Int64.of_int i.sector_size) <> 0L then
345 invalid_arg "offset must be sector-aligned";
346 let start_sector = Int64.div offset (Int64.of_int i.sector_size) in
347 let current_sector = ref start_sector in
348 let current_pos = ref 0 in
349 let remaining = ref length in
350 let current_data = ref "" in
351 Bytesrw.Bytes.Reader.make ~slice_length:i.sector_size @@ fun () ->
352 if !remaining <= 0L then Bytesrw.Bytes.Slice.eod
353 else if !current_pos >= String.length !current_data then (
354 (* Read next sector *)
355 match read t !current_sector with
356 | Error _ -> Bytesrw.Bytes.Slice.eod
357 | Ok data ->
358 current_data := data;
359 current_pos := 0;
360 current_sector := Int64.succ !current_sector;
361 let len = min (String.length data) (Int64.to_int !remaining) in
362 remaining := Int64.sub !remaining (Int64.of_int len);
363 current_pos := len;
364 Bytesrw.Bytes.Slice.make
365 (Bytes.unsafe_of_string data)
366 ~first:0 ~length:len)
367 else Bytesrw.Bytes.Slice.eod
368
369let to_writer t ~offset =
370 let i = info t in
371 if Int64.rem offset (Int64.of_int i.sector_size) <> 0L then
372 invalid_arg "offset must be sector-aligned";
373 let start_sector = Int64.div offset (Int64.of_int i.sector_size) in
374 let current_sector = ref start_sector in
375 let buffer = Buffer.create i.sector_size in
376 let flush () =
377 if Buffer.length buffer > 0 then (
378 (* Pad to sector size if needed *)
379 while Buffer.length buffer < i.sector_size do
380 Buffer.add_char buffer '\x00'
381 done;
382 let _ = write t !current_sector (Buffer.contents buffer) in
383 Buffer.clear buffer;
384 current_sector := Int64.succ !current_sector)
385 in
386 Bytesrw.Bytes.Writer.make ~slice_length:i.sector_size @@ fun slice ->
387 if Bytesrw.Bytes.Slice.is_eod slice then flush ()
388 else begin
389 let data =
390 Bytes.sub_string
391 (Bytesrw.Bytes.Slice.bytes slice)
392 (Bytesrw.Bytes.Slice.first slice)
393 (Bytesrw.Bytes.Slice.length slice)
394 in
395 Buffer.add_string buffer data;
396 while Buffer.length buffer >= i.sector_size do
397 let sector_data = Buffer.sub buffer 0 i.sector_size in
398 let _ = write t !current_sector sector_data in
399 current_sector := Int64.succ !current_sector;
400 let remaining =
401 Buffer.sub buffer i.sector_size (Buffer.length buffer - i.sector_size)
402 in
403 Buffer.clear buffer;
404 Buffer.add_string buffer remaining
405 done
406 end
407
408(* Generic operations *)
409
410let fold ~f t init =
411 let i = info t in
412 let rec loop sector acc =
413 if sector >= i.sectors then Ok acc
414 else
415 match read t sector with
416 | Error e -> Error e
417 | Ok data -> (
418 match f sector data acc with
419 | Error e -> Error e
420 | Ok acc' -> loop (Int64.succ sector) acc')
421 in
422 loop 0L init
423
424let iter ~f t = fold ~f:(fun sector data () -> f sector data) t ()
425
426type compare_error =
427 [ error
428 | `Different_sizes
429 | `Different_sector_sizes
430 | `Contents_differ of int64 ]
431
432let pp_compare_error ppf = function
433 | #error as e -> pp_error ppf e
434 | `Different_sizes -> Fmt.string ppf "different sizes"
435 | `Different_sector_sizes -> Fmt.string ppf "different sector sizes"
436 | `Contents_differ n -> Fmt.pf ppf "contents differ at sector %Ld" n
437
438let compare a b =
439 let ia = info a and ib = info b in
440 if ia.sector_size <> ib.sector_size then Error `Different_sector_sizes
441 else if ia.sectors <> ib.sectors then Error `Different_sizes
442 else
443 let rec loop sector =
444 if sector >= ia.sectors then Ok ()
445 else
446 match (read a sector, read b sector) with
447 | Error e, _ -> Error (e :> compare_error)
448 | _, Error e -> Error (e :> compare_error)
449 | Ok da, Ok db ->
450 if da <> db then Error (`Contents_differ sector)
451 else loop (Int64.succ sector)
452 in
453 loop 0L
454
455type copy_error = [ write_error | `Different_sizes | `Different_sector_sizes ]
456
457let pp_copy_error ppf = function
458 | #write_error as e -> pp_write_error ppf e
459 | `Different_sizes -> Fmt.string ppf "different sizes"
460 | `Different_sector_sizes -> Fmt.string ppf "different sector sizes"
461
462let copy ~src ~dst =
463 let is = info src and id = info dst in
464 if is.sector_size <> id.sector_size then Error `Different_sector_sizes
465 else if is.sectors > id.sectors then Error `Different_sizes
466 else
467 let rec loop sector =
468 if sector >= is.sectors then Ok ()
469 else
470 match read src sector with
471 | Error e -> Error (e :> copy_error)
472 | Ok data -> (
473 match write dst sector data with
474 | Error e -> Error (e :> copy_error)
475 | Ok () -> loop (Int64.succ sector))
476 in
477 loop 0L
478
479let is_zero data =
480 let rec loop i =
481 if i >= String.length data then true
482 else if data.[i] <> '\x00' then false
483 else loop (i + 1)
484 in
485 loop 0
486
487let sparse_copy ~src ~dst =
488 let is = info src and id = info dst in
489 if is.sector_size <> id.sector_size then Error `Different_sector_sizes
490 else if is.sectors > id.sectors then Error `Different_sizes
491 else
492 let rec loop sector =
493 if sector >= is.sectors then Ok ()
494 else
495 match read src sector with
496 | Error e -> Error (e :> copy_error)
497 | Ok data -> (
498 if is_zero data then loop (Int64.succ sector)
499 else
500 match write dst sector data with
501 | Error e -> Error (e :> copy_error)
502 | Ok () -> loop (Int64.succ sector))
503 in
504 loop 0L
505
506let fill t c =
507 let i = info t in
508 let data = String.make i.sector_size c in
509 let rec loop sector =
510 if sector >= i.sectors then Ok ()
511 else
512 match write t sector data with
513 | Error e -> Error e
514 | Ok () -> loop (Int64.succ sector)
515 in
516 loop 0L
517
518let zero t = fill t '\x00'