Source file Shell.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
open Core
open Async
open Frenetic_netkat.Syntax
module Netkat = Frenetic_netkat
module Controller = NetKAT_Controller.Make(OpenFlow0x01_Plugin)
module Field = Netkat.Fdd.Field
type showable =
| Ordering
| Policy
| FlowTable
| Help
type command =
| Update of (policy * string)
| UpdateGlobal of (policy * string)
| Order of Netkat.Local_compiler.order
| ToggleRemoveTailDrops
| Exit
| Quit
| Load of string
| LoadGlobal of string
| Show of showable
module Parser = struct
open MParser
module Tokens = MParser_RE.Tokens
let field (f : Field.t) : (Field.t, bytes list) MParser.t =
Tokens.symbol (Field.to_string f |> String.lowercase) <|>
Tokens.symbol (Field.to_string f) >>
return f
let any_field : (Field.t, bytes list) MParser.t =
field Field.Switch <|>
field Field.Location <|>
field Field.EthSrc <|>
field Field.EthDst <|>
field Field.Vlan <|>
field Field.VlanPcp <|>
field Field.EthType <|>
field Field.IPProto <|>
field Field.IP4Src <|>
field Field.IP4Dst <|>
field Field.TCPSrcPort <|>
field Field.TCPDstPort
let order : (command, bytes list) MParser.t =
Tokens.symbol "order" >> (
(eof >> return (Show Ordering)) <|>
(Tokens.symbol "heuristic" >> return (Order `Heuristic)) <|>
(Tokens.symbol "default" >> return (Order `Default)) <|>
(sep_by1 any_field (Tokens.symbol "<") >>=
fun fields -> eof >> return (Order (`Static fields))))
let string_of_position (p : Lexing.position) : string =
sprintf "%s:%d:%d" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol)
let parse_policy ?(name = "") (pol_str : string) : (policy, string) Result.t =
Ok (Frenetic_netkat.Parser.pol_of_string pol_str)
let policy' : ((policy * string), bytes list) MParser.t =
many_until any_char eof >>= fun pol_chars ->
let pol_str = String.of_char_list pol_chars in
match parse_policy pol_str with
| Ok pol -> return (pol, pol_str)
| Error msg -> fail msg
let update : (command, bytes list) MParser.t =
Tokens.symbol "update" >>
policy' >>=
(fun pol -> return (Update pol))
let update_global : (command, bytes list) MParser.t =
Tokens.symbol "update-global" >>
policy' >>=
(fun pol -> return (UpdateGlobal pol))
let help : (command, bytes list) MParser.t =
Tokens.symbol "help" >> return (Show Help)
let exit : (command, bytes list) MParser.t =
Tokens.symbol "exit" >> return Exit
let quit : (command, bytes list) MParser.t =
Tokens.symbol "quit" >> return Quit
let load : (command, bytes list) MParser.t =
Tokens.symbol "load" >>
many_until any_char eof >>=
(fun filename -> return (Load (String.of_char_list filename)))
let load_global : (command, bytes list) MParser.t =
Tokens.symbol "load-global" >>
many_until any_char eof >>=
(fun filename -> return (LoadGlobal (String.of_char_list filename)))
let policy : (command, bytes list) MParser.t =
Tokens.symbol "policy" >> return (Show Policy)
let remove_tail_drops : (command, bytes list) MParser.t =
Tokens.symbol "remove_tail_drops" >> return ToggleRemoveTailDrops
let flowtable : (command, bytes list) MParser.t =
Tokens.symbol "flow-table" >>
eof >>
return (Show FlowTable)
let command : (command, bytes list) MParser.t =
order <|>
update_global <|>
update <|>
policy <|>
help <|>
flowtable <|>
remove_tail_drops <|>
load_global <|>
load <|>
exit <|>
quit
end
let current_compiler_options =
ref { Netkat.Local_compiler.default_compiler_options with cache_prepare = `Keep }
let set_field_order ord : unit =
current_compiler_options := { !current_compiler_options with field_order = ord }
let print_order () : unit =
(!current_compiler_options).field_order
|> Netkat.Local_compiler.field_order_to_string
|> printf "Ordering Mode: %s\n%!"
let rec check_duplicates (fs : Field.t list) (acc : Field.t list) : bool =
match fs with
| [] -> false
| (f::rest) ->
if List.mem acc f ~equal:Field.equal
then
(printf "Invalid ordering: %s < %s" (Field.to_string f) (Field.to_string f);
false)
else check_duplicates rest (f::acc)
let set_order (o : Netkat.Local_compiler.order) : unit =
match o with
| `Heuristic ->
set_field_order `Heuristic;
print_order ()
| `Default ->
set_field_order `Default;
print_order ()
| `Static ls ->
if check_duplicates ls [] then ()
else
let curr_order = match (!current_compiler_options).field_order with
| `Heuristic -> Field.all
| `Default -> Field.all
| `Static fields -> fields
in
let removed = List.filter curr_order (Fn.compose not (List.mem ls ~equal:Field.equal)) in
let new_order = List.append (List.rev ls) removed in
set_field_order (`Static new_order);
print_order ()
let toggle_remove_tail_drops () =
let current_setting = (!current_compiler_options).remove_tail_drops in
current_compiler_options := { !current_compiler_options with remove_tail_drops = not current_setting };
printf "Remove Tail Drops: %B\n%!" (!current_compiler_options).remove_tail_drops
let policy : [`Local of (policy * string) | `Global of (policy * string) ] ref =
ref (`Local (drop, "drop"))
let compile_current () = match !policy with
| `Local (p,_) ->
Netkat.Local_compiler.compile ~options:(!current_compiler_options) p
| `Global (p,_) ->
Netkat.Global_compiler.compile ~options:(!current_compiler_options) p
let print_policy () =
match !policy with
| `Local (_, p) -> printf "Local policy:\n%s\n%!" p
| `Global (_, p) -> printf "Global policy:\n%s\n%!" p
let print_policy_table () : unit =
let pol = match !policy with `Local (p,_) | `Global (p,_) -> p in
let fdd = compile_current () in
let switches = Frenetic_netkat.Semantics.switches_of_policy pol in
(if List.is_empty switches then [0L] else switches)
|> List.map ~f:(fun sw ->
Netkat.Local_compiler.to_table ~options:(!current_compiler_options) sw fdd
|> Frenetic_kernel.OpenFlow.string_of_flowTable ~label:(Int64.to_string sw))
|> String.concat ~sep:"\n\n"
|> printf "%s%!"
let parse_command (line : string) : command option =
match (MParser.parse_string Parser.command line []) with
| Success command -> Some command
| Failed (msg, e) -> (print_endline msg; None)
let help =
String.concat ~sep:"\n" [
"";
"commands:";
" order - Display the ordering that will be used when compiling.";
" order <ordering> - Changes the order in which the compiler selects fields.";
"";
" orderings: heuristic";
" default";
" f_1 < f_2 [ < f_3 < ... < f_n ]";
"";
" fields: Switch, Location, EthSrc, EthDst, Vlan, VlanPcP,";
" EthType, IPProto, IP4Src, IP4Dst, TCPSrcPort,";
" TCPDstPort";
"";
" policy - Displays the policy that is currently active.";
"";
" flow-table - Displays the flow-table produced by the specified policy.";
" If no policy is specified, the current policy is used.";
"";
" update <policy> - Compiles the specified local policy using the current";
" ordering and updates the controller with the resulting";
" flow-table.";
"";
" update-global <pol> - Like update, but with a global policy.";
"";
" load <file> - Loads local policy from the specified file, compiles it,";
" and updates the controller with the resulting flow-table.";
"";
" load-global <file> - Like load, but with global policy.";
"";
" remove_tail_drops - Remove drop rules at the end of each flow-table. Toggles ";
" setting.";
"";
" help - Displays this message.";
"";
" exit - Exits Frenetic Shell.";
"";
" quit - Exits Frenetic Shell. Equivalent to CTRL-D";
""
]
let print_help () : unit =
printf "%s\n%!" help
let load_file (typ : [`Local | `Global]) (filename : string) : unit =
try
let open In_channel in
let chan = create filename in
let policy_string = input_all chan in
let pol = Parser.parse_policy policy_string in
close chan;
match pol with
| Ok p ->
policy := begin match typ with
| `Local -> `Local (p, policy_string)
| `Global -> `Global (p, policy_string)
end;
print_policy ();
compile_current ()
|> Controller.update_fdd
|> don't_wait_for
| Error msg -> print_endline msg
with
| Sys_error msg -> printf "Load failed: %s\n%!" msg
let rec repl () : unit Deferred.t =
printf "frenetic> %!";
Reader.read_line (Lazy.force Reader.stdin) >>= fun input ->
let handle line =
try match line with
| `Eof -> Shutdown.shutdown 0
| `Ok line -> match parse_command line with
| Some Exit | Some Quit ->
print_endline "Goodbye!";
Shutdown.shutdown 0
| Some (Show Ordering) -> print_order ()
| Some (Show Policy) -> print_policy ()
| Some (Show Help) -> print_help ()
| Some (Show FlowTable) -> print_policy_table ()
| Some (Update (pol, pol_str)) ->
policy := `Local (pol, pol_str);
compile_current ()
|> Controller.update_fdd
|> don't_wait_for
| Some (UpdateGlobal (pol, pol_str)) ->
policy := `Global (pol, pol_str);
compile_current ()
|> Controller.update_fdd
|> don't_wait_for
| Some (Load filename) -> load_file `Local filename
| Some (LoadGlobal filename) -> load_file `Global filename
| Some (Order order) -> set_order order
| Some (ToggleRemoveTailDrops) -> toggle_remove_tail_drops ()
| None -> ()
with exn -> Location.report_exception Format.std_formatter exn
in handle input; repl ()
let log_file = "frenetic.log"
let main (openflow_port : int) () : unit =
Logging.set_output [Async.Log.Output.file `Text log_file];
printf "Frenetic Shell v 4.0\n%!";
printf "Type `help` for a list of commands\n%!";
Controller.start openflow_port;
let _ = repl () in
()