upstream: https://github.com/stedolan/crowbar
feat(crowbar): use alcotest as property-testing runner, keep AFL mode
Replace the custom cmdliner-based runner with Alcotest.run_with_args,
preserving crowbar CLI flags (--seed, --repeat, --infinite,
--crowbar-verbose) via cmdliner term integration. AFL mode is detected
by checking if the last argv is an existing file. Also replace Str.split
with String.split_on_char to drop the str dependency.
+96
-143
+1
crowbar.opam
+1
crowbar.opam
+1
dune-project
+1
dune-project
+93
-142
src/crowbar.ml
+93
-142
src/crowbar.ml
···
418
418
pp ppf "%s" (Printexc.to_string e);
419
419
bt
420
420
|> Printexc.raw_backtrace_to_string
421
-
|> Str.split (Str.regexp "\n")
421
+
|> String.split_on_char '\n'
422
422
|> List.iter (pp ppf "@,%s") in
423
423
match status with
424
424
| TestPass pvs ->
···
450
450
let src_of_seed seed =
451
451
Random (prng_state_of_seed seed)
452
452
453
-
let run_test ~mode ~silent ?(verbose=false) (Test (name, gens, f)) =
454
-
let show_status_line ?(clear=false) stat =
455
-
Printf.printf "%s: %s\n" name stat;
456
-
if clear then print_newline ();
457
-
flush stdout in
458
-
let ppf = Format.std_formatter in
459
-
if not silent && Unix.isatty Unix.stdout then
460
-
show_status_line ~clear:false "....";
461
-
let status = match mode with
462
-
| `Once state ->
463
-
run_once gens f state
464
-
| `Repeat (iters, seedseed) ->
465
-
let worst_status = ref (TestPass (fun _ () -> ())) in
466
-
let npass = ref 0 in
467
-
let nbad = ref 0 in
468
-
let seedsrc = prng_state_of_seed seedseed in
469
-
while !npass < iters && classify_status !worst_status = `Pass do
470
-
let seed = Random.State.int64 seedsrc Int64.max_int in
471
-
let state = { chan = src_of_seed seed;
472
-
buf = Bytes.make 256 '0';
473
-
offset = 0; len = 0 } in
474
-
let status = run_once gens f state in
475
-
begin match classify_status status with
476
-
| `Pass -> incr npass
477
-
| `Bad -> incr nbad
478
-
| `Fail ->
479
-
worst_status := status
480
-
end;
481
-
done;
482
-
let status = !worst_status in
483
-
status in
484
-
if silent && verbose && classify_status status = `Fail then begin
485
-
show_status_line
486
-
~clear:true "FAIL";
487
-
pp ppf "%a@." print_status status;
488
-
end;
489
-
if not silent then begin
490
-
match classify_status status with
491
-
| `Pass ->
492
-
show_status_line
493
-
~clear:true "PASS";
494
-
if verbose then pp ppf "%a@." print_status status
495
-
| `Fail ->
496
-
show_status_line
497
-
~clear:true "FAIL";
498
-
pp ppf "%a@." print_status status;
499
-
| `Bad ->
500
-
show_status_line
501
-
~clear:true "BAD";
502
-
pp ppf "%a@." print_status status;
503
-
end;
504
-
status
453
+
(* {1 Property-testing runner (Alcotest)} *)
454
+
455
+
type config = {
456
+
seed : int64 option;
457
+
repeat : int;
458
+
verbose_crowbar : bool;
459
+
infinite : bool;
460
+
}
461
+
462
+
let config_term =
463
+
let open Cmdliner in
464
+
let seed =
465
+
let doc = "The seed (an int64) for the PRNG." in
466
+
Arg.(value & opt (some int64) None & info ["s"; "seed"] ~doc) in
467
+
let repeat =
468
+
let doc = "The number of times to repeat the test." in
469
+
Arg.(value & opt int 5000 & info ["r"; "repeat"] ~doc) in
470
+
let verbose_flag =
471
+
let doc = "Print information on each passing test." in
472
+
Arg.(value & flag & info ["crowbar-verbose"] ~doc) in
473
+
let infinite =
474
+
let doc = "Run until a failure is found." in
475
+
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)
479
+
480
+
let run_property_test (Test (_name, gens, f)) config =
481
+
let seed = match config.seed with
482
+
| Some s -> s
483
+
| None -> Random.int64 Int64.max_int in
484
+
let seedsrc = prng_state_of_seed seed in
485
+
let npass = ref 0 in
486
+
let failure = ref None in
487
+
let max_iter = if config.infinite then max_int else config.repeat in
488
+
while !npass < max_iter && Option.is_none !failure do
489
+
let s = Random.State.int64 seedsrc Int64.max_int in
490
+
let state = { chan = src_of_seed s;
491
+
buf = Bytes.make 256 '0';
492
+
offset = 0; len = 0 } in
493
+
let status = run_once gens f state in
494
+
match classify_status status with
495
+
| `Pass ->
496
+
incr npass;
497
+
if config.verbose_crowbar then
498
+
Printf.printf " pass %d\n%!" !npass
499
+
| `Bad -> ()
500
+
| `Fail -> failure := Some status
501
+
done;
502
+
match !failure with
503
+
| None -> ()
504
+
| Some status ->
505
+
Alcotest.fail (Format.asprintf "%a" print_status status)
506
+
507
+
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]
512
+
513
+
(* {1 AFL runner} *)
505
514
506
515
exception TestFailure
507
-
let run_all_tests seed repeat file verbosity infinity tests =
508
-
match file with
509
-
| None ->
510
-
let seed = match seed with
511
-
| Some seed -> seed
512
-
| None -> Random.int64 (Int64.max_int)
516
+
517
+
let run_afl tests file =
518
+
AflPersistent.run (fun () ->
519
+
let fd = Unix.openfile file [Unix.O_RDONLY] 0o000 in
520
+
let state = { chan = Fd fd; buf = Bytes.make 256 '0';
521
+
offset = 0; len = 0 } in
522
+
let status =
523
+
try
524
+
let test = List.nth tests (choose_int (List.length tests) state) in
525
+
let (Test (_, gens, f)) = test in
526
+
run_once gens f state
527
+
with
528
+
| BadTest s -> BadInput s
513
529
in
514
-
if infinity then
515
-
(* infinite QuickCheck mode *)
516
-
let rec go ntests alltests tests = match tests with
517
-
| [] ->
518
-
go ntests alltests alltests
519
-
| t :: rest ->
520
-
if ntests mod 10000 = 0 then Printf.eprintf "\r%d%!" ntests;
521
-
let chan = src_of_seed seed in
522
-
let state = { chan ; buf = Bytes.make 256 '0'; offset = 0; len = 0 } in
523
-
match classify_status (run_test ~mode:(`Once state) ~silent:true ~verbose:true t) with
524
-
| `Fail -> Printf.printf "%d tests passed before first failure\n%!" ntests
525
-
| _ -> go (ntests + 1) alltests rest in
526
-
let () = go 0 tests tests in
527
-
1
528
-
else
529
-
(* limited-run QuickCheck mode *)
530
-
let failures = ref 0 in
531
-
let () = tests |> List.iter (fun t ->
532
-
match (run_test ~mode:(`Repeat (repeat, seed)) ~silent:false t |> classify_status) with
533
-
| `Fail -> failures := !failures + 1
534
-
| _ -> ()
535
-
)
536
-
in
537
-
!failures
538
-
| Some file ->
539
-
(* AFL mode *)
540
-
let verbose = List.length verbosity > 0 in
541
-
let () = AflPersistent.run (fun () ->
542
-
let fd = Unix.openfile file [Unix.O_RDONLY] 0o000 in
543
-
let state = { chan = Fd fd; buf = Bytes.make 256 '0';
544
-
offset = 0; len = 0 } in
545
-
let status =
546
-
try run_test ~mode:(`Once state) ~silent:false ~verbose @@
547
-
List.nth tests (choose_int (List.length tests) state)
548
-
with
549
-
BadTest s -> BadInput s
550
-
in
551
-
Unix.close fd;
552
-
match classify_status status with
553
-
| `Pass | `Bad -> ()
554
-
| `Fail ->
555
-
Printexc.record_backtrace false;
556
-
raise TestFailure)
557
-
in
558
-
0 (* failures come via the exception mechanism above *)
530
+
Unix.close fd;
531
+
match classify_status status with
532
+
| `Pass | `Bad -> ()
533
+
| `Fail ->
534
+
Printexc.record_backtrace false;
535
+
raise TestFailure)
536
+
537
+
let detect_afl_file () =
538
+
let n = Array.length Sys.argv in
539
+
if n >= 2 then
540
+
let last = Sys.argv.(n - 1) in
541
+
if Sys.file_exists last then Some last
542
+
else None
543
+
else None
559
544
560
545
let last_generated_name = ref 0
561
546
let generate_name () =
···
570
555
| Some name -> name in
571
556
registered_tests := Test (name, gens, f) :: !registered_tests
572
557
573
-
(* cmdliner stuff *)
574
-
575
-
let randomness_file =
576
-
let doc = "A file containing some bytes, consulted in constructing test cases. \
577
-
When `afl-fuzz` is calling the test binary, use `@@` to indicate that \
578
-
`afl-fuzz` should put its test case here \
579
-
(e.g. `afl-fuzz -i input -o output ./my_crowbar_test @@`). Re-run a test by \
580
-
supplying the test file here \
581
-
(e.g. `./my_crowbar_test output/crashes/id:000000`). If no file is \
582
-
specified, the test will use OCaml's Random module as a source of \
583
-
randomness for a predefined number of rounds." in
584
-
Cmdliner.Arg.(value & pos 0 (some file) None & info [] ~doc ~docv:"FILE")
585
-
586
-
let seed =
587
-
let doc = "The seed (an int64) for the PRNG. Use as an alternative to FILE
588
-
when running in non-AFL (quickcheck) mode." in
589
-
Cmdliner.Arg.(value & opt (some int64) None & info ["s"; "seed"] ~doc ~docv:"SEED")
590
-
591
-
let repeat =
592
-
let doc = "The number of times to repeat the test in quick-check." in
593
-
Cmdliner.Arg.(value & opt int 5000 & info ["r"; "repeat"] ~doc ~docv:"REPEAT")
594
-
595
-
let verbosity =
596
-
let doc = "Print information on each test as it's conducted." in
597
-
Cmdliner.Arg.(value & flag_all & info ["v"; "verbose"] ~doc ~docv:"VERBOSE")
598
-
599
-
let infinity =
600
-
let doc = "In non-AFL (quickcheck) mode, continue running until a test failure is \
601
-
discovered. No attempt is made to track which tests have already been run, \
602
-
so some tests may be repeated, and if there are no failures reachable, the \
603
-
test will never terminate without outside intervention." in
604
-
Cmdliner.Arg.(value & flag & info ["i"] ~doc ~docv:"INFINITE")
605
-
606
-
let crowbar_info = Cmdliner.Cmd.info @@ Filename.basename Sys.argv.(0)
607
-
608
558
let () =
609
559
at_exit (fun () ->
610
560
let t = !registered_tests in
···
612
562
match t with
613
563
| [] -> ()
614
564
| t ->
615
-
let cmd = Cmdliner.Term.(const run_all_tests $ seed $ repeat $ randomness_file $ verbosity $
616
-
infinity $ const (List.rev t)) in
617
-
exit @@ Cmdliner.Cmd.eval' ~catch:false (Cmdliner.Cmd.v crowbar_info cmd)
565
+
let tests = List.rev t in
566
+
match detect_afl_file () with
567
+
| Some file -> run_afl tests file
568
+
| None -> run_with_alcotest tests
618
569
)
619
570
620
571
module Syntax = struct