Block device abstraction for OCaml 5 with Eio direct-style I/O and Bytesrw integration
Squashed 'ocaml-block/' content from commit 7b843a7a git-subtree-split: 7b843a7a1cb7806de8a6a5b284459457f097e4ca
+1345
+20
.gitignore
+20
.gitignore
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version=0.27.0
+15
LICENSE.md
+15
LICENSE.md
···
1
+
ISC License
2
+
3
+
Copyright (c) 2025 Thomas Gazagnaire
4
+
5
+
Permission to use, copy, modify, and/or distribute this software for any
6
+
purpose with or without fee is hereby granted, provided that the above
7
+
copyright notice and this permission notice appear in all copies.
8
+
9
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
10
+
REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
11
+
AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
12
+
INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
13
+
LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
14
+
OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
15
+
PERFORMANCE OF THIS SOFTWARE.
+90
README.md
+90
README.md
···
1
+
# block
2
+
3
+
Block device abstraction for OCaml 5 with Eio direct-style I/O and Bytesrw integration.
4
+
5
+
## Overview
6
+
7
+
This library provides a minimal block device interface inspired by MirageOS
8
+
[mirage-block](https://github.com/mirage/mirage-block) but using Eio's
9
+
effects-based concurrency instead of Lwt.
10
+
11
+
## Features
12
+
13
+
- Eio direct-style I/O (no monads)
14
+
- Bytesrw integration for streaming access
15
+
- Memory, file, and flow backends
16
+
- CRC32C integrity checking wrapper
17
+
- Sub-device views for partitioning
18
+
- Read-only wrapper
19
+
20
+
## Installation
21
+
22
+
```
23
+
opam install block
24
+
```
25
+
26
+
## Usage
27
+
28
+
```ocaml
29
+
Eio_main.run @@ fun env ->
30
+
Eio.Switch.run @@ fun sw ->
31
+
32
+
(* Create a file-backed block device *)
33
+
let blk = Block.of_file ~sw env#fs "disk.img" ~sector_size:512 ~create:1000L () in
34
+
let info = Block.info blk in
35
+
Printf.printf "Sectors: %Ld\n" info.sectors;
36
+
37
+
(* Write a sector *)
38
+
let data = String.make 512 'A' in
39
+
Block.write blk 0L data |> Result.get_ok;
40
+
41
+
(* Read it back *)
42
+
let read = Block.read blk 0L |> Result.get_ok in
43
+
assert (data = read);
44
+
45
+
(* Add CRC32C integrity checking *)
46
+
let safe_blk = Block.with_crc32c blk in
47
+
(* Now reads verify checksums, writes compute them *)
48
+
```
49
+
50
+
## API
51
+
52
+
### Core Operations
53
+
54
+
- `Block.info` - Get device info (sector size, count, read/write)
55
+
- `Block.read` - Read a single sector
56
+
- `Block.write` - Write a single sector
57
+
- `Block.read_many` - Read multiple consecutive sectors
58
+
- `Block.write_many` - Write multiple consecutive sectors
59
+
- `Block.sync` - Flush pending writes
60
+
- `Block.close` - Release resources
61
+
62
+
### Backends
63
+
64
+
- `Block.of_memory` - In-memory device (for testing)
65
+
- `Block.of_string` - Read-only device from string
66
+
- `Block.of_file` - File-backed device
67
+
- `Block.of_flow` - Eio flow-backed device
68
+
- `Block.of_bigarray` - Bigarray-backed device
69
+
70
+
### Wrappers
71
+
72
+
- `Block.read_only` - Read-only view
73
+
- `Block.sub` - Sub-device view (for partitions)
74
+
- `Block.with_crc32c` - CRC32C integrity checking
75
+
76
+
### Bytesrw Integration
77
+
78
+
- `Block.to_reader` - Create sequential reader from offset
79
+
- `Block.to_writer` - Create sequential writer from offset
80
+
81
+
## Related Work
82
+
83
+
- [mirage-block](https://github.com/mirage/mirage-block) - MirageOS block
84
+
interface (Lwt-based)
85
+
- [mirage-block-unix](https://github.com/mirage/mirage-block-unix) - Unix
86
+
backend for mirage-block
87
+
88
+
## License
89
+
90
+
ISC License. See [LICENSE.md](LICENSE.md) for details.
+28
dune-project
+28
dune-project
···
1
+
(lang dune 3.0)
2
+
3
+
(name block)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(license ISC)
8
+
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
9
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
10
+
11
+
(source
12
+
(uri https://tangled.org/gazagnaire.org/ocaml-block))
13
+
14
+
(package
15
+
(name block)
16
+
(synopsis "Block device abstraction for OCaml 5 with Eio")
17
+
(description
18
+
"Block device abstraction for OCaml 5 with Eio direct-style I/O and Bytesrw integration. Inspired by MirageOS mirage-block but using effects-based concurrency.")
19
+
(depends
20
+
(ocaml (>= 5.1))
21
+
(eio (>= 1.0))
22
+
(bytesrw (>= 0.1))
23
+
(cstruct (>= 6.0))
24
+
(fmt (>= 0.9))
25
+
(optint (>= 0.3))
26
+
(alcotest :with-test)
27
+
(eio_main :with-test)
28
+
(crowbar :with-test)))
+15
fuzz/dune
+15
fuzz/dune
···
1
+
; Crowbar fuzz testing for block
2
+
;
3
+
; To run: dune exec fuzz/fuzz_block.exe
4
+
; With AFL: afl-fuzz -i fuzz/corpus -o fuzz/findings -- ./_build/default/fuzz/fuzz_block.exe @@
5
+
6
+
(executable
7
+
(name fuzz_block)
8
+
(modules fuzz_block)
9
+
(libraries block crowbar))
10
+
11
+
(rule
12
+
(alias fuzz)
13
+
(deps fuzz_block.exe)
14
+
(action
15
+
(run %{exe:fuzz_block.exe})))
+112
fuzz/fuzz_block.ml
+112
fuzz/fuzz_block.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Crowbar
7
+
8
+
let sector_size = 512
9
+
10
+
(* Test that write followed by read returns same data *)
11
+
let test_roundtrip data sector =
12
+
let sectors = 100L in
13
+
let blk = Block.of_memory ~sector_size ~sectors in
14
+
let sector = Int64.of_int (sector mod 100) in
15
+
(* Pad or truncate data to sector size *)
16
+
let padded =
17
+
if String.length data >= sector_size then String.sub data 0 sector_size
18
+
else data ^ String.make (sector_size - String.length data) '\x00'
19
+
in
20
+
match Block.write blk sector padded with
21
+
| Error _ -> () (* Acceptable - may be invalid sector *)
22
+
| Ok () -> (
23
+
match Block.read blk sector with
24
+
| Error e -> fail (Fmt.str "read failed: %a" Block.pp_error e)
25
+
| Ok read_data -> check_eq ~pp:Fmt.string padded read_data)
26
+
27
+
(* Test that sub-device reads map correctly *)
28
+
let test_sub_mapping data start_sector sub_start sub_len read_sector =
29
+
let sectors = 100L in
30
+
let blk = Block.of_memory ~sector_size ~sectors in
31
+
let start_sector = Int64.of_int (start_sector mod 50) in
32
+
let sub_start = Int64.of_int (sub_start mod 25) in
33
+
let sub_len = Int64.of_int (max 1 (sub_len mod 20)) in
34
+
let read_sector = Int64.of_int (read_sector mod (Int64.to_int sub_len)) in
35
+
(* Write to original device *)
36
+
let padded =
37
+
if String.length data >= sector_size then String.sub data 0 sector_size
38
+
else data ^ String.make (sector_size - String.length data) '\x00'
39
+
in
40
+
let target = Int64.add sub_start read_sector in
41
+
if target >= 0L && target < sectors then (
42
+
match Block.write blk target padded with
43
+
| Error _ -> ()
44
+
| Ok () ->
45
+
let sub = Block.sub blk ~start:sub_start ~sectors:sub_len in
46
+
if read_sector >= 0L && read_sector < sub_len then
47
+
match Block.read sub read_sector with
48
+
| Error _ -> ()
49
+
| Ok read_data -> check_eq ~pp:Fmt.string padded read_data)
50
+
51
+
(* Test CRC32C detects any corruption *)
52
+
let test_crc_detects_corruption data corrupt_pos corrupt_byte =
53
+
let sectors = 10L in
54
+
let blk = Block.of_memory ~sector_size ~sectors in
55
+
let crc_blk = Block.with_crc32c blk in
56
+
let data_size = sector_size - 4 in
57
+
let padded =
58
+
if String.length data >= data_size then String.sub data 0 data_size
59
+
else data ^ String.make (data_size - String.length data) '\x00'
60
+
in
61
+
match Block.write crc_blk 0L padded with
62
+
| Error _ -> ()
63
+
| Ok () -> (
64
+
(* Read raw sector and corrupt it *)
65
+
match Block.read blk 0L with
66
+
| Error _ -> ()
67
+
| Ok raw ->
68
+
let corrupt_pos = corrupt_pos mod sector_size in
69
+
let corrupted = Bytes.of_string raw in
70
+
let orig_byte = Bytes.get corrupted corrupt_pos in
71
+
if Char.chr corrupt_byte <> orig_byte then (
72
+
Bytes.set corrupted corrupt_pos (Char.chr corrupt_byte);
73
+
match Block.write blk 0L (Bytes.to_string corrupted) with
74
+
| Error _ -> ()
75
+
| Ok () -> (
76
+
match Block.read crc_blk 0L with
77
+
| Ok _ -> fail "CRC should have detected corruption"
78
+
| Error (`Read_error _) -> () (* Expected *)
79
+
| Error e -> fail (Fmt.str "unexpected error: %a" Block.pp_error e))))
80
+
81
+
(* Test read_many returns concatenated sectors *)
82
+
let test_read_many_concat count =
83
+
let sectors = 100L in
84
+
let blk = Block.of_memory ~sector_size ~sectors in
85
+
let count = max 1 (count mod 10) in
86
+
(* Write distinct patterns *)
87
+
for i = 0 to count - 1 do
88
+
let data = String.make sector_size (Char.chr ((i mod 26) + 65)) in
89
+
match Block.write blk (Int64.of_int i) data with
90
+
| Ok () -> ()
91
+
| Error _ -> ()
92
+
done;
93
+
match Block.read_many blk 0L count with
94
+
| Error _ -> ()
95
+
| Ok data ->
96
+
check_eq ~pp:Fmt.int (count * sector_size) (String.length data);
97
+
(* Verify each sector's pattern *)
98
+
for i = 0 to count - 1 do
99
+
let expected = Char.chr ((i mod 26) + 65) in
100
+
let actual = data.[i * sector_size] in
101
+
check_eq ~pp:(fun ppf c -> Fmt.pf ppf "%C" c) expected actual
102
+
done
103
+
104
+
let () =
105
+
add_test ~name:"block: roundtrip" [ bytes; range 200 ] test_roundtrip;
106
+
add_test ~name:"block: sub mapping"
107
+
[ bytes; range 100; range 50; range 30; range 30 ]
108
+
test_sub_mapping;
109
+
add_test ~name:"block: crc corruption"
110
+
[ bytes; range 512; range 256 ]
111
+
test_crc_detects_corruption;
112
+
add_test ~name:"block: read_many" [ range 20 ] test_read_many_concat
+549
lib/block.ml
+549
lib/block.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type info = { read_write : bool; sector_size : int; sectors : int64 }
7
+
8
+
type error =
9
+
[ `Disconnected | `Read_error of string | `Invalid_sector of int64 ]
10
+
11
+
type write_error = [ error | `Write_error of string | `Read_only ]
12
+
13
+
let pp_error ppf = function
14
+
| `Disconnected -> Fmt.string ppf "disconnected"
15
+
| `Read_error s -> Fmt.pf ppf "read error: %s" s
16
+
| `Invalid_sector n -> Fmt.pf ppf "invalid sector: %Ld" n
17
+
18
+
let pp_write_error ppf = function
19
+
| #error as e -> pp_error ppf e
20
+
| `Write_error s -> Fmt.pf ppf "write error: %s" s
21
+
| `Read_only -> Fmt.string ppf "read-only device"
22
+
23
+
module type IMPL = sig
24
+
type state
25
+
26
+
val info : state -> info
27
+
val read : state -> int64 -> (string, error) result
28
+
val write : state -> int64 -> string -> (unit, write_error) result
29
+
val sync : state -> unit
30
+
val close : state -> unit
31
+
end
32
+
33
+
type t = T : { state : 'a; impl : (module IMPL with type state = 'a) } -> t
34
+
35
+
let info (T { state; impl = (module I) }) = I.info state
36
+
let read (T { state; impl = (module I) }) sector = I.read state sector
37
+
let write (T { state; impl = (module I) }) sector data = I.write state sector data
38
+
let sync (T { state; impl = (module I) }) = I.sync state
39
+
let close (T { state; impl = (module I) }) = I.close state
40
+
41
+
let read_many t start count =
42
+
let info = info t in
43
+
let buf = Buffer.create (count * info.sector_size) in
44
+
let rec loop i =
45
+
if i >= count then Ok (Buffer.contents buf)
46
+
else
47
+
match read t Int64.(add start (of_int i)) with
48
+
| Error e -> Error e
49
+
| Ok data ->
50
+
Buffer.add_string buf data;
51
+
loop (i + 1)
52
+
in
53
+
loop 0
54
+
55
+
let write_many t start sectors =
56
+
let rec loop i = function
57
+
| [] -> Ok ()
58
+
| data :: rest -> (
59
+
match write t Int64.(add start (of_int i)) data with
60
+
| Error e -> Error e
61
+
| Ok () -> loop (i + 1) rest)
62
+
in
63
+
loop 0 sectors
64
+
65
+
(* Memory implementation *)
66
+
module Memory = struct
67
+
type state = {
68
+
mutable data : bytes;
69
+
sector_size : int;
70
+
sectors : int64;
71
+
mutable closed : bool;
72
+
}
73
+
74
+
let info t =
75
+
{ read_write = true; sector_size = t.sector_size; sectors = t.sectors }
76
+
77
+
let read t sector =
78
+
if t.closed then Error `Disconnected
79
+
else if sector < 0L || sector >= t.sectors then Error (`Invalid_sector sector)
80
+
else
81
+
let off = Int64.to_int sector * t.sector_size in
82
+
Ok (Bytes.sub_string t.data off t.sector_size)
83
+
84
+
let write t sector data =
85
+
if t.closed then Error `Disconnected
86
+
else if sector < 0L || sector >= t.sectors then
87
+
Error (`Invalid_sector sector)
88
+
else if String.length data <> t.sector_size then
89
+
Error (`Write_error "data length must equal sector size")
90
+
else
91
+
let off = Int64.to_int sector * t.sector_size in
92
+
Bytes.blit_string data 0 t.data off t.sector_size;
93
+
Ok ()
94
+
95
+
let sync _ = ()
96
+
let close t = t.closed <- true
97
+
end
98
+
99
+
let of_memory ~sector_size ~sectors =
100
+
let size = Int64.to_int sectors * sector_size in
101
+
let state =
102
+
{ Memory.data = Bytes.make size '\x00'; sector_size; sectors; closed = false }
103
+
in
104
+
T { state; impl = (module Memory) }
105
+
106
+
let of_bigarray ~sector_size ba =
107
+
let len = Bigarray.Array1.dim ba in
108
+
if len mod sector_size <> 0 then
109
+
invalid_arg "bigarray size must be multiple of sector_size";
110
+
let sectors = Int64.of_int (len / sector_size) in
111
+
let data = Bytes.create len in
112
+
for i = 0 to len - 1 do
113
+
Bytes.set data i (Bigarray.Array1.get ba i)
114
+
done;
115
+
let state =
116
+
{ Memory.data; sector_size; sectors; closed = false }
117
+
in
118
+
T { state; impl = (module Memory) }
119
+
120
+
let of_string ~sector_size data =
121
+
let len = String.length data in
122
+
if len mod sector_size <> 0 then
123
+
invalid_arg "string length must be multiple of sector_size";
124
+
let sectors = Int64.of_int (len / sector_size) in
125
+
let state =
126
+
{
127
+
Memory.data = Bytes.of_string data;
128
+
sector_size;
129
+
sectors;
130
+
closed = false;
131
+
}
132
+
in
133
+
(* Return read-only by wrapping *)
134
+
let t = T { state; impl = (module Memory) } in
135
+
read_only t
136
+
137
+
(* File implementation *)
138
+
module File = struct
139
+
type state = {
140
+
file : Eio.File.rw_ty Eio.Resource.t;
141
+
sector_size : int;
142
+
sectors : int64;
143
+
mutable closed : bool;
144
+
}
145
+
146
+
let info t =
147
+
{ read_write = true; sector_size = t.sector_size; sectors = t.sectors }
148
+
149
+
let read t sector =
150
+
if t.closed then Error `Disconnected
151
+
else if sector < 0L || sector >= t.sectors then Error (`Invalid_sector sector)
152
+
else
153
+
try
154
+
let off = Optint.Int63.of_int64 (Int64.mul sector (Int64.of_int t.sector_size)) in
155
+
let buf = Cstruct.create t.sector_size in
156
+
Eio.File.pread_exact t.file ~file_offset:off [ buf ];
157
+
Ok (Cstruct.to_string buf)
158
+
with exn -> Error (`Read_error (Printexc.to_string exn))
159
+
160
+
let write t sector data =
161
+
if t.closed then Error `Disconnected
162
+
else if sector < 0L || sector >= t.sectors then
163
+
Error (`Invalid_sector sector)
164
+
else if String.length data <> t.sector_size then
165
+
Error (`Write_error "data length must equal sector size")
166
+
else
167
+
try
168
+
let off = Optint.Int63.of_int64 (Int64.mul sector (Int64.of_int t.sector_size)) in
169
+
let buf = Cstruct.of_string data in
170
+
Eio.File.pwrite_all t.file ~file_offset:off [ buf ];
171
+
Ok ()
172
+
with exn -> Error (`Write_error (Printexc.to_string exn))
173
+
174
+
let sync t =
175
+
if not t.closed then Eio.File.sync t.file
176
+
177
+
let close t =
178
+
if not t.closed then (
179
+
t.closed <- true;
180
+
Eio.Resource.close t.file)
181
+
end
182
+
183
+
let of_file ~sw path ~sector_size ?create () =
184
+
if sector_size < 512 || sector_size land (sector_size - 1) <> 0 then
185
+
invalid_arg "sector_size must be power of 2 and >= 512";
186
+
let file =
187
+
match create with
188
+
| Some sectors ->
189
+
let size = Int64.mul sectors (Int64.of_int sector_size) in
190
+
let f =
191
+
Eio.Path.open_out ~sw path ~create:(`Or_truncate 0o644)
192
+
in
193
+
(* Extend file to size *)
194
+
Eio.File.truncate f (Optint.Int63.of_int64 size);
195
+
(f :> Eio.File.rw_ty Eio.Resource.t)
196
+
| None ->
197
+
Eio.Path.open_out ~sw path ~create:`Never
198
+
|> fun f -> (f :> Eio.File.rw_ty Eio.Resource.t)
199
+
in
200
+
let stat = Eio.File.stat file in
201
+
let size = Optint.Int63.to_int64 stat.size in
202
+
let sectors = Int64.div size (Int64.of_int sector_size) in
203
+
let state = { File.file; sector_size; sectors; closed = false } in
204
+
T { state; impl = (module File) }
205
+
206
+
(* Flow implementation *)
207
+
module Flow = struct
208
+
type state = {
209
+
flow : Eio.Flow.two_way_ty Eio.Resource.t;
210
+
info : info;
211
+
mutable closed : bool;
212
+
}
213
+
214
+
let info t = t.info
215
+
216
+
let read t sector =
217
+
if t.closed then Error `Disconnected
218
+
else if sector < 0L || sector >= t.info.sectors then
219
+
Error (`Invalid_sector sector)
220
+
else
221
+
try
222
+
let off = Optint.Int63.of_int64 (Int64.mul sector (Int64.of_int t.info.sector_size)) in
223
+
let buf = Cstruct.create t.info.sector_size in
224
+
let file = Eio.Resource.get t.flow Eio.File.Pi.Rw in
225
+
Eio.File.Rw.pread_exact file ~file_offset:off [ buf ];
226
+
Ok (Cstruct.to_string buf)
227
+
with exn -> Error (`Read_error (Printexc.to_string exn))
228
+
229
+
let write t sector data =
230
+
if t.closed then Error `Disconnected
231
+
else if not t.info.read_write then Error `Read_only
232
+
else if sector < 0L || sector >= t.info.sectors then
233
+
Error (`Invalid_sector sector)
234
+
else if String.length data <> t.info.sector_size then
235
+
Error (`Write_error "data length must equal sector size")
236
+
else
237
+
try
238
+
let off = Optint.Int63.of_int64 (Int64.mul sector (Int64.of_int t.info.sector_size)) in
239
+
let buf = Cstruct.of_string data in
240
+
let file = Eio.Resource.get t.flow Eio.File.Pi.Rw in
241
+
Eio.File.Rw.pwrite_all file ~file_offset:off [ buf ];
242
+
Ok ()
243
+
with exn -> Error (`Write_error (Printexc.to_string exn))
244
+
245
+
let sync t =
246
+
if not t.closed then
247
+
try
248
+
let file = Eio.Resource.get t.flow Eio.File.Pi.Rw in
249
+
Eio.File.Rw.sync file
250
+
with _ -> ()
251
+
252
+
let close t = t.closed <- true
253
+
end
254
+
255
+
let of_flow ~sw:_ ~info flow =
256
+
let state =
257
+
{ Flow.flow = (flow :> Eio.Flow.two_way_ty Eio.Resource.t); info; closed = false }
258
+
in
259
+
T { state; impl = (module Flow) }
260
+
261
+
(* Read-only wrapper *)
262
+
module ReadOnly = struct
263
+
type state = { inner : t }
264
+
265
+
let info t =
266
+
let i = info t.inner in
267
+
{ i with read_write = false }
268
+
269
+
let read t sector = read t.inner sector
270
+
let write _ _ _ = Error `Read_only
271
+
let sync t = sync t.inner
272
+
let close t = close t.inner
273
+
end
274
+
275
+
let read_only t =
276
+
let state = { ReadOnly.inner = t } in
277
+
T { state; impl = (module ReadOnly) }
278
+
279
+
(* Sub-device wrapper *)
280
+
module Sub = struct
281
+
type state = { inner : t; start : int64; sectors : int64 }
282
+
283
+
let info t =
284
+
let i = info t.inner in
285
+
{ i with sectors = t.sectors }
286
+
287
+
let read t sector =
288
+
if sector < 0L || sector >= t.sectors then Error (`Invalid_sector sector)
289
+
else read t.inner Int64.(add t.start sector)
290
+
291
+
let write t sector data =
292
+
if sector < 0L || sector >= t.sectors then Error (`Invalid_sector sector)
293
+
else write t.inner Int64.(add t.start sector) data
294
+
295
+
let sync t = sync t.inner
296
+
let close _ = () (* Don't close underlying device *)
297
+
end
298
+
299
+
let sub t ~start ~sectors =
300
+
let i = info t in
301
+
if start < 0L || sectors < 0L || Int64.add start sectors > i.sectors then
302
+
invalid_arg "sub: invalid range";
303
+
let state = { Sub.inner = t; start; sectors } in
304
+
T { state; impl = (module Sub) }
305
+
306
+
(* CRC32C wrapper *)
307
+
module WithCrc = struct
308
+
type state = { inner : t; data_size : int }
309
+
310
+
let crc32c data =
311
+
(* Simple CRC32C implementation - in production use Wal.crc32c *)
312
+
let crc = ref 0xFFFFFFFFl in
313
+
for i = 0 to String.length data - 1 do
314
+
let byte = Char.code data.[i] in
315
+
crc := Int32.logxor !crc (Int32.of_int byte);
316
+
for _ = 0 to 7 do
317
+
let mask = Int32.neg (Int32.logand !crc 1l) in
318
+
crc := Int32.logxor (Int32.shift_right_logical !crc 1) (Int32.logand 0x82F63B78l mask)
319
+
done
320
+
done;
321
+
Int32.logxor !crc 0xFFFFFFFFl
322
+
323
+
let encode_crc crc =
324
+
let b = Bytes.create 4 in
325
+
Bytes.set b 0 (Char.chr (Int32.to_int (Int32.logand crc 0xFFl)));
326
+
Bytes.set b 1 (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical crc 8) 0xFFl)));
327
+
Bytes.set b 2 (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical crc 16) 0xFFl)));
328
+
Bytes.set b 3 (Char.chr (Int32.to_int (Int32.shift_right_logical crc 24)));
329
+
Bytes.to_string b
330
+
331
+
let decode_crc s off =
332
+
let b0 = Int32.of_int (Char.code s.[off]) in
333
+
let b1 = Int32.of_int (Char.code s.[off + 1]) in
334
+
let b2 = Int32.of_int (Char.code s.[off + 2]) in
335
+
let b3 = Int32.of_int (Char.code s.[off + 3]) in
336
+
Int32.logor b0
337
+
(Int32.logor (Int32.shift_left b1 8)
338
+
(Int32.logor (Int32.shift_left b2 16) (Int32.shift_left b3 24)))
339
+
340
+
let info t =
341
+
let i = info t.inner in
342
+
{ i with sector_size = t.data_size }
343
+
344
+
let read t sector =
345
+
match read t.inner sector with
346
+
| Error e -> Error e
347
+
| Ok raw ->
348
+
let data = String.sub raw 0 t.data_size in
349
+
let stored_crc = decode_crc raw t.data_size in
350
+
let computed_crc = crc32c data in
351
+
if stored_crc <> computed_crc then
352
+
Error (`Read_error (Printf.sprintf "CRC mismatch: stored=%lx computed=%lx" stored_crc computed_crc))
353
+
else Ok data
354
+
355
+
let write t sector data =
356
+
if String.length data <> t.data_size then
357
+
Error (`Write_error (Printf.sprintf "data length must be %d" t.data_size))
358
+
else
359
+
let crc = crc32c data in
360
+
let raw = data ^ encode_crc crc in
361
+
write t.inner sector raw
362
+
363
+
let sync t = sync t.inner
364
+
let close t = close t.inner
365
+
end
366
+
367
+
let with_crc32c t =
368
+
let i = info t in
369
+
let data_size = i.sector_size - 4 in
370
+
if data_size < 1 then invalid_arg "sector_size too small for CRC";
371
+
let state = { WithCrc.inner = t; data_size } in
372
+
T { state; impl = (module WithCrc) }
373
+
374
+
(* Bytesrw integration *)
375
+
let to_reader t ~offset ~length =
376
+
let i = info t in
377
+
if Int64.rem offset (Int64.of_int i.sector_size) <> 0L then
378
+
invalid_arg "offset must be sector-aligned";
379
+
let start_sector = Int64.div offset (Int64.of_int i.sector_size) in
380
+
let current_sector = ref start_sector in
381
+
let current_pos = ref 0 in
382
+
let remaining = ref length in
383
+
let current_data = ref "" in
384
+
Bytesrw.Bytes.Reader.create ~slice_length:i.sector_size @@ fun () ->
385
+
if !remaining <= 0L then Bytesrw.Bytes.Slice.eod
386
+
else if !current_pos >= String.length !current_data then (
387
+
(* Read next sector *)
388
+
match read t !current_sector with
389
+
| Error _ -> Bytesrw.Bytes.Slice.eod
390
+
| Ok data ->
391
+
current_data := data;
392
+
current_pos := 0;
393
+
incr_sector current_sector;
394
+
let len = min (String.length data) (Int64.to_int !remaining) in
395
+
remaining := Int64.sub !remaining (Int64.of_int len);
396
+
current_pos := len;
397
+
Bytesrw.Bytes.Slice.make (Bytes.unsafe_of_string data) ~first:0 ~length:len)
398
+
else Bytesrw.Bytes.Slice.eod
399
+
400
+
and incr_sector r = r := Int64.succ !r
401
+
402
+
let to_writer t ~offset =
403
+
let i = info t in
404
+
if Int64.rem offset (Int64.of_int i.sector_size) <> 0L then
405
+
invalid_arg "offset must be sector-aligned";
406
+
let start_sector = Int64.div offset (Int64.of_int i.sector_size) in
407
+
let current_sector = ref start_sector in
408
+
let buffer = Buffer.create i.sector_size in
409
+
let flush () =
410
+
if Buffer.length buffer > 0 then (
411
+
(* Pad to sector size if needed *)
412
+
while Buffer.length buffer < i.sector_size do
413
+
Buffer.add_char buffer '\x00'
414
+
done;
415
+
let _ = write t !current_sector (Buffer.contents buffer) in
416
+
Buffer.clear buffer;
417
+
current_sector := Int64.succ !current_sector)
418
+
in
419
+
Bytesrw.Bytes.Writer.create ~slice_length:i.sector_size @@ fun slice ->
420
+
let data = Bytes.sub_string (Bytesrw.Bytes.Slice.bytes slice)
421
+
(Bytesrw.Bytes.Slice.first slice)
422
+
(Bytesrw.Bytes.Slice.length slice)
423
+
in
424
+
Buffer.add_string buffer data;
425
+
while Buffer.length buffer >= i.sector_size do
426
+
let sector_data = Buffer.sub buffer 0 i.sector_size in
427
+
let _ = write t !current_sector sector_data in
428
+
current_sector := Int64.succ !current_sector;
429
+
let remaining = Buffer.sub buffer i.sector_size (Buffer.length buffer - i.sector_size) in
430
+
Buffer.clear buffer;
431
+
Buffer.add_string buffer remaining
432
+
done;
433
+
Bytesrw.Bytes.Slice.length slice
434
+
435
+
(* Generic operations *)
436
+
437
+
let fold ~f t init =
438
+
let i = info t in
439
+
let rec loop sector acc =
440
+
if sector >= i.sectors then Ok acc
441
+
else
442
+
match read t sector with
443
+
| Error e -> Error e
444
+
| Ok data -> (
445
+
match f sector data acc with
446
+
| Error e -> Error e
447
+
| Ok acc' -> loop (Int64.succ sector) acc')
448
+
in
449
+
loop 0L init
450
+
451
+
let iter ~f t =
452
+
fold ~f:(fun sector data () -> f sector data) t ()
453
+
454
+
type compare_error =
455
+
[ error
456
+
| `Different_sizes
457
+
| `Different_sector_sizes
458
+
| `Contents_differ of int64 ]
459
+
460
+
let pp_compare_error ppf = function
461
+
| #error as e -> pp_error ppf e
462
+
| `Different_sizes -> Fmt.string ppf "different sizes"
463
+
| `Different_sector_sizes -> Fmt.string ppf "different sector sizes"
464
+
| `Contents_differ n -> Fmt.pf ppf "contents differ at sector %Ld" n
465
+
466
+
let compare a b =
467
+
let ia = info a and ib = info b in
468
+
if ia.sector_size <> ib.sector_size then Error `Different_sector_sizes
469
+
else if ia.sectors <> ib.sectors then Error `Different_sizes
470
+
else
471
+
let rec loop sector =
472
+
if sector >= ia.sectors then Ok ()
473
+
else
474
+
match (read a sector, read b sector) with
475
+
| Error e, _ -> Error (e :> compare_error)
476
+
| _, Error e -> Error (e :> compare_error)
477
+
| Ok da, Ok db ->
478
+
if da <> db then Error (`Contents_differ sector)
479
+
else loop (Int64.succ sector)
480
+
in
481
+
loop 0L
482
+
483
+
type copy_error =
484
+
[ write_error
485
+
| `Different_sizes
486
+
| `Different_sector_sizes ]
487
+
488
+
let pp_copy_error ppf = function
489
+
| #write_error as e -> pp_write_error ppf e
490
+
| `Different_sizes -> Fmt.string ppf "different sizes"
491
+
| `Different_sector_sizes -> Fmt.string ppf "different sector sizes"
492
+
493
+
let copy ~src ~dst =
494
+
let is = info src and id = info dst in
495
+
if is.sector_size <> id.sector_size then Error `Different_sector_sizes
496
+
else if is.sectors > id.sectors then Error `Different_sizes
497
+
else
498
+
let rec loop sector =
499
+
if sector >= is.sectors then Ok ()
500
+
else
501
+
match read src sector with
502
+
| Error e -> Error (e :> copy_error)
503
+
| Ok data -> (
504
+
match write dst sector data with
505
+
| Error e -> Error (e :> copy_error)
506
+
| Ok () -> loop (Int64.succ sector))
507
+
in
508
+
loop 0L
509
+
510
+
let is_zero data =
511
+
let rec loop i =
512
+
if i >= String.length data then true
513
+
else if data.[i] <> '\x00' then false
514
+
else loop (i + 1)
515
+
in
516
+
loop 0
517
+
518
+
let sparse_copy ~src ~dst =
519
+
let is = info src and id = info dst in
520
+
if is.sector_size <> id.sector_size then Error `Different_sector_sizes
521
+
else if is.sectors > id.sectors then Error `Different_sizes
522
+
else
523
+
let rec loop sector =
524
+
if sector >= is.sectors then Ok ()
525
+
else
526
+
match read src sector with
527
+
| Error e -> Error (e :> copy_error)
528
+
| Ok data ->
529
+
if is_zero data then loop (Int64.succ sector)
530
+
else
531
+
match write dst sector data with
532
+
| Error e -> Error (e :> copy_error)
533
+
| Ok () -> loop (Int64.succ sector)
534
+
in
535
+
loop 0L
536
+
537
+
let fill t c =
538
+
let i = info t in
539
+
let data = String.make i.sector_size c in
540
+
let rec loop sector =
541
+
if sector >= i.sectors then Ok ()
542
+
else
543
+
match write t sector data with
544
+
| Error e -> Error e
545
+
| Ok () -> loop (Int64.succ sector)
546
+
in
547
+
loop 0L
548
+
549
+
let zero t = fill t '\x00'
+194
lib/block.mli
+194
lib/block.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Block device abstraction for Eio.
7
+
8
+
This library provides a minimal block device interface inspired by MirageOS
9
+
but using Eio direct-style I/O instead of Lwt.
10
+
11
+
{1 Overview}
12
+
13
+
Block devices provide fixed-size sector access to storage. Unlike streaming
14
+
I/O, block devices support random access reads and writes at sector
15
+
granularity.
16
+
17
+
{[
18
+
Eio_main.run @@ fun env ->
19
+
Eio.Switch.run @@ fun sw ->
20
+
let blk = Block.of_file ~sw env#fs "disk.img" ~sector_size:512 in
21
+
let info = Block.info blk in
22
+
Printf.printf "Sectors: %Ld, Size: %d\n" info.sectors info.sector_size;
23
+
let data = Block.read blk 0L in
24
+
(* ... *)
25
+
]}
26
+
27
+
{1 Types} *)
28
+
29
+
type info = {
30
+
read_write : bool; (** [true] if writes are permitted *)
31
+
sector_size : int; (** Bytes per sector (typically 512 or 4096) *)
32
+
sectors : int64; (** Total number of sectors *)
33
+
}
34
+
(** Device information. *)
35
+
36
+
type t
37
+
(** A block device handle. *)
38
+
39
+
type error =
40
+
[ `Disconnected (** Device has been disconnected *)
41
+
| `Read_error of string (** Read operation failed *)
42
+
| `Invalid_sector of int64 (** Sector number out of bounds *) ]
43
+
(** Read errors. *)
44
+
45
+
type write_error =
46
+
[ error
47
+
| `Write_error of string (** Write operation failed *)
48
+
| `Read_only (** Device is read-only *) ]
49
+
(** Write errors. *)
50
+
51
+
val pp_error : error Fmt.t
52
+
val pp_write_error : write_error Fmt.t
53
+
54
+
(** {1 Device Operations} *)
55
+
56
+
val info : t -> info
57
+
(** [info t] returns device information. *)
58
+
59
+
val read : t -> int64 -> (string, error) result
60
+
(** [read t sector] reads a single sector. Returns sector data or error. *)
61
+
62
+
val read_many : t -> int64 -> int -> (string, error) result
63
+
(** [read_many t start count] reads [count] consecutive sectors starting at
64
+
[start]. Returns concatenated data or error on first failure. *)
65
+
66
+
val write : t -> int64 -> string -> (unit, write_error) result
67
+
(** [write t sector data] writes [data] to [sector]. The length of [data] must
68
+
equal the sector size. *)
69
+
70
+
val write_many : t -> int64 -> string list -> (unit, write_error) result
71
+
(** [write_many t start sectors] writes multiple sectors starting at [start].
72
+
Each string must have length equal to sector size. *)
73
+
74
+
val sync : t -> unit
75
+
(** [sync t] flushes all pending writes to the underlying storage. *)
76
+
77
+
val close : t -> unit
78
+
(** [close t] releases resources. Further operations will return
79
+
[`Disconnected]. *)
80
+
81
+
(** {1 Bytesrw Integration} *)
82
+
83
+
val to_reader : t -> offset:int64 -> length:int64 -> Bytesrw.Bytes.Reader.t
84
+
(** [to_reader t ~offset ~length] creates a sequential reader starting at byte
85
+
[offset] for [length] bytes. Offset must be sector-aligned. *)
86
+
87
+
val to_writer : t -> offset:int64 -> Bytesrw.Bytes.Writer.t
88
+
(** [to_writer t ~offset] creates a sequential writer starting at byte [offset].
89
+
Offset must be sector-aligned. Writes are buffered to sector boundaries. *)
90
+
91
+
(** {1 Implementations} *)
92
+
93
+
val of_memory : sector_size:int -> sectors:int64 -> t
94
+
(** [of_memory ~sector_size ~sectors] creates an in-memory block device. Useful
95
+
for testing. *)
96
+
97
+
val of_bigarray :
98
+
sector_size:int ->
99
+
(char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t ->
100
+
t
101
+
(** [of_bigarray ~sector_size ba] wraps an existing bigarray as a block device.
102
+
The bigarray size must be a multiple of [sector_size]. *)
103
+
104
+
val of_string : sector_size:int -> string -> t
105
+
(** [of_string ~sector_size data] creates a read-only block device from a
106
+
string. Useful for testing with known data. *)
107
+
108
+
val of_file :
109
+
sw:Eio.Switch.t ->
110
+
_ Eio.Path.t ->
111
+
sector_size:int ->
112
+
?create:int64 ->
113
+
unit ->
114
+
t
115
+
(** [of_file ~sw path ~sector_size ?create ()] opens a file as a block device.
116
+
117
+
@param create
118
+
If provided, creates the file with this many sectors if it doesn't exist.
119
+
@param sector_size Sector size in bytes (must be power of 2, >= 512). *)
120
+
121
+
val of_flow :
122
+
sw:Eio.Switch.t ->
123
+
info:info ->
124
+
#Eio.Flow.two_way ->
125
+
t
126
+
(** [of_flow ~sw ~info flow] wraps an Eio two-way flow as a block device. The
127
+
flow must support seeking. Used for raw device access. *)
128
+
129
+
(** {1 Combinators} *)
130
+
131
+
val read_only : t -> t
132
+
(** [read_only t] returns a read-only view of [t]. *)
133
+
134
+
val sub : t -> start:int64 -> sectors:int64 -> t
135
+
(** [sub t ~start ~sectors] returns a view of a subset of sectors. Useful for
136
+
partitioning. *)
137
+
138
+
val with_crc32c : t -> t
139
+
(** [with_crc32c t] wraps [t] with CRC32C checksums. Each sector reserves 4
140
+
bytes for the checksum, reducing usable space per sector by 4 bytes. Reads
141
+
verify checksums and return [`Read_error] on mismatch. *)
142
+
143
+
(** {1 Generic Operations}
144
+
145
+
Operations inspired by MirageOS mirage-block. *)
146
+
147
+
val fold :
148
+
f:(int64 -> string -> 'a -> ('a, error) result) ->
149
+
t ->
150
+
'a ->
151
+
('a, error) result
152
+
(** [fold ~f t init] folds [f] over every sector in the device. [f sector data acc]
153
+
is called for each sector in order. Stops on first error. *)
154
+
155
+
val iter : f:(int64 -> string -> (unit, error) result) -> t -> (unit, error) result
156
+
(** [iter ~f t] iterates [f] over every sector. *)
157
+
158
+
type compare_error =
159
+
[ error
160
+
| `Different_sizes (** Devices have different sector counts *)
161
+
| `Different_sector_sizes (** Devices have different sector sizes *)
162
+
| `Contents_differ of int64 (** Contents differ at this sector *) ]
163
+
(** Comparison errors. *)
164
+
165
+
val pp_compare_error : compare_error Fmt.t
166
+
167
+
val compare : t -> t -> (unit, compare_error) result
168
+
(** [compare a b] compares two block devices sector by sector. Returns [Ok ()]
169
+
if they are identical, or an error describing the first difference. *)
170
+
171
+
type copy_error =
172
+
[ write_error
173
+
| `Different_sizes (** Source larger than destination *)
174
+
| `Different_sector_sizes (** Devices have different sector sizes *) ]
175
+
(** Copy errors. *)
176
+
177
+
val pp_copy_error : copy_error Fmt.t
178
+
179
+
val copy : src:t -> dst:t -> (unit, copy_error) result
180
+
(** [copy ~src ~dst] copies all sectors from [src] to [dst]. The destination
181
+
must be at least as large as the source. *)
182
+
183
+
val sparse_copy : src:t -> dst:t -> (unit, copy_error) result
184
+
(** [sparse_copy ~src ~dst] copies non-zero sectors from [src] to [dst]. Sectors
185
+
that are all zeros are skipped, preserving sparseness. *)
186
+
187
+
val fill : t -> char -> (unit, write_error) result
188
+
(** [fill t c] fills every sector with byte [c]. Useful for wiping a device. *)
189
+
190
+
val zero : t -> (unit, write_error) result
191
+
(** [zero t] fills every sector with zeros. Equivalent to [fill t '\x00']. *)
192
+
193
+
val is_zero : string -> bool
194
+
(** [is_zero data] returns [true] if [data] contains only zero bytes. *)
+4
lib/dune
+4
lib/dune
+1
test/test.ml
+1
test/test.ml
···
1
+
let () = Alcotest.run "block" Test_block.suite
+313
test/test_block.ml
+313
test/test_block.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let sector_size = 512
7
+
8
+
let test_memory_basic () =
9
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
10
+
let info = Block.info blk in
11
+
Alcotest.(check int) "sector_size" sector_size info.sector_size;
12
+
Alcotest.(check bool) "read_write" true info.read_write;
13
+
Alcotest.(check int64) "sectors" 10L info.sectors
14
+
15
+
let test_memory_read_write () =
16
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
17
+
let data = String.make sector_size 'A' in
18
+
(match Block.write blk 0L data with
19
+
| Ok () -> ()
20
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e));
21
+
match Block.read blk 0L with
22
+
| Ok read_data -> Alcotest.(check string) "roundtrip" data read_data
23
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e)
24
+
25
+
let test_memory_bounds () =
26
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
27
+
let data = String.make sector_size 'A' in
28
+
(* Valid write *)
29
+
(match Block.write blk 9L data with
30
+
| Ok () -> ()
31
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e));
32
+
(* Out of bounds *)
33
+
match Block.write blk 10L data with
34
+
| Ok () -> Alcotest.fail "should have failed"
35
+
| Error (`Invalid_sector 10L) -> ()
36
+
| Error e -> Alcotest.fail (Fmt.str "wrong error: %a" Block.pp_write_error e)
37
+
38
+
let test_memory_negative_sector () =
39
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
40
+
match Block.read blk (-1L) with
41
+
| Ok _ -> Alcotest.fail "should have failed"
42
+
| Error (`Invalid_sector _) -> ()
43
+
| Error e -> Alcotest.fail (Fmt.str "wrong error: %a" Block.pp_error e)
44
+
45
+
let test_read_only () =
46
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
47
+
let data = String.make sector_size 'A' in
48
+
(* Write before making read-only *)
49
+
(match Block.write blk 0L data with
50
+
| Ok () -> ()
51
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e));
52
+
let ro = Block.read_only blk in
53
+
let info = Block.info ro in
54
+
Alcotest.(check bool) "read_write" false info.read_write;
55
+
(* Read should work *)
56
+
(match Block.read ro 0L with
57
+
| Ok d -> Alcotest.(check string) "read" data d
58
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e));
59
+
(* Write should fail *)
60
+
match Block.write ro 0L data with
61
+
| Ok () -> Alcotest.fail "should have failed"
62
+
| Error `Read_only -> ()
63
+
| Error e -> Alcotest.fail (Fmt.str "wrong error: %a" Block.pp_write_error e)
64
+
65
+
let test_sub () =
66
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
67
+
(* Write pattern *)
68
+
for i = 0 to 9 do
69
+
let data = String.make sector_size (Char.chr (i + 65)) in
70
+
match Block.write blk (Int64.of_int i) data with
71
+
| Ok () -> ()
72
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e)
73
+
done;
74
+
(* Create sub-device for sectors 3-5 *)
75
+
let sub = Block.sub blk ~start:3L ~sectors:3L in
76
+
let info = Block.info sub in
77
+
Alcotest.(check int64) "sub sectors" 3L info.sectors;
78
+
(* Read from sub (sector 0 of sub = sector 3 of original) *)
79
+
match Block.read sub 0L with
80
+
| Ok data ->
81
+
Alcotest.(check char) "sub read" 'D' data.[0]
82
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e)
83
+
84
+
let test_read_many () =
85
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
86
+
for i = 0 to 9 do
87
+
let data = String.make sector_size (Char.chr (i + 65)) in
88
+
match Block.write blk (Int64.of_int i) data with
89
+
| Ok () -> ()
90
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e)
91
+
done;
92
+
match Block.read_many blk 2L 3 with
93
+
| Ok data ->
94
+
Alcotest.(check int) "length" (3 * sector_size) (String.length data);
95
+
Alcotest.(check char) "first" 'C' data.[0];
96
+
Alcotest.(check char) "second" 'D' data.[sector_size];
97
+
Alcotest.(check char) "third" 'E' data.[2 * sector_size]
98
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e)
99
+
100
+
let test_crc32c () =
101
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
102
+
let crc_blk = Block.with_crc32c blk in
103
+
let info = Block.info crc_blk in
104
+
(* Effective sector size is reduced by 4 bytes for CRC *)
105
+
Alcotest.(check int) "effective sector_size" (sector_size - 4) info.sector_size;
106
+
let data = String.make (sector_size - 4) 'X' in
107
+
(match Block.write crc_blk 0L data with
108
+
| Ok () -> ()
109
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e));
110
+
match Block.read crc_blk 0L with
111
+
| Ok read_data -> Alcotest.(check string) "crc roundtrip" data read_data
112
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e)
113
+
114
+
let test_crc32c_corruption () =
115
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
116
+
let crc_blk = Block.with_crc32c blk in
117
+
let data = String.make (sector_size - 4) 'Y' in
118
+
(match Block.write crc_blk 0L data with
119
+
| Ok () -> ()
120
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e));
121
+
(* Corrupt the underlying data *)
122
+
let raw = match Block.read blk 0L with Ok d -> d | Error _ -> Alcotest.fail "read" in
123
+
let corrupted = Bytes.of_string raw in
124
+
Bytes.set corrupted 0 'Z';
125
+
(match Block.write blk 0L (Bytes.to_string corrupted) with
126
+
| Ok () -> ()
127
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e));
128
+
(* Read through CRC layer should fail *)
129
+
match Block.read crc_blk 0L with
130
+
| Ok _ -> Alcotest.fail "should have detected corruption"
131
+
| Error (`Read_error msg) ->
132
+
Alcotest.(check bool) "crc error" true (String.length msg > 0)
133
+
| Error e -> Alcotest.fail (Fmt.str "wrong error: %a" Block.pp_error e)
134
+
135
+
let test_of_string () =
136
+
let original = String.init (sector_size * 3) (fun i -> Char.chr ((i mod 26) + 65)) in
137
+
let blk = Block.of_string ~sector_size original in
138
+
let info = Block.info blk in
139
+
Alcotest.(check bool) "read_only" false info.read_write;
140
+
Alcotest.(check int64) "sectors" 3L info.sectors;
141
+
match Block.read blk 1L with
142
+
| Ok data ->
143
+
let expected = String.sub original sector_size sector_size in
144
+
Alcotest.(check string) "read sector 1" expected data
145
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e)
146
+
147
+
let test_close () =
148
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
149
+
Block.close blk;
150
+
match Block.read blk 0L with
151
+
| Ok _ -> Alcotest.fail "should have failed after close"
152
+
| Error `Disconnected -> ()
153
+
| Error e -> Alcotest.fail (Fmt.str "wrong error: %a" Block.pp_error e)
154
+
155
+
let test_file () =
156
+
Eio_main.run @@ fun env ->
157
+
Eio.Switch.run @@ fun sw ->
158
+
let path = Eio.Path.(Eio.Stdenv.cwd env / "test_block.img") in
159
+
let blk = Block.of_file ~sw path ~sector_size ~create:10L () in
160
+
let data = String.make sector_size 'F' in
161
+
(match Block.write blk 5L data with
162
+
| Ok () -> ()
163
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e));
164
+
Block.sync blk;
165
+
(match Block.read blk 5L with
166
+
| Ok d -> Alcotest.(check string) "file roundtrip" data d
167
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e));
168
+
Block.close blk;
169
+
(* Cleanup *)
170
+
Eio.Path.unlink path
171
+
172
+
let test_fold () =
173
+
let blk = Block.of_memory ~sector_size ~sectors:5L in
174
+
for i = 0 to 4 do
175
+
let data = String.make sector_size (Char.chr (i + 65)) in
176
+
match Block.write blk (Int64.of_int i) data with
177
+
| Ok () -> ()
178
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e)
179
+
done;
180
+
match Block.fold ~f:(fun _ data acc -> Ok (acc + Char.code data.[0])) blk 0 with
181
+
| Ok sum ->
182
+
(* A=65, B=66, C=67, D=68, E=69 => sum = 335 *)
183
+
Alcotest.(check int) "fold sum" 335 sum
184
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e)
185
+
186
+
let test_compare_equal () =
187
+
let a = Block.of_memory ~sector_size ~sectors:10L in
188
+
let b = Block.of_memory ~sector_size ~sectors:10L in
189
+
for i = 0 to 9 do
190
+
let data = String.make sector_size (Char.chr (i + 65)) in
191
+
let _ = Block.write a (Int64.of_int i) data in
192
+
let _ = Block.write b (Int64.of_int i) data in
193
+
()
194
+
done;
195
+
match Block.compare a b with
196
+
| Ok () -> ()
197
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_compare_error e)
198
+
199
+
let test_compare_different () =
200
+
let a = Block.of_memory ~sector_size ~sectors:10L in
201
+
let b = Block.of_memory ~sector_size ~sectors:10L in
202
+
for i = 0 to 9 do
203
+
let data = String.make sector_size (Char.chr (i + 65)) in
204
+
let _ = Block.write a (Int64.of_int i) data in
205
+
let _ = Block.write b (Int64.of_int i) data in
206
+
()
207
+
done;
208
+
(* Make sector 5 different *)
209
+
let _ = Block.write b 5L (String.make sector_size 'Z') in
210
+
match Block.compare a b with
211
+
| Ok () -> Alcotest.fail "should have detected difference"
212
+
| Error (`Contents_differ 5L) -> ()
213
+
| Error e -> Alcotest.fail (Fmt.str "wrong error: %a" Block.pp_compare_error e)
214
+
215
+
let test_copy () =
216
+
let src = Block.of_memory ~sector_size ~sectors:10L in
217
+
let dst = Block.of_memory ~sector_size ~sectors:10L in
218
+
for i = 0 to 9 do
219
+
let data = String.make sector_size (Char.chr (i + 65)) in
220
+
let _ = Block.write src (Int64.of_int i) data in
221
+
()
222
+
done;
223
+
(match Block.copy ~src ~dst with
224
+
| Ok () -> ()
225
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_copy_error e));
226
+
match Block.compare src dst with
227
+
| Ok () -> ()
228
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_compare_error e)
229
+
230
+
let test_sparse_copy () =
231
+
let src = Block.of_memory ~sector_size ~sectors:10L in
232
+
let dst = Block.of_memory ~sector_size ~sectors:10L in
233
+
(* Write non-zero to sectors 0, 5, 9 only *)
234
+
let _ = Block.write src 0L (String.make sector_size 'A') in
235
+
let _ = Block.write src 5L (String.make sector_size 'F') in
236
+
let _ = Block.write src 9L (String.make sector_size 'J') in
237
+
(* Fill dst with pattern to detect non-writes *)
238
+
let _ = Block.fill dst 'X' in
239
+
(match Block.sparse_copy ~src ~dst with
240
+
| Ok () -> ()
241
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_copy_error e));
242
+
(* Check copied sectors *)
243
+
(match Block.read dst 0L with
244
+
| Ok d -> Alcotest.(check char) "sector 0" 'A' d.[0]
245
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e));
246
+
(match Block.read dst 5L with
247
+
| Ok d -> Alcotest.(check char) "sector 5" 'F' d.[0]
248
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e));
249
+
(* Check skipped sector still has X pattern *)
250
+
match Block.read dst 3L with
251
+
| Ok d -> Alcotest.(check char) "sector 3" 'X' d.[0]
252
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e)
253
+
254
+
let test_zero () =
255
+
let blk = Block.of_memory ~sector_size ~sectors:10L in
256
+
let _ = Block.fill blk 'X' in
257
+
(match Block.zero blk with
258
+
| Ok () -> ()
259
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_write_error e));
260
+
for i = 0 to 9 do
261
+
match Block.read blk (Int64.of_int i) with
262
+
| Ok d -> Alcotest.(check bool) "is zero" true (Block.is_zero d)
263
+
| Error e -> Alcotest.fail (Fmt.str "%a" Block.pp_error e)
264
+
done
265
+
266
+
let test_is_zero () =
267
+
Alcotest.(check bool) "all zeros" true (Block.is_zero (String.make 512 '\x00'));
268
+
Alcotest.(check bool) "not zeros" false (Block.is_zero "hello");
269
+
Alcotest.(check bool) "one non-zero" false (Block.is_zero (String.make 511 '\x00' ^ "x"))
270
+
271
+
let suite =
272
+
[
273
+
( "memory",
274
+
[
275
+
Alcotest.test_case "basic" `Quick test_memory_basic;
276
+
Alcotest.test_case "read_write" `Quick test_memory_read_write;
277
+
Alcotest.test_case "bounds" `Quick test_memory_bounds;
278
+
Alcotest.test_case "negative sector" `Quick test_memory_negative_sector;
279
+
Alcotest.test_case "close" `Quick test_close;
280
+
] );
281
+
( "wrappers",
282
+
[
283
+
Alcotest.test_case "read_only" `Quick test_read_only;
284
+
Alcotest.test_case "sub" `Quick test_sub;
285
+
Alcotest.test_case "of_string" `Quick test_of_string;
286
+
] );
287
+
( "operations",
288
+
[
289
+
Alcotest.test_case "read_many" `Quick test_read_many;
290
+
Alcotest.test_case "fold" `Quick test_fold;
291
+
Alcotest.test_case "is_zero" `Quick test_is_zero;
292
+
Alcotest.test_case "zero" `Quick test_zero;
293
+
] );
294
+
( "compare",
295
+
[
296
+
Alcotest.test_case "equal" `Quick test_compare_equal;
297
+
Alcotest.test_case "different" `Quick test_compare_different;
298
+
] );
299
+
( "copy",
300
+
[
301
+
Alcotest.test_case "copy" `Quick test_copy;
302
+
Alcotest.test_case "sparse_copy" `Quick test_sparse_copy;
303
+
] );
304
+
( "crc32c",
305
+
[
306
+
Alcotest.test_case "roundtrip" `Quick test_crc32c;
307
+
Alcotest.test_case "corruption" `Quick test_crc32c_corruption;
308
+
] );
309
+
( "file",
310
+
[
311
+
Alcotest.test_case "roundtrip" `Quick test_file;
312
+
] );
313
+
]