1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
(* TEST
include runtime_events;
include unix;
set OCAML_RUNTIME_EVENTS_PRESERVE = "1";
hasunix;
not-target-windows;
{
bytecode;
}{
native;
}
*)
let runtime_begin _ _ _ = ()
let runtime_end _ _ _ = ()
let runtime_counter _ _ _ _ = ()
let alloc _ _ _ = ()
let lifecycle _ _ _ _ = ()
let lost_events _ _ = ()
let callbacks = Runtime_events.Callbacks.create
~runtime_begin ~runtime_end ~runtime_counter ~alloc ~lifecycle ~lost_events ()
let parse path_pid =
let cursor =
Runtime_events.create_cursor path_pid in
let finally () = Runtime_events.free_cursor cursor in
Fun.protect ~finally @@ fun () ->
Runtime_events.read_poll cursor callbacks None
let parse_corrupted path_pid =
try let (_:int) = parse path_pid in ()
with Failure _ | Invalid_argument _ ->
(* parsing corrupted rings, raises exceptions,
this is expected *)
()
let buf = Bytes.create (8 * 8)
let with_ring ring_file f =
let fd = Unix.openfile ring_file [Unix.O_RDWR] 0 in
let finally () = Unix.close fd in
Fun.protect ~finally @@ fun () ->
let size = Int64.to_int Unix.LargeFile.((fstat fd).st_size) in
let n = Unix.read fd buf 0 (Bytes.length buf) in
assert (n = Bytes.length buf);
let version = Bytes.get_int64_ne buf 0 in
assert (version = 1L);
(* this needs to be updated if on-disk layout changes *)
let data_offset = Bytes.get_int64_ne buf (6*8) in
let write_event_header is_runtime event_type event_id event_length =
let (<<:) i n = Int64.(shift_left (of_int i) n) and (|:) = Int64.logor in
(* see runtime_events.h *)
let event_header =
(event_length <<: 54) |:
(is_runtime <<: 53) |:
(event_type <<: 49) |:
(event_id <<: 36)
in
Bytes.set_int64_ne buf 0 event_header;
let n = Unix.LargeFile.lseek fd data_offset Unix.SEEK_SET in
assert (n = data_offset);
let n = Unix.write fd buf 0 (Bytes.length buf) in
assert (n = Bytes.length buf)
in
let write_metadata_header offset value =
let offset = Int64.of_int offset in
let n = Unix.LargeFile.lseek fd offset Unix.SEEK_SET in
assert (n = offset);
Bytes.set_int64_ne buf 0 value;
let n = Unix.write fd buf 0 (Bytes.length buf) in
assert (n = Bytes.length buf)
in
f ~size ~write_event_header ~write_metadata_header
(* this tests the preservation of ring buffers after termination *)
let () =
(* start runtime_events now to avoid a race *)
let parent_cwd = Sys.getcwd () in
let child_pid = Unix.fork () in
if child_pid == 0 then begin
(* we are in the child, so start Runtime_events *)
Runtime_events.start ();
(* this creates a ring buffer. Now exit. *)
end else begin
(* now wait for our child to finish *)
Unix.wait () |> ignore;
(* child has finished. We now have a valid ring *)
let ring_file =
Filename.concat parent_cwd (string_of_int child_pid ^ ".events")
and path_pid = Some (parent_cwd, child_pid);
in
let finally () = Unix.unlink ring_file in
Fun.protect ~finally @@ fun () ->
with_ring ring_file @@ fun ~size ~write_event_header ~write_metadata_header ->
(* we must succeed parsing it as is *)
let n = parse path_pid in
assert (n > 0);
let original = Bytes.to_string buf in
(* now overwrite various fields, corrupting the ring,
and check that we don't crash (raising exceptions is fine).
*)
for offset = 8 downto 0 do
[0L; size * 3/4 |> Int64.of_int; size * 2 |> Int64.of_int;
Int64.max_int; Int64.min_int; Int64.(shift_right_logical max_int 1)
] |> List.iter @@ fun value ->
write_metadata_header (8 * offset) value;
parse_corrupted path_pid;
(* restore original, we only corrupt and test one offset at a time,
otherwise we may not find missing bounds checks if we exit early
due to bounds error on an earlier offset
*)
Bytes.blit_string original 0 buf 0 (Bytes.length buf);
done;
(* restore metadata header, so we have a valid ring again *)
write_metadata_header 0 1L (* version *);
for is_runtime = 0 to 1 do
for event_type = 0 to 15 (* event type is 4 bits *) do
for event_id = 0 to 64 (* event_id is 13 bits, but not all used yet *) do
for length = 0 to 3 (* short lengths trigger uninit read bugs *) do
(* modify just 1 event in the otherwise valid ring *)
write_event_header is_runtime event_type event_id length;
(* parse ring *)
parse_corrupted path_pid;
done
done
done;
done;
end
|
