├── .gitignore ├── CHANGES.md ├── LICENSE.md ├── README.md ├── bun.opam ├── dune-project ├── src ├── bun.ml ├── bun.mli ├── dune └── files.ml └── test ├── dune ├── long.ml └── short.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.3.4 2021-07-07 2 | ----------------- 3 | 4 | - update to dune 2 (#18, by @talex5 and @edwintorok) 5 | - use `-M` for first worker (#17, by @edwintorok and @talex5) 6 | - move bun to https://github.com/ocurrent/bun (#20, by @talex5) 7 | 8 | v0.3.3 2019-05-24 9 | ----------------- 10 | 11 | - use Lwt to manage processes (#7, by @talex5) 12 | - print crashes when killing a fuzzer in no-kill mode (#8, by @NathanReb) 13 | - do some CI maintenance (#10, by @yomimono) 14 | 15 | v0.3.2 2018-05-01 16 | ----------------- 17 | 18 | - use spawn v0.12 API (#5, @diml) 19 | 20 | v0.3.1 2018-05-01 21 | ----------------- 22 | 23 | - use alarms/pause instead of sleeping to prevent hanging around after fuzzers have terminated (fixes #3 reported by github user gasche - thanks!) 24 | - add a --max-cores option, to be considerate when appropriate (#2, by gasche) 25 | - add some tests and CI for this test and CI thing 26 | 27 | v0.3 2018-04-04 28 | --------------- 29 | 30 | - set up input directory if the user hasn't already 31 | - avoid ugly invocation of whatsup before fuzzers have reported their status 32 | 33 | v0.2 2018-03-29 34 | --------------- 35 | 36 | - better pathfinding for the fuzzer 37 | - add a no-kill mode (-n) to continue fuzzing after the first bug is found 38 | - dump the crash data when bun receives SIGUSR1 39 | - try harder to avoid CPU detection collisions 40 | - tighten up dependency specifications for opam 41 | 42 | v0.1 2017-10-24 43 | --------------- 44 | 45 | - Initial pre-release. 46 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Identity Function, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # What is this? 2 | 3 | `bun` is a tool for integrating fuzzer-based tests into a conventional CI pipeline. The popular afl-fuzz tool in particular is designed to use only one CPU core per invocation and keep records on persistent storage for later examination by an analyst; this particular workflow is ill-suited for cloud-based CI testing services, which do not persist storage for users and unceremoniously kill long-running processes. It also makes using available compute resources (two CPU cores even for free-tier Travis CI) challenging. `bun` attempts to solve these problems. 4 | 5 | ![Demo video](https://user-images.githubusercontent.com/554131/124629462-60b7cf00-de79-11eb-9779-a3909bc90a05.gif) 6 | 7 | ## How does it work? 8 | 9 | `bun` uses `afl-gotcpu` to detect the number of free CPU cores and then launches that number of `afl-fuzz` processes, configured in the correct manner to cooperate exploring the program's state space. `bun` monitors the progress of running `afl-fuzz` instances with `afl-whatsup`. `afl-fuzz` instances launched by `bun` run in a mode where they will stop when they find a crash or `afl-fuzz` determines that there is a low likelihood of finding one with additional work. 10 | 11 | When crashes are detected on any `afl-fuzz` process, `bun` will stop the others and report the crash information. If no crashes are detected, `bun` will continue running until the last `afl-fuzz` gives up. (You may wish to limit the wall-clock time consumed with `timeout` when initially launching `bun`.) 12 | 13 | ## How do I use the output? 14 | 15 | When crashes are detected, `bun` will base64-encode them and output them on the console. You can then copy the text chunks and base64-decode them into reproduction cases to run locally. 16 | 17 | ## How do I run it? 18 | 19 | See `bun --help` for the most current information. 20 | 21 | Here's an example of fuzzing one of Crowbar's packaged examples, `calendar`: 22 | 23 | ``` 24 | $ bun -i input/ -o output/ ./calendar 25 | The last (or only) fuzzer (28129) has finished! 26 | Crashes found! Take a look; copy/paste to save for reproduction: 27 | echo UN5QAd5Q3t7u7u7u7u7u7u7u7u7u7u7u7u7u7u7u7u7u7u7u | base64 -d > crash_0.$(date -u +%s) 28 | $ echo UN5QAd5Q3t7u7u7u7u7u7u7u7u7u7u7u7u7u7u7u7u7u7u7u | base64 -d > crash_0.$(date -u +%s) 29 | $ ./calendar crash_0.1508880277 30 | calendar: .... 31 | calendar: FAIL 32 | 33 | When given the input: 34 | 35 | [1825-01-30 22:50:45; 1825-03-17 04:05:41] 36 | 37 | the test failed: 38 | 39 | 1825-03-20 04:05:41 != 1825-03-17 04:05:41 40 | 41 | Fatal error: exception Crowbar.TestFailure 42 | ``` 43 | 44 | # Building 45 | 46 | The usual `dune` command should be sufficient: 47 | 48 | ``` 49 | dune build 50 | ``` 51 | 52 | # For CI 53 | 54 | For an example of using `bun` in a CI environment, see [ocaml-test-stdlib](https://github.com/yomimono/ocaml-test-stdlib), which uses `bun` to manage its Crowbar tests in Travis CI. 55 | -------------------------------------------------------------------------------- /bun.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Simple management of afl-fuzz processes" 3 | maintainer: ["Ben Andrew " "Tim McGilchrist "] 4 | authors: [ 5 | "Mindy Preston" 6 | "Thomas Leonard" 7 | ] 8 | license: "MIT" 9 | homepage: "https://github.com/ocurrent/bun" 10 | bug-reports: "https://github.com/ocurrent/bun/issues" 11 | depends: [ 12 | "ocaml" {>= "4.05"} 13 | "dune" {>= "2.0"} 14 | "bos" {>= "0.2.0"} 15 | "cmdliner" {>= "1.1.0"} 16 | "fpath" 17 | "rresult" {>= "0.3.0"} 18 | "astring" 19 | "crowbar" {with-test} 20 | "afl" {= "2.52b"} 21 | "logs" 22 | "fmt" {>= "0.8.7"} 23 | "lwt" 24 | ] 25 | build: [ 26 | ["dune" "build" "-p" name "-j" jobs] 27 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 28 | ] 29 | conflicts: [ 30 | "base-domains" 31 | ] 32 | dev-repo: "git+https://github.com/ocurrent/bun.git" 33 | description: """ 34 | A wrapper for OCaml processes using afl-fuzz, intended for easy use in CI environments. 35 | See the README.md for more information. 36 | """ 37 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | 3 | (name bun) 4 | 5 | (formatting disabled) 6 | -------------------------------------------------------------------------------- /src/bun.ml: -------------------------------------------------------------------------------- 1 | let program = 2 | let doc = "Fuzz this program. (Ideally it's a Crowbar test; if it isn't, \ 3 | ensure that it takes, as its last argument, a file for afl-fuzz to pass it.)" 4 | in 5 | Cmdliner.Arg.(required & pos 0 (some non_dir_file) None & 6 | info [] ~docv:"PROGRAM" ~doc) 7 | 8 | let program_argv = 9 | let doc = "Arguments to the program to be fuzzed. These will be prepended \ 10 | to the invocation, and the file to be considered as input last; \ 11 | in other words, `bun myprogram --for-fun on-fire` will run \ 12 | `afl-fuzz {afl arguments} -- myprogram --for-fun on-fire @@`." in 13 | Cmdliner.Arg.(value & pos_right 0 string [] & info [] ~docv:"PROGRAM_ARGS" 14 | ~doc) 15 | 16 | let single_core = 17 | let doc = "Start only one fuzzer instance, even if more CPU cores are \ 18 | available. Even in this mode, the (lone) fuzzer will be invoked \ 19 | with -S and an id; for more on implications, see the afl-fuzz \ 20 | parallel_fuzzing.txt documentation." in 21 | Cmdliner.Arg.(value & flag & info ["s"; "single-core"] ~docv:"SINGLE_CORE" ~doc) 22 | 23 | let max_cores = 24 | let env = Cmdliner.Cmd.Env.info "MAX_CORES" in 25 | let doc = "Maximum number of instances to run -- of CPU cores to use. \ 26 | If no value is given, all the cores found by GOTCPU \ 27 | will be used." in 28 | Cmdliner.Arg.(value & opt (some int) None 29 | & info ["max-cores"] ~docv:"MAX_CORES" ~doc ~env) 30 | 31 | let no_kill = 32 | let doc = "Allow afl-fuzz to continue attempting to find crashes after the 33 | first crash is discovered. In this mode, individual afl-fuzz instances will 34 | not automatically terminate after discovering crashes, nor will bun kill all 35 | other instances once a single instance terminates for any reason." in 36 | Cmdliner.Arg.(value & flag & info ["n"; "no-kill"] ~docv:"NO_KILL" ~doc) 37 | 38 | let fpath_conv = Cmdliner.Arg.conv Fpath.(of_string, pp) 39 | 40 | let input_dir = 41 | let doc = "Cache of inputs to use in fuzzing the program. Will be passed \ 42 | through to the fuzzer as the input parameter." in 43 | Cmdliner.Arg.(value & opt fpath_conv (Fpath.v "input") 44 | & info ["i"; "input"] ~docv:"INPUT" ~doc) 45 | 46 | let output_dir = 47 | let doc = "Where to instruct the fuzzer to put its output." in 48 | Cmdliner.Arg.(value & opt fpath_conv (Fpath.v "output") 49 | & info ["o"; "output"] ~docv:"OUTPUT" ~doc) 50 | 51 | let memory = 52 | let env = Cmdliner.Cmd.Env.info "MEMORY" in 53 | let doc = "Memory limit to pass to the fuzzer." in 54 | Cmdliner.Arg.(value & opt int 200 55 | & info ["mem"; "m"] ~docv:"MEMORY" ~doc ~env) 56 | 57 | let fuzzer = 58 | let env = Cmdliner.Cmd.Env.info "FUZZER" in 59 | let doc = "The fuzzer to invoke." in 60 | Cmdliner.Arg.(value & opt file "afl-fuzz" 61 | & info ["fuzzer"] ~docv:"FUZZER" ~doc ~env) 62 | 63 | let gotcpu = 64 | let env = Cmdliner.Cmd.Env.info "GOTCPU" in 65 | let doc = "The command to run to see whether more cores are available. For \ 66 | all practical purposes, it should be afl-gotcpu." in 67 | Cmdliner.Arg.(value & opt file "afl-gotcpu" 68 | & info ["gotcpu"] ~docv:"GOTCPU" ~doc ~env) 69 | 70 | let whatsup = 71 | let env = Cmdliner.Cmd.Env.info "WHATSUP" in 72 | let doc = "The command to run to display information on the fuzzer stats \ 73 | during operation. This is usually afl-whatsup, but `ocaml-bun` is not \ 74 | sensitive to its output, so you can use whatever you like." in 75 | Cmdliner.Arg.(value & opt file "afl-whatsup" & info ["whatsup"] 76 | ~docv:"WHATSUP" ~doc ~env) 77 | 78 | (* Print progress reports from time to time. *) 79 | let mon whatsup output = 80 | let open Lwt.Infix in 81 | (* Give things a chance to start... *) 82 | Lwt_unix.sleep 5.0 >>= fun () -> 83 | let rec loop () = 84 | Logs.info (fun f -> f "Checking progress..."); 85 | match Bos.OS.Path.matches @@ Fpath.(output / "$(dir)" / "fuzzer_stats") with 86 | | Error (`Msg e) -> 87 | (* this is probably just a race -- keep trying *) 88 | (* (but TODO retry-bound this and print an appropriate message if it doesn't 89 | look like we were just too fast *) 90 | Logs.info (fun f -> f "No fuzzer_stats in the output directory:%s" e); 91 | Lwt_unix.sleep 5.0 >>= loop 92 | | Ok [] -> 93 | Logs.debug (fun f -> f "No fuzzer stats files found - waiting on the world to change"); 94 | Lwt_unix.sleep 5.0 >>= loop 95 | | Ok _ -> 96 | (* the caller will know if all children have died. *) 97 | (* no compelling reason to reimplement afl-whatsup at the moment. 98 | if that changes, check commit history for the `mon` binary and its 99 | associated code, which parses `fuzzer_stats` itself and doubles as a nice 100 | thing for `bun` to test itself on. *) 101 | let () = 102 | match Bos.OS.Cmd.run Bos.Cmd.(v whatsup % Fpath.to_string output) with 103 | | Error (`Msg e) -> Logs.warn (fun f -> f "error running whatsup: %s" e) 104 | | Ok () -> () 105 | in 106 | Lwt_unix.sleep 60.0 >>= loop 107 | in 108 | loop () 109 | 110 | let term_handler ~switch ~no_kill ~output _sigterm = 111 | Logs.app (fun f -> f 112 | "Terminating the remaining fuzzing processes in response to SIGTERM.@.\ 113 | It's likely that this job could benefit from more fuzzing time @\n\ 114 | - consider running it in an environment with more available cores or allowing @\n\ 115 | the fuzzers more time to explore the state space, if possible."); 116 | if no_kill then (Files.Print.print_crashes output |> Rresult.R.get_ok); 117 | Lwt.async (fun () -> Lwt_switch.turn_off switch) 118 | 119 | let pp_fuzzer f (id, proc) = 120 | Fmt.pf f "%d (pid=%d)" id proc#pid 121 | 122 | let crash_detector output fuzzer status = 123 | match status with 124 | | Unix.WEXITED 0 -> begin 125 | Logs.app (fun f -> f "Fuzzer %a finished" pp_fuzzer fuzzer); 126 | Files.Print.print_crashes output |> Rresult.R.get_ok; 127 | match Files.Parse.get_crash_files output with 128 | | Ok [] -> Ok () 129 | | _ -> Error `Crash_found 130 | end 131 | | WEXITED d -> 132 | Logs.warn (fun f -> f "Fuzzer %a has failed with code %d" pp_fuzzer fuzzer d); 133 | Files.Print.print_crashes output |> Rresult.R.get_ok; 134 | Error `Crash_found 135 | | WSIGNALED s -> 136 | Logs.warn (fun f -> f "Fuzzer %a was killed by signal %d" pp_fuzzer fuzzer s); 137 | Files.Print.print_crashes output |> Rresult.R.get_ok; 138 | Error `Crash_found 139 | | WSTOPPED _ -> assert false 140 | 141 | let spawn ~switch env id fuzzer memory input output program program_argv = 142 | let fuzzer = Fpath.to_string fuzzer in 143 | let argv = [fuzzer; 144 | "-m"; (string_of_int memory); 145 | "-i"; (Fpath.to_string input); 146 | "-o"; (Fpath.to_string output); 147 | (if id = 1 then "-M" else "-S"); string_of_int id; 148 | "--"; program; ] @ program_argv @ ["@@"] in 149 | Logs.info (fun f -> f "Executing %s" @@ String.concat " " argv); 150 | let stdout = 151 | match Logs.level () with 152 | | Some Logs.Debug -> `Keep 153 | | _ -> `Dev_null 154 | in 155 | (* see afl-latest's docs/env_variables.txt for information on these -- 156 | the variables we pass ask AFL to finish after it's "done" (the cycle 157 | counter would turn green in the UI) or it's found a crash, plus the obvious 158 | (if sad) request not to show us its excellent UI *) 159 | let env = Array.of_list ("AFL_EXIT_WHEN_DONE=1"::"AFL_NO_UI=1"::env) in 160 | let command = (fuzzer, Array.of_list argv) in 161 | let proc = Lwt_process.open_process_none ~env ~stdout command in 162 | Logs.info (fun f -> f "%s launched: PID %d" fuzzer proc#pid); 163 | Lwt_switch.add_hook (Some switch) (fun () -> 164 | if proc#state = Lwt_process.Running then ( 165 | Logs.info (fun f -> f "Terminating fuzzer %a" pp_fuzzer (id, proc)); 166 | proc#terminate 167 | ); 168 | Lwt.return ()); 169 | proc 170 | 171 | let sigusr1_handler ~output _ = 172 | Logs.app (fun f -> f "USR1 signal received; showing progress..."); 173 | match Files.Print.print_crashes output with 174 | | Ok () -> () 175 | | Error (`Msg m) -> Logs.err (fun f -> f "print_crashes: %s" m) 176 | 177 | let fuzz () no_kill single_core max_cores 178 | fuzzer whatsup gotcpu 179 | input output memory program program_argv 180 | : (unit, string) result = 181 | let open Rresult in 182 | let env = Unix.environment () |> Array.to_list |> fun env -> 183 | match no_kill with | false -> "AFL_BENCH_UNTIL_CRASH=1"::env 184 | | true -> env 185 | in 186 | let cores = 187 | let limit = if single_core then Some 1 else max_cores in 188 | let available = Files.Parse.get_cores gotcpu in 189 | match limit with 190 | | None -> available 191 | | Some limit -> 192 | (* always launch at least 1 *) 193 | max 1 (min available limit) 194 | in 195 | Files.fixup_input input |> R.reword_error (fun (`Msg err) -> err) >>= fun () -> 196 | Logs.info (fun f -> f "%d available cores detected!" cores); 197 | let fill_cores ~switch fuzzer start_id = 198 | let rec launch_more max i = 199 | if i > max then [] else begin 200 | let fuzzer = (i, spawn ~switch env i fuzzer memory input output program program_argv) in 201 | fuzzer :: launch_more cores (i+1) 202 | end 203 | in 204 | launch_more cores start_id 205 | in 206 | Bos.OS.Cmd.find_tool Bos.Cmd.(v fuzzer) |> R.reword_error (fun (`Msg err) -> err) >>= function 207 | | None -> Error (Fmt.str "could not find %s to invoke it -- \ 208 | try specifying the full path, or ensuring the binary \ 209 | is in your PATH" fuzzer) 210 | | Some fuzzer -> 211 | Bos.OS.Dir.create output |> R.reword_error (fun (`Msg err) -> err) >>= fun _ -> 212 | (* always start at least one afl-fuzz *) 213 | Lwt_main.run @@ begin 214 | let open Lwt.Infix in 215 | Lwt_switch.with_switch @@ fun switch -> 216 | let _ : Lwt_unix.signal_handler_id = Lwt_unix.(on_signal Sys.sigterm (term_handler ~switch ~no_kill ~output)) in 217 | let _ : Lwt_unix.signal_handler_id = Lwt_unix.(on_signal Sys.sigusr1 (sigusr1_handler ~output)) in 218 | let id = 1 in 219 | let fuzzers = 220 | match single_core with 221 | | true -> 222 | let proc = spawn ~switch env id fuzzer memory input output program program_argv in 223 | let fuzzer = (id, proc) in 224 | Logs.app (fun f -> f "Fuzzer %a launched." pp_fuzzer fuzzer); 225 | [fuzzer] 226 | | false -> 227 | (* check once to see how many afl-fuzzes we can spawn, and then 228 | let afl-fuzz's own startup jitter plus a small delay from us 229 | ensure they don't step on each others' toes when discovering CPU 230 | affinity. *) 231 | let fuzzers = fill_cores ~switch fuzzer id in 232 | Logs.app (fun f -> f "Fuzzers launched: %a." (Fmt.Dump.list pp_fuzzer) fuzzers); 233 | fuzzers 234 | in 235 | let results = 236 | fuzzers 237 | |> Lwt_list.map_p (fun fuzzer -> 238 | let _id, proc = fuzzer in 239 | proc#status >>= fun status -> 240 | if Lwt_switch.is_on switch then ( 241 | match crash_detector output fuzzer status with 242 | | Error `Crash_found as e when not no_kill -> Lwt_switch.turn_off switch >|= fun () -> e 243 | | x -> Lwt.return x 244 | ) else ( 245 | Logs.info (fun f -> f "Fuzzer %a shut down, as requested" pp_fuzzer fuzzer); 246 | Lwt.return (Ok ()) 247 | ) 248 | ) 249 | >|= fun results -> 250 | try List.find ((<>) (Ok ())) results 251 | with Not_found -> Ok () 252 | in 253 | let progress = mon whatsup output in 254 | Lwt.choose [progress; results] >|= function 255 | | Ok () -> Ok () 256 | | Error `Crash_found -> Error ("All fuzzers finished, but some crashes were found!") 257 | end 258 | 259 | let pp_header ppf x = 260 | let { Unix.tm_hour; tm_min; tm_sec; _ } = Unix.gmtime (Unix.gettimeofday ()) in 261 | Fmt.pf ppf "%02d:%02d.%02d:" tm_hour tm_min tm_sec; 262 | Logs_fmt.pp_header ppf x 263 | 264 | let setup_log = 265 | let set style_renderer level = 266 | Fmt_tty.setup_std_outputs ?style_renderer (); 267 | Logs.set_level level; 268 | Logs.set_reporter (Logs_fmt.reporter ~pp_header ()) 269 | in 270 | Cmdliner.Term.(const set $ Fmt_cli.style_renderer () $ Logs_cli.level ()) 271 | 272 | let fuzz_t = 273 | Cmdliner.Term.(const fuzz 274 | $ setup_log $ no_kill $ single_core $ max_cores (* bun/mon args *) 275 | $ fuzzer $ whatsup $ gotcpu (* external cmds *) 276 | $ input_dir $ output_dir $ memory 277 | $ program $ program_argv) (* fuzzer flags *) 278 | 279 | let bun_info = 280 | let doc = "invoke afl-fuzz on a program in a CI-friendly way" in 281 | Cmdliner.Cmd.(info ~version:"%%VERSION%%" ~exits:Exit.defaults ~doc "bun") 282 | 283 | let () = exit @@ Cmdliner.Cmd.eval_result (Cmdliner.Cmd.v bun_info fuzz_t) 284 | -------------------------------------------------------------------------------- /src/bun.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocurrent/bun/edb099ddce28a538412a62564b419879c278c403/src/bun.mli -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name bun) 3 | (public_name bun) 4 | (libraries bos cmdliner fpath rresult astring lwt.unix logs logs.cli 5 | logs.fmt fmt.tty fmt.cli)) 6 | -------------------------------------------------------------------------------- /src/files.ml: -------------------------------------------------------------------------------- 1 | (* afl-fuzz needs for there to be at least one file in its input directory. 2 | if the input directory doesn't exist, or it's empty, fix that for the user 3 | by creating it and making an empty file. *) 4 | let fixup_input input = 5 | let open Rresult.R in 6 | Bos.OS.Dir.create input >>= fun _created -> (* Ok anything will do *) 7 | Bos.OS.Dir.contents input >>= function 8 | | _::_ -> Ok () (* any file will do! *) 9 | | [] -> Bos.OS.File.write Fpath.(input / "bun_autogenerated_seed") 10 | "'rabbit rabbit rabbit'is one variant of a superstition found in Britain and North America that states that a person should say or repeat the word 'rabbit' or 'rabbits', or 'white rabbits', or some combination of these elements, out loud upon waking on the first day of the month, because doing so will ensure good luck for the duration of that month. -- en.wikipedia.org/wiki/Rabbit_rabbit_rabbit" 11 | 12 | module Parse = struct 13 | let get_stats lines = 14 | (* did someone say shotgun parsers? *) 15 | List.map (Astring.String.fields ~empty:false ~is_sep:((=) ':')) lines |> 16 | List.map (List.map Astring.String.trim) |> 17 | List.fold_left (fun acc -> function | hd::tl::[]-> (hd, tl)::acc 18 | | _ -> acc) [] |> List.rev 19 | 20 | let lookup s l = 21 | try Some (List.find (fun (a,_) -> Astring.String.equal a s) l) with Not_found -> None 22 | 23 | let lookup_int s l = match lookup s l with 24 | | None -> None 25 | | Some (_, i) -> try Some (int_of_string i) with Invalid_argument _ -> None 26 | 27 | let lookup_crashes l = lookup_int "unique_crashes" l 28 | let lookup_pid l = lookup_int "fuzzer_pid" l 29 | 30 | let get_crash_files ?(id = "$(file)") output_dir = 31 | let crashes = Fpath.(output_dir / id / "crashes" / "id$(file)" ) in 32 | Bos.OS.Path.matches crashes 33 | 34 | let get_stats_lines ~id output = 35 | Bos.OS.File.read_lines Fpath.(output / id / "fuzzer_stats") 36 | 37 | let get_cores cpu = 38 | let aux gotcpus = 39 | let process_preamble = "more processes on " in 40 | let more_processes = Bos.Cmd.(v "grep" % process_preamble) in 41 | let (>>=) = Rresult.R.bind in 42 | Bos.OS.Cmd.(run_io more_processes gotcpus |> to_lines) >>= fun l -> 43 | match List.map (Astring.String.cut ~sep:process_preamble) l 44 | |> List.find (function | Some _ -> true | None -> false) with 45 | | None -> Ok 0 46 | | Some (_, cores) -> 47 | Logs.debug (fun f -> f "cores line: %s" cores); 48 | let words = Astring.String.fields cores in 49 | (* afl-gotcpu sometimes tells us that some CPUs *might* be overcommitted. 50 | it's usually too conservative; we want to try to use the CPUs that it's 51 | not sure about. *) 52 | match Astring.String.compare (List.nth words 1) "to" with 53 | | 0 -> Ok (List.nth words 2 |> int_of_string) 54 | | _ -> Ok (List.hd words |> int_of_string) 55 | in 56 | let er = Rresult.R.error_msg_to_invalid_arg in 57 | try 58 | Bos.OS.Cmd.(run_out ~err:err_run_out (Bos.Cmd.v cpu) |> out_run_in |> er) |> 59 | aux |> er 60 | with 61 | | Not_found | Invalid_argument _ | Failure _ -> 0 62 | 63 | end 64 | 65 | module Print = struct 66 | let base64 f = 67 | Bos.OS.Cmd.run_out @@ 68 | Bos.Cmd.(v "base64" % "-w" % "0" % (Fpath.to_string f)) |> 69 | Bos.OS.Cmd.to_string 70 | 71 | let output_pasteable str id = 72 | Printf.sprintf "echo %s | base64 -d > crash_%d.$(date -u +%%s)" str id 73 | 74 | let print_crashes output_dir = 75 | match Parse.get_crash_files output_dir with 76 | | Error (`Msg e) -> 77 | Error (`Msg (Format.asprintf "Failure finding crashes in \ 78 | directory %a: %s" Fpath.pp output_dir e)) 79 | | Ok [] -> 80 | Printf.printf "No crashes found!\n%!"; Ok () 81 | | Ok crashes -> 82 | Printf.printf "Crashes found! Take a look; copy/paste to save for \ 83 | reproduction:\n%!"; 84 | try 85 | List.iteri (fun i c -> 86 | match base64 c with 87 | | Error _ -> () 88 | | Ok base64 -> 89 | Printf.printf "%s\n%!" (output_pasteable base64 i) 90 | ) crashes; 91 | Ok () 92 | with 93 | | Invalid_argument e -> Error (`Msg (Format.asprintf "Failed to base64 a \ 94 | crash file: %s" e)) 95 | end 96 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name short) 3 | (ocamlopt_flags -afl-instrument) 4 | (modules short) 5 | (libraries crowbar)) 6 | 7 | (executable 8 | (name long) 9 | (ocamlopt_flags -afl-instrument) 10 | (modules long) 11 | (libraries crowbar)) 12 | 13 | (rule 14 | (alias runtest) 15 | (deps ../src/bun.exe short.exe) 16 | (locks core) 17 | (action 18 | (setenv AFL_NO_AFFINITY 1 19 | (setenv AFL_SKIP_CPUFREQ 1 20 | (progn 21 | (with-stdout-to 22 | "shorttest-output" 23 | (bash "! timeout 30s ../src/bun.exe -vv --max-cores=2 ./short.exe")) 24 | (bash "grep 'Crashes found!' shorttest-output || (cat shorttest-output; echo FAILED; exit 1)") 25 | (cat shorttest-output)))))) 26 | 27 | (rule 28 | (alias longtest) 29 | (deps ../src/bun.exe long.exe) 30 | (locks core) 31 | (action 32 | (run timeout 65s ../src/bun.exe -vv ./long.exe))) 33 | -------------------------------------------------------------------------------- /test/long.ml: -------------------------------------------------------------------------------- 1 | open Crowbar 2 | 3 | let () = 4 | add_test ~name:"good ol' rev" [list bytes] (fun l -> check_eq 5 | ~cmp:(fun a b -> match List.compare_lengths a b with 6 | | 0 -> List.fold_left2 (fun a x y -> match a with 7 | | 0 -> String.compare x y 8 | | n -> n) 0 a b 9 | | n -> n) l (List.rev @@ List.rev l)) 10 | -------------------------------------------------------------------------------- /test/short.ml: -------------------------------------------------------------------------------- 1 | open Crowbar 2 | 3 | let () = 4 | add_test ~name:"negation" [float] (fun f -> check (not (f = -. f))) 5 | --------------------------------------------------------------------------------