upstream: https://github.com/stedolan/crowbar
fix(fuzz): TTY restore, crowbar budget, skip afl runtest, E725 lint rule
- Restore cursor on exit via at_exit in Tty.Progress (fixes TTY corruption)
- Install SIGINT handler in monopam test for clean Ctrl-C
- Add 2s per-iteration timeout and 2s total budget to crowbar
- Group crowbar alcotest output by module prefix ("mdns: foo" → group "mdns")
- Skip fuzz runtest in afl context (enabled_if <> profile afl)
- Add merlint E725: enforce "module: description" fuzz test name convention
+65
-9
+65
-9
src/crowbar.ml
+65
-9
src/crowbar.ml
···
457
457
repeat : int;
458
458
verbose_crowbar : bool;
459
459
infinite : bool;
460
+
timeout : int;
461
+
budget : float;
460
462
}
463
+
464
+
exception Timeout
465
+
466
+
let default_timeout =
467
+
match Sys.getenv_opt "CROWBAR_TIMEOUT" with
468
+
| Some s -> (try int_of_string s with _ -> 2)
469
+
| None -> 2
461
470
462
471
let config_term =
463
472
let open Cmdliner in
···
473
482
let infinite =
474
483
let doc = "Run until a failure is found." in
475
484
Arg.(value & flag & info ["i"; "infinite"] ~doc) in
476
-
Term.(const (fun seed repeat verbose_crowbar infinite ->
477
-
{ seed; repeat; verbose_crowbar; infinite })
478
-
$ seed $ repeat $ verbose_flag $ infinite)
485
+
let timeout =
486
+
let doc =
487
+
"Per-test timeout in seconds (0 to disable). \
488
+
Can also be set via CROWBAR_TIMEOUT." in
489
+
Arg.(value & opt int default_timeout & info ["timeout"] ~doc) in
490
+
let budget =
491
+
let doc =
492
+
"Total time budget per test in seconds (0 to disable). \
493
+
Stops iterating when the budget is exhausted." in
494
+
Arg.(value & opt float 2. & info ["budget"] ~docv:"SECONDS" ~doc) in
495
+
Term.(const (fun seed repeat verbose_crowbar infinite timeout budget ->
496
+
{ seed; repeat; verbose_crowbar; infinite; timeout; budget })
497
+
$ seed $ repeat $ verbose_flag $ infinite $ timeout $ budget)
498
+
499
+
let with_timeout timeout f =
500
+
if timeout <= 0 then f ()
501
+
else begin
502
+
let old_handler = Sys.signal Sys.sigalrm
503
+
(Sys.Signal_handle (fun _ -> raise Timeout)) in
504
+
let old_alarm = Unix.alarm timeout in
505
+
Fun.protect ~finally:(fun () ->
506
+
ignore (Unix.alarm old_alarm);
507
+
Sys.set_signal Sys.sigalrm old_handler
508
+
) f
509
+
end
479
510
480
511
let run_property_test (Test (_name, gens, f)) config =
481
512
let seed = match config.seed with
···
485
516
let npass = ref 0 in
486
517
let failure = ref None in
487
518
let max_iter = if config.infinite then max_int else config.repeat in
488
-
while !npass < max_iter && Option.is_none !failure do
519
+
let start_time = Unix.gettimeofday () in
520
+
let within_budget () =
521
+
config.budget <= 0. || Unix.gettimeofday () -. start_time < config.budget
522
+
in
523
+
while !npass < max_iter && Option.is_none !failure && within_budget () do
489
524
let s = Random.State.int64 seedsrc Int64.max_int in
490
525
let state = { chan = src_of_seed s;
491
526
buf = Bytes.make 256 '0';
492
527
offset = 0; len = 0 } in
493
-
let status = run_once gens f state in
528
+
let status =
529
+
try with_timeout config.timeout (fun () -> run_once gens f state)
530
+
with Timeout ->
531
+
TestExn (Timeout, Printexc.get_raw_backtrace (),
532
+
fun ppf () -> pp ppf "<timeout after %ds>" config.timeout)
533
+
in
494
534
match classify_status status with
495
535
| `Pass ->
496
536
incr npass;
···
505
545
Alcotest.fail (Format.asprintf "%a" print_status status)
506
546
507
547
let run_with_alcotest tests =
508
-
let test_cases = List.map (fun (Test (name, _, _) as test) ->
509
-
Alcotest.test_case name `Quick (run_property_test test)
510
-
) tests in
511
-
Alcotest.run_with_args "crowbar" config_term ["crowbar", test_cases]
548
+
let split_name name =
549
+
match String.index_opt name ':' with
550
+
| Some i ->
551
+
let group = String.trim (String.sub name 0 i) in
552
+
let rest = String.trim (String.sub name (i + 1) (String.length name - i - 1)) in
553
+
(group, rest)
554
+
| None -> ("crowbar", name)
555
+
in
556
+
let groups = Hashtbl.create 16 in
557
+
List.iter (fun (Test (name, _, _) as test) ->
558
+
let group, short = split_name name in
559
+
let tc = Alcotest.test_case short `Quick (run_property_test test) in
560
+
let prev = try Hashtbl.find groups group with Not_found -> [] in
561
+
Hashtbl.replace groups group (tc :: prev)
562
+
) tests;
563
+
let suites = Hashtbl.fold (fun group tcs acc ->
564
+
(group, List.rev tcs) :: acc
565
+
) groups [] in
566
+
let suites = List.sort (fun (a, _) (b, _) -> String.compare a b) suites in
567
+
Alcotest.run_with_args "crowbar" config_term suites
512
568
513
569
(* {1 AFL runner} *)
514
570