1
(* This file is part of Marionnet, a virtual network laboratory
2
Copyright (C) 2010 Jean-Vincent Loddo
3
Copyright (C) 2010 Université Paris 13
5
This program is free software: you can redistribute it and/or modify
6
it under the terms of the GNU General Public License as published by
7
the Free Software Foundation, either version 2 of the License, or
8
(at your option) any later version.
10
This program is distributed in the hope that it will be useful,
11
but WITHOUT ANY WARRANTY; without even the implied warranty of
12
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13
GNU General Public License for more details.
15
You should have received a copy of the GNU General Public License
16
along with this program. If not, see <http://www.gnu.org/licenses/>. *)
19
(** "Switch" component implementation. *)
26
(* Switch related constants: *)
27
(* TODO: make it configurable! *)
29
let port_no_default = 4
33
let initial_content_for_rcfiles =
34
"# ===== FAST SPANNING TREE COMMANDS
35
# fstp/setfstp 0/1 Fast spanning tree protocol 1=ON 0=OFF
36
# fstp/setedge VLAN PORT 1/0 Define an edge port for a vlan 1=Y 0=N
37
# fstp/bonus VLAN PORT COST set the port bonus for a vlan
38
# ===== PORT STATUS COMMANDS
39
# port/sethub 0/1 1=HUB 0=switch
40
# port/setvlan PORT VLAN assign PORT to VLAN (untagged port)
41
# ===== VLAN MANAGEMENT COMMANDS
42
# vlan/create VLAN create the vlan VLAN
43
# vlan/remove VLAN remove the vlan VLAN
44
# vlan/addport VLAN PORT add PORT to the VLAN's trunk (tagged)
45
# vlan/delport VLAN PORT remove PORT from the VLAN's trunk
50
(* The type of data exchanged with the dialog: *)
56
show_vde_terminal : bool;
58
rc_config : bool * string;
62
let to_string t = "<obj>" (* TODO? *)
65
module Make_menus (Params : sig
66
val st : State.globalState
67
val packing : [ `toolbar of GButton.toolbar | `menu_parent of Menu_factory.menu_parent ]
72
module Toolbar_entry = struct
73
let imagefile = "ico.switch.palette.png"
74
let tooltip = (s_ "Switch")
75
let packing = Params.packing
81
let key = Some GdkKeysyms._S
83
let ok_callback t = Gui_bricks.Ok_callback.check_name t.name t.old_name st#network#name_exists t
86
let name = st#network#suggestedName "S" in
87
Dialog_add_or_update.make ~title:(s_ "Add switch") ~name ~ok_callback ()
90
{ name = name; label = label; port_no = port_no;
91
show_vde_terminal = show_vde_terminal; activate_fstp = activate_fstp;
92
rc_config = rc_config; }
96
(new User_level_switch.switch
97
~network:st#network ~name ~label ~port_no ~show_vde_terminal ~activate_fstp ~rc_config ())
99
st#network_change action ();
103
module Properties = struct
105
let dynlist () = st#network#get_nodes_that_can_startup ~devkind:`Switch ()
108
let d = (st#network#get_node_by_name name) in
109
let s = ((Obj.magic d):> User_level_switch.switch) in
110
let title = (s_ "Modify switch")^" "^name in
111
let label = s#get_label in
112
let port_no = s#get_port_no in
113
let port_no_min = st#network#port_no_lower_of (s :> User_level.node) in
114
let show_vde_terminal = s#get_show_vde_terminal in
115
let activate_fstp = s#get_activate_fstp in
116
let rc_config = s#get_rc_config in
117
Dialog_add_or_update.make
118
~title ~name ~label ~port_no ~port_no_min
119
~show_vde_terminal ~activate_fstp ~rc_config
120
~ok_callback:Add.ok_callback ()
122
let reaction { name = name; label = label; port_no = port_no;
124
show_vde_terminal = show_vde_terminal;
125
activate_fstp = activate_fstp;
126
rc_config = rc_config }
128
let d = (st#network#get_node_by_name old_name) in
129
let s = ((Obj.magic d):> User_level_switch.switch) in
130
let action () = s#update_switch_with ~name ~label ~port_no ~show_vde_terminal ~activate_fstp ~rc_config in
131
st#network_change action ();
135
module Remove = struct
136
type t = string (* just the name *)
137
let to_string = (Printf.sprintf "name = %s\n")
139
let dynlist = Properties.dynlist
142
Gui_bricks.Dialog.yes_or_cancel_question
144
~markup:(Printf.sprintf (f_ "Are you sure that you want to remove %s\nand all the cables connected to this %s?") name (s_ "switch"))
149
let d = (st#network#get_node_by_name name) in
150
let h = ((Obj.magic d):> User_level_switch.switch) in
151
let action () = h#destroy in
152
st#network_change action ();
156
module Startup = struct
157
type t = string (* just the name *)
158
let to_string = (Printf.sprintf "name = %s\n")
159
let dynlist = Properties.dynlist
160
let dialog = Menu_factory.no_dialog_but_simply_return_name
161
let reaction name = (st#network#get_node_by_name name)#startup
166
type t = string (* just the name *)
167
let to_string = (Printf.sprintf "name = %s\n")
168
let dynlist () = st#network#get_nodes_that_can_gracefully_shutdown ~devkind:`Switch ()
169
let dialog = Menu_factory.no_dialog_but_simply_return_name
170
let reaction name = (st#network#get_node_by_name name)#gracefully_shutdown
174
module Suspend = struct
175
type t = string (* just the name *)
176
let to_string = (Printf.sprintf "name = %s\n")
177
let dynlist () = st#network#get_nodes_that_can_suspend ~devkind:`Switch ()
178
let dialog = Menu_factory.no_dialog_but_simply_return_name
179
let reaction name = (st#network#get_node_by_name name)#suspend
183
module Resume = struct
184
type t = string (* just the name *)
185
let to_string = (Printf.sprintf "name = %s\n")
186
let dynlist () = st#network#get_nodes_that_can_resume ~devkind:`Switch ()
187
let dialog = Menu_factory.no_dialog_but_simply_return_name
188
let reaction name = (st#network#get_node_by_name name)#resume
192
module Create_entries =
193
Gui_toolbar_COMPONENTS_layouts.Layout_for_network_node (Params) (Toolbar_entry) (Add) (Properties) (Remove) (Startup) (Stop) (Suspend) (Resume)
195
(* Subscribe this kind of component to the network club: *)
196
st#network#subscribe_a_try_to_add_procedure Eval_forest_child.try_to_add_switch;
204
module Dialog_add_or_update = struct
206
(* This function may be useful for testing the widget creation without
207
recompiling the whole project. *)
209
?(title="Add switch")
212
?(port_no=Const.port_no_default)
213
?(port_no_min=Const.port_no_min)
214
?(port_no_max=Const.port_no_max)
215
?(show_vde_terminal=false)
216
?(activate_fstp=false)
217
?(rc_config=(false, Const.initial_content_for_rcfiles))
218
?(help_callback=help_callback) (* defined backward with "WHERE" *)
219
?(ok_callback=(fun data -> Some data))
220
?(dialog_image_file=Initialization.Path.images^"ico.switch.dialog.png")
222
let old_name = name in
223
let (w,_,name,label) =
224
Gui_bricks.Dialog_add_or_update.make_window_image_name_and_label
226
~image_file:dialog_image_file
227
~image_tooltip:(s_ "Switch")
229
~name_tooltip:(s_ "Switch name. This name must be unique in the virtual network. Suggested: S1, S2, ...")
233
let (port_no, show_vde_terminal, activate_fstp, rc_config) =
234
let vbox = GPack.vbox ~homogeneous:false ~border_width:20 ~spacing:10 ~packing:w#vbox#add () in
236
Gui_bricks.make_form_with_labels
238
[(s_ "Ports number");
239
(s_ "Show VDE terminal");
240
(s_ "Activate FSTP");
241
(s_ "Startup configuration");
246
~packing:(form#add_with_tooltip (s_ "Switch ports number"))
247
~lower:port_no_min ~upper:port_no_max ~step_incr:2
250
let show_vde_terminal =
252
~active:show_vde_terminal
253
~packing:(form#add_with_tooltip (s_ "Check to access the switch through a terminal" ))
258
~active:activate_fstp
259
~packing:(form#add_with_tooltip (s_ "Check to activate the FSTP (Fast Spanning Tree Protocol)" ))
263
let hbox = GPack.hbox
264
~packing:(form#add_with_tooltip (s_ "Check to activate a startup configuration" ))
270
~active:(fst rc_config)
275
GButton.button ~stock:`EDIT ~packing:hbox#add ()
277
let content = ref (snd rc_config) in
278
let make_editing_window () =
279
let result = Egg.create () in
281
Gui_source_editing.window
282
~title:(Printf.sprintf (f_ "%s configuration file") old_name)
283
~language:(`id "vde_switch")
292
ignore (Thread.create (fun () -> content := Option.extract_or (Egg.wait result) !content) ());
294
ignore (edit_button#connect#clicked (make_editing_window));
295
(edit_button#misc#set_sensitive check_button#active);
296
ignore (check_button#connect#toggled (fun () -> edit_button#misc#set_sensitive check_button#active));
297
object method active = check_button#active method content = !content end
299
(port_no, show_vde_terminal, activate_fstp, rc_config)
302
let get_widget_data () :'result =
303
let name = name#text in
304
let label = label#text in
305
let port_no = int_of_float port_no#value in
306
let show_vde_terminal = show_vde_terminal#active in
307
let rc_config = (rc_config#active, rc_config#content) in
308
let activate_fstp = activate_fstp#active in
311
Data.port_no = port_no;
312
Data.show_vde_terminal = show_vde_terminal;
313
Data.activate_fstp = activate_fstp;
314
Data.rc_config = rc_config;
315
Data.old_name = old_name;
318
(* The result of make is the result of the dialog loop (of type 'result option): *)
319
Gui_bricks.Dialog_run.ok_or_cancel w ~ok_callback ~help_callback ~get_widget_data ()
326
let title = (s_ "ADD OR MODIFY A SWITCH") in
328
In this dialog window you can define the name of an Ethernet switch \
329
and set parameters for it:\n\n\
330
- Label: a string appearing near the switch icon in the network graph; it may \
331
allow, for example, to know at a glance the Ethernet network realized by the device; \
332
this field is exclusively for graphic purposes, is not taken in consideration \
333
for the configuration.\n\n\
334
- Nb of Ports: the number of ports of the switch (default 4); this number must \
335
not be increased without a reason, because the number of processes needed for the \
336
device emulation is proportional to his ports number.")
337
in Simple_dialogs.help title msg
345
module Eval_forest_child = struct
347
let try_to_add_switch (network:User_level.network) ((root,childs):Xforest.tree) =
350
| ("switch", attrs) ->
351
let name = List.assoc "name" attrs in
352
let port_no = int_of_string (List.assoc "port_no" attrs) in
353
Log.printf "Importing switch \"%s\" with %d ports...\n" name port_no;
354
let x = new User_level_switch.switch ~network ~name ~port_no () in
355
x#from_tree ("switch", attrs) childs;
356
Log.printf "Switch \"%s\" successfully imported.\n" name;
359
(* backward compatibility *)
360
| ("device", attrs) ->
361
let name = List.assoc "name" attrs in
362
let port_no = try int_of_string (List.assoc "eth" attrs) with _ -> Const.port_no_default in
363
let kind = List.assoc "kind" attrs in
366
Log.printf "Importing switch \"%s\" with %d ports...\n" name port_no;
367
let x = new User_level_switch.switch ~network ~name ~port_no () in
368
x#from_tree ("device", attrs) childs; (* Just for the label... *)
369
Log.printf "This is an old project: we set the user port offset to 1...\n";
370
network#defects#change_port_user_offset ~device_name:name ~user_port_offset:1;
371
Log.printf "Switch \"%s\" successfully imported.\n" name;
379
end (* module Eval_forest_child *)
387
module User_level_switch = struct
395
?(show_vde_terminal=false)
396
?(activate_fstp=false)
397
?(rc_config=(false,""))
399
object (self) inherit OoExtra.destroy_methods ()
402
User_level.node_with_ledgrid_and_defects
404
~name ?label ~devkind:`Switch
406
~port_no_min:Const.port_no_min
407
~port_no_max:Const.port_no_max
408
~user_port_offset:1 (* in order to have a perfect mapping with VDE *)
411
as self_as_node_with_ledgrid_and_defects
412
method ledgrid_label = "Switch"
413
method defects_device_type = "switch"
414
method polarity = User_level.MDI_X
415
method string_of_devkind = "switch"
417
val mutable show_vde_terminal : bool = show_vde_terminal
418
method get_show_vde_terminal = show_vde_terminal
419
method set_show_vde_terminal x = show_vde_terminal <- x
421
val mutable activate_fstp : bool = activate_fstp
422
method get_activate_fstp = activate_fstp
423
method set_activate_fstp x = activate_fstp <- x
425
val mutable rc_config : bool * string = rc_config
426
method get_rc_config = rc_config
427
method set_rc_config x = rc_config <- x
429
method dotImg iconsize =
430
let imgDir = Initialization.Path.images in
431
(imgDir^"ico.switch."^(self#string_of_simulated_device_state)^"."^iconsize^".png")
433
method update_switch_with ~name ~label ~port_no
434
~show_vde_terminal ~activate_fstp ~rc_config
436
(* The following call ensure that the simulated device will be destroyed: *)
437
self_as_node_with_ledgrid_and_defects#update_with ~name ~label ~port_no;
438
self#set_show_vde_terminal (show_vde_terminal);
439
self#set_activate_fstp (activate_fstp);
440
self#set_rc_config (rc_config);
442
(** Create the simulated device *)
443
method private make_simulated_device =
444
let hublet_no = self#get_port_no in
445
let show_vde_terminal = self#get_show_vde_terminal in
446
let fstp = Option.of_bool (self#get_activate_fstp) in
448
match self#get_rc_config with
452
let motherboard = Motherboard.extract () in
454
~parent:motherboard#project_working_directory
455
~prefix:(Printf.sprintf "switch_%s_rcfile." self#get_name)
459
self#add_destroy_callback (lazy (Unix.unlink filename));
463
match self#get_rc_config with
465
| true, content -> Some content
467
let unexpected_death_callback = self#destroy_because_of_unexpected_death in
468
((new Simulation_level_switch.switch
470
~hublet_no (* TODO: why not accessible from parent? *)
471
~show_vde_terminal (* TODO: why not accessible from parent? *)
474
~unexpected_death_callback
475
()) :> User_level.node Simulation_level.device)
478
Forest.tree_of_leaf ("switch", [
479
("name" , self#get_name );
480
("label" , self#get_label);
481
("port_no" , (string_of_int self#get_port_no)) ;
482
("show_vde_terminal" , string_of_bool (self#get_show_vde_terminal));
483
("activate_fstp" , string_of_bool (self#get_activate_fstp));
484
("rc_config" , Marshal.to_string self#get_rc_config []);
487
method eval_forest_attribute = function
488
| ("name" , x ) -> self#set_name x
489
| ("label" , x ) -> self#set_label x
490
| ("port_no" , x ) -> self#set_port_no (int_of_string x)
491
| ("show_vde_terminal", x ) -> self#set_show_vde_terminal (bool_of_string x)
492
| ("activate_fstp", x ) -> self#set_activate_fstp (bool_of_string x)
493
| ("rc_config", x ) -> self#set_rc_config (Marshal.from_string x 0)
494
| _ -> () (* Forward-comp. *)
496
end (* class switch *)
498
end (* module User_level *)
504
module Simulation_level_switch = struct
506
(* The question is "port/print" *)
507
let scan_vde_switch_answer_to_port_print (ch:Network.stream_channel) : int =
509
let answer = ch#input_line () in
510
try (Scanf.sscanf answer "Port %d %s ACTIVE") (fun i _ -> ()); loop (n+1) with _ ->
511
try (Scanf.sscanf answer ".") (); n with _ -> loop n
515
let ask_vde_switch_for_current_active_ports ~socketfile () =
516
let protocol (ch:Network.stream_channel) =
517
ch#output_line "port/print";
518
scan_vde_switch_answer_to_port_print ch
520
Network.stream_unix_client ~socketfile ~protocol ()
522
let wait_vde_switch_until_ports_will_be_allocated ~numports ~socketfile () =
523
let rec protocol (ch:Network.stream_channel) =
524
ch#output_line "port/print";
525
let active_ports = scan_vde_switch_answer_to_port_print ch in
526
if active_ports >= numports then active_ports else (Thread.delay 0.2; (protocol ch))
528
Network.stream_unix_client ~socketfile ~protocol ()
530
(*let send_commands_to_vde_switch ~socketfile ~commands () =
531
Log.printf "Sending commands to a switch:\n---\n%s\n---\n" commands;
532
let protocol (ch:Network.stream_channel) = ch#send commands in
533
Network.stream_unix_client ~socketfile ~protocol ()*)
535
let get_lines_removing_comments (commands:string) : string list =
536
let t = StringExtra.Text.of_string commands in
537
let result = StringExtra.Text.grep (Str.regexp "^[^#]") t in
540
(* Currently unused, but useful for testing: *)
541
let get_vde_switch_boolean_answer (ch:Network.stream_channel) : bool =
542
let ignore2 _ _ = () in
544
Log.printf "Waiting for an answer...\n";
545
let answer = ch#input_line () in
546
Log.printf "Received answer `%s'\n" answer;
547
try (Scanf.sscanf answer "vde$ 1000 Success" ()); true with _ ->
548
try (Scanf.sscanf answer "vde$ %d %s" ignore2); false with _ ->
553
(* Currently unused, but useful for testing: *)
554
let send_commands_to_vde_switch_and_get_answers ~socketfile ~commands ()
555
: (exn, (string * bool) list) Either.t
557
let lines = get_lines_removing_comments commands in
558
Log.printf "Sending commands to a switch:\n---\n%s\n---\n" commands;
559
let protocol (ch:Network.stream_channel) =
562
Log.printf "Sending line: %s\n" line;
564
let answer = get_vde_switch_boolean_answer ch in
565
Log.printf "Received boolean answer: %b\n" (answer);
569
Network.stream_unix_client ~socketfile ~protocol ()
571
let rec repeat_until_exception f x =
572
try ignore (f x); repeat_until_exception f x with _ -> ()
574
let send_commands_to_vde_switch_ignoring_answers ~socketfile ~commands () =
575
let lines = get_lines_removing_comments commands in
576
let protocol (ch:Network.stream_channel) =
577
ignore (Thread.create (repeat_until_exception ch#input_line) ());
580
Log.printf "Sending line: %s\n" line;
586
Network.stream_unix_client ~socketfile ~protocol ()
589
(** A switch: just a [hub_or_switch] with [hub = false] *)
590
class ['parent] switch =
591
fun ~(parent:'parent)
593
?(last_user_visible_port_index:int option)
594
?(show_vde_terminal=false)
596
?rcfile (* Unused: vde_switch doesn't interpret correctly commands provided in this way! *)
598
~unexpected_death_callback
601
inherit ['parent] Simulation_level.hub_or_switch
604
?last_user_visible_port_index
606
~management_socket:()
609
~unexpected_death_callback
612
method device_type = "switch"
614
method spawn_internal_cables =
615
match show_vde_terminal || (rcfile_content <> None) with
616
| false -> super#spawn_internal_cables
618
(* If the user want to configure VLANs etc, we must be sure that
619
the port numbering will be the same for marionnet and vde_switch: *)
620
let socketfile = Option.extract self#get_management_socket_name in
621
let numports = ref (Either.extract (ask_vde_switch_for_current_active_ports ~socketfile ())) in
622
let name = parent#get_name in
623
Log.printf "The vde_switch %s has currently %d active ports.\n" name !numports;
624
Log.printf "Spawning internal cables for switch %s...\n" name;
625
List.iter (fun thunk -> thunk ())
626
(List.map (* Here map returns a list of thunks *)
627
begin fun internal_cable_process () ->
628
(* The protocol implemented here should ensure that vde_switch will not be solicited
629
before having accepted the previously asked connection. However, for safety we add
630
a little delay in order to give to vde_switch the time to allocate the previous port: *)
632
(* Now we launch the process that will ask vde_switch to obtain a new port: *)
633
internal_cable_process#spawn;
636
Either.extract (wait_vde_switch_until_ports_will_be_allocated ~numports:(!numports) ~socketfile ())
638
(if answer <> !numports then Log.printf "Unexpected vde_switch %s answer: %d instead of the expected value %d. Ignoring.\n" name answer !numports);
639
Log.printf "Ok, the vde_switch %s has now %d allocated ports.\n" name !numports;
641
self#get_internal_cable_processes);
642
(* Now send rc commands to the switch: *)
643
match rcfile_content with
648
(send_commands_to_vde_switch_ignoring_answers ~socketfile ~commands) ())
653
match show_vde_terminal with
656
let name = parent#get_name in
657
self#add_accessory_process
658
(new Simulation_level.unixterm_process
659
~xterm_title:(name^" terminal")
660
~management_socket_name:(Option.extract self#get_management_socket_name)
661
~unexpected_death_callback:
663
Death_monitor.stop_monitoring i;
664
Log.printf "Terminal of switch %s closed (pid %d).\n" name i)
669
end (* module Simulation_level_switch *)
671
(** Just for testing: *)
672
let test = Dialog_add_or_update.make
added
removed
switch.ml
