1
(* This file is part of Marionnet, a virtual network laboratory
2
Copyright (C) 2009, 2010 Jean-Vincent Loddo
3
Copyright (C) 2009, 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/>. *)
20
(** Gui-related stuff for the user-level component "router". *)
22
(* The module containing the add/update dialog is defined later,
23
using the syntax extension "where" *)
27
(* Router related constants: *)
28
(* TODO: make it configurable! *)
30
let port_no_default = 4
34
let port_0_ip_config_default = Initialization.router_port0_default_ipv4_config
35
let memory_default = 48
39
(* The type of data returned by the dialog: *)
44
port_0_ip_config : Ipv4.config;
46
distribution : string; (* epithet *)
47
variant : string option;
48
kernel : string; (* epithet *)
49
show_unix_terminal : bool;
53
let to_string t = "<obj>" (* TODO? *)
56
module Make_menus (Params : sig
57
val st : State.globalState
58
val packing : [ `toolbar of GButton.toolbar | `menu_parent of Menu_factory.menu_parent ]
63
module Toolbar_entry = struct
64
let imagefile = "ico.router.palette.png"
65
let tooltip = (s_ "Router")
66
let packing = Params.packing
72
let key = Some GdkKeysyms._R
74
let ok_callback t = Gui_bricks.Ok_callback.check_name t.name t.old_name st#network#name_exists t
77
let name = st#network#suggestedName "R" in
78
Dialog_add_or_update.make
79
~title:(s_ "Add router") ~name ~ok_callback ()
84
port_0_ip_config = port_0_ip_config;
86
distribution = distribution;
89
show_unix_terminal = show_unix_terminal;
93
let action () = ignore (
94
new User_level_router.router (* defined later with WHERE *)
106
st#network_change action ();
110
module Properties = struct
112
let dynlist () = st#network#get_nodes_that_can_startup ~devkind:`Router ()
115
let r = (st#network#get_node_by_name name) in
116
let r = ((Obj.magic r):> User_level_router.router) in
117
let title = (s_ "Modify router")^" "^name in
118
let label = r#get_label in
119
let distribution = r#get_epithet in
120
let variant = r#get_variant in
121
let kernel = r#get_kernel in
122
let show_unix_terminal = r#get_show_unix_terminal in
123
let port_no = r#get_port_no in
124
let port_0_ip_config = r#get_port_0_ip_config in
125
(* The user cannot remove receptacles used by a cable. *)
126
let port_no_min = st#network#port_no_lower_of (r :> User_level.node)
128
Dialog_add_or_update.make
129
~title ~name ~label ~distribution ?variant ~show_unix_terminal
130
~port_no ~port_no_min
133
~updating:() (* the user cannot change the distrib & variant *)
134
~ok_callback:Add.ok_callback ()
139
port_0_ip_config = port_0_ip_config;
142
show_unix_terminal = show_unix_terminal;
146
let d = (st#network#get_node_by_name old_name) in
147
let r = ((Obj.magic d):> User_level_router.router) in
150
~name ~label ~port_0_ip_config ~port_no ~kernel ~show_unix_terminal
152
st#network_change action ();
156
module Remove = struct
157
type t = string (* just the name *)
158
let to_string = (Printf.sprintf "name = %s\n")
160
let dynlist = Properties.dynlist
163
Gui_bricks.Dialog.yes_or_cancel_question
165
~markup:(Printf.sprintf (f_ "Are you sure that you want to remove %s\nand all the cables connected to this %s?") name (s_ "router"))
170
let d = (st#network#get_node_by_name name) in
171
let r = ((Obj.magic d):> User_level_router.router) in
172
let action () = r#destroy in
173
st#network_change action ();
177
module Startup = struct
178
type t = string (* just the name *)
179
let to_string = (Printf.sprintf "name = %s\n")
180
let dynlist = Properties.dynlist
181
let dialog = Menu_factory.no_dialog_but_simply_return_name
182
let reaction name = (st#network#get_node_by_name name)#startup
187
type t = string (* just the name *)
188
let to_string = (Printf.sprintf "name = %s\n")
189
let dynlist () = st#network#get_nodes_that_can_gracefully_shutdown ~devkind:`Router ()
190
let dialog = Menu_factory.no_dialog_but_simply_return_name
191
let reaction name = (st#network#get_node_by_name name)#gracefully_shutdown
195
module Suspend = struct
196
type t = string (* just the name *)
197
let to_string = (Printf.sprintf "name = %s\n")
198
let dynlist () = st#network#get_nodes_that_can_suspend ~devkind:`Router ()
199
let dialog = Menu_factory.no_dialog_but_simply_return_name
200
let reaction name = (st#network#get_node_by_name name)#suspend
204
module Resume = struct
205
type t = string (* just the name *)
207
let to_string = (Printf.sprintf "name = %s\n")
208
let dynlist () = st#network#get_nodes_that_can_resume ~devkind:`Router ()
209
let dialog = Menu_factory.no_dialog_but_simply_return_name
210
let reaction name = (st#network#get_node_by_name name)#resume
214
module Create_entries =
215
Gui_toolbar_COMPONENTS_layouts.Layout_for_network_node (Params) (Toolbar_entry) (Add) (Properties) (Remove) (Startup) (Stop) (Suspend) (Resume)
217
(* Subscribe this kind of component to the network club: *)
218
st#network#subscribe_a_try_to_add_procedure Eval_forest_child.try_to_add_router;
226
module Dialog_add_or_update = struct
228
(* This function may be useful for testing the widget creation without
229
recompiling the whole project. *)
231
?(title="Add a router")
234
?(port_0_ip_config=Const.port_0_ip_config_default)
235
?(port_no=Const.port_no_default)
236
?(port_no_min=Const.port_no_min)
237
?(port_no_max=Const.port_no_max)
241
?(updating:unit option)
242
?(show_unix_terminal=false)
243
?(help_callback=help_callback) (* defined backward with "WHERE" *)
244
?(ok_callback=(fun data -> Some data))
245
?(dialog_image_file=Initialization.Path.images^"ico.router.dialog.png")
247
let old_name = name in
248
let ((b1,b2,b3,b4),b5) = port_0_ip_config in
249
let vm_installations = Disk.get_router_installations () in
250
let (w,_,name,label) =
251
Gui_bricks.Dialog_add_or_update.make_window_image_name_and_label
253
~image_file:dialog_image_file
254
~image_tooltip:(s_ "Router")
256
~name_tooltip:(s_ "Router name. This name must be unique in the virtual network. Suggested: R1, R2, ...")
260
let ((s1,s2,s3,s4,s5), port_no, distribution_variant_kernel, show_unix_terminal) =
261
let vbox = GPack.vbox ~homogeneous:false ~border_width:20 ~spacing:10 ~packing:w#vbox#add () in
263
Gui_bricks.make_form_with_labels
265
[(s_ "Ports number");
266
(s_ "Port 0 address");
270
(s_ "Show unix terminal");
273
form#add_section ~no_line:() "Hardware";
275
Gui_bricks.spin_byte ~lower:port_no_min ~upper:port_no_max ~step_incr:2
276
~packing:(form#add_with_tooltip (s_ "Number of router ports" )) port_no
278
let port_0_ip_config =
279
Gui_bricks.spin_ipv4_address_with_cidr_netmask
280
~packing:(form#add_with_tooltip
282
(s_ "IPv4 configuration of the first router port (0)"))
285
form#add_section "Software";
286
let distribution_variant_kernel =
287
let packing_distribution =
288
form#add_with_tooltip
289
(s_ "GNU/Linux distribution installed on the router." )
291
let packing_variant =
292
form#add_with_tooltip
293
(s_ "Initial hard disk state. The router will start by default with this variant of the chosen distribution." )
296
form#add_with_tooltip
297
(s_ "Linux kernel version used for this router." )
299
let packing = (packing_distribution, packing_variant, packing_kernel) in
300
Gui_bricks.make_combo_boxes_of_vm_installations
301
?distribution ?variant ?kernel ?updating
305
form#add_section "Access";
306
let show_unix_terminal =
308
~active:show_unix_terminal
309
~packing:(form#add_with_tooltip (s_ "Do you want access the router also by a Unix terminal?" ))
312
(port_0_ip_config, port_no, distribution_variant_kernel, show_unix_terminal)
314
let get_widget_data () :'result =
315
let name = name#text in
316
let label = label#text in
317
let port_0_ip_config =
318
let s1 = int_of_float s1#value in
319
let s2 = int_of_float s2#value in
320
let s3 = int_of_float s3#value in
321
let s4 = int_of_float s4#value in
322
let s5 = int_of_float s5#value in
325
let port_no = int_of_float port_no#value in
326
let distribution = distribution_variant_kernel#selected in
327
let variant = distribution_variant_kernel#slave0#selected in
328
let kernel = distribution_variant_kernel#slave1#selected in
329
let variant = match variant with
333
let show_unix_terminal = show_unix_terminal#active in
336
Data.port_0_ip_config = port_0_ip_config;
337
Data.port_no = port_no;
338
Data.distribution = distribution;
339
Data.variant = variant;
340
Data.kernel = kernel;
341
Data.show_unix_terminal = show_unix_terminal;
342
Data.old_name = old_name;
346
(* The result of make is the result of the dialog loop (of type 'result option): *)
347
Gui_bricks.Dialog_run.ok_or_cancel w ~ok_callback ~help_callback ~get_widget_data ()
355
let title = (s_ "ADD OR MODIFY A ROUTER") in
357
In this dialog window you can define the name of an IP router \
358
and set many parameters for it:\n\n\
359
- Label: a string appearing near the router icon in the network graph; \
360
this field is exclusively for graphic purposes, is not taken in consideration \
361
for the configuration.\n\
362
- Nb of Ports: the number of ports of the router (default 4); this number must \
363
not be increased without a reason, because the number of processes needed for the \
364
device emulation is proportional to his ports number.\n\n\
365
The emulation of this device is realised with the program 'quagga' derived from \
366
the project 'zebra'.\n\n\
367
Every interface of the router can be configured in the tab \
368
'Interfaces'. Once started, the router will answer to the telnet \
369
protocol on every configured interface, on the following tcp ports:\n\n\
370
zebra\t\t2601/tcp\t\t# zebra vty\n\
371
ripd\t\t\t2602/tcp\t\t# RIPd vty\n\
372
ripngd\t\t2603/tcp\t\t# RIPngd vty\n\
373
ospfd\t\t2604/tcp\t\t# OSPFd vty\n\
374
bgpd\t\t2605/tcp\t\t# BGPd vty\n\
375
ospf6d\t\t2606/tcp\t\t# OSPF6d vty\n\
376
isisd\t\t\t2608/tcp\t\t# ISISd vty\n\n\
378
in Simple_dialogs.help title msg ;;
386
module Eval_forest_child = struct
387
let try_to_add_router (network:User_level.network) ((root,childs):Xforest.tree) =
390
| ("router", attrs) ->
391
let name = List.assoc "name" attrs in
392
let port_no = int_of_string (List.assoc "port_no" attrs) in
393
Log.printf "Importing router \"%s\" with %d ports...\n" name port_no;
394
let x = new User_level_router.router ~network ~name ~port_no () in
395
x#from_tree ("router", attrs) childs;
396
Log.printf "Router \"%s\" successfully imported.\n" name;
399
(* backward compatibility *)
400
| ("device", attrs) ->
401
let name = List.assoc "name" attrs in
402
let port_no = int_of_string (List.assoc "eth" attrs) in
403
let kind = List.assoc "kind" attrs in
406
Log.printf "Importing router \"%s\" with %d ports...\n" name port_no;
407
let r = new User_level_router.router ~network ~name ~port_no () in
408
let x = (r :> User_level.node_with_ledgrid_and_defects) in
409
x#from_tree ("device", attrs) childs ;
410
Log.printf "Router \"%s\" successfully imported.\n" name;
417
end (* module Eval_forest_child *)
425
module User_level_router = struct
428
~(network:User_level.network)
430
?(port_0_ip_config=Const.port_0_ip_config_default)
435
?(show_unix_terminal=false)
440
let vm_installations = Disk.get_router_installations () in
441
let network_alias = network in
442
(* The ifconfig treeview wants a port 0 configuration at creation time:*)
443
let ifconfig_port_row_completions =
444
let (ipv4,cidr) = port_0_ip_config in (* the class parameter *)
445
let netmask_string = (Ipv4.to_string (Ipv4.netmask_of_cidr cidr)) in
447
[ "IPv4 address", Treeview.Row_item.String (Ipv4.to_string ipv4);
448
"IPv4 netmask", Treeview.Row_item.String netmask_string; ])
452
object (self) inherit OoExtra.destroy_methods ()
454
inherit User_level.node_with_ledgrid_and_defects
456
~name ?label ~devkind:`Router
458
~port_no_min:Const.port_no_min
459
~port_no_max:Const.port_no_max
462
as self_as_node_with_ledgrid_and_defects
464
inherit User_level.virtual_machine_with_history_and_ifconfig
465
~network:network_alias
466
?epithet ?variant ?kernel ?terminal
467
~history_icon:"router"
468
~ifconfig_device_type:"router"
469
~ifconfig_port_row_completions
472
as self_as_virtual_machine_with_history_and_ifconfig
474
method polarity = User_level.MDI
475
method string_of_devkind = "router"
476
method ledgrid_label = "Router"
477
method defects_device_type = "router"
479
method dotImg iconsize =
480
let imgDir = Initialization.Path.images in
481
(imgDir^"ico.router."^(self#string_of_simulated_device_state)^"."^iconsize^".png")
483
(** Get the full host pathname to the directory containing the guest hostfs
485
method hostfs_directory_pathname =
486
let d = ((Option.extract !simulated_device) :> User_level.node Simulation_level.router) in
487
d#hostfs_directory_pathname
489
val mutable show_unix_terminal : bool = show_unix_terminal
490
method get_show_unix_terminal = show_unix_terminal
491
method set_show_unix_terminal x = show_unix_terminal <- x
493
(** Create the simulated device *)
494
method private make_simulated_device =
496
let cow_file_name, dynamically_get_the_cow_file_name_source =
497
self#create_cow_file_name_and_thunk_to_get_the_source
501
"About to start the router %s\n with filesystem: %s\n cow file: %s\n kernel: %s\n"
503
self#get_filesystem_file_name
505
self#get_kernel_file_name
507
new Simulation_level.router
509
~kernel_file_name:self#get_kernel_file_name
510
?kernel_console_arguments:self#get_kernel_console_arguments
511
~filesystem_file_name:self#get_filesystem_file_name
512
~dynamically_get_the_cow_file_name_source
514
~states_directory:(self#get_states_directory)
515
~ethernet_interface_no:self#get_port_no
518
~show_unix_terminal:self#get_show_unix_terminal
519
~unexpected_death_callback:self#destroy_because_of_unexpected_death
523
(** Here we also have to manage cow files... *)
524
method private gracefully_shutdown_right_now =
525
self_as_node_with_ledgrid_and_defects#gracefully_shutdown_right_now;
526
(* We have to manage the hostfs stuff (when in exam mode) and
527
destroy the simulated device, so that we can use a new cow file the next time: *)
528
Log.printf "Calling hostfs_directory_pathname on %s...\n" self#name;
529
let hostfs_directory_pathname = self#hostfs_directory_pathname in
530
Log.printf "Ok, we're still alive\n";
531
(* If we're in exam mode then make the report available in the texts treeview: *)
532
(if Command_line.are_we_in_exam_mode then begin
533
let treeview_documents = Treeview_documents.extract () in
534
Log.printf "Adding the report on %s to the texts interface\n" self#name;
535
treeview_documents#import_report
536
~machine_or_router_name:self#name
537
~pathname:(hostfs_directory_pathname ^ "/report.html")
539
Log.printf "Added the report on %s to the texts interface\n" self#name;
541
(* ...And destroy, so that the next time we have to re-create the process command line
542
can use a new cow file (see the make_simulated_device method) *)
543
self#destroy_right_now
546
(** Here we also have to manage LED grids and, for routers, cow files: *)
547
method private poweroff_right_now =
548
self_as_node_with_ledgrid_and_defects#poweroff_right_now;
549
(* Destroy, so that the next time we have to re-create a simulated device,
550
and we start with a new cow: *)
551
self#destroy_right_now
554
Forest.tree_of_leaf ("router", [
555
("name" , self#get_name );
556
("label" , self#get_label);
557
("distrib" , self#get_epithet );
558
("variant" , self#get_variant_as_string);
559
("kernel" , self#get_kernel );
560
("show_unix_terminal" , string_of_bool (self#get_show_unix_terminal));
561
("terminal" , self#get_terminal );
562
("port_no" , (string_of_int self#get_port_no)) ;
565
(** A machine has just attributes (no childs) in this version. *)
566
method eval_forest_attribute = function
567
| ("name" , x ) -> self#set_name x
568
| ("label" , x ) -> self#set_label x
569
| ("distrib" , x ) -> self#set_epithet x
570
| ("variant" , "") -> self#set_variant None
571
| ("variant" , x ) -> self#set_variant (Some x)
572
| ("kernel" , x ) -> self#set_kernel x
573
| ("show_unix_terminal", x ) -> self#set_show_unix_terminal (bool_of_string x)
574
| ("terminal" , x ) -> self#set_terminal x
575
| ("port_no" , x ) -> self#set_port_no (int_of_string x)
576
| _ -> () (* Forward-comp. *)
578
method private get_assoc_list_from_ifconfig ~key =
580
(fun i -> (i,network#ifconfig#get_port_attribute_by_index self#get_name i key))
581
(ListExtra.range 0 (self#get_port_no - 1))
583
method get_mac_addresses = self#get_assoc_list_from_ifconfig ~key:"MAC address"
584
method get_ipv4_addresses = self#get_assoc_list_from_ifconfig ~key:"IPv4 address"
585
(* other: "MTU", "IPv4 netmask", "IPv4 broadcast", "IPv6 address" *)
587
method get_port_0_ip_config =
588
let name = self#get_name in
591
(network#ifconfig#get_port_attribute_by_index
592
name 0 "IPv4 address")
596
(Ipv4.netmask_of_string
597
(network#ifconfig#get_port_attribute_by_index
598
name 0 "IPv4 netmask"))
603
method set_port_0_ipv4_address (ipv4:Ipv4.t) =
604
network#ifconfig#set_port_string_attribute_by_index
605
self#get_name 0 "IPv4 address"
606
(Ipv4.to_string ipv4);
608
method set_port_0_ipv4_netmask_by_cidr cidr =
609
let netmask_as_string = Ipv4.to_string (Ipv4.netmask_of_cidr cidr) in
610
network#ifconfig#set_port_string_attribute_by_index
611
self#get_name 0 "IPv4 netmask"
614
method set_port_0_ip_config port_0_ip_config =
615
let (ipv4,cidr) = port_0_ip_config in
616
self#set_port_0_ipv4_address ipv4;
617
self#set_port_0_ipv4_netmask_by_cidr cidr;
619
method update_router_with ~name ~label ~port_0_ip_config ~port_no ~kernel ~show_unix_terminal =
621
self_as_virtual_machine_with_history_and_ifconfig#update_virtual_machine_with ~name ~port_no kernel;
622
(* then we can set the object property "name" (read by #get_name): *)
623
self_as_node_with_ledgrid_and_defects#update_with ~name ~label ~port_no;
624
self#set_port_0_ip_config port_0_ip_config;
625
self#set_show_unix_terminal show_unix_terminal;
629
end (* module User_level_router *)
635
module Simulation_level = struct
636
(** A router: just a [machine_or_router] with [router = true] *)
637
class ['parent] router =
638
fun ~(parent:'parent)
639
~dynamically_get_the_cow_file_name_source
643
?(kernel_console_arguments)
644
~(filesystem_file_name)
645
~(ethernet_interface_no)
649
~unexpected_death_callback
652
inherit ['parent] Simulation_level.machine_or_router
655
~filesystem_file_name(* :"/usr/marionnet/filesystems/router.debian.lenny.sid.fs" *)
657
?kernel_console_arguments
658
~dynamically_get_the_cow_file_name_source
661
~ethernet_interface_no
662
~memory:Const.memory_default
664
(* Change this when debugging the router device *)
665
~console:"none" (* To do: this should be "none" for releases and "xterm" for debugging *)
669
~unexpected_death_callback
672
method device_type = "router"
675
end (* module Simulation_level *)
678
(** Just for testing: *)
679
let test = Dialog_add_or_update.make
added
removed
router.ml
