this repo has no description
gdiazlo.tngl.sh
1open Swim.Types
2
3let gen_node_id : node_id QCheck.Gen.t =
4 let open QCheck.Gen in
5 let+ id =
6 oneof_weighted
7 [
8 (3, string_size ~gen:printable (int_range 1 64));
9 (1, return "");
10 (1, string_size ~gen:printable (return 255));
11 ]
12 in
13 node_id_of_string id
14
15let gen_incarnation : incarnation QCheck.Gen.t =
16 let open QCheck.Gen in
17 let+ i =
18 oneof_weighted
19 [ (5, int_range 0 1000); (2, int_range 0 max_int); (1, return 0) ]
20 in
21 incarnation_of_int i
22
23let gen_member_state : member_state QCheck.Gen.t =
24 let open QCheck.Gen in
25 let alive : member_state = Alive in
26 let suspect : member_state = Suspect in
27 let dead : member_state = Dead in
28 oneof [ return alive; return suspect; return dead ]
29
30let gen_ipv4 : string QCheck.Gen.t =
31 let open QCheck.Gen in
32 let+ a = int_range 0 255
33 and+ b = int_range 0 255
34 and+ c = int_range 0 255
35 and+ d = int_range 0 255 in
36 Printf.sprintf "%d.%d.%d.%d" a b c d
37
38let gen_port : int QCheck.Gen.t =
39 let open QCheck.Gen in
40 oneof_weighted
41 [ (3, int_range 1024 65535); (1, int_range 1 1023); (1, return 7946) ]
42
43let gen_addr : addr QCheck.Gen.t =
44 let open QCheck.Gen in
45 let+ ip = gen_ipv4 and+ port = gen_port in
46 let ipaddr =
47 match Ipaddr.V4.of_string ip with
48 | Ok v4 -> v4
49 | Error _ -> Ipaddr.V4.localhost
50 in
51 `Udp (Eio.Net.Ipaddr.of_raw (Ipaddr.V4.to_octets ipaddr), port)
52
53let gen_meta : string QCheck.Gen.t =
54 let open QCheck.Gen in
55 oneof_weighted
56 [
57 (3, string_size ~gen:printable (int_range 0 256));
58 (1, return "");
59 (1, return (String.make 1024 'x'));
60 ]
61
62let gen_node_info : node_info QCheck.Gen.t =
63 let open QCheck.Gen in
64 let+ id = gen_node_id and+ addr = gen_addr and+ meta = gen_meta in
65 make_node_info ~id ~addr ~meta
66
67let gen_seq : int QCheck.Gen.t =
68 let open QCheck.Gen in
69 oneof_weighted
70 [ (5, int_range 0 10000); (2, int_range 0 max_int); (1, return 0) ]
71
72let gen_ping : protocol_msg QCheck.Gen.t =
73 let open QCheck.Gen in
74 let+ seq = gen_seq and+ sender = gen_node_info in
75 Ping { seq; sender }
76
77let gen_ping_req : protocol_msg QCheck.Gen.t =
78 let open QCheck.Gen in
79 let+ seq = gen_seq and+ target = gen_node_id and+ sender = gen_node_info in
80 Ping_req { seq; target; sender }
81
82let gen_payload : string option QCheck.Gen.t =
83 let open QCheck.Gen in
84 oneof_weighted
85 [
86 (2, return None);
87 (3, map Option.some (string_size ~gen:printable (int_range 0 512)));
88 ]
89
90let gen_ack : protocol_msg QCheck.Gen.t =
91 let open QCheck.Gen in
92 let+ seq = gen_seq
93 and+ responder = gen_node_info
94 and+ payload = gen_payload in
95 Ack { seq; responder; payload }
96
97let gen_alive : protocol_msg QCheck.Gen.t =
98 let open QCheck.Gen in
99 let+ node = gen_node_info and+ incarnation = gen_incarnation in
100 Alive { node; incarnation }
101
102let gen_suspect : protocol_msg QCheck.Gen.t =
103 let open QCheck.Gen in
104 let+ node = gen_node_id
105 and+ incarnation = gen_incarnation
106 and+ suspector = gen_node_id in
107 Suspect { node; incarnation; suspector }
108
109let gen_dead : protocol_msg QCheck.Gen.t =
110 let open QCheck.Gen in
111 let+ node = gen_node_id
112 and+ incarnation = gen_incarnation
113 and+ declarator = gen_node_id in
114 Dead { node; incarnation; declarator }
115
116let gen_topic : string QCheck.Gen.t =
117 QCheck.Gen.string_size ~gen:QCheck.Gen.printable (QCheck.Gen.int_range 1 64)
118
119let gen_user_payload : string QCheck.Gen.t =
120 QCheck.Gen.string_size ~gen:QCheck.Gen.printable (QCheck.Gen.int_range 0 1024)
121
122let gen_user_msg : protocol_msg QCheck.Gen.t =
123 let open QCheck.Gen in
124 let+ topic = gen_topic
125 and+ payload = gen_user_payload
126 and+ origin = gen_node_id in
127 User_msg { topic; payload; origin }
128
129let gen_protocol_msg : protocol_msg QCheck.Gen.t =
130 QCheck.Gen.oneof
131 [
132 gen_ping;
133 gen_ping_req;
134 gen_ack;
135 gen_alive;
136 gen_suspect;
137 gen_dead;
138 gen_user_msg;
139 ]
140
141let gen_cluster_name : string QCheck.Gen.t =
142 let open QCheck.Gen in
143 oneof_weighted
144 [
145 (3, string_size ~gen:printable (int_range 1 32));
146 (1, return "default");
147 (1, return "test-cluster");
148 ]
149
150let gen_piggyback : protocol_msg list QCheck.Gen.t =
151 let open QCheck.Gen in
152 let piggyback_msg =
153 oneof [ gen_alive; gen_suspect; gen_dead; gen_user_msg ]
154 in
155 list_size (int_range 0 8) piggyback_msg
156
157let gen_packet : packet QCheck.Gen.t =
158 let open QCheck.Gen in
159 let+ cluster = gen_cluster_name
160 and+ primary = gen_protocol_msg
161 and+ piggyback = gen_piggyback in
162 { cluster; primary; piggyback }
163
164let gen_cstruct : Cstruct.t QCheck.Gen.t =
165 let open QCheck.Gen in
166 let+ len =
167 oneof_weighted
168 [ (3, int_range 0 1024); (1, return 0); (1, int_range 1024 4096) ]
169 and+ fill = char in
170 let cs = Cstruct.create len in
171 Cstruct.memset cs (Char.code fill);
172 cs
173
174let gen_cstruct_sized (size : int) : Cstruct.t QCheck.Gen.t =
175 let open QCheck.Gen in
176 let+ bytes = string_size ~gen:char (return size) in
177 Cstruct.of_string bytes
178
179let gen_config : config QCheck.Gen.t =
180 let open QCheck.Gen in
181 let+ bind_addr = gen_ipv4
182 and+ bind_port = gen_port
183 and+ node_name =
184 oneof_weighted [ (2, return None); (3, map Option.some gen_topic) ]
185 and+ protocol_interval = float_range 0.1 10.0
186 and+ probe_timeout = float_range 0.1 5.0
187 and+ indirect_checks = int_range 1 10
188 and+ suspicion_mult = int_range 1 10
189 and+ suspicion_max_timeout = float_range 10.0 120.0
190 and+ retransmit_mult = int_range 1 10
191 and+ udp_buffer_size =
192 oneof [ return 1400; return 1500; return 8192; return 65507 ]
193 and+ tcp_timeout = float_range 1.0 30.0
194 and+ send_buffer_count = int_range 4 64
195 and+ recv_buffer_count = int_range 4 64
196 and+ secret_key = gen_cstruct_sized 32
197 and+ cluster_name = gen_cluster_name in
198 {
199 bind_addr;
200 bind_port;
201 node_name;
202 protocol_interval;
203 probe_timeout;
204 indirect_checks;
205 suspicion_mult;
206 suspicion_max_timeout;
207 retransmit_mult;
208 udp_buffer_size;
209 tcp_timeout;
210 send_buffer_count;
211 recv_buffer_count;
212 secret_key = Cstruct.to_string secret_key;
213 cluster_name;
214 }
215
216let gen_decode_error : decode_error QCheck.Gen.t =
217 let open QCheck.Gen in
218 oneof
219 [
220 return Invalid_magic;
221 map (fun v -> Unsupported_version v) (int_range 0 255);
222 return Truncated_message;
223 map (fun t -> Invalid_tag t) (int_range 0 255);
224 return Decryption_failed;
225 ]
226
227let gen_send_error : send_error QCheck.Gen.t =
228 let open QCheck.Gen in
229 oneof [ return Node_unreachable; return Timeout; return Connection_reset ]
230
231let gen_mtime_span : Mtime.span QCheck.Gen.t =
232 let open QCheck.Gen in
233 let+ ns = map Int64.of_int (int_range 0 1_000_000_000) in
234 Mtime.Span.of_uint64_ns ns
235
236let gen_member_snapshot : member_snapshot QCheck.Gen.t =
237 let open QCheck.Gen in
238 let+ node = gen_node_info
239 and+ state = gen_member_state
240 and+ incarnation = gen_incarnation
241 and+ state_change = gen_mtime_span in
242 { node; state; incarnation; state_change }
243
244let arb_node_id : node_id QCheck.arbitrary =
245 QCheck.make ~print:(fun id -> node_id_to_string id) gen_node_id
246
247let arb_incarnation : incarnation QCheck.arbitrary =
248 QCheck.make
249 ~print:(fun inc -> string_of_int (incarnation_to_int inc))
250 ~shrink:(fun inc ->
251 let i = incarnation_to_int inc in
252 QCheck.Shrink.int i |> QCheck.Iter.map incarnation_of_int)
253 gen_incarnation
254
255let arb_member_state : member_state QCheck.arbitrary =
256 QCheck.make ~print:member_state_to_string gen_member_state
257
258let format_addr (addr : addr) : string =
259 match addr with
260 | `Udp (ip, port) -> Fmt.str "%a:%d" Eio.Net.Ipaddr.pp ip port
261 | `Unix path -> Printf.sprintf "unix:%s" path
262
263let format_node_info (ni : node_info) : string =
264 Printf.sprintf "{ id=%s; addr=%s; meta=%S }" (node_id_to_string ni.id)
265 (format_addr ni.addr) ni.meta
266
267let arb_node_info : node_info QCheck.arbitrary =
268 QCheck.make ~print:format_node_info gen_node_info
269
270let format_protocol_msg (msg : protocol_msg) : string =
271 match msg with
272 | Ping { seq; sender } ->
273 Printf.sprintf "Ping { seq=%d; sender=%s }" seq (format_node_info sender)
274 | Ping_req { seq; target; sender } ->
275 Printf.sprintf "Ping_req { seq=%d; target=%s; sender=%s }" seq
276 (node_id_to_string target) (format_node_info sender)
277 | Ack { seq; responder; payload } ->
278 Printf.sprintf "Ack { seq=%d; responder=%s; payload=%s }" seq
279 (format_node_info responder)
280 (match payload with
281 | None -> "None"
282 | Some p -> Printf.sprintf "Some %S" p)
283 | Alive { node; incarnation } ->
284 Printf.sprintf "Alive { node=%s; incarnation=%d }" (format_node_info node)
285 (incarnation_to_int incarnation)
286 | Suspect { node; incarnation; suspector } ->
287 Printf.sprintf "Suspect { node=%s; incarnation=%d; suspector=%s }"
288 (node_id_to_string node)
289 (incarnation_to_int incarnation)
290 (node_id_to_string suspector)
291 | Dead { node; incarnation; declarator } ->
292 Printf.sprintf "Dead { node=%s; incarnation=%d; declarator=%s }"
293 (node_id_to_string node)
294 (incarnation_to_int incarnation)
295 (node_id_to_string declarator)
296 | User_msg { topic; payload; origin } ->
297 Printf.sprintf "User_msg { topic=%S; payload=%S; origin=%s }" topic
298 payload (node_id_to_string origin)
299
300let arb_protocol_msg : protocol_msg QCheck.arbitrary =
301 QCheck.make ~print:format_protocol_msg gen_protocol_msg
302
303let format_packet (p : packet) : string =
304 Printf.sprintf "{ cluster=%S; primary=%s; piggyback=[%d msgs] }" p.cluster
305 (format_protocol_msg p.primary)
306 (List.length p.piggyback)
307
308let arb_packet : packet QCheck.arbitrary =
309 QCheck.make ~print:format_packet gen_packet
310
311let arb_cstruct : Cstruct.t QCheck.arbitrary =
312 QCheck.make
313 ~print:(fun cs -> Printf.sprintf "<cstruct len=%d>" (Cstruct.length cs))
314 gen_cstruct
315
316let arb_decode_error : decode_error QCheck.arbitrary =
317 QCheck.make ~print:decode_error_to_string gen_decode_error
318
319let arb_send_error : send_error QCheck.arbitrary =
320 QCheck.make ~print:send_error_to_string gen_send_error
321
322let arb_member_snapshot : member_snapshot QCheck.arbitrary =
323 QCheck.make
324 ~print:(fun ms ->
325 Printf.sprintf "{ node=%s; state=%s; incarnation=%d }"
326 (format_node_info ms.node)
327 (member_state_to_string ms.state)
328 (incarnation_to_int ms.incarnation))
329 gen_member_snapshot