upstream: https://github.com/mirage/ocaml-gpt
Squashed 'ocaml-gpt/' content from commit b86c3620 git-subtree-split: b86c3620b3f5c49f7aceeb923b5c78d1e0c395ff
+1253
+29
.gitignore
+29
.gitignore
···
1
+
*.annot
2
+
*.cmo
3
+
*.cma
4
+
*.cmi
5
+
*.a
6
+
*.o
7
+
*.cmx
8
+
*.cmxs
9
+
*.cmxa
10
+
11
+
# ocamlbuild working directory
12
+
_build/
13
+
14
+
# ocamlbuild targets
15
+
*.byte
16
+
*.native
17
+
18
+
# oasis generated files
19
+
setup.data
20
+
setup.log
21
+
22
+
# Merlin configuring file for Vim and Emacs
23
+
.merlin
24
+
25
+
# Dune generated files
26
+
*.install
27
+
28
+
# Local OPAM switch
29
+
_opam/
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version = 0.28.1
+14
LICENSE
+14
LICENSE
···
1
+
Copyright (c) 2014, Citrix Systems Inc
2
+
3
+
Permission to use, copy, modify, and/or distribute this software for any
4
+
purpose with or without fee is hereby granted, provided that the above
5
+
copyright notice and this permission notice appear in all copies.
6
+
7
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14
+
+113
README.md
+113
README.md
···
1
+
# ocaml-gpt
2
+
3
+
## Introduction
4
+
5
+
This library provides functionality for working with the GUID Partition Table (GPT). It allows you to create, manipulate, and marshal/unmarshal GPT headers and partitions.
6
+
7
+
## Dependencies
8
+
- `OCaml` (version 4.02 or later)
9
+
- `dune` (build system)
10
+
- `uuidm` (library for UUID manipulation)
11
+
- `checkseum` (library for checksum calculations)
12
+
- `ocaml-cstruct` (library for working with C-like structures)
13
+
14
+
## Installation
15
+
1) Install OCaml and dune by following the instructions for your platform. [Up and Running with Ocaml](https://ocaml.org/docs/up-and-running)
16
+
2) Install the required dependencies using OPAM (OCaml package manager)
17
+
```sh
18
+
opam install .
19
+
```
20
+
3) Build the project using dune
21
+
```sh
22
+
dune build
23
+
```
24
+
25
+
4) Run Test
26
+
```sh
27
+
dune build @runtest
28
+
```
29
+
30
+
## Usage
31
+
32
+
### Module: Partition
33
+
This module provides functions for working with GPT partitions.
34
+
```ocaml
35
+
Partition.make
36
+
val make :
37
+
?name:string ->
38
+
type_guid:Uuidm.t ->
39
+
attributes:int64 ->
40
+
starting_lba:int64 ->
41
+
ending_lba:int64 ->
42
+
(Partition.t, string) result
43
+
```
44
+
This function creates a new GPT partition with the specified parameters. It returns a `Partition.t` value wrapped in the Result type, indicating success or failure. `name` should be a `utf-16-le` encoded string of length 72 bytes.
45
+
46
+
#### Partition.unmarshal
47
+
```ocaml
48
+
val unmarshal : Cstruct.t -> (Partition.t, string) result
49
+
```
50
+
This function takes a `Cstruct.t` buffer and unmarshals the data into a `Partition.t` value. It returns the unmarshalled partition wrapped in the Result type, indicating success or failure.
51
+
52
+
#### Partition.marshal
53
+
```ocaml
54
+
val marshal : Cstruct.t -> Partition.t -> unit
55
+
```
56
+
This function marshals a `Partition.t` value into a `Cstruct.t` buffer.
57
+
58
+
59
+
### Module: Gpt
60
+
This module provides functions for working with GPT headers.
61
+
62
+
#### Gpt.make
63
+
```ocaml
64
+
val make : ?disk_guid:Uuidm.t -> disk_size:int64
65
+
-> sector_size:int -> Partition.t list -> (t, string) result
66
+
```
67
+
This function creates a new GPT header with the specified list of partitions. It returns a `Gpt.t` value wrapped in the Result type, indicating success or failure.
68
+
69
+
#### Gpt.unmarshal
70
+
```ocaml
71
+
val unmarshal : Cstruct.t -> sector_size:int -> (t, string) result
72
+
```
73
+
This function takes a `Cstruct.t` buffer and unmarshals the data into a `Gpt.t` value. It returns the unmarshalled GPT header wrapped in the Result type, indicating success or failure.
74
+
75
+
#### Gpt.marshal
76
+
```ocaml
77
+
val marshal : Cstruct.t -> t -> unit
78
+
```
79
+
This function marshals a `Gpt.t` value into a `Cstruct.t` buffer.
80
+
81
+
## Example Usage
82
+
Here's an example of how you can use this library to create and manipulate GPT headers and partitions:
83
+
84
+
```ocaml
85
+
let create_gpt_header () =
86
+
let partition1 = Match Partition.make ~name:"Partition 1" ~type_guid:"12345678-1234-1234-1234-123456789abc" ~attributes:0L 1L 100L
87
+
with
88
+
| Ok p -> p
89
+
| Error error -> Printf.eprintf "Error %s" error
90
+
in
91
+
match make [partition1] ~disk_size:1024L ~sector_size:512 with
92
+
| Ok gpt -> gpt
93
+
| Error error -> Printf.eprintf "Error %s" error
94
+
95
+
```
96
+
97
+
## Tools
98
+
99
+
### Inspect the GPT Header:
100
+
- `gpt_inspect.exe`: This script prints the GPT header and it's corresponding partitions. It enables you inspect your GPT disks.
101
+
102
+
#### Usage
103
+
```ocaml
104
+
dune exec -- bin/gpt_inspect.exe disk.img
105
+
```
106
+
107
+
- `disk.img` corresponds to the disk or disk file image you wish to inspect
108
+
109
+
## License
110
+
This libray is licensed with the Ocaml standard ISC license. See here [License](LICENSE)
111
+
112
+
## Contributions
113
+
Please report bugs using the issue tracker at [https://github.com/PizieDust/ocaml-gpt/issues](https://github.com/PizieDust/ocaml-gpt/issues)
+92
bin/gpt_inspect.ml
+92
bin/gpt_inspect.ml
···
1
+
open Cmdliner
2
+
3
+
let _sizeof = 128
4
+
5
+
let print_gpt_partitions partitions =
6
+
List.iteri
7
+
(fun i part ->
8
+
if
9
+
Uuidm.to_string part.Gpt.Partition.type_guid
10
+
<> "00000000-0000-0000-0000-000000000000"
11
+
then (
12
+
Printf.printf " Partition %d:\n" (i + 1);
13
+
Printf.printf " name: %s\n" part.Gpt.Partition.name;
14
+
Printf.printf " type-guid: %s\n"
15
+
(Uuidm.to_string ~upper:true part.Gpt.Partition.type_guid);
16
+
Printf.printf " partition-guid: %s\n"
17
+
(Uuidm.to_string ~upper:true part.Gpt.Partition.partition_guid);
18
+
Printf.printf " attributes: 0x%Lx\n" part.Gpt.Partition.attributes;
19
+
Printf.printf " starting-lba: %Lu\n"
20
+
part.Gpt.Partition.starting_lba;
21
+
Printf.printf " ending-lba: %Lu\n" part.Gpt.Partition.ending_lba))
22
+
partitions
23
+
24
+
let print_gpt_header gpt =
25
+
Printf.printf "GPT header:\n";
26
+
Printf.printf " revision: 0x%08lx\n" gpt.Gpt.revision;
27
+
Printf.printf " gpt-size: %lu\n" gpt.Gpt.header_size;
28
+
Printf.printf " gpt-checksum: %lu\n" gpt.Gpt.header_crc32;
29
+
Printf.printf " reserved: %lu\n" gpt.Gpt.reserved;
30
+
Printf.printf " current-lba: %Lu\n" gpt.Gpt.current_lba;
31
+
Printf.printf " backup-lba: %Lu\n" gpt.Gpt.backup_lba;
32
+
Printf.printf " first-usable-lba: %Lu\n" gpt.Gpt.first_usable_lba;
33
+
Printf.printf " last-usable-lba: %Lu\n" gpt.Gpt.last_usable_lba;
34
+
Printf.printf " disk-guid: %s\n"
35
+
(Uuidm.to_string ~upper:true gpt.Gpt.disk_guid);
36
+
Printf.printf " first-partition-lba: %Lu\n" gpt.Gpt.partition_entry_lba;
37
+
Printf.printf " total-partitions: %lu\n" gpt.Gpt.num_partition_entries;
38
+
Printf.printf " partition-size: %lu\n" gpt.Gpt.partition_size;
39
+
Printf.printf " partitions-checksum: %lu\n" gpt.Gpt.partitions_crc32;
40
+
Printf.printf " Partitions: \n";
41
+
Printf.printf " *********** \n";
42
+
print_gpt_partitions gpt.Gpt.partitions
43
+
44
+
let really_input fd buf pos len =
45
+
let rec loop pos remaining =
46
+
if remaining > 0 then
47
+
let len = Unix.read fd buf pos remaining in
48
+
if len = 0 then raise End_of_file;
49
+
loop (pos + len) (remaining - len)
50
+
in
51
+
loop pos len
52
+
53
+
let read_gpts sector_size gpts =
54
+
List.iter
55
+
(fun gpt ->
56
+
let fd = Unix.openfile gpt Unix.[O_RDONLY; O_CLOEXEC] 0 in
57
+
let buf = Bytes.create sector_size in
58
+
let _ = Unix.lseek fd sector_size Unix.SEEK_SET in
59
+
let () = really_input fd buf 0 sector_size in
60
+
match Gpt.unmarshal (Cstruct.of_bytes buf) ~sector_size with
61
+
| Error msg ->
62
+
Printf.printf "Failed to read GPT header from %s: %s\n" gpt msg;
63
+
exit 1
64
+
| Ok (`Read_partition_table (lba, num_sectors), k) ->
65
+
let buf = Bytes.create (sector_size * num_sectors) in
66
+
let _ = Unix.lseek fd (sector_size * Int64.to_int lba) Unix.SEEK_SET in
67
+
let () = really_input fd buf 0 (sector_size * num_sectors) in
68
+
let () = Unix.close fd in
69
+
match k (Cstruct.of_bytes buf) with
70
+
| Error msg ->
71
+
Printf.printf "Failed to read GPT partition table from %s: %s\n" gpt msg;
72
+
exit 1
73
+
| Ok gpt ->
74
+
print_gpt_header gpt
75
+
)
76
+
gpts
77
+
78
+
let gpts = Arg.(non_empty & pos_all file [] & info [] ~docv:"disk_images")
79
+
80
+
let sector_size =
81
+
let doc = Arg.info ["sector-size"] ~docv:"SECTOR_SIZE" in
82
+
Arg.(value & opt int 512 & doc)
83
+
84
+
let cmd =
85
+
let doc =
86
+
"Inspect the GUID Partition Table (GPT) headers of one or more disk images."
87
+
in
88
+
let info = Cmd.info "gpt_inspect" ~version:"1.0.0" ~doc in
89
+
Cmd.v info Term.(const read_gpts $ sector_size $ gpts)
90
+
91
+
let main () = exit (Cmd.eval cmd)
92
+
let () = main ()
+35
dune-project
+35
dune-project
···
1
+
(lang dune 3.17)
2
+
3
+
(name gpt)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(license ISC)
8
+
9
+
(authors
10
+
"David Scott <dave.scott@eu.citrix.com>"
11
+
"PizieDust <playersrebirth@gmail.com>"
12
+
"Reynir Björnsson <reynir@reynir.dk>")
13
+
14
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
15
+
16
+
(source
17
+
(uri https://tangled.org/gazagnaire.org/ocaml-gpt))
18
+
19
+
(bug_reports "https://tangled.org/gazagnaire.org/ocaml-gpt/issues")
20
+
21
+
(package
22
+
(name gpt)
23
+
(synopsis "A library to manipulate GUID Partition Tables")
24
+
(description
25
+
"Pure OCaml library for reading and writing GUID Partition Tables (GPT).
26
+
Useful for creating bootable disk images with modern partition layouts.")
27
+
(depends
28
+
(ocaml (>= 5.1))
29
+
(bytesrw (>= 0.1))
30
+
(uuidm (>= 0.9.7))
31
+
(checkseum (>= 0.4.0))
32
+
(mbr-format (>= 2.0.0))
33
+
(alcotest :with-test)
34
+
(fmt :with-test)
35
+
(crowbar :with-test)))
+23
fuzz/dune
+23
fuzz/dune
···
1
+
; Crowbar fuzz testing for gpt
2
+
;
3
+
; Run: dune exec fuzz/fuzz_gpt.exe
4
+
; AFL: afl-fuzz -i fuzz/input -o fuzz/findings -- ./_build/default/fuzz/fuzz_gpt.exe @@
5
+
6
+
(executable
7
+
(name fuzz_gpt)
8
+
(libraries gpt bytesrw crowbar))
9
+
10
+
(rule
11
+
(alias fuzz)
12
+
(deps fuzz_gpt.exe)
13
+
(action
14
+
(run %{exe:fuzz_gpt.exe})))
15
+
16
+
; AFL-instrumented build target
17
+
18
+
(rule
19
+
(alias fuzz-afl)
20
+
(deps
21
+
(glob_files *.ml))
22
+
(action
23
+
(run echo "Build with: dune build --profile=afl fuzz/fuzz_gpt.exe")))
+99
fuzz/fuzz_gpt.ml
+99
fuzz/fuzz_gpt.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Fuzz tests for GPT parsing.
7
+
8
+
Key properties tested:
9
+
1. Header parser crash safety - no crashes on arbitrary input
10
+
2. Partition entry parser crash safety
11
+
3. Roundtrip - marshal(make(partitions)) is parseable
12
+
4. CRC32 validation
13
+
14
+
Security considerations:
15
+
- GPT has CRC32 checksums that must be validated
16
+
- Partition count field can claim huge values
17
+
- LBA values can overflow when multiplied by sector size *)
18
+
19
+
open Crowbar
20
+
21
+
(** Truncate input to reasonable size. *)
22
+
let truncate ?(max_len = 4096) buf =
23
+
let len = min max_len (String.length buf) in
24
+
String.sub buf 0 len
25
+
26
+
(** GPT header unmarshal crash safety.
27
+
Parser must not crash on any input. *)
28
+
let test_header_unmarshal_crash_safety buf =
29
+
let buf = truncate ~max_len:512 buf in
30
+
(* Pad to at least 92 bytes (GPT header size) *)
31
+
let buf =
32
+
if String.length buf < 512 then
33
+
buf ^ String.make (512 - String.length buf) '\x00'
34
+
else buf
35
+
in
36
+
let _ = Gpt.of_string buf ~sector_size:512 in
37
+
()
38
+
39
+
(** GPT make and marshal roundtrip. *)
40
+
let test_roundtrip () =
41
+
let linux_fs =
42
+
match Uuidm.of_string "0FC63DAF-8483-4772-8E79-3D69D8477DE4" with
43
+
| Some u -> u
44
+
| None -> fail "invalid UUID"
45
+
in
46
+
let p1 =
47
+
match Gpt.Partition.make ~type_guid:linux_fs ~attributes:0L 2048L 1050623L with
48
+
| Ok p -> p
49
+
| Error _ -> fail "failed to create partition"
50
+
in
51
+
let gpt =
52
+
match Gpt.make ~disk_sectors:2097152L ~sector_size:512 [ p1 ] with
53
+
| Ok g -> g
54
+
| Error _ -> fail "failed to create GPT"
55
+
in
56
+
(* Create a reader from header + partition table *)
57
+
let header = Gpt.marshal_header_to_bytes ~sector_size:512 ~primary:true gpt in
58
+
let table = Gpt.marshal_partition_table_to_string ~sector_size:512 gpt in
59
+
let data = header ^ table in
60
+
let reader = Bytesrw.Bytes.Reader.of_string data in
61
+
match Gpt.read reader ~sector_size:512 with
62
+
| Error _ -> fail "roundtrip: read failed"
63
+
| Ok _ -> ()
64
+
65
+
(** Partition make with arbitrary LBA values. *)
66
+
let test_partition_make start_lba end_lba attrs =
67
+
let linux_fs =
68
+
match Uuidm.of_string "0FC63DAF-8483-4772-8E79-3D69D8477DE4" with
69
+
| Some u -> u
70
+
| None -> fail "invalid UUID"
71
+
in
72
+
let start_lba = Int64.of_int (abs start_lba) in
73
+
let end_lba = Int64.of_int (abs end_lba) in
74
+
let attrs = Int64.of_int attrs in
75
+
let _ = Gpt.Partition.make ~type_guid:linux_fs ~attributes:attrs start_lba end_lba in
76
+
()
77
+
78
+
(** GPT make with arbitrary disk parameters. *)
79
+
let test_gpt_make disk_sectors sector_mult =
80
+
let linux_fs =
81
+
match Uuidm.of_string "0FC63DAF-8483-4772-8E79-3D69D8477DE4" with
82
+
| Some u -> u
83
+
| None -> fail "invalid UUID"
84
+
in
85
+
let disk_sectors = Int64.of_int (max 100 (abs disk_sectors)) in
86
+
let sector_size = 512 * (1 + abs (sector_mult mod 8)) in
87
+
let p1 = Gpt.Partition.make ~type_guid:linux_fs ~attributes:0L 34L 100L in
88
+
match p1 with
89
+
| Error _ -> ()
90
+
| Ok p1 ->
91
+
let _ = Gpt.make ~disk_sectors ~sector_size [ p1 ] in
92
+
()
93
+
94
+
let () =
95
+
add_test ~name:"gpt: header unmarshal crash safety" [ bytes ]
96
+
test_header_unmarshal_crash_safety;
97
+
add_test ~name:"gpt: roundtrip" [] test_roundtrip;
98
+
add_test ~name:"gpt: partition make" [ int; int; int ] test_partition_make;
99
+
add_test ~name:"gpt: make with params" [ int; int ] test_gpt_make
+1
fuzz/input/seed
+1
fuzz/input/seed
···
1
+
seed
+40
gpt.opam
+40
gpt.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "A library to manipulate GUID Partition tables"
4
+
description: "A longer description"
5
+
maintainer: [
6
+
"PizieDust <playersrebirth@gmail.com>"
7
+
"Reynir Björnsson <reynir@reynir.dk>"
8
+
]
9
+
authors: ["PizieDust <playersrebirth@gmail.com>"]
10
+
license: "ISC"
11
+
tags: ["mirage" "ocaml" "storage" "gpt"]
12
+
homepage: "https://github.com/mirage/ocaml-gpt"
13
+
doc: "https://mirage.github.io/ocaml-gpt/"
14
+
bug-reports: "https://github.com/mirage/ocaml-gpt/issues"
15
+
depends: [
16
+
"ocaml" {>= "4.13.0"}
17
+
"dune" {>= "3.7"}
18
+
"cstruct"
19
+
"uuidm" {>= "0.9.7"}
20
+
"checkseum" {>= "0.4.0"}
21
+
"mbr-format" {>= "2.0.0"}
22
+
"alcotest" {with-test}
23
+
"fmt" {with-test}
24
+
"odoc" {with-doc}
25
+
]
26
+
build: [
27
+
["dune" "subst"] {dev}
28
+
[
29
+
"dune"
30
+
"build"
31
+
"-p"
32
+
name
33
+
"-j"
34
+
jobs
35
+
"@install"
36
+
"@runtest" {with-test}
37
+
"@doc" {with-doc}
38
+
]
39
+
]
40
+
dev-repo: "git+https://github.com/mirage/ocaml-gpt.git"
+5
lib/dune
+5
lib/dune
+468
lib/gpt.ml
+468
lib/gpt.ml
···
1
+
(*
2
+
* Copyright (C) 2013 Citrix Inc
3
+
*
4
+
* Permission to use, copy, modify, and distribute this software for any
5
+
* purpose with or without fee is hereby granted, provided that the above
6
+
* copyright notice and this permission notice appear in all copies.
7
+
*
8
+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9
+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10
+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11
+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12
+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13
+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14
+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15
+
*)
16
+
17
+
module Result_syntax = struct
18
+
let ( let* ) = Result.bind
19
+
end
20
+
21
+
open Result_syntax
22
+
23
+
let guid_len = 16
24
+
25
+
(* The size of a header not counting the reserved space *)
26
+
let sizeof = 92
27
+
28
+
(* Binary reading helpers - little-endian *)
29
+
let get_u8 s off = Char.code (Bytes.get s off)
30
+
let get_u16_le s off = get_u8 s off lor (get_u8 s (off + 1) lsl 8)
31
+
32
+
let get_u32_le s off =
33
+
Int32.logor
34
+
(Int32.of_int (get_u16_le s off))
35
+
(Int32.shift_left (Int32.of_int (get_u16_le s (off + 2))) 16)
36
+
37
+
let get_u64_le s off =
38
+
Int64.logor
39
+
(Int64.of_int32 (get_u32_le s off))
40
+
(Int64.shift_left (Int64.of_int32 (get_u32_le s (off + 4))) 32)
41
+
42
+
(* Binary writing helpers - little-endian *)
43
+
let set_u8 s off v = Bytes.set s off (Char.chr (v land 0xff))
44
+
45
+
let set_u16_le s off v =
46
+
set_u8 s off (v land 0xff);
47
+
set_u8 s (off + 1) ((v lsr 8) land 0xff)
48
+
49
+
let set_u32_le s off v =
50
+
set_u16_le s off (Int32.to_int (Int32.logand v 0xffffl));
51
+
set_u16_le s (off + 2)
52
+
(Int32.to_int (Int32.logand (Int32.shift_right_logical v 16) 0xffffl))
53
+
54
+
let set_u64_le s off v =
55
+
set_u32_le s off (Int64.to_int32 v);
56
+
set_u32_le s (off + 4) (Int64.to_int32 (Int64.shift_right_logical v 32))
57
+
58
+
module Reader = Bytesrw.Bytes.Reader
59
+
module Writer = Bytesrw.Bytes.Writer
60
+
module Slice = Bytesrw.Bytes.Slice
61
+
62
+
(* Read exactly n bytes from reader *)
63
+
let read_exactly reader n =
64
+
if n = 0 then Ok Bytes.empty
65
+
else
66
+
let buf = Bytes.create n in
67
+
let rec loop pos remaining =
68
+
if remaining = 0 then Ok buf
69
+
else
70
+
match Reader.read reader with
71
+
| slice when Slice.is_eod slice -> Error "unexpected end of data"
72
+
| slice ->
73
+
let str = Slice.to_string slice in
74
+
let available = String.length str in
75
+
let to_copy = min available remaining in
76
+
Bytes.blit_string str 0 buf pos to_copy;
77
+
if to_copy < available then begin
78
+
let leftover = String.sub str to_copy (available - to_copy) in
79
+
Reader.push_back reader (Slice.of_string leftover)
80
+
end;
81
+
loop (pos + to_copy) (remaining - to_copy)
82
+
in
83
+
loop 0 n
84
+
85
+
module Partition = struct
86
+
type t = {
87
+
type_guid : Uuidm.t;
88
+
partition_guid : Uuidm.t;
89
+
starting_lba : int64;
90
+
ending_lba : int64;
91
+
attributes : int64;
92
+
name : string;
93
+
}
94
+
95
+
let make ?(name = String.make 72 '\000') ~type_guid ~attributes starting_lba
96
+
ending_lba =
97
+
let partition_guid = Uuidm.v4_gen (Random.State.make_self_init ()) () in
98
+
if String.length name <> 72 then
99
+
Printf.ksprintf invalid_arg "Name length %d should be exactly 72\n"
100
+
(String.length name);
101
+
Ok { type_guid; partition_guid; starting_lba; ending_lba; attributes; name }
102
+
103
+
let is_zero_partition p =
104
+
let zero_uuid =
105
+
Option.get (Uuidm.of_string "00000000-0000-0000-0000-000000000000")
106
+
in
107
+
Uuidm.equal p.type_guid zero_uuid
108
+
&& Uuidm.equal p.partition_guid zero_uuid
109
+
&& p.starting_lba = 0L && p.ending_lba = 0L && p.attributes = 0L
110
+
&& String.for_all (Char.equal '\000') p.name
111
+
112
+
let sizeof = 128
113
+
let type_guid_offset = 0
114
+
let partition_guid_offset = 16
115
+
let starting_lba_offset = 32
116
+
let ending_lba_offset = 40
117
+
let attributes_offset = 48
118
+
let name_offset = 56
119
+
120
+
let unmarshal buf off =
121
+
if Bytes.length buf < off + sizeof then
122
+
Printf.ksprintf invalid_arg "Partition entry too small: %d < %d"
123
+
(Bytes.length buf - off)
124
+
sizeof;
125
+
let type_guid_bytes = Bytes.sub_string buf (off + type_guid_offset) guid_len in
126
+
let type_guid = Option.get (Uuidm.of_mixed_endian_bytes type_guid_bytes) in
127
+
let partition_guid_bytes =
128
+
Bytes.sub_string buf (off + partition_guid_offset) guid_len
129
+
in
130
+
let partition_guid =
131
+
Option.get (Uuidm.of_mixed_endian_bytes partition_guid_bytes)
132
+
in
133
+
let starting_lba = get_u64_le buf (off + starting_lba_offset) in
134
+
let ending_lba = get_u64_le buf (off + ending_lba_offset) in
135
+
let attributes = get_u64_le buf (off + attributes_offset) in
136
+
let name = Bytes.sub_string buf (off + name_offset) 72 in
137
+
{ type_guid; partition_guid; starting_lba; ending_lba; attributes; name }
138
+
139
+
let marshal (buf : bytes) off t =
140
+
Bytes.blit_string (Uuidm.to_mixed_endian_bytes t.type_guid) 0 buf
141
+
(off + type_guid_offset) guid_len;
142
+
Bytes.blit_string (Uuidm.to_mixed_endian_bytes t.partition_guid) 0 buf
143
+
(off + partition_guid_offset) guid_len;
144
+
set_u64_le buf (off + starting_lba_offset) t.starting_lba;
145
+
set_u64_le buf (off + ending_lba_offset) t.ending_lba;
146
+
set_u64_le buf (off + attributes_offset) t.attributes;
147
+
let name_len = min 72 (String.length t.name) in
148
+
Bytes.blit_string t.name 0 buf (off + name_offset) name_len;
149
+
if name_len < 72 then Bytes.fill buf (off + name_offset + name_len) (72 - name_len) '\000'
150
+
151
+
let to_string t =
152
+
let buf = Bytes.create sizeof in
153
+
marshal buf 0 t;
154
+
Bytes.to_string buf
155
+
end
156
+
157
+
type t = {
158
+
revision : int32;
159
+
header_size : int32;
160
+
header_crc32 : int32;
161
+
reserved : int32;
162
+
current_lba : int64;
163
+
backup_lba : int64;
164
+
first_usable_lba : int64;
165
+
last_usable_lba : int64;
166
+
disk_guid : Uuidm.t;
167
+
partition_entry_lba : int64;
168
+
num_partition_entries : int32;
169
+
partition_size : int32;
170
+
partitions_crc32 : int32;
171
+
partitions : Partition.t list;
172
+
}
173
+
174
+
let signature = "EFI PART"
175
+
let signature_offset = 0
176
+
let signature_len = 8
177
+
let revision_offset = 8
178
+
let header_size_offset = 12
179
+
let header_crc32_offset = 16
180
+
let reserved_offset = 20
181
+
let current_lba_offset = 24
182
+
let backup_lba_offset = 32
183
+
let first_usable_lba_offset = 40
184
+
let last_usable_lba_offset = 48
185
+
let disk_guid_offset = 56
186
+
let partition_entry_lba_offset = 72
187
+
let num_partition_entries_offset = 80
188
+
let partition_size_offset = 84
189
+
let partitions_crc32_offset = 88
190
+
191
+
let marshal_header_bytes buf header =
192
+
Bytes.blit_string signature 0 buf 0 (String.length signature);
193
+
set_u32_le buf revision_offset header.revision;
194
+
set_u32_le buf header_size_offset header.header_size;
195
+
set_u32_le buf header_crc32_offset 0l; (* zero for CRC calculation *)
196
+
set_u32_le buf reserved_offset header.reserved;
197
+
set_u64_le buf current_lba_offset header.current_lba;
198
+
set_u64_le buf backup_lba_offset header.backup_lba;
199
+
set_u64_le buf first_usable_lba_offset header.first_usable_lba;
200
+
set_u64_le buf last_usable_lba_offset header.last_usable_lba;
201
+
Bytes.blit_string (Uuidm.to_mixed_endian_bytes header.disk_guid) 0 buf
202
+
disk_guid_offset guid_len;
203
+
set_u64_le buf partition_entry_lba_offset header.partition_entry_lba;
204
+
set_u32_le buf num_partition_entries_offset header.num_partition_entries;
205
+
set_u32_le buf partition_size_offset header.partition_size;
206
+
set_u32_le buf partitions_crc32_offset header.partitions_crc32
207
+
208
+
let calculate_header_crc32 header =
209
+
let buf = Bytes.create sizeof in
210
+
marshal_header_bytes buf header;
211
+
Checkseum.Crc32.digest_string (Bytes.to_string buf) 0 sizeof
212
+
Checkseum.Crc32.default
213
+
214
+
let calculate_partition_crc32 num_partitions partitions =
215
+
let num_partitions = Int32.to_int num_partitions in
216
+
let crc =
217
+
List.fold_left
218
+
(fun crc32 partition ->
219
+
let s = Partition.to_string partition in
220
+
Checkseum.Crc32.digest_string s 0 Partition.sizeof crc32)
221
+
Checkseum.Crc32.default partitions
222
+
in
223
+
let zero_partition = String.make Partition.sizeof '\000' in
224
+
let rec loop crc n =
225
+
if n = 0 then crc
226
+
else
227
+
let crc =
228
+
Checkseum.Crc32.digest_string zero_partition 0 Partition.sizeof crc
229
+
in
230
+
loop crc (pred n)
231
+
in
232
+
loop crc (num_partitions - List.length partitions)
233
+
234
+
let table_sectors_required num_partition_entries sector_size =
235
+
((num_partition_entries * Partition.sizeof) + sector_size - 1) / sector_size
236
+
237
+
let make ?disk_guid ~disk_sectors ~sector_size partitions =
238
+
let num_partition_entries = 128 in
239
+
let num_actual_partition_entries = List.length partitions in
240
+
let* () =
241
+
if num_actual_partition_entries > num_partition_entries then
242
+
Error
243
+
(Printf.sprintf "Number of partitions %d exceeds required number %d\n%!"
244
+
num_actual_partition_entries num_partition_entries)
245
+
else Ok ()
246
+
in
247
+
let partitions =
248
+
List.sort
249
+
(fun p1 p2 ->
250
+
Int64.unsigned_compare p1.Partition.starting_lba p2.Partition.starting_lba)
251
+
partitions
252
+
in
253
+
let* _last_partition_lba =
254
+
List.fold_left
255
+
(fun r p ->
256
+
let* offset = r in
257
+
if Int64.unsigned_compare offset p.Partition.starting_lba < 0 then
258
+
Ok p.Partition.ending_lba
259
+
else Error "Partitions overlap")
260
+
(Ok 1L) partitions
261
+
in
262
+
let current_lba = 1L in
263
+
let backup_lba = Int64.sub disk_sectors 1L in
264
+
let last_usable_lba = Int64.sub backup_lba 1L in
265
+
let partition_entry_lba = 2L in
266
+
let first_usable_lba =
267
+
let partition_table_sectors =
268
+
table_sectors_required num_partition_entries sector_size
269
+
in
270
+
Int64.(add partition_entry_lba (of_int partition_table_sectors))
271
+
in
272
+
let disk_guid =
273
+
Option.value disk_guid
274
+
~default:(Uuidm.v4_gen (Random.State.make_self_init ()) ())
275
+
in
276
+
let partition_size = Int32.of_int Partition.sizeof in
277
+
let header_size = Int32.of_int sizeof in
278
+
let revision = 0x010000l in
279
+
let reserved = 0l in
280
+
let num_partition_entries = Int32.of_int num_partition_entries in
281
+
let partitions_crc32 =
282
+
Optint.to_int32 (calculate_partition_crc32 num_partition_entries partitions)
283
+
in
284
+
let header =
285
+
{
286
+
revision;
287
+
header_size;
288
+
header_crc32 = 0l;
289
+
reserved;
290
+
current_lba;
291
+
backup_lba;
292
+
first_usable_lba;
293
+
last_usable_lba;
294
+
disk_guid;
295
+
partition_entry_lba;
296
+
num_partition_entries;
297
+
partitions;
298
+
partition_size;
299
+
partitions_crc32;
300
+
}
301
+
in
302
+
let header_crc32 = Optint.to_int32 (calculate_header_crc32 header) in
303
+
Ok { header with header_crc32 }
304
+
305
+
let unmarshal_bytes buf ~sector_size =
306
+
if Bytes.length buf < sizeof then
307
+
Printf.ksprintf invalid_arg "GPT too small: %d < %d" (Bytes.length buf)
308
+
sizeof;
309
+
let sig_str = Bytes.sub_string buf signature_offset signature_len in
310
+
let* () =
311
+
match sig_str with
312
+
| "EFI PART" -> Ok ()
313
+
| x ->
314
+
Error
315
+
(Printf.sprintf "Signature not found; expected 'EFI PART', got '%s'" x)
316
+
in
317
+
let revision = get_u32_le buf revision_offset in
318
+
let* () =
319
+
if revision = 0x010000l then Ok ()
320
+
else
321
+
Error
322
+
(Printf.sprintf "Unknown revision; expected 0x10000, got 0x%08lx"
323
+
revision)
324
+
in
325
+
let header_size = get_u32_le buf header_size_offset in
326
+
let header_crc32 = get_u32_le buf header_crc32_offset in
327
+
let* () =
328
+
let header_size_int = Int32.to_int header_size in
329
+
let buf_str = Bytes.to_string buf in
330
+
let crc32 =
331
+
Checkseum.Crc32.digest_string buf_str 0 header_crc32_offset
332
+
Checkseum.Crc32.default
333
+
in
334
+
let crc32 = Checkseum.Crc32.digest_string "\000\000\000\000" 0 4 crc32 in
335
+
let crc32 =
336
+
Checkseum.Crc32.digest_string buf_str (header_crc32_offset + 4)
337
+
(header_size_int - header_crc32_offset - 4)
338
+
crc32
339
+
in
340
+
let header_crc32' = Checkseum.Crc32.to_int32 crc32 in
341
+
if header_crc32' = header_crc32 then Ok () else Error "Bad GPT header checksum"
342
+
in
343
+
let reserved = get_u32_le buf reserved_offset in
344
+
let current_lba = get_u64_le buf current_lba_offset in
345
+
let backup_lba = get_u64_le buf backup_lba_offset in
346
+
let first_usable_lba = get_u64_le buf first_usable_lba_offset in
347
+
let last_usable_lba = get_u64_le buf last_usable_lba_offset in
348
+
let disk_guid_bytes = Bytes.sub_string buf disk_guid_offset guid_len in
349
+
let* disk_guid =
350
+
match Uuidm.of_mixed_endian_bytes disk_guid_bytes with
351
+
| Some guid -> Ok guid
352
+
| None ->
353
+
Error
354
+
(Printf.sprintf "Failed to parse disk_guid; got '%s'" disk_guid_bytes)
355
+
in
356
+
let partition_entry_lba = get_u64_le buf partition_entry_lba_offset in
357
+
let num_partition_entries = get_u32_le buf num_partition_entries_offset in
358
+
let partitions_crc32 = get_u32_le buf partitions_crc32_offset in
359
+
let partition_size = get_u32_le buf partition_size_offset in
360
+
let* () =
361
+
if partition_size <> Int32.of_int Partition.sizeof then
362
+
Error (Printf.sprintf "Unexpected partition size: %lu" partition_size)
363
+
else Ok ()
364
+
in
365
+
let partition_entry_sectors =
366
+
(Int32.to_int num_partition_entries * Partition.sizeof + sector_size - 1)
367
+
/ sector_size
368
+
in
369
+
Ok
370
+
( `Read_partition_table (partition_entry_lba, partition_entry_sectors),
371
+
fun table_buf ->
372
+
let table_size = Int32.to_int num_partition_entries * Partition.sizeof in
373
+
if Bytes.length table_buf < table_size then
374
+
Printf.ksprintf invalid_arg "partition table buffer too small";
375
+
let table_str = Bytes.sub_string table_buf 0 table_size in
376
+
let partitions_crc32' =
377
+
Checkseum.Crc32.digest_string table_str 0 table_size
378
+
Checkseum.Crc32.default
379
+
|> Checkseum.Crc32.to_int32
380
+
in
381
+
let* () =
382
+
if Int32.equal partitions_crc32' partitions_crc32 then Ok ()
383
+
else Error "Bad partition table checksum"
384
+
in
385
+
let rev_partitions =
386
+
List.fold_left
387
+
(fun acc i ->
388
+
let entry = Partition.unmarshal table_buf (i * Partition.sizeof) in
389
+
if Partition.is_zero_partition entry then acc else entry :: acc)
390
+
[]
391
+
(List.init (Int32.to_int num_partition_entries) Fun.id)
392
+
in
393
+
let partitions = List.rev rev_partitions in
394
+
Ok
395
+
{
396
+
revision;
397
+
header_size;
398
+
header_crc32;
399
+
reserved;
400
+
current_lba;
401
+
backup_lba;
402
+
first_usable_lba;
403
+
last_usable_lba;
404
+
disk_guid;
405
+
partition_entry_lba;
406
+
num_partition_entries;
407
+
partitions;
408
+
partition_size;
409
+
partitions_crc32;
410
+
} )
411
+
412
+
let of_string s ~sector_size = unmarshal_bytes (Bytes.of_string s) ~sector_size
413
+
414
+
let marshal_header_to_bytes ~sector_size ~primary t =
415
+
let buf = Bytes.create sector_size in
416
+
Bytes.fill buf 0 sector_size '\000';
417
+
let t =
418
+
if primary then t
419
+
else
420
+
let t = { t with current_lba = t.backup_lba; backup_lba = t.current_lba } in
421
+
{ t with header_crc32 = Optint.to_int32 (calculate_header_crc32 t) }
422
+
in
423
+
marshal_header_bytes buf t;
424
+
set_u32_le buf header_crc32_offset t.header_crc32;
425
+
Bytes.to_string buf
426
+
427
+
let marshal_partition_table_to_string ~sector_size t =
428
+
let table_size = Int32.to_int t.num_partition_entries * Partition.sizeof in
429
+
let padded_size =
430
+
((table_size + sector_size - 1) / sector_size) * sector_size
431
+
in
432
+
let buf = Bytes.create padded_size in
433
+
Bytes.fill buf 0 padded_size '\000';
434
+
List.iteri
435
+
(fun i p -> Partition.marshal buf (i * Int32.to_int t.partition_size) p)
436
+
t.partitions;
437
+
Bytes.to_string buf
438
+
439
+
let read reader ~sector_size =
440
+
let* header_buf = read_exactly reader sector_size in
441
+
let* (`Read_partition_table (partition_lba, num_sectors), k) =
442
+
unmarshal_bytes header_buf ~sector_size
443
+
in
444
+
ignore partition_lba;
445
+
let table_size = num_sectors * sector_size in
446
+
let* table_buf = read_exactly reader table_size in
447
+
k table_buf
448
+
449
+
let write_header writer ~sector_size ~primary t =
450
+
let s = marshal_header_to_bytes ~sector_size ~primary t in
451
+
Writer.write writer (Slice.of_string s)
452
+
453
+
let write_partition_table writer ~sector_size t =
454
+
let s = marshal_partition_table_to_string ~sector_size t in
455
+
Writer.write writer (Slice.of_string s)
456
+
457
+
let protective_mbr ~sector_size t =
458
+
if sector_size < 512 || sector_size land 511 <> 0 then
459
+
invalid_arg "Gpt.protective_mbr";
460
+
let factor = sector_size / 512 in
461
+
let partition =
462
+
let size =
463
+
Int64.(
464
+
to_int32 (min 0xFFFFFFFFL (mul (of_int factor) (succ t.last_usable_lba))))
465
+
in
466
+
Mbr.Partition.make ~active:true ~partition_type:0xEE 1l size |> Result.get_ok
467
+
in
468
+
Mbr.make [ partition ] |> Result.get_ok
+119
lib/gpt.mli
+119
lib/gpt.mli
···
1
+
(*
2
+
* Copyright (C) 2013 Citrix Inc
3
+
*
4
+
* Permission to use, copy, modify, and distribute this software for any
5
+
* purpose with or without fee is hereby granted, provided that the above
6
+
* copyright notice and this permission notice appear in all copies.
7
+
*
8
+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9
+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10
+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11
+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12
+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13
+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14
+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15
+
*)
16
+
17
+
(** GPT (GUID Partition Table) format. *)
18
+
19
+
module Partition : sig
20
+
type t = private {
21
+
type_guid : Uuidm.t;
22
+
partition_guid : Uuidm.t;
23
+
starting_lba : int64;
24
+
ending_lba : int64;
25
+
attributes : int64;
26
+
name : string;
27
+
}
28
+
(** A GPT partition entry. [name] should be a zero-padded UTF-16LE encoded
29
+
string of 72 bytes. *)
30
+
31
+
val make :
32
+
?name:string ->
33
+
type_guid:Uuidm.t ->
34
+
attributes:int64 ->
35
+
int64 ->
36
+
int64 ->
37
+
(t, string) result
38
+
(** [make ?name ~type_guid ~attributes starting_lba ending_lba] constructs a
39
+
partition entry.
40
+
@raise Invalid_argument if [name] is not exactly 72 bytes *)
41
+
42
+
val is_zero_partition : t -> bool
43
+
(** [is_zero_partition p] is [true] if [p] is the all-zero partition entry
44
+
(unused slot). *)
45
+
46
+
val sizeof : int
47
+
(** Size of a partition entry in bytes (128). *)
48
+
end
49
+
50
+
type t = private {
51
+
revision : int32;
52
+
header_size : int32;
53
+
header_crc32 : int32;
54
+
reserved : int32;
55
+
current_lba : int64;
56
+
backup_lba : int64;
57
+
first_usable_lba : int64;
58
+
last_usable_lba : int64;
59
+
disk_guid : Uuidm.t;
60
+
partition_entry_lba : int64;
61
+
num_partition_entries : int32;
62
+
partition_size : int32;
63
+
partitions_crc32 : int32;
64
+
partitions : Partition.t list;
65
+
}
66
+
(** A GPT header with partition table. *)
67
+
68
+
val make :
69
+
?disk_guid:Uuidm.t ->
70
+
disk_sectors:int64 ->
71
+
sector_size:int ->
72
+
Partition.t list ->
73
+
(t, string) result
74
+
(** [make ?disk_guid ~disk_sectors ~sector_size partitions] constructs a GPT.
75
+
The header is written at LBA 1, partition table from LBA 2 with 128 entries.
76
+
Returns [Error _] if partitions exceed 128 or overlap. *)
77
+
78
+
val sizeof : int
79
+
(** Size of a GPT header in bytes (92). *)
80
+
81
+
(** {1 Serialization} *)
82
+
83
+
val marshal_header_to_bytes : sector_size:int -> primary:bool -> t -> string
84
+
(** [marshal_header_to_bytes ~sector_size ~primary t] serializes the GPT header.
85
+
If [primary] is false, swaps current/backup LBA and recalculates CRC. *)
86
+
87
+
val marshal_partition_table_to_string : sector_size:int -> t -> string
88
+
(** [marshal_partition_table_to_string ~sector_size t] serializes the partition
89
+
table. *)
90
+
91
+
(** {1 Streaming API} *)
92
+
93
+
val of_string :
94
+
string ->
95
+
sector_size:int ->
96
+
( [ `Read_partition_table of int64 * int ] * (bytes -> (t, string) result),
97
+
string )
98
+
result
99
+
(** [of_string s ~sector_size] parses a GPT header. Returns a pair
100
+
[(`Read_partition_table (lba, num_sectors), k)] where the caller should read
101
+
the partition table and pass it to continuation [k]. *)
102
+
103
+
val read : Bytesrw.Bytes.Reader.t -> sector_size:int -> (t, string) result
104
+
(** [read reader ~sector_size] reads a GPT header and partition table from a
105
+
bytesrw reader. Assumes header is at current position followed by partition
106
+
table. *)
107
+
108
+
val write_header :
109
+
Bytesrw.Bytes.Writer.t -> sector_size:int -> primary:bool -> t -> unit
110
+
(** [write_header writer ~sector_size ~primary t] writes the GPT header. If
111
+
[primary] is false, swaps current/backup LBA and recalculates CRC. *)
112
+
113
+
val write_partition_table :
114
+
Bytesrw.Bytes.Writer.t -> sector_size:int -> t -> unit
115
+
(** [write_partition_table writer ~sector_size t] writes the partition table. *)
116
+
117
+
val protective_mbr : sector_size:int -> t -> Mbr.t
118
+
(** [protective_mbr ~sector_size t] creates a protective MBR for GPT.
119
+
@raise Invalid_argument if [sector_size] is not a positive multiple of 512. *)
+206
test/test_gpt.ml
+206
test/test_gpt.ml
···
1
+
(*let ( let* ) = Result.bind *)
2
+
3
+
let get_ok = function
4
+
| Ok x -> x
5
+
| Error s -> Alcotest.failf "expected Ok, got Error \"%S\"" s
6
+
7
+
module Testable_partition = struct
8
+
let pp ppf
9
+
{
10
+
Gpt.Partition.type_guid;
11
+
partition_guid;
12
+
starting_lba;
13
+
ending_lba;
14
+
attributes;
15
+
name;
16
+
} =
17
+
Fmt.pf ppf
18
+
"{ type_guid = %s; partition_guid = %s; starting_lba = %Ld; ending_lba = \
19
+
%Ld; attributes = %Ld; name = %S }"
20
+
(Uuidm.to_string type_guid)
21
+
(Uuidm.to_string partition_guid)
22
+
starting_lba ending_lba attributes name
23
+
24
+
type t = Gpt.Partition.t
25
+
26
+
let equal = ( = ) (* :/ *)
27
+
end
28
+
29
+
module Testable_gpt = struct
30
+
type t = Gpt.t
31
+
32
+
let pp ppf { Gpt.revision; header_size; header_crc32; reserved; current_lba;
33
+
backup_lba; first_usable_lba; last_usable_lba; disk_guid;
34
+
partition_entry_lba; num_partition_entries; partitions;
35
+
partition_size; partitions_crc32 } =
36
+
Fmt.pf ppf
37
+
"{ revision = %lu; header_size = %lu; header_crc32 = %lu; reserved = %lu; \
38
+
current_lba = %Lu; backup_lba = %Lu; first_usable_lba = %Lu; \
39
+
last_usable_lba = %Lu; disk_guid = %a; partition_entry_lba = %Lu; \
40
+
num_partition_entries = %lu; partition_size = %lu; partitions_crc32 = %lu; \
41
+
partitions = %a; }"
42
+
revision header_size header_crc32 reserved current_lba backup_lba first_usable_lba
43
+
last_usable_lba Uuidm.pp disk_guid partition_entry_lba num_partition_entries
44
+
partition_size partitions_crc32
45
+
Fmt.(list Testable_partition.pp) partitions
46
+
47
+
let equal t { Gpt.revision; header_size; header_crc32; reserved; current_lba;
48
+
backup_lba; first_usable_lba; last_usable_lba; disk_guid;
49
+
partition_entry_lba; num_partition_entries; partitions;
50
+
partition_size; partitions_crc32 } =
51
+
t.Gpt.revision = revision && t.header_size = header_size &&
52
+
t.header_crc32 = header_crc32 && t.reserved = reserved &&
53
+
t.current_lba = current_lba && t.backup_lba = backup_lba &&
54
+
t.first_usable_lba = first_usable_lba && t.last_usable_lba = last_usable_lba &&
55
+
Uuidm.equal t.disk_guid disk_guid &&
56
+
t.partition_entry_lba = partition_entry_lba &&
57
+
t.num_partition_entries = num_partition_entries &&
58
+
t.partition_size = partition_size && t.partitions_crc32 = partitions_crc32 &&
59
+
Testable_partition.equal t.partitions partitions
60
+
end
61
+
62
+
let partition =
63
+
(module Testable_partition : Alcotest.TESTABLE with type t = Gpt.Partition.t)
64
+
65
+
let gpt =
66
+
(module Testable_gpt : Alcotest.TESTABLE with type t = Gpt.t)
67
+
68
+
let utf16le_of_ascii s =
69
+
String.init (2 * String.length s)
70
+
(fun i ->
71
+
if i land 1 = 0 then
72
+
s.[i / 2]
73
+
else
74
+
'\000')
75
+
76
+
let name_of_ascii s =
77
+
let s = utf16le_of_ascii s in
78
+
String.init 72
79
+
(fun i ->
80
+
if i < String.length s then s.[i] else '\000')
81
+
82
+
let test_make_partition () =
83
+
let type_guid = Option.get (Uuidm.of_string "12345678-1234-1234-1234-123456789abc") in
84
+
match
85
+
Gpt.Partition.make ~type_guid
86
+
~name:(name_of_ascii "Test Partition")
87
+
~attributes:255L 2048L 4096L
88
+
with
89
+
| Ok partition -> ignore partition
90
+
| Error error -> Alcotest.failf "Error creating partition: %s" error
91
+
92
+
let test_make_gpt_no_partitions () =
93
+
match Gpt.make ~disk_sectors:1024L ~sector_size:512 [] with
94
+
| Ok _ -> ()
95
+
| Error e -> Alcotest.failf "Expected Ok, got %s" e
96
+
97
+
let test_make_gpt_too_many_partitions () =
98
+
let type_guid = Option.get (Uuidm.of_string "12345678-1234-1234-1234-123456789abc") in
99
+
let num_partitions = 129 in
100
+
let partitions =
101
+
Array.init num_partitions (fun i ->
102
+
let partition =
103
+
Gpt.Partition.make ~type_guid
104
+
~name:(Printf.ksprintf name_of_ascii "Partition %d" (i + 1))
105
+
~attributes:255L
106
+
(Int64.of_int (i * 2048))
107
+
(Int64.of_int ((i + 1) * 2048))
108
+
in
109
+
match partition with
110
+
| Ok p -> p
111
+
| Error _ -> Alcotest.fail "Expected Ok")
112
+
in
113
+
match Gpt.make ~disk_sectors:1024L ~sector_size:512 (Array.to_list partitions) with
114
+
| Ok _ -> Alcotest.fail "Expected too many partitons error"
115
+
| Error _ -> ()
116
+
117
+
let test_make_gpt_overlapping_partitions () =
118
+
let type_guid = Option.get (Uuidm.of_string "12345678-1234-1234-1234-123456789abc") in
119
+
let p1 =
120
+
get_ok
121
+
(Gpt.Partition.make ~type_guid
122
+
~name:(name_of_ascii "Partition 1") ~attributes:255L 2048L 4096L)
123
+
in
124
+
let p2 =
125
+
get_ok
126
+
(Gpt.Partition.make ~type_guid
127
+
~name:(name_of_ascii "Partition 1") ~attributes:255L 3048L 4096L)
128
+
in
129
+
match (Gpt.make ~disk_sectors:1024L ~sector_size:512 [ p1; p2 ], Gpt.make ~disk_sectors:1024L ~sector_size:512 [ p2; p1 ]) with
130
+
| Ok _, _ | _, Ok _ -> Alcotest.fail "Expected overlapping error"
131
+
| Error _, Error _ -> ()
132
+
133
+
let test_make_gpt_sorted_partitions () =
134
+
let type_guid = Option.get (Uuidm.of_string "12345678-1234-1234-1234-123456789abc") in
135
+
let p1 =
136
+
get_ok
137
+
(Gpt.Partition.make ~type_guid
138
+
~name:(name_of_ascii "Partition 1") ~attributes:255L 2048L 1L)
139
+
in
140
+
let p2 =
141
+
get_ok
142
+
(Gpt.Partition.make ~type_guid
143
+
~name:(name_of_ascii "Partition 2") ~attributes:255L 4096L 1L)
144
+
in
145
+
let m1 = get_ok (Gpt.make ~disk_sectors:1024L ~sector_size:512 [ p1; p2 ]) in
146
+
let m2 = get_ok (Gpt.make ~disk_sectors:1024L ~sector_size:512 [ p2; p1 ]) in
147
+
(* polymorphic compare :`( *)
148
+
Alcotest.(
149
+
check (list partition) "partitons equal" m1.partitions m2.partitions)
150
+
151
+
let test_marshal_unmarshal () =
152
+
let type_guid = Option.get (Uuidm.of_string "12345678-1234-1234-1234-123456789abc") in
153
+
let p1 =
154
+
get_ok
155
+
(Gpt.Partition.make ~type_guid
156
+
~name:(name_of_ascii "Partition 1") ~attributes:255L 2048L 1L)
157
+
in
158
+
let p2 =
159
+
get_ok
160
+
(Gpt.Partition.make ~type_guid
161
+
~name:(name_of_ascii "Partition 2") ~attributes:255L 4096L 1L)
162
+
in
163
+
let morig = get_ok (Gpt.make ~disk_sectors:1024L ~sector_size:512 [ p1; p2 ]) in
164
+
let buf_header = Cstruct.create 512 in
165
+
let partition_table_len =
166
+
let len = Int32.to_int morig.num_partition_entries * Int32.to_int morig.partition_size in
167
+
512 * ((len + 511) / 512)
168
+
in
169
+
let buf_partition_table = Cstruct.create partition_table_len in
170
+
Gpt.marshal_header ~sector_size:512 ~primary:true buf_header morig;
171
+
Gpt.marshal_partition_table ~sector_size:512 buf_partition_table morig;
172
+
match Gpt.unmarshal ~sector_size:512 buf_header with
173
+
| Error e -> Alcotest.failf "Failed to parse marshalled gpt header: %s" e
174
+
| Ok (`Read_partition_table (_lba, sectors), k) ->
175
+
Printf.printf "expected %d, got %d\n%!" (partition_table_len / 512) sectors;
176
+
Alcotest.(check int) "partition table length" (partition_table_len / 512) sectors;
177
+
match k buf_partition_table with
178
+
| Error e -> Alcotest.failf "Failed to parse marshalled partition table: %s" e
179
+
| Ok unmarshalled ->
180
+
Alcotest.check gpt "unmarshalled equal to original" morig unmarshalled
181
+
182
+
let partition_test_collection =
183
+
[
184
+
("correct-partition", `Quick, test_make_partition);
185
+
]
186
+
187
+
let gpt_header_test_collection =
188
+
[
189
+
("gpt-empty-partitions", `Quick, test_make_gpt_no_partitions);
190
+
("gpt-too-many-partitions", `Quick, test_make_gpt_too_many_partitions);
191
+
("gpt-overlapping-partitions", `Quick, test_make_gpt_overlapping_partitions);
192
+
("gpt-sorted-partitions", `Quick, test_make_gpt_sorted_partitions);
193
+
]
194
+
195
+
let gpt_test_collection =
196
+
[
197
+
("gpt marshal then unmarshal", `Quick, test_marshal_unmarshal);
198
+
]
199
+
200
+
let () =
201
+
Alcotest.run "Ocaml Gpt"
202
+
[
203
+
("Test GPT Partitions", partition_test_collection);
204
+
("Test GPT Header", gpt_header_test_collection);
205
+
("Test GPT", gpt_test_collection);
206
+
]