1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Stephen Dolan, University of Cambridge */
6 /* */
7 /* Copyright 2016 Stephen Dolan. */
8 /* */
9 /* All rights reserved. This file is distributed under the terms of */
10 /* the GNU Lesser General Public License version 2.1, with the */
11 /* special exception on linking described in the file LICENSE. */
12 /* */
13 /**************************************************************************/
14
15 /* Runtime support for afl-fuzz */
16
17 /* Android's libc does not implement System V shared memory. */
18 #if defined(_WIN32) || defined(__ANDROID__)
19
20 #include "caml/mlvalues.h"
21
caml_setup_afl(value unit)22 CAMLprim value caml_setup_afl (value unit)
23 {
24 return Val_unit;
25 }
26
caml_reset_afl_instrumentation(value unused)27 CAMLprim value caml_reset_afl_instrumentation(value unused)
28 {
29 return Val_unit;
30 }
31
32 #else
33
34 #include <unistd.h>
35 #include <sys/types.h>
36 #include <signal.h>
37 #include <sys/shm.h>
38 #include <sys/wait.h>
39 #include <stdio.h>
40 #include <string.h>
41
42 #define CAML_INTERNALS
43 #include "caml/misc.h"
44 #include "caml/mlvalues.h"
45 #include "caml/osdeps.h"
46
47 static int afl_initialised = 0;
48
49 /* afl uses abnormal termination (SIGABRT) to check whether
50 to count a testcase as "crashing" */
51 extern int caml_abort_on_uncaught_exn;
52
53 /* Values used by the instrumentation logic (see cmmgen.ml) */
54 static unsigned char afl_area_initial[1 << 16];
55 unsigned char* caml_afl_area_ptr = afl_area_initial;
56 uintnat caml_afl_prev_loc;
57
58 /* File descriptors used to synchronise with afl-fuzz */
59 #define FORKSRV_FD_READ 198
60 #define FORKSRV_FD_WRITE 199
61
afl_write(uint32_t msg)62 static void afl_write(uint32_t msg)
63 {
64 if (write(FORKSRV_FD_WRITE, &msg, 4) != 4)
65 caml_fatal_error("writing to afl-fuzz");
66 }
67
afl_read()68 static uint32_t afl_read()
69 {
70 uint32_t msg;
71 if (read(FORKSRV_FD_READ, &msg, 4) != 4)
72 caml_fatal_error("reading from afl-fuzz");
73 return msg;
74 }
75
caml_setup_afl(value unit)76 CAMLprim value caml_setup_afl(value unit)
77 {
78 if (afl_initialised) return Val_unit;
79 afl_initialised = 1;
80
81 char* shm_id_str = caml_secure_getenv("__AFL_SHM_ID");
82 if (shm_id_str == NULL) {
83 /* Not running under afl-fuzz, continue as normal */
84 return Val_unit;
85 }
86
87 /* if afl-fuzz is attached, we want it to know about uncaught exceptions */
88 caml_abort_on_uncaught_exn = 1;
89
90 char* shm_id_end;
91 long int shm_id = strtol(shm_id_str, &shm_id_end, 10);
92 if (!(*shm_id_str != '\0' && *shm_id_end == '\0'))
93 caml_fatal_error("afl-fuzz: bad shm id");
94
95 caml_afl_area_ptr = shmat((int)shm_id, NULL, 0);
96 if (caml_afl_area_ptr == (void*)-1)
97 caml_fatal_error("afl-fuzz: could not attach shm area");
98
99 /* poke the bitmap so that afl-fuzz knows we exist, even if the
100 application has sparse instrumentation */
101 caml_afl_area_ptr[0] = 1;
102
103 /* synchronise with afl-fuzz */
104 uint32_t startup_msg = 0;
105 if (write(FORKSRV_FD_WRITE, &startup_msg, 4) != 4) {
106 /* initial write failed, so assume we're not meant to fork.
107 afl-tmin uses this mode. */
108 return Val_unit;
109 }
110 afl_read();
111
112 while (1) {
113 int child_pid = fork();
114 if (child_pid < 0) caml_fatal_error("afl-fuzz: could not fork");
115 else if (child_pid == 0) {
116 /* Run the program */
117 close(FORKSRV_FD_READ);
118 close(FORKSRV_FD_WRITE);
119 return Val_unit;
120 }
121
122 /* As long as the child keeps raising SIGSTOP, we re-use the same process */
123 while (1) {
124 afl_write((uint32_t)child_pid);
125
126 int status;
127 /* WUNTRACED means wait until termination or SIGSTOP */
128 if (waitpid(child_pid, &status, WUNTRACED) < 0)
129 caml_fatal_error("afl-fuzz: waitpid failed");
130
131 afl_write((uint32_t)status);
132
133 uint32_t was_killed = afl_read();
134 if (WIFSTOPPED(status)) {
135 /* child stopped, waiting for another test case */
136 if (was_killed) {
137 /* we saw the child stop, but since then afl-fuzz killed it.
138 we should wait for it before forking another child */
139 if (waitpid(child_pid, &status, 0) < 0)
140 caml_fatal_error("afl-fuzz: waitpid failed");
141 break;
142 } else {
143 kill(child_pid, SIGCONT);
144 }
145 } else {
146 /* child died */
147 break;
148 }
149 }
150 }
151 }
152
caml_reset_afl_instrumentation(value full)153 CAMLprim value caml_reset_afl_instrumentation(value full)
154 {
155 if (full != Val_int(0)) {
156 memset(caml_afl_area_ptr, 0, sizeof(afl_area_initial));
157 }
158 caml_afl_prev_loc = 0;
159 return Val_unit;
160 }
161
162 #endif /* _WIN32 */
163