upstream: https://github.com/stedolan/crowbar
Add 'crowbar' from https://github.com/stedolan/crowbar.git
git-subtree-dir: crowbar
+1456
+14
CHANGES.md
+14
CHANGES.md
+8
LICENSE.md
+8
LICENSE.md
···
1
+
Copyright (c) 2017 Stephen Dolan
2
+
3
+
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
4
+
5
+
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
6
+
7
+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
8
+
+82
README.md
+82
README.md
···
1
+
# Crowbar
2
+
3
+
**Crowbar** is a library for testing code, combining QuickCheck-style
4
+
property-based testing and the magical bug-finding powers of
5
+
[afl-fuzz](http://lcamtuf.coredump.cx/afl/).
6
+
7
+
## TL;DR
8
+
9
+
There are [some examples](./examples).
10
+
11
+
Some brief hints:
12
+
13
+
1. Use an opam switch with AFL instrumentation enabled (e.g. `opam sw 4.04.0+afl`).
14
+
2. Run in AFL mode with `afl-fuzz -i in -o out -- ./_build/myprog.exe @@`.
15
+
3. If you run your executable without arguments, crowbar will perform some simple (non-AFL) testing instead.
16
+
4. Test binaries have a small amount of documentation, available with `--help`.
17
+
18
+
## writing tests
19
+
20
+
To test your software, come up with a property you'd like to test, then decide on the input you'd like for Crowbar to vary. A Crowbar test is some invocation of `Crowbar.check_eq` or `Crowbar.check`:
21
+
22
+
```ocaml
23
+
let identity x =
24
+
Crowbar.check_eq x x
25
+
```
26
+
27
+
and instructions for running the test with generated items with `Crowbar.add_test`:
28
+
29
+
```ocaml
30
+
let () =
31
+
Crowbar.(add_test ~name:"identity function" [int] (fun i -> identity i))
32
+
```
33
+
34
+
There are [more examples available](./examples), with varying levels complexity.
35
+
36
+
## building tests
37
+
38
+
Include `crowbar` in your list of dependencies via your favorite build system. The resulting executable is a Crowbar test. (Be sure to build a native-code executable, not bytecode.)
39
+
40
+
To build tests that run under AFL, you'll need to build your tests with a compiler that has AFL instrumentation enabled. (You can also enable it specifically for your build, although this is not recommended if your code has any dependencies, including the OCaml standard library). OCaml compiler variants with AFL enabled by default are available in `opam` with the `+afl` tag. All versions published starting with 4.05.0 are available, along with a backported 4.04.0.
41
+
42
+
```shell
43
+
$ opam switch 4.06.0+afl
44
+
$ eval `opam config env`
45
+
$ ./build_my_rad_test.sh # or your relevant build runes
46
+
```
47
+
48
+
## running Tests
49
+
50
+
Crowbar tests have two modes:
51
+
52
+
* a simple quickcheck-like mode for testing propositions against totally random input
53
+
* a mode using [afl-persistent](https://github.com/stedolan/ocaml-afl-persistent) to get good performance from `afl-fuzz` with OCaml's instrumentation enabled
54
+
55
+
Crowbar tests can be directly invoked with `--help` for more documentation at runtime.
56
+
57
+
### fully random test mode
58
+
59
+
If you wish to use the quickcheck-like, fully random mode to run all tests distributed here, build the tests as above and then run the binary with no arguments.
60
+
61
+
```
62
+
$ ./my_rad_test.exe | head -5
63
+
the first test: PASS
64
+
65
+
the second test: PASS
66
+
```
67
+
68
+
### AFL mode requirements
69
+
70
+
To run the tests in AFL mode, you'll need to install American Fuzzy Lop ([latest source tarball](http://lcamtuf.coredump.cx/afl/releases/afl-latest.tgz), although your distribution may also have a package available).
71
+
72
+
Once `afl-fuzz` is available on your system, create an `input` directory with a non-empty file in it (or use `test/input`, conveniently provided in this repository), and an `output` directory for `afl-fuzz` to store its findings. Then, invoke your test binary:
73
+
74
+
```
75
+
afl-fuzz -i test/input -o output ./my_rad_test.exe @@
76
+
```
77
+
78
+
This will launch AFL, which will generate new test cases and track the exploration of the state space. When inputs are discovered which cause a property not to hold, they will be reported as crashes (along with actual crashes, although in the OCaml standard library these are rare). See the [afl-fuzz documentation](https://lcamtuf.coredump.cx/afl/status_screen.txt) for more on AFL's excellent interface.
79
+
80
+
# What bugs have you found?
81
+
82
+
[An open issue](https://github.com/stedolan/crowbar/issues/2) has a list of issues discovered by testing with Crowbar. If you use Crowbar to improve your software, please let us know!
+43
crowbar.opam
+43
crowbar.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Write tests, let a fuzzer find failing cases"
4
+
description: """
5
+
Crowbar is a library for testing code, combining QuickCheck-style
6
+
property-based testing and the magical bug-finding powers of
7
+
[afl-fuzz](http://lcamtuf.coredump.cx/afl/).
8
+
"""
9
+
maintainer: ["Stephen Dolan <stephen.dolan@cl.cam.ac.uk>"]
10
+
authors: ["Stephen Dolan <stephen.dolan@cl.cam.ac.uk>"]
11
+
license: "MIT"
12
+
homepage: "https://github.com/stedolan/crowbar"
13
+
bug-reports: "https://github.com/stedolan/crowbar/issues"
14
+
depends: [
15
+
"dune" {>= "2.9"}
16
+
"ocaml" {>= "4.08"}
17
+
"cmdliner" {>= "1.1.0"}
18
+
"afl-persistent" {>= "1.1"}
19
+
"calendar" {>= "2.00" & with-test}
20
+
"fpath" {with-test}
21
+
"pprint" {with-test}
22
+
"uucp" {with-test}
23
+
"uunf" {with-test}
24
+
"uutf" {with-test}
25
+
"odoc" {with-doc}
26
+
]
27
+
build: [
28
+
["dune" "subst"] {dev}
29
+
[
30
+
"dune"
31
+
"build"
32
+
"-p"
33
+
name
34
+
"-j"
35
+
jobs
36
+
"--promote-install-files=false"
37
+
"@install"
38
+
"@runtest" {with-test}
39
+
"@doc" {with-doc}
40
+
]
41
+
["dune" "install" "-p" name "--create-install-files" name]
42
+
]
43
+
dev-repo: "git+https://github.com/stedolan/crowbar.git"
+1
dune
+1
dune
···
1
+
(env (dev (flags (:standard -warn-error -A))))
+29
dune-project
+29
dune-project
···
1
+
(lang dune 2.9)
2
+
(name crowbar)
3
+
4
+
(formatting disabled)
5
+
(generate_opam_files true)
6
+
7
+
(source (github stedolan/crowbar))
8
+
(license MIT)
9
+
(authors "Stephen Dolan <stephen.dolan@cl.cam.ac.uk>")
10
+
(maintainers "Stephen Dolan <stephen.dolan@cl.cam.ac.uk>")
11
+
12
+
(package
13
+
(name crowbar)
14
+
(synopsis "Write tests, let a fuzzer find failing cases")
15
+
(description
16
+
"\| Crowbar is a library for testing code, combining QuickCheck-style
17
+
"\| property-based testing and the magical bug-finding powers of
18
+
"\| [afl-fuzz](http://lcamtuf.coredump.cx/afl/).
19
+
)
20
+
(depends
21
+
(ocaml (>= "4.08"))
22
+
(cmdliner (>= 1.1.0))
23
+
(afl-persistent (>= "1.1"))
24
+
("calendar" (and (>= "2.00") :with-test))
25
+
("fpath" :with-test)
26
+
("pprint" :with-test)
27
+
("uucp" :with-test)
28
+
("uunf" :with-test)
29
+
("uutf" :with-test)))
+1
examples/.gitignore
+1
examples/.gitignore
···
1
+
output
+29
examples/calendar/test_calendar.ml
+29
examples/calendar/test_calendar.ml
···
1
+
open Crowbar
2
+
3
+
module C = CalendarLib.Calendar.Precise
4
+
5
+
let time =
6
+
map [int64] (fun a ->
7
+
try
8
+
C.from_mjd (Int64.to_float a /. 100_000_000_000_000.)
9
+
with
10
+
CalendarLib.Date.Out_of_bounds -> bad_test ())
11
+
12
+
let pp_time ppf t =
13
+
pp ppf "%04d-%02d-%02d %02d:%02d:%02d"
14
+
(C.year t)
15
+
(C.month t |> C.Date.int_of_month)
16
+
(C.day_of_month t)
17
+
(C.hour t)
18
+
(C.minute t)
19
+
(C.second t)
20
+
let time = with_printer pp_time time
21
+
22
+
let period =
23
+
map [const 0;const 0;int8;int8;int8;int8] C.Period.make
24
+
25
+
26
+
let () =
27
+
add_test ~name:"calendar" [time; time] @@ fun t1 t2 ->
28
+
guard (C.compare t1 t2 < 0);
29
+
check_eq ~pp:pp_time ~eq:C.equal (C.add t1 (C.precise_sub t2 t1)) t2
+4
examples/fpath/dune
+4
examples/fpath/dune
+18
examples/fpath/test_fpath.ml
+18
examples/fpath/test_fpath.ml
···
1
+
open Crowbar
2
+
open Astring
3
+
open Fpath
4
+
let fpath =
5
+
map [bytes] (fun s ->
6
+
try
7
+
v s
8
+
with
9
+
Invalid_argument _ -> bad_test ())
10
+
11
+
12
+
let () =
13
+
add_test ~name:"segs" [fpath] @@ fun p ->
14
+
let np = normalize p in
15
+
assert (is_dir_path p = is_dir_path np);
16
+
assert (is_file_path p = is_file_path np);
17
+
assert (filename p = filename np);
18
+
check_eq ~eq:equal p (v @@ (fst @@ split_volume p) ^ (String.concat ~sep:dir_sep (segs p)))
+1
examples/input/testcase
+1
examples/input/testcase
···
1
+
asdf
+4
examples/map/dune
+4
examples/map/dune
+47
examples/map/test_map.ml
+47
examples/map/test_map.ml
···
1
+
open Crowbar
2
+
3
+
module Map = Map.Make (struct
4
+
type t = int
5
+
let compare (i : int) (j : int) = compare i j
6
+
end)
7
+
8
+
type t = ((int * int) list * int Map.t)
9
+
10
+
let check_map ((list, map) : t) =
11
+
let rec dedup k = function
12
+
| [] -> []
13
+
| (k', v') :: rest when k = k' -> dedup k rest
14
+
| (k', v') :: rest ->
15
+
(k', v') :: dedup k' rest in
16
+
let list = match List.stable_sort (fun a b -> compare (fst a) (fst b)) list with
17
+
| [] -> []
18
+
| (k, v) :: rest -> (k, v) :: dedup k rest in
19
+
List.for_all (fun (k, v) -> Map.find k map = v) list &&
20
+
list = Map.bindings map
21
+
22
+
let map_gen : t gen = fix (fun map_gen -> choose [
23
+
const ([], Map.empty);
24
+
map [uint8; uint8; map_gen] (fun k v (l, m) ->
25
+
(k, v) :: l, Map.add k v m);
26
+
map [uint8; uint8] (fun k v ->
27
+
[k, v], Map.singleton k v);
28
+
map [uint8; map_gen] (fun k (l, m) ->
29
+
let rec rem_all k l =
30
+
let l' = List.remove_assoc k l in
31
+
if l = l' then l else rem_all k l' in
32
+
rem_all k l, Map.remove k m);
33
+
(* merge? *)
34
+
map [map_gen; map_gen] (fun (l, m) (l', m') ->
35
+
l @ l', Map.union (fun k a b -> Some a) m m');
36
+
map [uint8; map_gen] (fun k (list, map) ->
37
+
let (l, v, r) = Map.split k map in
38
+
let (l', vr') = List.partition (fun (kx,vx) -> kx < k) list in
39
+
let r' = List.filter (fun (kx, vx) -> kx <> k) vr' in
40
+
let v' = match List.assoc k vr' with n -> Some n | exception Not_found -> None in
41
+
assert (v = v');
42
+
(l' @ List.map (fun (k,v) -> k,v+42) r',
43
+
Map.union (fun k a b -> assert false) l (Map.map (fun v -> v + 42) r)))])
44
+
45
+
let () =
46
+
add_test ~name:"map" [map_gen] @@ fun m ->
47
+
check (check_map m)
+39
examples/pprint/test_pprint.ml
+39
examples/pprint/test_pprint.ml
···
1
+
open PPrint
2
+
open Crowbar
3
+
type t = (string * PPrint.document)
4
+
let doc = fix (fun doc -> choose [
5
+
const ("", empty);
6
+
const ("a", PPrint.char 'a');
7
+
const ("123", string "123");
8
+
const ("Hello", string "Hello");
9
+
const ("awordwhichisalittlebittoolong",
10
+
string "awordwhichisalittlebittoolong");
11
+
const ("", hardline);
12
+
map [range 10] (fun n -> ("", break n));
13
+
map [range 10] (fun n -> ("", break n));
14
+
map [doc; doc]
15
+
(fun (sa,da) (sb,db) -> (sa ^ sb, da ^^ db));
16
+
map [range 10; doc] (fun n (s,d) -> (s, nest n d));
17
+
map [doc] (fun (s, d) -> (s, group d));
18
+
map [doc] (fun (s, d) -> (s, align d))
19
+
])
20
+
21
+
let check_doc (s, d) =
22
+
let b = Buffer.create 100 in
23
+
let w = 40 in
24
+
ToBuffer.pretty 1.0 w b d;
25
+
let text = Bytes.to_string (Buffer.to_bytes b) in
26
+
let ws = Str.regexp "[ \t\n\r]*" in
27
+
(* Printf.printf "doc2{\n%s\n}%!" text; *)
28
+
let del_ws = Str.global_replace ws "" in
29
+
(* Printf.printf "[%s] = [%s]\n%!" (del_ws s) (del_ws text);*)
30
+
Str.split (Str.regexp "\n") text |> List.iter (fun s ->
31
+
let mspace = Str.regexp "[^ ] " in
32
+
if String.length s > w then
33
+
match Str.search_forward mspace s w with
34
+
| _ -> assert false
35
+
| exception Not_found -> ());
36
+
check_eq (del_ws s) (del_ws text)
37
+
38
+
let () =
39
+
add_test ~name:"pprint" [doc] check_doc
+34
examples/serializer/serializer.ml
+34
examples/serializer/serializer.ml
···
1
+
type data =
2
+
| Datum of string
3
+
| Block of header * data list
4
+
and header = string
5
+
6
+
type _ ty =
7
+
| Int : int ty
8
+
| Bool : bool ty
9
+
| Prod : 'a ty * 'b ty -> ('a * 'b) ty
10
+
| List : 'a ty -> 'a list ty
11
+
12
+
let rec pp_ty : type a . _ -> a ty -> unit = fun ppf ->
13
+
let printf fmt = Format.fprintf ppf fmt in
14
+
function
15
+
| Int -> printf "Int"
16
+
| Bool -> printf "Bool"
17
+
| Prod(ta, tb) -> printf "Prod(%a,%a)" pp_ty ta pp_ty tb
18
+
| List t -> printf "List(%a)" pp_ty t
19
+
20
+
let rec serialize : type a . a ty -> a -> data = function
21
+
| Int -> fun n -> Datum (string_of_int n)
22
+
| Bool -> fun b -> Datum (string_of_bool b)
23
+
| Prod (ta, tb) -> fun (va, vb) ->
24
+
Block("pair", [serialize ta va; serialize tb vb])
25
+
| List t -> fun vs ->
26
+
Block("list", List.map (serialize t) vs)
27
+
28
+
let rec deserialize : type a . a ty -> data -> a = function[@warning "-8"]
29
+
| Int -> fun (Datum s) -> int_of_string s
30
+
| Bool -> fun (Datum s) -> bool_of_string s
31
+
| Prod (ta, tb) -> fun (Block("pair", [sa; sb])) ->
32
+
(deserialize ta sa, deserialize tb sb)
33
+
| List t -> fun (Block("list", ss)) ->
34
+
List.map (deserialize t) ss
+47
examples/serializer/test_serializer.ml
+47
examples/serializer/test_serializer.ml
···
1
+
open Crowbar
2
+
3
+
module S = Serializer
4
+
5
+
type any_ty = Any : 'a S.ty -> any_ty
6
+
7
+
let ty_gen =
8
+
with_printer (fun ppf (Any t)-> S.pp_ty ppf t) @@
9
+
fix (fun ty_gen -> choose [
10
+
const (Any S.Int);
11
+
const (Any S.Bool);
12
+
map [ty_gen; ty_gen] (fun (Any ta) (Any tb) ->
13
+
Any (S.Prod (ta, tb)));
14
+
map [ty_gen] (fun (Any t) -> Any (List t));
15
+
])
16
+
17
+
let prod_gen ga gb = map [ga; gb] (fun va vb -> (va, vb))
18
+
19
+
let rec gen_of_ty : type a . a S.ty -> a gen = function
20
+
| S.Int -> int
21
+
| S.Bool -> bool
22
+
| S.Prod (ta, tb) -> prod_gen (gen_of_ty ta) (gen_of_ty tb)
23
+
| S.List t -> list (gen_of_ty t)
24
+
25
+
type pair = Pair : 'a S.ty * 'a -> pair
26
+
27
+
(* The generator for the final value, [gen_of_ty t], depends on the
28
+
generated type representation, [t]. This dynamic dependency cannot
29
+
be expressed with [map], it requires [dynamic_bind]. *)
30
+
let pair_gen : pair gen =
31
+
dynamic_bind ty_gen @@ fun (Any t) ->
32
+
map [gen_of_ty t] (fun v -> Pair (t, v))
33
+
34
+
let rec printer_of_ty : type a . a S.ty -> a printer = function
35
+
| S.Int -> pp_int
36
+
| S.Bool -> pp_bool
37
+
| S.Prod (ta, tb) -> (fun ppf (a, b) ->
38
+
pp ppf "(%a, %a)" (printer_of_ty ta) a (printer_of_ty tb) b)
39
+
| S.List t -> pp_list (printer_of_ty t)
40
+
41
+
let check_pair (Pair (t, v)) =
42
+
let data = S.serialize t v in
43
+
match S.deserialize t data with
44
+
| exception _ -> fail "incorrect deserialization"
45
+
| v' -> check_eq ~pp:(printer_of_ty t) v v'
46
+
47
+
let () = add_test ~name:"pairs" [pair_gen] check_pair
+75
examples/uunf/test_uunf.ml
+75
examples/uunf/test_uunf.ml
···
1
+
open Crowbar
2
+
3
+
let uchar =
4
+
map [int32] (fun n ->
5
+
let n = (Int32.to_int n land 0xFFFFFFF) mod 0x10FFFF in
6
+
try Uchar.of_int n
7
+
with Invalid_argument _ -> bad_test ())
8
+
9
+
let unicode = list1 uchar
10
+
11
+
let norm form str =
12
+
let n = Uunf.create form in
13
+
let rec add acc v = match Uunf.add n v with
14
+
| `Uchar u -> add (u :: acc) `Await
15
+
| `Await | `End -> acc in
16
+
let rec go acc = function
17
+
| [] -> List.rev (add acc `End)
18
+
| (v :: vs) -> go (add acc (`Uchar v)) vs in
19
+
go [] str
20
+
21
+
let unicode_to_string s =
22
+
let b = Buffer.create 10 in
23
+
List.iter (Uutf.Buffer.add_utf_8 b) s;
24
+
Buffer.contents b
25
+
26
+
27
+
let pp_unicode ppf s =
28
+
Format.fprintf ppf "@[<v 2>";
29
+
Format.fprintf ppf "@[\"%s\"@]@ " (unicode_to_string s);
30
+
s |> List.iter (fun u ->
31
+
Format.fprintf ppf "@[U+%04x %s (%a)@]@ " (Uchar.to_int u) (Uucp.Name.name u) Uucp.Block.pp (Uucp.Block.block u));
32
+
Format.fprintf ppf "@]\n"
33
+
34
+
35
+
let unicode = with_printer pp_unicode unicode
36
+
37
+
let () =
38
+
add_test ~name:"uunf" [unicode] @@ fun s ->
39
+
let nfc = norm `NFC s in
40
+
let nfd = norm `NFD s in
41
+
let nfkc = norm `NFKC s in
42
+
let nfkd = norm `NFKD s in
43
+
(* [s; nfc; nfd; nfkc; nfkd] |> List.iter (fun s ->
44
+
Printf.printf "[%s]\n" (unicode_to_string s));
45
+
Printf.printf "\n%!";*)
46
+
47
+
let tests =
48
+
[
49
+
nfc, [
50
+
norm `NFC nfc;
51
+
norm `NFC nfd];
52
+
53
+
nfd, [
54
+
norm `NFD nfc;
55
+
norm `NFD nfd];
56
+
57
+
nfkc, [
58
+
norm `NFC nfkc;
59
+
norm `NFC nfkd;
60
+
norm `NFKC nfc;
61
+
norm `NFKC nfd;
62
+
norm `NFKC nfkc;
63
+
norm `NFKC nfkd];
64
+
65
+
nfkd, [
66
+
norm `NFD nfkc;
67
+
norm `NFD nfkd;
68
+
norm `NFKD nfc;
69
+
norm `NFKD nfd;
70
+
norm `NFKD nfkc;
71
+
norm `NFKD nfkd]
72
+
] in
73
+
tests |> List.iter (fun (s, eqs) ->
74
+
List.iter (fun s' -> check_eq ~pp:pp_unicode s s') eqs)
75
+
+4
examples/xmldiff/dune
+4
examples/xmldiff/dune
+42
examples/xmldiff/test_xmldiff.ml
+42
examples/xmldiff/test_xmldiff.ml
···
1
+
open Crowbar
2
+
3
+
let ident = choose [const "a"; const "b"; const "c"]
4
+
let elem_name = map [ident] (fun s -> ("", s))
5
+
6
+
7
+
let attrs =
8
+
choose [
9
+
const Xmldiff.Nmap.empty;
10
+
map [elem_name; ident] Xmldiff.Nmap.singleton
11
+
]
12
+
13
+
let rec xml = lazy (
14
+
choose [
15
+
const (`D "a");
16
+
map [ident] (fun s -> `D s);
17
+
map [elem_name; attrs; list (unlazy xml)] (fun s attrs elems ->
18
+
let rec normalise = function
19
+
| ([] | [_]) as x -> x
20
+
| `E _ as el :: xs ->
21
+
el :: normalise xs
22
+
| `D s :: xs ->
23
+
match normalise xs with
24
+
| `D s' :: xs' ->
25
+
`D (s ^ s') :: xs'
26
+
| xs' -> `D s :: xs' in
27
+
`E (s, attrs, normalise elems))
28
+
])
29
+
30
+
let lazy xml = xml
31
+
32
+
let xml = map [xml] (fun d -> `E (("", "a"), Xmldiff.Nmap.empty, [d]))
33
+
34
+
let pp_xml ppf xml =
35
+
pp ppf "%s" (Xmldiff.string_of_xml xml)
36
+
let xml = with_printer pp_xml xml
37
+
38
+
39
+
let () =
40
+
add_test ~name:"xmldiff" [xml; xml] @@ fun xml1 xml2 ->
41
+
let (patch, xml3) = Xmldiff.diff_with_final_tree xml1 xml2 in
42
+
check_eq ~pp:pp_xml xml2 xml3
+624
src/crowbar.ml
+624
src/crowbar.ml
···
1
+
(* Fix for OCaml 5.0 *)
2
+
let () = Random.init 42
3
+
4
+
type src = Random of Random.State.t | Fd of Unix.file_descr
5
+
type state =
6
+
{
7
+
chan : src;
8
+
buf : Bytes.t;
9
+
mutable offset : int;
10
+
mutable len : int
11
+
}
12
+
13
+
type 'a printer = Format.formatter -> 'a -> unit
14
+
15
+
type 'a strat =
16
+
| Choose of 'a gen list
17
+
| Map : ('f, 'a) gens * 'f -> 'a strat
18
+
| Bind : 'a gen * ('a -> 'b gen) -> 'b strat
19
+
| Option : 'a gen -> 'a option strat
20
+
| List : 'a gen -> 'a list strat
21
+
| List1 : 'a gen -> 'a list strat
22
+
| Array : 'a gen -> 'a array strat
23
+
| Array1 : 'a gen -> 'a array strat
24
+
| Unlazy of 'a gen Lazy.t
25
+
| Primitive of (state -> 'a)
26
+
| Print of 'a printer * 'a gen
27
+
28
+
and 'a gen =
29
+
{ strategy: 'a strat;
30
+
small_examples: 'a list; }
31
+
32
+
and ('k, 'res) gens =
33
+
| [] : ('res, 'res) gens
34
+
| (::) : 'a gen * ('k, 'res) gens -> ('a -> 'k, 'res) gens
35
+
36
+
type nonrec +'a list = 'a list = [] | (::) of 'a * 'a list
37
+
38
+
let unlazy f = { strategy = Unlazy f; small_examples = [] }
39
+
40
+
let fix f =
41
+
let rec lazygen = lazy (f (unlazy lazygen)) in
42
+
Lazy.force lazygen
43
+
44
+
let map (type f) (type a) (gens : (f, a) gens) (f : f) =
45
+
{ strategy = Map (gens, f); small_examples = match gens with [] -> [f] | _ -> [] }
46
+
47
+
let dynamic_bind m f = {strategy = Bind(m, f); small_examples = [] }
48
+
49
+
let const x = map [] x
50
+
let choose gens = { strategy = Choose gens; small_examples = List.map (fun x -> x.small_examples) gens |> List.concat }
51
+
let option gen = { strategy = Option gen; small_examples = [None] }
52
+
let list gen = { strategy = List gen; small_examples = [[]] }
53
+
let list1 gen = { strategy = List1 gen; small_examples = List.map (fun x -> [x]) gen.small_examples }
54
+
let array gen = { strategy = Array gen; small_examples = [[||]] }
55
+
let array1 gen = { strategy = Array1 gen; small_examples = List.map (fun x -> [|x|]) gen.small_examples }
56
+
let primitive f ex = { strategy = Primitive f; small_examples = [ex] }
57
+
58
+
let pair gena genb =
59
+
map (gena :: genb :: []) (fun a b -> (a, b))
60
+
61
+
let concat_gen_list sep l =
62
+
match l with
63
+
| h::t -> List.fold_left (fun acc e ->
64
+
map [acc; sep; e] (fun acc sep e -> acc ^ sep ^ e)
65
+
) h t
66
+
| [] -> const ""
67
+
68
+
let with_printer pp gen = {strategy = Print (pp, gen); small_examples = gen.small_examples }
69
+
70
+
let result gena genb =
71
+
choose [
72
+
map [gena] (fun va -> Ok va);
73
+
map [genb] (fun vb -> Error vb);
74
+
]
75
+
76
+
77
+
let pp = Format.fprintf
78
+
let pp_int ppf n = pp ppf "%d" n
79
+
let pp_int32 ppf n = pp ppf "%s" (Int32.to_string n)
80
+
let pp_int64 ppf n = pp ppf "%s" (Int64.to_string n)
81
+
let pp_float ppf f = pp ppf "%f" f
82
+
let pp_bool ppf b = pp ppf "%b" b
83
+
let pp_char ppf c = pp ppf "%c" c
84
+
let pp_uchar ppf c = pp ppf "U+%04x" (Uchar.to_int c)
85
+
let pp_string ppf s = pp ppf "%S" s
86
+
(* taken from OCaml stdlib *)
87
+
let pp_print_iter ~pp_sep iter pp_v ppf v =
88
+
let is_first = ref true in
89
+
let pp_v v =
90
+
if !is_first then is_first := false else pp_sep ppf ();
91
+
pp_v ppf v
92
+
in
93
+
iter pp_v v
94
+
let pp_list pv ppf l =
95
+
pp ppf "@[<hv 1>[%a]@]"
96
+
(pp_print_iter ~pp_sep:(fun ppf () -> pp ppf ";@ ") List.iter pv) l
97
+
let pp_array pv ppf a =
98
+
pp ppf "@[<hv 1>[|%a|]@]"
99
+
(pp_print_iter ~pp_sep:(fun ppf () -> pp ppf ";@ ") Array.iter pv) a
100
+
let pp_option pv ppf = function
101
+
| None ->
102
+
Format.fprintf ppf "None"
103
+
| Some x ->
104
+
Format.fprintf ppf "(Some %a)" pv x
105
+
106
+
exception BadTest of string
107
+
exception FailedTest of unit printer
108
+
let guard = function
109
+
| true -> ()
110
+
| false -> raise (BadTest "guard failed")
111
+
let bad_test () = raise (BadTest "bad test")
112
+
let nonetheless = function
113
+
| None -> bad_test ()
114
+
| Some a -> a
115
+
116
+
let get_data chan buf off len =
117
+
match chan with
118
+
| Random rand ->
119
+
for i = off to off + len - 1 do
120
+
Bytes.set buf i (Char.chr (Random.State.bits rand land 0xff))
121
+
done;
122
+
len - off
123
+
| Fd ch ->
124
+
Unix.read ch buf off len
125
+
126
+
let refill src =
127
+
assert (src.offset <= src.len);
128
+
let remaining = src.len - src.offset in
129
+
(* move remaining data to start of buffer *)
130
+
Bytes.blit src.buf src.offset src.buf 0 remaining;
131
+
src.len <- remaining;
132
+
src.offset <- 0;
133
+
let read = get_data src.chan src.buf remaining (Bytes.length src.buf - remaining) in
134
+
if read = 0 then
135
+
raise (BadTest "premature end of file")
136
+
else
137
+
src.len <- remaining + read
138
+
139
+
let rec getbytes src n =
140
+
assert (src.offset <= src.len);
141
+
if n > Bytes.length src.buf then failwith "request too big";
142
+
if src.len - src.offset >= n then
143
+
let off = src.offset in
144
+
(src.offset <- src.offset + n; off)
145
+
else
146
+
(refill src; getbytes src n)
147
+
148
+
let read_char src =
149
+
let off = getbytes src 1 in
150
+
Bytes.get src.buf off
151
+
152
+
let read_byte src =
153
+
Char.code (read_char src)
154
+
155
+
let read_bool src =
156
+
let n = read_byte src in
157
+
n land 1 = 1
158
+
159
+
let bool = with_printer pp_bool (primitive read_bool false)
160
+
161
+
let uint8 = with_printer pp_int (primitive read_byte 0)
162
+
let int8 = with_printer pp_int (map [uint8] (fun n -> n - 128))
163
+
164
+
let read_uint16 src =
165
+
let off = getbytes src 2 in
166
+
Bytes.get_uint16_le src.buf off
167
+
168
+
let read_int16 src =
169
+
let off = getbytes src 2 in
170
+
Bytes.get_int16_le src.buf off
171
+
172
+
let uint16 = with_printer pp_int (primitive read_uint16 0)
173
+
let int16 = with_printer pp_int (primitive read_int16 0)
174
+
175
+
let read_int32 src =
176
+
let off = getbytes src 4 in
177
+
Bytes.get_int32_le src.buf off
178
+
179
+
let read_int64 src =
180
+
let off = getbytes src 8 in
181
+
Bytes.get_int64_le src.buf off
182
+
183
+
let int32 = with_printer pp_int32 (primitive read_int32 0l)
184
+
let int64 = with_printer pp_int64 (primitive read_int64 0L)
185
+
186
+
let int =
187
+
with_printer pp_int
188
+
(if Sys.word_size <= 32 then
189
+
map [int32] Int32.to_int
190
+
else
191
+
map [int64] Int64.to_int)
192
+
193
+
let float = with_printer pp_float (primitive (fun src ->
194
+
let off = getbytes src 8 in
195
+
let i64 = Bytes.get_int64_le src.buf off in
196
+
Int64.float_of_bits i64) 0.)
197
+
198
+
let char = with_printer pp_char (primitive read_char 'a')
199
+
200
+
(* maybe print as a hexdump? *)
201
+
let bytes = with_printer pp_string (primitive (fun src ->
202
+
(* null-terminated, with '\001' as an escape code *)
203
+
let buf = Bytes.make 64 '\255' in
204
+
let rec read_bytes p =
205
+
if p >= Bytes.length buf then p else
206
+
match read_char src with
207
+
| '\000' -> p
208
+
| '\001' ->
209
+
Bytes.set buf p (read_char src);
210
+
read_bytes (p + 1)
211
+
| c ->
212
+
Bytes.set buf p c;
213
+
read_bytes (p + 1) in
214
+
let count = read_bytes 0 in
215
+
Bytes.sub_string buf 0 count) "")
216
+
217
+
let bytes_fixed n = with_printer pp_string (primitive (fun src ->
218
+
let off = getbytes src n in
219
+
Bytes.sub_string src.buf off n) (String.make n 'a'))
220
+
221
+
let choose_int n state =
222
+
assert (n > 0);
223
+
if n = 1 then
224
+
0
225
+
else if (n <= 0x100) then
226
+
read_byte state mod n
227
+
else if (n < 0x1000000) then
228
+
Int32.(to_int (abs (rem (read_int32 state) (of_int n))))
229
+
else
230
+
Int64.(to_int (abs (rem (read_int64 state) (of_int n))))
231
+
232
+
let range ?(min=0) n =
233
+
if n <= 0 then
234
+
raise (Invalid_argument "Crowbar.range: argument n must be positive");
235
+
if min < 0 then
236
+
raise (Invalid_argument "Crowbar.range: argument min must be positive or null");
237
+
with_printer pp_int (primitive (fun s -> min + choose_int n s) min)
238
+
239
+
let uchar : Uchar.t gen =
240
+
map [range 0x110000] (fun x ->
241
+
guard (Uchar.is_valid x); Uchar.of_int x)
242
+
let uchar = with_printer pp_uchar uchar
243
+
244
+
let rec sequence = function
245
+
g::gs -> map [g; sequence gs] (fun x xs -> x::xs)
246
+
| [] -> const []
247
+
248
+
let shuffle_arr arr =
249
+
let n = Array.length arr in
250
+
let gs = List.init n (fun i -> range ~min:i (n - i)) in
251
+
map [sequence gs] @@ fun js ->
252
+
js |> List.iteri (fun i j ->
253
+
let t = arr.(i) in arr.(i) <- arr.(j); arr.(j) <- t);
254
+
arr
255
+
256
+
let shuffle l = map [shuffle_arr (Array.of_list l)] Array.to_list
257
+
258
+
exception GenFailed of exn * Printexc.raw_backtrace * unit printer
259
+
260
+
let rec generate : type a . int -> state -> a gen -> a * unit printer =
261
+
fun size input gen ->
262
+
if size <= 1 && gen.small_examples <> [] then List.hd gen.small_examples, fun ppf () -> pp ppf "?" else
263
+
match gen.strategy with
264
+
| Choose gens ->
265
+
(* FIXME: better distribution? *)
266
+
(* FIXME: choices of size > 255? *)
267
+
let n = choose_int (List.length gens) input in
268
+
let v, pv = generate size input (List.nth gens n) in
269
+
v, fun ppf () -> pp ppf "#%d %a" n pv ()
270
+
| Map ([], k) ->
271
+
k, fun ppf () -> pp ppf "?"
272
+
| Map (gens, f) ->
273
+
let rec len : type k res . int -> (k, res) gens -> int =
274
+
fun acc xs -> match xs with
275
+
| [] -> acc
276
+
| _ :: xs -> len (1 + acc) xs in
277
+
let n = len 0 gens in
278
+
(* the size parameter is (apparently?) meant to ensure that generation
279
+
eventually terminates, by limiting the set of options from which the
280
+
generator might choose once we've gotten deep into a tree. make sure we
281
+
always mark our passing, even when we've mapped one value into another,
282
+
so we don't blow the stack. *)
283
+
let size = (size - 1) / n in
284
+
let v, pvs = gen_apply size input gens f in
285
+
begin match v with
286
+
| Ok v -> v, pvs
287
+
| Error (e, bt) -> raise (GenFailed (e, bt, pvs))
288
+
end
289
+
| Bind (m, f) ->
290
+
let index, pv_index = generate (size - 1) input m in
291
+
let a, pv = generate (size - 1) input (f index) in
292
+
a, (fun ppf () -> pp ppf "(%a) => %a" pv_index () pv ())
293
+
| Option gen ->
294
+
if size < 1 then
295
+
None, fun ppf () -> pp ppf "None"
296
+
else if read_bool input then
297
+
let v, pv = generate size input gen in
298
+
Some v, fun ppf () -> pp ppf "Some (%a)" pv ()
299
+
else
300
+
None, fun ppf () -> pp ppf "None"
301
+
| List gen ->
302
+
let elems = generate_list size input gen in
303
+
List.map fst elems,
304
+
fun ppf () -> pp_list (fun ppf (_, pv) -> pv ppf ()) ppf elems
305
+
| List1 gen ->
306
+
let elems = generate_list1 size input gen in
307
+
List.map fst elems,
308
+
fun ppf () -> pp_list (fun ppf (_, pv) -> pv ppf ()) ppf elems
309
+
| Array gen ->
310
+
let elems = generate_list size input gen in
311
+
let elems = Array.of_list elems in
312
+
Array.map fst elems, fun ppf () -> pp_array (fun ppf (_, pv) -> pv ppf ()) ppf elems
313
+
| Array1 gen ->
314
+
let elems = generate_list1 size input gen in
315
+
let elems = Array.of_list elems in
316
+
Array.map fst elems, fun ppf () -> pp_array (fun ppf (_, pv) -> pv ppf ()) ppf elems
317
+
| Primitive gen ->
318
+
gen input, fun ppf () -> pp ppf "?"
319
+
| Unlazy gen ->
320
+
generate size input (Lazy.force gen)
321
+
| Print (ppv, gen) ->
322
+
let v, _ = generate size input gen in
323
+
v, fun ppf () -> ppv ppf v
324
+
325
+
and generate_list : type a . int -> state -> a gen -> (a * unit printer) list =
326
+
fun size input gen ->
327
+
if size <= 1 then []
328
+
else if read_bool input then
329
+
generate_list1 size input gen
330
+
else
331
+
[]
332
+
333
+
and generate_list1 : type a . int -> state -> a gen -> (a * unit printer) list =
334
+
fun size input gen ->
335
+
let ans = generate (size/2) input gen in
336
+
ans :: generate_list (size/2) input gen
337
+
338
+
and gen_apply :
339
+
type k res . int -> state ->
340
+
(k, res) gens -> k ->
341
+
(res, exn * Printexc.raw_backtrace) result * unit printer =
342
+
fun size state gens f ->
343
+
let rec go :
344
+
type k res . int -> state ->
345
+
(k, res) gens -> k ->
346
+
(res, exn * Printexc.raw_backtrace) result * unit printer list =
347
+
fun size input gens -> match gens with
348
+
| [] -> fun x -> Ok x, []
349
+
| g :: gs -> fun f ->
350
+
let v, pv = generate size input g in
351
+
let res, pvs =
352
+
match f v with
353
+
| exception (BadTest _ as e) -> raise e
354
+
| exception e ->
355
+
Error (e, Printexc.get_raw_backtrace ()) , []
356
+
| fv -> go size input gs fv in
357
+
res, pv :: pvs in
358
+
let v, pvs = go size state gens f in
359
+
let pvs = fun ppf () ->
360
+
match pvs with
361
+
| [pv] ->
362
+
pv ppf ()
363
+
| pvs ->
364
+
pp_list (fun ppf pv -> pv ppf ()) ppf pvs in
365
+
v, pvs
366
+
367
+
368
+
let fail s = raise (FailedTest (fun ppf () -> pp ppf "%s" s))
369
+
370
+
let failf format =
371
+
Format.kasprintf fail format
372
+
373
+
let check = function
374
+
| true -> ()
375
+
| false -> raise (FailedTest (fun ppf () -> pp ppf "check false"))
376
+
377
+
let check_eq ?pp:pv ?cmp ?eq a b =
378
+
let pass = match eq, cmp with
379
+
| Some eq, _ -> eq a b
380
+
| None, Some cmp -> cmp a b = 0
381
+
| None, None ->
382
+
Stdlib.compare a b = 0 in
383
+
if pass then
384
+
()
385
+
else
386
+
raise (FailedTest (fun ppf () ->
387
+
match pv with
388
+
| None -> pp ppf "different"
389
+
| Some pv -> pp ppf "@[<hv>%a@ !=@ %a@]" pv a pv b))
390
+
391
+
let () = Printexc.record_backtrace true
392
+
393
+
type test = Test : string * ('f, unit) gens * 'f -> test
394
+
395
+
type test_status =
396
+
| TestPass of unit printer
397
+
| BadInput of string
398
+
| GenFail of exn * Printexc.raw_backtrace * unit printer
399
+
| TestExn of exn * Printexc.raw_backtrace * unit printer
400
+
| TestFail of unit printer * unit printer
401
+
402
+
let run_once (gens : (_, unit) gens) f state =
403
+
match gen_apply 100 state gens f with
404
+
| Ok (), pvs -> TestPass pvs
405
+
| Error (FailedTest p, _), pvs -> TestFail (p, pvs)
406
+
| Error (e, bt), pvs -> TestExn (e, bt, pvs)
407
+
| exception (BadTest s) -> BadInput s
408
+
| exception (GenFailed (e, bt, pvs)) -> GenFail (e, bt, pvs)
409
+
410
+
let classify_status = function
411
+
| TestPass _ -> `Pass
412
+
| BadInput _ -> `Bad
413
+
| GenFail _ -> `Fail (* slightly dubious... *)
414
+
| TestExn _ | TestFail _ -> `Fail
415
+
416
+
let print_status ppf status =
417
+
let print_ex ppf (e, bt) =
418
+
pp ppf "%s" (Printexc.to_string e);
419
+
bt
420
+
|> Printexc.raw_backtrace_to_string
421
+
|> Str.split (Str.regexp "\n")
422
+
|> List.iter (pp ppf "@,%s") in
423
+
match status with
424
+
| TestPass pvs ->
425
+
pp ppf "When given the input:@.@[<v 4>@,%a@,@]@.the test passed."
426
+
pvs ()
427
+
| BadInput s ->
428
+
pp ppf "The testcase was invalid:@.%s" s
429
+
| GenFail (e, bt, pvs) ->
430
+
pp ppf "When given the input:@.@[<4>%a@]@.the testcase generator threw an exception:@.@[<v 4>@,%a@,@]"
431
+
pvs ()
432
+
print_ex (e, bt)
433
+
| TestExn (e, bt, pvs) ->
434
+
pp ppf "When given the input:@.@[<v 4>@,%a@,@]@.the test threw an exception:@.@[<v 4>@,%a@,@]"
435
+
pvs ()
436
+
print_ex (e, bt)
437
+
| TestFail (err, pvs) ->
438
+
pp ppf "When given the input:@.@[<v 4>@,%a@,@]@.the test failed:@.@[<v 4>@,%a@,@]"
439
+
pvs ()
440
+
err ()
441
+
442
+
let prng_state_of_seed seed =
443
+
(* try to make this independent of word size *)
444
+
let seed = Int64.( [|
445
+
to_int (logand (of_int 0xffff) seed);
446
+
to_int (logand (of_int 0xffff) (shift_right seed 16));
447
+
to_int (logand (of_int 0xffff) (shift_right seed 32));
448
+
to_int (logand (of_int 0xffff) (shift_right seed 48)) |]) in
449
+
Random.State.make seed
450
+
let src_of_seed seed =
451
+
Random (prng_state_of_seed seed)
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
505
+
506
+
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)
513
+
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 *)
559
+
560
+
let last_generated_name = ref 0
561
+
let generate_name () =
562
+
incr last_generated_name;
563
+
"test" ^ string_of_int !last_generated_name
564
+
565
+
let registered_tests = ref []
566
+
567
+
let add_test ?name gens f =
568
+
let name = match name with
569
+
| None -> generate_name ()
570
+
| Some name -> name in
571
+
registered_tests := Test (name, gens, f) :: !registered_tests
572
+
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
+
let () =
609
+
at_exit (fun () ->
610
+
let t = !registered_tests in
611
+
registered_tests := [];
612
+
match t with
613
+
| [] -> ()
614
+
| 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)
618
+
)
619
+
620
+
module Syntax = struct
621
+
let ( let* ) = dynamic_bind
622
+
let ( let+ ) gen map_fn = map [ gen ] map_fn
623
+
let ( and+ ) = pair
624
+
end
+276
src/crowbar.mli
+276
src/crowbar.mli
···
1
+
(** {1:top Types } *)
2
+
3
+
type 'a gen
4
+
(** ['a gen] knows how to generate ['a] for use in Crowbar tests. *)
5
+
6
+
type ('k, 'res) gens =
7
+
| [] : ('res, 'res) gens
8
+
| (::) : 'a gen * ('k, 'res) gens -> ('a -> 'k, 'res) gens
9
+
(** multiple generators are passed to functions using a listlike syntax.
10
+
for example, [map [int; int] (fun a b -> a + b)] *)
11
+
12
+
type 'a printer = Format.formatter -> 'a -> unit
13
+
(** pretty-printers for items generated by Crowbar; useful for the user in
14
+
translating test failures into bugfixes. *)
15
+
16
+
(**/**)
17
+
(* re-export stdlib's list
18
+
We only want to override [] syntax in the argument to Map *)
19
+
type nonrec +'a list = 'a list = [] | (::) of 'a * 'a list
20
+
(**/**)
21
+
22
+
(** {1:generators Generators } *)
23
+
24
+
(** {2:simple_generators Simple Generators } *)
25
+
26
+
val int : int gen
27
+
(** [int] generates an integer ranging from min_int to max_int, inclusive.
28
+
If you need integers from a smaller domain, consider using {!range}. *)
29
+
30
+
val uint8 : int gen
31
+
(** [uint8] generates an unsigned byte, ranging from 0 to 255 inclusive. *)
32
+
33
+
val int8 : int gen
34
+
(** [int8] generates a signed byte, ranging from -128 to 127 inclusive. *)
35
+
36
+
val uint16 : int gen
37
+
(** [uint16] generates an unsigned 16-bit integer,
38
+
ranging from 0 to 65535 inclusive. *)
39
+
40
+
val int16 : int gen
41
+
(** [int16] generates a signed 16-bit integer,
42
+
ranging from -32768 to 32767 inclusive. *)
43
+
44
+
val int32 : Int32.t gen
45
+
(** [int32] generates a 32-bit signed integer. *)
46
+
47
+
val int64 : Int64.t gen
48
+
(** [int64] generates a 64-bit signed integer. *)
49
+
50
+
val float : float gen
51
+
(** [float] generates a double-precision floating-point number. *)
52
+
53
+
val char : char gen
54
+
(** [char] generates a char. *)
55
+
56
+
val uchar : Uchar.t gen
57
+
(** [uchar] generates a Unicode scalar value *)
58
+
59
+
val bytes : string gen
60
+
(** [bytes] generates a string of arbitrary length (including zero-length strings). *)
61
+
62
+
val bytes_fixed : int -> string gen
63
+
(** [bytes_fixed length] generates a string of the specified length. *)
64
+
65
+
val bool : bool gen
66
+
(** [bool] generates a yes or no answer. *)
67
+
68
+
val range : ?min:int -> int -> int gen
69
+
(** [range ?min n] is a generator for integers between [min] (inclusive)
70
+
and [min + n] (exclusive). Default [min] value is 0.
71
+
[range ?min n] will raise [Invalid_argument] for [n <= 0].
72
+
*)
73
+
74
+
(** {2:generator_functions Functions on Generators } *)
75
+
76
+
val map : ('f, 'a) gens -> 'f -> 'a gen
77
+
(** [map gens map_fn] provides a means for creating generators using other
78
+
generators' output. For example, one might generate a Char.t from a
79
+
{!uint8}:
80
+
{[
81
+
open Crowbar
82
+
let char_gen : Char.t gen = map [uint8] Char.chr
83
+
]}
84
+
*)
85
+
86
+
val unlazy : 'a gen Lazy.t -> 'a gen
87
+
(** [unlazy gen] forces the generator [gen]. It is useful when defining
88
+
generators for recursive data types:
89
+
90
+
{[
91
+
open Crowbar
92
+
type a = A of int | Self of a
93
+
let rec a_gen = lazy (
94
+
choose [
95
+
map [int] (fun i -> A i);
96
+
map [(unlazy a_gen)] (fun s -> Self s);
97
+
])
98
+
let lazy a_gen = a_gen
99
+
]}
100
+
*)
101
+
102
+
val fix : ('a gen -> 'a gen) -> 'a gen
103
+
(** [fix fn] applies the function [fn]. It is useful when defining generators
104
+
for recursive data types:
105
+
106
+
{[
107
+
open Crowbar
108
+
type a = A of int | Self of a
109
+
let rec a_gen = fix (fun a_gen ->
110
+
choose [
111
+
map [int] (fun i -> A i);
112
+
map [a_gen] (fun s -> Self s);
113
+
])
114
+
]}
115
+
*)
116
+
117
+
val const : 'a -> 'a gen
118
+
(** [const a] always generates [a]. *)
119
+
120
+
val choose : 'a gen list -> 'a gen
121
+
(** [choose gens] chooses a generator arbitrarily from [gens]. *)
122
+
123
+
val option : 'a gen -> 'a option gen
124
+
(** [option gen] generates either [None] or [Some x], where [x] is the item
125
+
generated by [gen]. *)
126
+
127
+
val pair : 'a gen -> 'b gen -> ('a * 'b) gen
128
+
(** [pair gena gen] generates (a, b)
129
+
where [a] is generated by [gena] and [b] by [genb]. *)
130
+
131
+
val result : 'a gen -> 'b gen -> ('a, 'b) result gen
132
+
(** [result gena genb] generates either [Ok va] or [Error vb],
133
+
where [va], [vb] are generated by [gena], [genb] respectively. *)
134
+
135
+
val list : 'a gen -> 'a list gen
136
+
(** [list gen] makes a generator for lists using [gen]. Lists may be empty; for
137
+
non-empty lists, use {!list1}. *)
138
+
139
+
val list1 : 'a gen -> 'a list gen
140
+
(** [list1 gen] makes non-empty list generators. For potentially empty lists,
141
+
use {!list}.*)
142
+
143
+
val array : 'a gen -> 'a array gen
144
+
(** [array gen] makes a generator for arrays using [gen]. Arrays may be empty; for
145
+
non-empty arrays, use {!array1}. *)
146
+
147
+
val array1 : 'a gen -> 'a array gen
148
+
(** [array1 gen] makes non-empty array generators. For potentially empty arrays,
149
+
use {!array}.*)
150
+
151
+
val shuffle : 'a list -> 'a list gen
152
+
(** [shuffle l] generates random permutations of [l]. *)
153
+
154
+
val concat_gen_list : string gen -> string gen list -> string gen
155
+
(** [concat_gen_list sep l] concatenates a list of string gen [l] inserting the
156
+
separator [sep] between each *)
157
+
158
+
val with_printer : 'a printer -> 'a gen -> 'a gen
159
+
(** [with_printer printer gen] generates the same values as [gen]. If [gen]
160
+
is used to create a failing test case and the test was reached by
161
+
calling [check_eq] without [pp] set, [printer] will be used to print the
162
+
failing test case. *)
163
+
164
+
val dynamic_bind : 'a gen -> ('a -> 'b gen) -> 'b gen
165
+
(** [dynamic_bind gen f] is a monadic bind, it allows to express the
166
+
generation of a value whose generator itself depends on
167
+
a previously generated value. This is in contrast with [map gen f],
168
+
where no further generation happens in [f] after [gen] has
169
+
generated an element.
170
+
171
+
An typical example where this sort of dependencies is required is
172
+
a serialization library exporting combinators letting you build
173
+
values of the form ['a serializer]. You may want to test this
174
+
library by first generating a pair of a serializer and generator
175
+
['a serializer * 'a gen] for arbitrary ['a], and then generating
176
+
values of type ['a] depending on the (generated) generator to test
177
+
the serializer. There is such an example in the
178
+
[examples/serializer/] directory of the Crowbar implementation.
179
+
180
+
Because the structure of a generator built with [dynamic_bind] is
181
+
opaque/dynamic (it depends on generated values), the Crowbar
182
+
library cannot analyze its statically
183
+
(without generating anything) -- the generator is opaque to the
184
+
library, hidden in a function. In particular, many optimizations or
185
+
or fuzzing techniques based on generator analysis are
186
+
impossible. As a client of the library, you should avoid
187
+
[dynamic_bind] whenever it is not strictly required to express
188
+
a given generator, so that you can take advantage of these features
189
+
(present or future ones). Use the least powerful/complex
190
+
combinators that suffice for your needs.
191
+
*)
192
+
193
+
(** {1:printing Printing } *)
194
+
195
+
(* Format.fprintf, renamed *)
196
+
val pp : Format.formatter -> ('a, Format.formatter, unit) format -> 'a
197
+
val pp_int : int printer
198
+
val pp_int32 : Int32.t printer
199
+
val pp_int64 : Int64.t printer
200
+
val pp_float : float printer
201
+
val pp_bool : bool printer
202
+
val pp_string : string printer
203
+
val pp_list : 'a printer -> 'a list printer
204
+
val pp_option : 'a printer -> 'a option printer
205
+
206
+
(** {1:testing Testing} *)
207
+
208
+
val add_test :
209
+
?name:string -> ('f, unit) gens -> 'f -> unit
210
+
(** [add_test name generators test_fn] adds [test_fn] to the list of eligible
211
+
tests to be run when the program is invoked. At runtime, random data will
212
+
be sent to [generators] to create the input necessary to run [test_fn]. Any
213
+
failures will be printed annotated with [name]. *)
214
+
215
+
(** {2:aborting Aborting Tests} *)
216
+
217
+
val guard : bool -> unit
218
+
(** [guard b] aborts a test if [b] is false. The test will not be recorded
219
+
or reported as a failure. *)
220
+
221
+
val bad_test : unit -> 'a
222
+
(** [bad_test ()] aborts a test. The test will not be recorded or reported
223
+
as a failure. *)
224
+
225
+
val nonetheless : 'a option -> 'a
226
+
(** [nonetheless o] aborts a test if [o] is None. The test will not be recorded
227
+
or reported as a failure. *)
228
+
229
+
(** {2:failing Failing} *)
230
+
231
+
val fail : string -> 'a
232
+
(** [fail message] generates a test failure and prints [message]. *)
233
+
234
+
val failf : ('a, Format.formatter, unit, _) format4 -> 'a
235
+
(** [failf format ...] generates a test failure and prints the message
236
+
specified by the format string [format] and the following arguments.
237
+
It is set up so that [%a] calls for an ['a printer] and an ['a] value. *)
238
+
239
+
(** {2:asserting Asserting Properties} *)
240
+
241
+
val check : bool -> unit
242
+
(** [check b] generates a test failure if [b] is false. No useful information
243
+
will be printed in this case. *)
244
+
245
+
val check_eq : ?pp:('a printer) -> ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) ->
246
+
'a -> 'a -> unit
247
+
(** [check_eq pp cmp eq x y] evaluates whether x and y are equal, and if they
248
+
are not, raises a failure and prints an error message.
249
+
Equality is evaluated as follows:
250
+
251
+
{ol
252
+
{- use a provided [eq]}
253
+
{- if no [eq] is provided, use a provided [cmp]}
254
+
{- if neither [eq] nor [cmp] is provided, use Stdlib.compare}}
255
+
256
+
If [pp] is provided, use this to print [x] and [y] if they are not equal.
257
+
If [pp] is not provided, a best-effort printer will be generated from the
258
+
printers for primitive generators and any printers registered with
259
+
[with_printer] and used. *)
260
+
261
+
262
+
(** {1:syntax Syntax module } *)
263
+
module Syntax : sig
264
+
val ( let+ ) : 'a gen -> ('a -> 'b) -> 'b gen
265
+
(** [let+ x = gen in e] is equivalent to [map [ gen ] (fun x -> e)]. *)
266
+
267
+
val ( let* ) : 'a gen -> ('a -> 'b gen) -> 'b gen
268
+
(** Equivalent to {!dynamic_bind}.
269
+
[let* x = gen in e] is equivalent to [dynamic_bind gen (fun x -> e)]. *)
270
+
271
+
val ( and+ ) : 'a gen -> 'b gen -> ('a * 'b) gen
272
+
(** Equivalent to {!pair}.
273
+
[let+ x = gen_x and+ y = gen_y and+ z = gen_z in e]
274
+
is equivalent to
275
+
[ map [pair (pair gen_x gen_y) gen_z)] (fun ((x, y), z) -> e) ]. *)
276
+
end
+16
src/todo
+16
src/todo
···
1
+
join/bind (v2?)
2
+
3
+
command line interface:
4
+
- afl-fuzz mode
5
+
- quickcheck mode
6
+
- random fuzzing mode (for me testing, really)
7
+
- file / file list mode
8
+
- reproduction mode (seed / file)
9
+
- select which tests to run
10
+
11
+
output:
12
+
- seeds for failed tests
13
+
- maybe use notty to figure out pretty-printing width
14
+
15
+
api:
16
+
- manual testsuite interface?