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
(** "cloud" component implementation. *)
26
(* Cloud related constants: *)
27
(* TODO: make it configurable! *)
29
let port_no_default = 2
34
(* The type of data exchanged with the dialog: *)
42
let to_string t = "<obj>" (* TODO? *)
45
module Make_menus (Params : sig
46
val st : State.globalState
47
val packing : [ `toolbar of GButton.toolbar | `menu_parent of Menu_factory.menu_parent ]
52
module Toolbar_entry = struct
53
let imagefile = "ico.cloud.palette.png"
54
let tooltip = s_ "Unknown layer 2 sub-network"
55
let packing = Params.packing
63
let ok_callback t = Gui_bricks.Ok_callback.check_name t.name t.old_name st#network#name_exists t
66
let name = st#network#suggestedName "N" in
67
Dialog_add_or_update.make ~title:(s_ "Add cloud") ~name ~ok_callback ()
69
let reaction { name = name; label = label } =
70
let action () = ignore (
71
new User_level_cloud.cloud
76
st#network_change action ();
80
module Properties = struct
82
let dynlist () = st#network#get_nodes_that_can_startup ~devkind:`Cloud ()
85
let d = (st#network#get_node_by_name name) in
86
let title = (s_ "Modify cloud")^" "^name in
87
let label = d#get_label in
88
Dialog_add_or_update.make ~title ~name ~label ~ok_callback:Add.ok_callback ()
90
let reaction { name = name; label = label; old_name = old_name } =
91
let d = (st#network#get_node_by_name old_name) in
92
let h = ((Obj.magic d):> User_level_cloud.cloud) in
93
let action () = h#update_cloud_with ~name ~label in
94
st#network_change action ();
98
module Remove = struct
99
type t = string (* just the name *)
100
let to_string = (Printf.sprintf "name = %s\n")
102
let dynlist = Properties.dynlist
105
Gui_bricks.Dialog.yes_or_cancel_question
107
~markup:(Printf.sprintf (f_ "Are you sure that you want to remove %s\nand all the cables connected to this %s?") name (s_ "cloud"))
112
let d = (st#network#get_node_by_name name) in
113
let h = ((Obj.magic d):> User_level_cloud.cloud) in
114
let action () = h#destroy in
115
st#network_change action ();
119
module Startup = struct
120
type t = string (* just the name *)
121
let to_string = (Printf.sprintf "name = %s\n")
122
let dynlist = Properties.dynlist
123
let dialog = Menu_factory.no_dialog_but_simply_return_name
124
let reaction name = (st#network#get_node_by_name name)#startup
129
type t = string (* just the name *)
130
let to_string = (Printf.sprintf "name = %s\n")
131
let dynlist () = st#network#get_nodes_that_can_gracefully_shutdown ~devkind:`Cloud ()
132
let dialog = Menu_factory.no_dialog_but_simply_return_name
133
let reaction name = (st#network#get_node_by_name name)#gracefully_shutdown
137
module Suspend = struct
138
type t = string (* just the name *)
139
let to_string = (Printf.sprintf "name = %s\n")
140
let dynlist () = st#network#get_nodes_that_can_suspend ~devkind:`Cloud ()
141
let dialog = Menu_factory.no_dialog_but_simply_return_name
142
let reaction name = (st#network#get_node_by_name name)#suspend
146
module Resume = struct
147
type t = string (* just the name *)
148
let to_string = (Printf.sprintf "name = %s\n")
149
let dynlist () = st#network#get_nodes_that_can_resume ~devkind:`Cloud ()
150
let dialog = Menu_factory.no_dialog_but_simply_return_name
151
let reaction name = (st#network#get_node_by_name name)#resume
155
module Create_entries =
156
Gui_toolbar_COMPONENTS_layouts.Layout_for_network_node (Params) (Toolbar_entry) (Add) (Properties) (Remove) (Startup) (Stop) (Suspend) (Resume)
158
(* Subscribe this kind of component to the network club: *)
159
st#network#subscribe_a_try_to_add_procedure Eval_forest_child.try_to_add_cloud;
167
module Dialog_add_or_update = struct
169
(* This function may be useful for testing the widget creation without
170
recompiling the whole project. *)
175
?(help_callback=help_callback) (* defined backward with "WHERE" *)
176
?(ok_callback=(fun data -> Some data))
177
?(dialog_image_file=Initialization.Path.images^"ico.cloud.dialog.png")
179
let old_name = name in
180
let (w,_,name,label) =
181
Gui_bricks.Dialog_add_or_update.make_window_image_name_and_label
183
~image_file:dialog_image_file
184
~image_tooltip:(s_ "Unknown layer 2 sub-network")
186
~name_tooltip:(s_ "Sub-network name. This name must be unique in the virtual network. Suggested: N1, N2, ... ")
191
let get_widget_data () :'result =
192
let name = name#text in
193
let label = label#text in
196
Data.old_name = old_name;
199
(* The result of make is the result of the dialog loop (of type 'result option): *)
200
Gui_bricks.Dialog_run.ok_or_cancel w ~ok_callback ~help_callback ~get_widget_data ()
207
let title = (s_ "ADD OR MODIFY A CLOUD" ) in
208
let msg = (s_ "In this dialog window you can define the name of a cloud. \
209
This component is an Ethernet network with an unknown internal \
210
structure introducing delays and other anomalies when packets \
212
Once the cloud is defined, use the tab 'Anomalies' to control delays, \
213
frame loss and the other anomalies.")
214
in Simple_dialogs.help title msg
222
module Eval_forest_child = struct
224
let try_to_add_cloud (network:User_level.network) ((root,childs):Xforest.tree) =
227
| ("cloud", attrs) ->
228
let name = List.assoc "name" attrs in
229
Log.printf "Importing cloud \"%s\"...\n" name;
230
let x = new User_level_cloud.cloud ~network ~name () in
231
x#from_tree ("cloud", attrs) childs ;
232
Log.printf "Cloud \"%s\" successfully imported.\n" name;
239
end (* module Eval_forest_child *)
247
module User_level_cloud = struct
255
object (self) inherit OoExtra.destroy_methods ()
258
User_level.node_with_defects
260
~name ?label ~devkind:`Cloud
261
~port_no:Const.port_no_default
262
~port_no_min:Const.port_no_min
263
~port_no_max:Const.port_no_max
267
as self_as_node_with_defects
268
method defects_device_type = "cloud"
269
method polarity = User_level.Intelligent (* Because it is didactically meaningless *)
270
method string_of_devkind = "cloud"
272
method dotImg iconsize =
273
let imgDir = Initialization.Path.images in
274
(imgDir^"ico.cloud."^(self#string_of_simulated_device_state)^"."^iconsize^".png")
276
method update_cloud_with ~name ~label =
277
self_as_node_with_defects#update_with ~name ~label ~port_no:2;
279
(** Create the simulated device *)
280
method private make_simulated_device =
281
((new Simulation_level_cloud.cloud
283
~unexpected_death_callback:self#destroy_because_of_unexpected_death
284
()) :> User_level.node Simulation_level.device)
287
Forest.tree_of_leaf ("cloud", [
288
("name" , self#get_name );
289
("label" , self#get_label);
292
method eval_forest_attribute = function
293
| ("name" , x ) -> self#set_name x
294
| ("label" , x ) -> self#set_label x
295
| _ -> () (* Forward-comp. *)
297
end (* class cloud *)
299
end (* module User_level_cloud *)
305
module Simulation_level_cloud = struct
309
class ['parent] cloud =
312
~unexpected_death_callback
315
inherit ['parent] Simulation_level.device
318
~unexpected_death_callback
321
method device_type = "cloud"
323
val internal_cable_process = ref None
324
method private get_internal_cable_process =
325
match !internal_cable_process with
326
Some internal_cable_process -> internal_cable_process
327
| None -> failwith "cloud: get_the_internal_cable_process was called when there is no such process"
332
method spawn_processes =
333
(* Create the internal cable process and spawn it: *)
334
let the_internal_cable_process =
335
Simulation_level.make_ethernet_cable_process
336
~left_end:(self#get_hublet_process_of_port 0)
337
~right_end:(self#get_hublet_process_of_port 1)
338
~leftward_defects:(parent#ports_card#get_my_inward_defects_by_index 0)
339
~rightward_defects:(parent#ports_card#get_my_outward_defects_by_index 0)
340
~unexpected_death_callback:self#execute_the_unexpected_death_callback
343
internal_cable_process := Some the_internal_cable_process;
344
the_internal_cable_process#spawn
346
method terminate_processes =
347
(* Terminate the internal cable process: *)
348
(try self#get_internal_cable_process#terminate with _ -> ());
349
(* Unreference it: *)
350
internal_cable_process := None;
352
(** As clouds are stateless from the point of view of the user, stop/continue
353
aren't distinguishable from terminate/spawn: *)
354
method stop_processes = self#terminate_processes
355
method continue_processes = self#spawn_processes
359
end (* module Simulation_level_cloud *)
361
(** Just for testing: *)
362
let test = Dialog_add_or_update.make
added
removed
cloud.ml
