From 25a40352ca36131c143ee4817cdbf9ac0ff72db5 Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 20 Sep 2012 02:38:26 +0100 Subject: [PATCH 01/75] fixing oasis file --- _oasis | 4 ++-- _tags | 14 +------------- setup.ml | 8 ++++---- 3 files changed, 7 insertions(+), 19 deletions(-) diff --git a/_oasis b/_oasis index 3ca2b76..fdb2422 100644 --- a/_oasis +++ b/_oasis @@ -44,7 +44,7 @@ Executable learning_switch_lwt MainIs: learning_switch.ml Build$: flag(lwt) Custom: true - CompiledObject: best + CompiledObject: native Install: false BuildDepends: cstruct, cstruct.syntax, openflow @@ -53,7 +53,7 @@ Executable basic_switch_lwt MainIs: basic_switch.ml Build$: flag(lwt) Custom: true - CompiledObject: best + CompiledObject: native Install: false BuildDepends: openflow diff --git a/_tags b/_tags index 56e24ac..6dcf32a 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 1790da9bc8f70d70b92ff9a71d1a8f1b) +# DO NOT EDIT (digest: dd7990914a6a608221f40ce0e4a2ade4) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -23,19 +23,7 @@ : pkg_mirage : pkg_mirage-net # Executable learning_switch_lwt -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_mirage -: pkg_mirage-net -: custom # Executable basic_switch_lwt -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_mirage -: pkg_mirage-net -: custom # Executable learning_switch_mirage : use_openflow : pkg_cstruct diff --git a/setup.ml b/setup.ml index 1038403..a2dbfd7 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.2.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: e7bddf76b679e718a961ab2e2e0f8534) *) +(* DO NOT EDIT (digest: 51fd861dc46531f91613c60947d76907) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6010,7 +6010,7 @@ let setup_t = ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "controller"; - bs_compiled_object = Best; + bs_compiled_object = Native; bs_build_depends = [ FindlibPackage ("cstruct", None); @@ -6046,7 +6046,7 @@ let setup_t = ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "switch"; - bs_compiled_object = Best; + bs_compiled_object = Native; bs_build_depends = [InternalLibrary "openflow"]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -6137,7 +6137,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "\131y\002~[):\189$\220;,\016\029\203\228"; + oasis_digest = Some "\157\247\216\175\244n-A\020\167i&\194\r\229="; oasis_exec = None; oasis_setup_args = []; setup_update = false; From 3afb44c4a2f0d3670bbdf198634af09c207fbbfc Mon Sep 17 00:00:00 2001 From: crotsos Date: Sun, 23 Sep 2012 10:26:10 -0700 Subject: [PATCH 02/75] A daemon to receive openflow configurations and a command line tool to add ports --- lib/ofswitch_config.ml | 114 ++++++++++++++++++++++++++++++++++++++++ lib/ofswitch_config.mli | 27 ++++++++++ lib/ofswitch_ctrl.ml | 52 ++++++++++++++++++ 3 files changed, 193 insertions(+) create mode 100644 lib/ofswitch_config.ml create mode 100644 lib/ofswitch_config.mli create mode 100644 lib/ofswitch_ctrl.ml diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml new file mode 100644 index 0000000..0596c6e --- /dev/null +++ b/lib/ofswitch_config.ml @@ -0,0 +1,114 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt +open Lwt_unix +open Printf + +type t = { +(* + dev_m: (string * string) Lwt_condition.t; + res_m: bool Lwt_condition.t; + *) + fd: Lwt_unix.file_descr; +} + +let add_port t dev = + let buf = String.create 4096 in + let req = Jsonrpc.string_of_call + (Rpc.call "add_port" [Rpc.String dev]) in + lwt _ = send t.fd req 0 (String.length req) [] in + lwt len = recv t.fd buf 0 4096 [] in + let resp = Jsonrpc.response_of_string buf in + return (resp.Rpc.success) + (* + let _ = Lwt_condition.signal t.dev_m ("add_port", dev) in + Lwt_condition.wait t.res_m + + *) +let del_port t dev = + return false + (* + let _ = Lwt_condition.signal t.dev_m ("add_port", dev) in + Lwt_condition.wait t.res_m + *) + + (* +let client_t mgr client t = + let _ = Lwt_condition.signal client.res_m true in + while_lwt true do + lwt (op, dev) = Lwt_condition.wait client.dev_m in + let req = Jsonrpc.string_of_call + (Rpc.call op [Rpc.String dev]) in + let _ = Net.Channel.write_string t req 0 (String.length req) in + lwt _ = Net.Channel.flush t in + lwt resp_str = Net.Channel.read_some t in + let resp = + Jsonrpc.response_of_string + (Cstruct.to_string resp_str) in + return (Lwt_condition.signal client.res_m resp.Rpc.success) + done + +let connect_client mgr dst = + try_lwt + let dev_m = Lwt_condition.create () in + let res_m = Lwt_condition.create () in + let cl = {dev_m; res_m;} in + let _ = + Lwt.ignore_result + (Net.Channel.connect mgr + (`TCPv4 (None, dst, (client_t mgr cl)))) in + lwt res = Lwt_condition.wait cl.res_m in + match res with + | true -> return cl + | false -> failwith "ofswitch_config client failed" + with ex -> + failwith (sprintf "ofswitch_config client failed: %s" + (Printexc.to_string ex)) + *) + +let connect_client () = + try_lwt + let sock = socket PF_INET SOCK_STREAM 0 in + let dst = ADDR_INET( (Unix.inet_addr_of_string "10.0.0.2"), + 6634) in + lwt _ = connect sock dst in + let cl = {fd=sock;} in + return cl + with ex -> + failwith (sprintf "ofswitch_config client failed: %s" + (Printexc.to_string ex)) + +let listen_t mgr port = + let listen_inner mgr dst t = + while_lwt true do + lwt req = Net.Channel.read_some t in + let req = Jsonrpc.call_of_string + (Cstruct.to_string req) in + lwt success = + match (req.Rpc.name, req.Rpc.params) with + | ("add_port", (Rpc.String (dev))::_) -> Net.Manager.attach mgr dev + | ("del_port", (Rpc.String (dev))::_) -> Net.Manager.detach mgr dev + | (_, _) -> return false + in + let resp = + Jsonrpc.string_of_response (Rpc.success (Rpc.Null)) in + let _ = Net.Channel.write_string t resp in + Net.Channel.flush t + done + in + Net.Channel.listen mgr + (`TCPv4 ((None, port), (listen_inner mgr) )) diff --git a/lib/ofswitch_config.mli b/lib/ofswitch_config.mli new file mode 100644 index 0000000..8e8f4fb --- /dev/null +++ b/lib/ofswitch_config.mli @@ -0,0 +1,27 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t + +val add_port: t -> string -> bool Lwt.t +val del_port: t -> string -> bool Lwt.t +(* +val connect_client: Net.Manager.t -> + Net.Nettypes.ipv4_dst -> t Lwt.t + *) +val connect_client: unit -> t Lwt.t +val listen_t: Net.Manager.t -> + int -> unit Lwt.t diff --git a/lib/ofswitch_ctrl.ml b/lib/ofswitch_ctrl.ml new file mode 100644 index 0000000..9865a01 --- /dev/null +++ b/lib/ofswitch_ctrl.ml @@ -0,0 +1,52 @@ +(* + * Copyright (c) 2011 Richard Mortier + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt +open Printf +open Ofswitch_config +open Lwt_unix + +let check_cmd_args cmd count = + if ((Array.length Sys.argv) < (2 + count)) then + failwith (sprintf "Insufficient args for command %s (required %d)" + cmd count) + +let send_cmd cl = + try_lwt + let _ = + if ((Array.length Sys.argv) < 2) then + failwith "No command defined" + in + match (Sys.argv.(1)) with + | "add-port" -> + let _ = check_cmd_args "add_port" 1 in + lwt _ = Ofswitch_config.add_port cl Sys.argv.(2) in + return () + | _ -> + let _ = printf "Fail: unknown cmd: %s\n%!" Sys.argv.(1) in + return () + with ex -> + return (printf "Fail: %s" (Printexc.to_string ex)) + +lwt _ = + try_lwt + lwt cl = Ofswitch_config.connect_client () in + lwt _ = send_cmd cl in + return () + with e -> + Printf.eprintf "Error: %s" (Printexc.to_string e); + return () From fe5f1d2ca76c72c8d41f2233afd4d954efca9138 Mon Sep 17 00:00:00 2001 From: crotsos Date: Sun, 23 Sep 2012 10:27:06 -0700 Subject: [PATCH 03/75] switch now send a port_status when a port is added. Fixed parsing code for port_status messages. --- lib/ofpacket.ml | 10 ++++++++ lib/ofpacket.mli | 2 ++ lib/ofswitch.ml | 54 +++++++++++++++++++++++++++++++++++------- lib/ofswitch.mli | 3 ++- myocamlbuild.ml | 16 ++++++------- switch/basic_switch.ml | 18 +++++++------- 6 files changed, 78 insertions(+), 25 deletions(-) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 644bac5..e8cc6b0 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -552,7 +552,17 @@ module Port = struct in let _ = Cstruct.shift_left bits sizeof_ofp_port_status in {reason; desc=(parse_phy bits)} + let create_port_status reason desc = + {reason; desc;} + let marshal_port_status ?(xid=0l) status bits = + let len = Header.get_len + sizeof_ofp_port_status + phy_len in + let header = Header.create Header.PORT_STATUS len xid in + let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in + let _ = set_ofp_port_status_reason bits (reason_to_int status.reason) in + let bits = Cstruct.shift bits sizeof_ofp_port_status in + let _ = marshal_phy status.desc bits in + len end module Switch = struct diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index 61d748f..886be37 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -148,6 +148,8 @@ module Port : val reason_to_string: reason -> string type status = { reason : reason; desc : phy; } val string_of_status : status -> string + val create_port_status: reason -> phy -> status + val marshal_port_status: ?xid:int32 -> status -> Cstruct.buf -> int end module Switch : sig diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index ac5332c..68dc862 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -18,6 +18,7 @@ open Lwt open Net open Nettypes +open Ofswitch_config module OP = Ofpacket @@ -499,7 +500,7 @@ type t = Switch.t (* * let process_frame_depr intf_name frame = *) let process_frame_inner st intf frame = - try_lwt + try_lwt let p = (!(Hashtbl.find st.Switch.dev_to_port intf)) in let in_port = (OP.Port.port_of_int p.Switch.port_id) in let tupple = (OP.Match.raw_packet_to_match in_port frame ) in @@ -510,10 +511,7 @@ let process_frame_inner st intf frame = * process it *) let frame = match (Switch.size_of_raw_packet frame) with - | Some(len) -> - let _ = pr "received packet of size %d (buf len %d)\n%!" - (Cstruct.len frame) len in - Cstruct.sub_buffer frame 0 len + | Some(len) -> Cstruct.sub_buffer frame 0 len | None -> raise Packet_type_unknw in (* Lookup packet flow to existing flows in table *) @@ -752,7 +750,9 @@ let process_openflow st t bits = function (OS.Io_page.get ()) in let _ = Channel.write_buffer t bs in Channel.flush t - | Some(pkt_in) -> + | Some(pkt_in) -> + let _ = pr "Sending as packet_out data %d\n%!" + (Cstruct.len pkt_in.OP.Packet_in.data) in Switch.apply_of_actions st pkt_in.OP.Packet_in.in_port pkt_in.OP.Packet_in.data pkt.OP.Packet_out.actions end @@ -864,9 +864,43 @@ let add_port mgr sw ethif = Hashtbl.add sw.Switch.dev_to_port ethif (ref port); sw.Switch.features.OP.Switch.ports <- sw.Switch.features.OP.Switch.ports @ [port.Switch.phy]; + let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw) in + let port_status = OP.Port.create_port_status OP.Port.ADD port.Switch.phy in + let bits = OP.marshal_and_sub (OP.Port.marshal_port_status port_status) + (Lwt_bytes.create 2048) in + lwt _ = Lwt_list.iter_p + (fun t -> + let _ = Net.Channel.write_buffer t bits in + Net.Channel.flush t + ) + sw.Switch.controllers in + return () + +let add_port_local mgr sw ethif = + let _ = pr "Adding port 0 (%s)\n %!" + (Net.Manager.get_intf_name mgr ethif) in + (*TODO Find first if a port is already registered as port 0 + * as port 0 and disable it *) + let port = Switch.init_port mgr 0 ethif in + sw.Switch.ports <- + (List.filter (fun a -> (a.Switch.port_id <> 0)) sw.Switch.ports) + @ [port]; + Hashtbl.replace sw.Switch.int_to_port 0 (ref port); + Hashtbl.iter + (fun a b -> + if (!b.Switch.port_id = 0) then + Hashtbl.remove sw.Switch.dev_to_port a + ) sw.Switch.dev_to_port; + Hashtbl.add sw.Switch.dev_to_port ethif (ref port); + (*TODO Need to filter out any 0 port *) + sw.Switch.features.OP.Switch.ports <- + (List.filter (fun a -> (a.OP.Port.port_no <> 0)) + sw.Switch.features.OP.Switch.ports ) + @ [port.Switch.phy]; let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw) in () + let create_switch () = let (packet_queue, push_packet) = Lwt_stream.create () in Switch.( @@ -877,7 +911,11 @@ let create_switch () = packet_buffer=[]; packet_buffer_id=0l};) let listen st mgr loc = - Channel.listen mgr (`TCPv4 (loc, (control_channel st))) <&> (data_plane st ()) + Channel.listen mgr (`TCPv4 (loc, (control_channel st))) <&> + (Ofswitch_config.listen_t mgr 6634) <&> + (data_plane st ()) let connect st mgr loc = - Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> (data_plane st ()) + Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> + (Ofswitch_config.listen_t mgr 6634) <&> + (data_plane st ()) diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index b544fde..dabd768 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -16,7 +16,8 @@ *) type t -val add_port : Net.Manager.t -> t -> Net.Manager.id -> unit +val add_port : Net.Manager.t -> t -> Net.Manager.id -> unit Lwt.t +val add_port_local : Net.Manager.t -> t -> Net.Manager.id -> unit val create_switch : unit -> t val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> unit Lwt.t diff --git a/myocamlbuild.ml b/myocamlbuild.ml index f33e739..1f90a8f 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: dbfa1d0236d637cd0031feb9743abecd) *) +(* DO NOT EDIT (digest: 32161ea95f034567b4a3e8f24bb83d88) *) module OASISGettext = struct -# 21 "/home/cr409/oasis/src/oasis/OASISGettext.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISGettext.ml" let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -# 21 "/home/cr409/oasis/src/oasis/OASISExpr.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISExpr.ml" @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -# 21 "/home/cr409/oasis/src/base/BaseEnvLight.ml" +# 21 "/Users/cr409/oasis/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildXen = struct -# 22 "/home/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildXen.ml" +# 22 "/Users/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildXen.ml" open Ocamlbuild_plugin @@ -282,7 +282,7 @@ module MyOCamlbuildXen = struct end module MyOCamlbuildFindlib = struct -# 21 "/home/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" +# 21 "/Users/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -394,7 +394,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -# 21 "/home/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +# 21 "/Users/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -410,7 +410,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -# 56 "/home/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +# 56 "/Users/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" type t = { diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index 76485e4..b111f28 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -32,20 +32,22 @@ let print_time () = let switch_run () = let sw = Ofswitch.create_switch () in try_lwt - Manager.create ~devs:3 + Manager.create ~devs:2 (*~attached:(["vboxnet0"]) *) (fun mgr interface id -> match (Manager.get_intf_name mgr id) with - | "tap0" -> + | "tap0" + | "0" -> let ip = - (ipv4_addr_of_tuple (10l,0l,0l,1l), + (ipv4_addr_of_tuple (10l,0l,0l,2l), ipv4_addr_of_tuple (255l,255l,255l,0l), []) in lwt _ = Manager.configure interface (`IPv4 ip) in - let dst_ip = ipv4_addr_of_tuple (10l,0l,0l,2l) in - lwt _ = (Ofswitch.listen sw mgr (None, 6633) <&> - (print_time ())) in + let dst_ip = ipv4_addr_of_tuple (10l,0l,0l,1l) in + let _ = printf "connecting switch...\n%!" in + lwt _ = Ofswitch.connect sw mgr (dst_ip, 6633) in + let _ = printf "connect returned...\n%!" in return () - | _ -> - return (Ofswitch.add_port mgr sw id) + | "1" -> return (Ofswitch.add_port_local mgr sw id) + | _ -> Ofswitch.add_port mgr sw id ) with e -> Printf.eprintf "Error: %s" (Printexc.to_string e); From 206220cc15cdf388eff9c9d2144f34c112471425 Mon Sep 17 00:00:00 2001 From: crotsos Date: Sun, 23 Sep 2012 10:28:21 -0700 Subject: [PATCH 04/75] Adding new _oasis file for the additional source files. update build generated files --- Makefile | 14 ++-- _oasis | 18 +++-- _tags | 21 ++++-- lib/META | 4 +- lib/openflow.mlpack | 3 +- setup.ml | 165 ++++++++++++++++++-------------------------- 6 files changed, 108 insertions(+), 117 deletions(-) diff --git a/Makefile b/Makefile index e8659e1..218223a 100644 --- a/Makefile +++ b/Makefile @@ -5,25 +5,21 @@ NAME=openflow J=4 LWT ?= $(shell if ocamlfind query lwt.ssl >/dev/null 2>&1; then echo --enable-lwt; fi) -ASYNC ?= $(shell if ocamlfind query async_core >/dev/null 2>&1; then echo --enable-async; fi) MIRAGE ?= $(shell if ocamlfind query mirage-net >/dev/null 2>&1; then echo --enable-mirage; fi) -ifneq ($(MIRAGE_OS),xen) -TESTS ?= --enable-tests -endif -include Makefile.config -clean: setup.data +clean: setup.data setup.bin ./setup.bin -clean $(OFLAGS) rm -f setup.data setup.log setup.bin -distclean: setup.data +distclean: setup.data setup.bin ./setup.bin -distclean $(OFLAGS) rm -f setup.data setup.log setup.bin -setup: setup.data +setup: setup.data setup.bin -build: setup.data $(wildcard lib/*.ml) +build: setup.data setup.bin $(wildcard lib/*.ml) ./setup.bin -build -j $(J) $(OFLAGS) doc: setup.data setup.bin @@ -50,4 +46,4 @@ setup.bin: setup.ml $(RM) setup.cmx setup.cmi setup.o setup.cmo setup.data: setup.bin - ./setup.bin -configure $(LWT) $(ASYNC) $(MIRAGE) $(TESTS) $(NETTESTS) + ./setup.bin -configure $(LWT) --disable-mirage diff --git a/_oasis b/_oasis index fdb2422..551fe50 100644 --- a/_oasis +++ b/_oasis @@ -28,9 +28,9 @@ Flag nettests Library openflow Path: lib Findlibname: openflow - Modules: Ofpacket, Ofcontroller, Ofswitch + Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch Pack: True - BuildDepends: cstruct, cstruct.syntax, mirage, mirage-net (>= 0.3.0) + BuildDepends: cstruct, cstruct.syntax, rpc, mirage, mirage-net (>= 0.3.0) Document openflow Title: OpenFlow docs @@ -39,6 +39,16 @@ Document openflow XOCamlbuildPath: lib XOCamlbuildModules: Ofpacket, Ofcontroller, Ofswitch +Executable ofswitch_ctrl + Path: lib + MainIs: ofswitch_ctrl.ml + Build$: flag(lwt) + Custom: true + CompiledObject: native + Install: false + BuildDepends: openflow + + Executable learning_switch_lwt Path: controller MainIs: learning_switch.ml @@ -57,7 +67,7 @@ Executable basic_switch_lwt Install: false BuildDepends: openflow -Executable learning_switch_mirage +(*Executable learning_switch_mirage Path: controller MainIs: learning_switch.ml Build$: flag(mirage) @@ -75,4 +85,4 @@ Executable basic_switch_mirage CompiledObject: native Target: xen Install: false - BuildDepends: openflow + BuildDepends: openflow*) diff --git a/_tags b/_tags index 6dcf32a..7af304e 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: dd7990914a6a608221f40ce0e4a2ade4) +# DO NOT EDIT (digest: b02617c692f6bf096916733d41523409) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -17,34 +17,47 @@ "lib/openflow.cmxs": use_openflow "lib/ofpacket.cmx": for-pack(Openflow) "lib/ofcontroller.cmx": for-pack(Openflow) +"lib/ofswitch_config.cmx": for-pack(Openflow) "lib/ofswitch.cmx": for-pack(Openflow) +# Executable ofswitch_ctrl +: use_openflow +: pkg_cstruct +: pkg_cstruct.syntax +: pkg_rpc +: pkg_mirage +: pkg_mirage-net +: use_openflow : pkg_cstruct : pkg_cstruct.syntax +: pkg_rpc : pkg_mirage : pkg_mirage-net +: custom # Executable learning_switch_lwt -# Executable basic_switch_lwt -# Executable learning_switch_mirage : use_openflow : pkg_cstruct : pkg_cstruct.syntax +: pkg_rpc : pkg_mirage : pkg_mirage-net : use_openflow : pkg_cstruct : pkg_cstruct.syntax +: pkg_rpc : pkg_mirage : pkg_mirage-net : custom -# Executable basic_switch_mirage +# Executable basic_switch_lwt : use_openflow : pkg_cstruct : pkg_cstruct.syntax +: pkg_rpc : pkg_mirage : pkg_mirage-net : use_openflow : pkg_cstruct : pkg_cstruct.syntax +: pkg_rpc : pkg_mirage : pkg_mirage-net : custom diff --git a/lib/META b/lib/META index 8e1e4ee..b1e399d 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: f5e8b8a6695871d05a454bbedcc5779a) +# DO NOT EDIT (digest: 6849fb3ace6d3535ac1163c91dc21113) version = "0.3.0" description = "OpenFlow protocol and switch implementations in pure OCaml" -requires = "cstruct cstruct.syntax mirage mirage-net" +requires = "cstruct cstruct.syntax rpc mirage mirage-net" archive(byte) = "openflow.cma" archive(byte, plugin) = "openflow.cma" archive(native) = "openflow.cmxa" diff --git a/lib/openflow.mlpack b/lib/openflow.mlpack index 26a1c02..5828c2a 100644 --- a/lib/openflow.mlpack +++ b/lib/openflow.mlpack @@ -1,6 +1,7 @@ # OASIS_START -# DO NOT EDIT (digest: 169e106a3d54b9d1a37dc1f99698ecbb) +# DO NOT EDIT (digest: dd263c48adf310d29b88feb5aef173c7) Ofpacket Ofcontroller +Ofswitch_config Ofswitch # OASIS_STOP diff --git a/setup.ml b/setup.ml index a2dbfd7..3242726 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.2.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 51fd861dc46531f91613c60947d76907) *) +(* DO NOT EDIT (digest: e29e9bf67d9b44260daea4788e1f0556) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -# 21 "/home/cr409/oasis/src/oasis/OASISGettext.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISGettext.ml" let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -# 21 "/home/cr409/oasis/src/oasis/OASISContext.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISContext.ml" open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -# 1 "/home/cr409/oasis/src/oasis/OASISString.ml" +# 1 "/Users/cr409/oasis/src/oasis/OASISString.ml" @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -# 21 "/home/cr409/oasis/src/oasis/OASISUtils.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISUtils.ml" open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -# 21 "/home/cr409/oasis/src/oasis/PropList.ml" +# 21 "/Users/cr409/oasis/src/oasis/PropList.ml" open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -# 71 "/home/cr409/oasis/src/oasis/PropList.ml" +# 71 "/Users/cr409/oasis/src/oasis/PropList.ml" end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -# 21 "/home/cr409/oasis/src/oasis/OASISMessage.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISMessage.ml" open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -# 21 "/home/cr409/oasis/src/oasis/OASISVersion.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISVersion.ml" open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -# 21 "/home/cr409/oasis/src/oasis/OASISLicense.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISLicense.ml" (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -# 21 "/home/cr409/oasis/src/oasis/OASISExpr.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISExpr.ml" @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -# 21 "/home/cr409/oasis/src/oasis/OASISTypes.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISTypes.ml" @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -# 102 "/home/cr409/oasis/src/oasis/OASISTypes.ml" +# 102 "/Users/cr409/oasis/src/oasis/OASISTypes.ml" type 'a conditional = 'a OASISExpr.choices @@ -1185,7 +1185,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -# 21 "/home/cr409/oasis/src/oasis/OASISUnixPath.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISUnixPath.ml" type unix_filename = string type unix_dirname = string @@ -1269,7 +1269,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -# 21 "/home/cr409/oasis/src/oasis/OASISHostPath.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISHostPath.ml" open Filename @@ -1302,7 +1302,7 @@ module OASISHostPath = struct end module OASISSection = struct -# 21 "/home/cr409/oasis/src/oasis/OASISSection.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISSection.ml" open OASISTypes @@ -1385,12 +1385,12 @@ module OASISSection = struct end module OASISBuildSection = struct -# 21 "/home/cr409/oasis/src/oasis/OASISBuildSection.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISBuildSection.ml" end module OASISExecutable = struct -# 21 "/home/cr409/oasis/src/oasis/OASISExecutable.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISExecutable.ml" open OASISTypes @@ -1421,7 +1421,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -# 21 "/home/cr409/oasis/src/oasis/OASISLibrary.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISLibrary.ml" open OASISTypes open OASISUtils @@ -1599,7 +1599,7 @@ module OASISLibrary = struct end module OASISObject = struct -# 21 "/home/cr409/oasis/src/oasis/OASISObject.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISObject.ml" open OASISTypes open OASISGettext @@ -1664,7 +1664,7 @@ module OASISObject = struct end module OASISFindlib = struct -# 21 "/home/cr409/oasis/src/oasis/OASISFindlib.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISFindlib.ml" open OASISTypes @@ -1951,32 +1951,32 @@ module OASISFindlib = struct end module OASISFlag = struct -# 21 "/home/cr409/oasis/src/oasis/OASISFlag.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISFlag.ml" end module OASISPackage = struct -# 21 "/home/cr409/oasis/src/oasis/OASISPackage.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISPackage.ml" end module OASISSourceRepository = struct -# 21 "/home/cr409/oasis/src/oasis/OASISSourceRepository.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISSourceRepository.ml" end module OASISTest = struct -# 21 "/home/cr409/oasis/src/oasis/OASISTest.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISTest.ml" end module OASISDocument = struct -# 21 "/home/cr409/oasis/src/oasis/OASISDocument.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISDocument.ml" end module OASISExec = struct -# 21 "/home/cr409/oasis/src/oasis/OASISExec.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISExec.ml" open OASISGettext open OASISUtils @@ -2054,7 +2054,7 @@ module OASISExec = struct end module OASISFileUtil = struct -# 21 "/home/cr409/oasis/src/oasis/OASISFileUtil.ml" +# 21 "/Users/cr409/oasis/src/oasis/OASISFileUtil.ml" open OASISGettext @@ -2251,7 +2251,7 @@ end # 2252 "setup.ml" module BaseEnvLight = struct -# 21 "/home/cr409/oasis/src/base/BaseEnvLight.ml" +# 21 "/Users/cr409/oasis/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) @@ -2349,7 +2349,7 @@ end # 2350 "setup.ml" module BaseContext = struct -# 21 "/home/cr409/oasis/src/base/BaseContext.ml" +# 21 "/Users/cr409/oasis/src/base/BaseContext.ml" open OASISContext @@ -2360,7 +2360,7 @@ module BaseContext = struct end module BaseMessage = struct -# 21 "/home/cr409/oasis/src/base/BaseMessage.ml" +# 21 "/Users/cr409/oasis/src/base/BaseMessage.ml" (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2379,7 +2379,7 @@ module BaseMessage = struct end module BaseEnv = struct -# 21 "/home/cr409/oasis/src/base/BaseEnv.ml" +# 21 "/Users/cr409/oasis/src/base/BaseEnv.ml" open OASISGettext open OASISUtils @@ -2839,7 +2839,7 @@ module BaseEnv = struct end module BaseArgExt = struct -# 21 "/home/cr409/oasis/src/base/BaseArgExt.ml" +# 21 "/Users/cr409/oasis/src/base/BaseArgExt.ml" open OASISUtils open OASISGettext @@ -2867,7 +2867,7 @@ module BaseArgExt = struct end module BaseCheck = struct -# 21 "/home/cr409/oasis/src/base/BaseCheck.ml" +# 21 "/Users/cr409/oasis/src/base/BaseCheck.ml" open BaseEnv open BaseMessage @@ -2993,7 +2993,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -# 21 "/home/cr409/oasis/src/base/BaseOCamlcConfig.ml" +# 21 "/Users/cr409/oasis/src/base/BaseOCamlcConfig.ml" open BaseEnv @@ -3109,7 +3109,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -# 21 "/home/cr409/oasis/src/base/BaseStandardVar.ml" +# 21 "/Users/cr409/oasis/src/base/BaseStandardVar.ml" open OASISGettext @@ -3473,7 +3473,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -# 21 "/home/cr409/oasis/src/base/BaseFileAB.ml" +# 21 "/Users/cr409/oasis/src/base/BaseFileAB.ml" open BaseEnv open OASISGettext @@ -3521,7 +3521,7 @@ module BaseFileAB = struct end module BaseLog = struct -# 21 "/home/cr409/oasis/src/base/BaseLog.ml" +# 21 "/Users/cr409/oasis/src/base/BaseLog.ml" open OASISUtils @@ -3640,7 +3640,7 @@ module BaseLog = struct end module BaseBuilt = struct -# 21 "/home/cr409/oasis/src/base/BaseBuilt.ml" +# 21 "/Users/cr409/oasis/src/base/BaseBuilt.ml" open OASISTypes open OASISGettext @@ -3808,7 +3808,7 @@ module BaseBuilt = struct end module BaseCustom = struct -# 21 "/home/cr409/oasis/src/base/BaseCustom.ml" +# 21 "/Users/cr409/oasis/src/base/BaseCustom.ml" open BaseEnv open BaseMessage @@ -3858,7 +3858,7 @@ module BaseCustom = struct end module BaseDynVar = struct -# 21 "/home/cr409/oasis/src/base/BaseDynVar.ml" +# 21 "/Users/cr409/oasis/src/base/BaseDynVar.ml" open OASISTypes @@ -3905,7 +3905,7 @@ module BaseDynVar = struct end module BaseTest = struct -# 21 "/home/cr409/oasis/src/base/BaseTest.ml" +# 21 "/Users/cr409/oasis/src/base/BaseTest.ml" open BaseEnv open BaseMessage @@ -3995,7 +3995,7 @@ module BaseTest = struct end module BaseDoc = struct -# 21 "/home/cr409/oasis/src/base/BaseDoc.ml" +# 21 "/Users/cr409/oasis/src/base/BaseDoc.ml" open BaseEnv open BaseMessage @@ -4030,7 +4030,7 @@ module BaseDoc = struct end module BaseSetup = struct -# 21 "/home/cr409/oasis/src/base/BaseSetup.ml" +# 21 "/Users/cr409/oasis/src/base/BaseSetup.ml" open BaseEnv open BaseMessage @@ -4611,7 +4611,7 @@ end # 4612 "setup.ml" module InternalConfigurePlugin = struct -# 21 "/home/cr409/oasis/src/plugins/internal/InternalConfigurePlugin.ml" +# 21 "/Users/cr409/oasis/src/plugins/internal/InternalConfigurePlugin.ml" (** Configure using internal scheme @author Sylvain Le Gall @@ -4867,7 +4867,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -# 21 "/home/cr409/oasis/src/plugins/internal/InternalInstallPlugin.ml" +# 21 "/Users/cr409/oasis/src/plugins/internal/InternalInstallPlugin.ml" (** Install using internal scheme @author Sylvain Le Gall @@ -5452,7 +5452,7 @@ end # 5453 "setup.ml" module OCamlbuildCommon = struct -# 21 "/home/cr409/oasis/src/plugins/ocamlbuild/OCamlbuildCommon.ml" +# 21 "/Users/cr409/oasis/src/plugins/ocamlbuild/OCamlbuildCommon.ml" (** Functions common to OCamlbuild build and doc plugin *) @@ -5554,7 +5554,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -# 21 "/home/cr409/oasis/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" +# 21 "/Users/cr409/oasis/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" (** Build using ocamlbuild @author Sylvain Le Gall @@ -5759,7 +5759,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -# 21 "/home/cr409/oasis/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" +# 21 "/Users/cr409/oasis/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5945,6 +5945,7 @@ let setup_t = [ FindlibPackage ("cstruct", None); FindlibPackage ("cstruct.syntax", None); + FindlibPackage ("rpc", None); FindlibPackage ("mirage", None); FindlibPackage ("mirage-net", @@ -5961,7 +5962,13 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { - lib_modules = ["Ofpacket"; "Ofcontroller"; "Ofswitch"]; + lib_modules = + [ + "Ofpacket"; + "Ofcontroller"; + "Ofswitch_config"; + "Ofswitch" + ]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = None; @@ -5998,43 +6005,7 @@ let setup_t = }); Executable ({ - cs_name = "learning_switch_lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "lwt", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "controller"; - bs_compiled_object = Native; - bs_build_depends = - [ - FindlibPackage ("cstruct", None); - FindlibPackage ("cstruct.syntax", None); - InternalLibrary "openflow" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - exec_custom = true; - exec_main_is = "learning_switch.ml"; - exec_target = None; - }); - Executable - ({ - cs_name = "basic_switch_lwt"; + cs_name = "ofswitch_ctrl"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -6045,7 +6016,7 @@ let setup_t = (OASISExpr.EFlag "lwt", true) ]; bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "switch"; + bs_path = "lib"; bs_compiled_object = Native; bs_build_depends = [InternalLibrary "openflow"]; bs_build_tools = [ExternalTool "ocamlbuild"]; @@ -6060,12 +6031,12 @@ let setup_t = }, { exec_custom = true; - exec_main_is = "basic_switch.ml"; + exec_main_is = "ofswitch_ctrl.ml"; exec_target = None; }); Executable ({ - cs_name = "learning_switch_mirage"; + cs_name = "learning_switch_lwt"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -6073,7 +6044,7 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "mirage", true) + (OASISExpr.EFlag "lwt", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "controller"; @@ -6097,11 +6068,11 @@ let setup_t = { exec_custom = true; exec_main_is = "learning_switch.ml"; - exec_target = Some "xen"; + exec_target = None; }); Executable ({ - cs_name = "basic_switch_mirage"; + cs_name = "basic_switch_lwt"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -6109,7 +6080,7 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "mirage", true) + (OASISExpr.EFlag "lwt", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "switch"; @@ -6128,7 +6099,7 @@ let setup_t = { exec_custom = true; exec_main_is = "basic_switch.ml"; - exec_target = Some "xen"; + exec_target = None; }) ]; plugins = [(`Extra, "META", Some "0.2")]; @@ -6137,7 +6108,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "\157\247\216\175\244n-A\020\167i&\194\r\229="; + oasis_digest = Some "$ºÉÛ&W¬fõÂ\139\142íÝÒ}"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6145,6 +6116,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6149 "setup.ml" +# 6120 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 8b99c95b66f1f491a46536b22c8415a4ffb9264e Mon Sep 17 00:00:00 2001 From: crotsos Date: Fri, 28 Sep 2012 18:54:56 +0100 Subject: [PATCH 05/75] Extend the Datapath_join event definition --- controller/learning_switch.ml | 2 +- lib/ofcontroller.ml | 6 +++--- lib/ofcontroller.mli | 2 +- switch/basic_switch.ml | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index 4af60d7..b5d63ae 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -54,7 +54,7 @@ let switch_data = let datapath_join_cb controller dpid evt = let dp = match evt with - | OE.Datapath_join (c) -> c + | OE.Datapath_join (c, _) -> c | _ -> invalid_arg "bogus datapath_join event match!" in switch_data.dpid <- switch_data.dpid @ [dp]; diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index ffa6de9..ec74f69 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -38,7 +38,7 @@ module Event = struct | PORT_STATS_REPLY | TABLE_STATS_REPLY | PORT_STATUS_CHANGE type e = - | Datapath_join of OP.datapath_id + | Datapath_join of OP.datapath_id * OP.Port.phy list | Datapath_leave of OP.datapath_id | Packet_in of OP.Port.t * int32 * Cstruct.buf * OP.datapath_id | Flow_removed of @@ -54,7 +54,7 @@ module Event = struct | Port_status of OP.Port.reason * OP.Port.phy * OP.datapath_id let string_of_event = function - | Datapath_join dpid -> sp "Datapath_join: dpid:0x%012Lx" dpid + | Datapath_join(dpid, _) -> sp "Datapath_join: dpid:0x%012Lx" dpid | Datapath_leave dpid -> sp "Datapath_leave: dpid:0x%012Lx" dpid | Packet_in (port, buffer_id, bs, dpid) -> (sp "Packet_in: port:%s ... dpid:0x%012Lx buffer_id:%ld" @@ -172,7 +172,7 @@ let process_of_packet state (remote_addr, remote_port) ofp t = | Features_resp (h, sfs) (* Generate a datapath join event *) -> ((* cp "FEATURES_RESP";*) let dpid = sfs.Switch.datapath_id in - let evt = Event.Datapath_join dpid in + let evt = Event.Datapath_join(dpid, sfs.OP.Switch.ports) in if (Hashtbl.mem state.dp_db dpid) then ( Printf.printf "Deleting old state \n%!"; Hashtbl.remove state.dp_db dpid; diff --git a/lib/ofcontroller.mli b/lib/ofcontroller.mli index 96ab82b..e6f1ded 100644 --- a/lib/ofcontroller.mli +++ b/lib/ofcontroller.mli @@ -33,7 +33,7 @@ module Event : sig | PORT_STATUS_CHANGE type e = - Datapath_join of datapath_id + Datapath_join of datapath_id * Ofpacket.Port.phy list | Datapath_leave of datapath_id | Packet_in of Port.t * int32 * Cstruct.buf * datapath_id | Flow_removed of Match.t * Flow_removed.reason * diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index b111f28..3206a5b 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -32,7 +32,7 @@ let print_time () = let switch_run () = let sw = Ofswitch.create_switch () in try_lwt - Manager.create ~devs:2 (*~attached:(["vboxnet0"]) *) + Manager.create ~devs:2 ~attached:(["vboxnet0"]) (fun mgr interface id -> match (Manager.get_intf_name mgr id) with | "tap0" From dbf75fc20d6d0f113e644cdbedad7c067840f6be Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Sun, 7 Oct 2012 00:33:05 +0000 Subject: [PATCH 06/75] synching with the mirage code --- lib/ofcontroller.ml | 72 ++++++++++------- lib/ofpacket.ml | 187 ++++++++++++++++++++++++++++++++++++-------- lib/ofpacket.mli | 15 ++-- 3 files changed, 206 insertions(+), 68 deletions(-) diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index ec74f69..3b4f142 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -16,14 +16,13 @@ open Lwt open Lwt_list -(* open Openflow_net_lwt *) open Net open Printexc let sp = Printf.sprintf let pp = Printf.printf let ep = Printf.eprintf -let cp = Printf.printf "%s\n%!" +let cp = OS.Console.log module OP = Ofpacket @@ -38,7 +37,7 @@ module Event = struct | PORT_STATS_REPLY | TABLE_STATS_REPLY | PORT_STATUS_CHANGE type e = - | Datapath_join of OP.datapath_id * OP.Port.phy list + | Datapath_join of OP.datapath_id * OP.Port.phy list | Datapath_leave of OP.datapath_id | Packet_in of OP.Port.t * int32 * Cstruct.buf * OP.datapath_id | Flow_removed of @@ -54,7 +53,7 @@ module Event = struct | Port_status of OP.Port.reason * OP.Port.phy * OP.datapath_id let string_of_event = function - | Datapath_join(dpid, _) -> sp "Datapath_join: dpid:0x%012Lx" dpid + | Datapath_join (dpid, _) -> sp "Datapath_join: dpid:0x%012Lx" dpid | Datapath_leave dpid -> sp "Datapath_leave: dpid:0x%012Lx" dpid | Packet_in (port, buffer_id, bs, dpid) -> (sp "Packet_in: port:%s ... dpid:0x%012Lx buffer_id:%ld" @@ -172,7 +171,7 @@ let process_of_packet state (remote_addr, remote_port) ofp t = | Features_resp (h, sfs) (* Generate a datapath join event *) -> ((* cp "FEATURES_RESP";*) let dpid = sfs.Switch.datapath_id in - let evt = Event.Datapath_join(dpid, sfs.OP.Switch.ports) in + let evt = Event.Datapath_join (dpid, sfs.Switch.ports) in if (Hashtbl.mem state.dp_db dpid) then ( Printf.printf "Deleting old state \n%!"; Hashtbl.remove state.dp_db dpid; @@ -257,7 +256,7 @@ let process_of_packet state (remote_addr, remote_port) ofp t = Lwt_list.iter_p (fun cb -> cb state dpid evt) state.table_stats_reply_cb ) - | _ -> cp "New stats response received"; return (); + | _ -> OS.Console.log "New stats response received"; return (); ) | Port_status(h, st) @@ -269,7 +268,7 @@ let process_of_packet state (remote_addr, remote_port) ofp t = Lwt_list.iter_p (fun cb -> cb state dpid evt) state.port_status_cb ) - | _ -> cp "New packet received"; return () + | _ -> OS.Console.log "New packet received"; return () ) let send_of_data controller dpid bits = @@ -297,11 +296,10 @@ let terminate st = Hashtbl.iter (fun _ ch -> resolve (Channel.close ch) ) st.dp_db; Printf.printf "Terminating controller...\n" -let controller init st (remote_addr, remote_port) t = +let controller st (remote_addr, remote_port) t = let rs = Nettypes.ipv4_addr_to_string remote_addr in let cached_socket = Ofsocket.create_socket t in - pp "OpenFlow Controller %s:%d\n%!" rs remote_port; - let _ = init st in + let _ = pp "OpenFlow Controller+ %s:%d\n%!" rs remote_port in let echo () = try_lwt lwt hbuf = Ofsocket.read_data cached_socket OP.Header.sizeof_ofp_header in @@ -332,7 +330,7 @@ let controller init st (remote_addr, remote_port) t = | exn -> pp "{OpenFlow-controller} ERROR:%s\n%s\n%!" (Printexc.to_string exn) (Printexc.get_backtrace ()); - return false + return true in let continue = ref true in @@ -344,25 +342,39 @@ let controller init st (remote_addr, remote_port) t = return () done -let init_controller () = - { dp_db = Hashtbl.create 0; - channel_dp = Hashtbl.create 0; - datapath_join_cb = []; - datapath_leave_cb = []; - packet_in_cb = []; - flow_removed_cb = []; - flow_stats_reply_cb = []; - aggr_flow_stats_reply_cb = []; - desc_stats_reply_cb = []; - port_stats_reply_cb = []; - table_stats_reply_cb = []; - port_status_cb = [];} - let listen mgr loc init = - let st = init_controller () in - (Channel.listen mgr (`TCPv4 (loc, (controller init st) ))) + let st = { dp_db = Hashtbl.create 0; + channel_dp = Hashtbl.create 0; + datapath_join_cb = []; + datapath_leave_cb = []; + packet_in_cb = []; + flow_removed_cb = []; + flow_stats_reply_cb = []; + aggr_flow_stats_reply_cb = []; + desc_stats_reply_cb = []; + port_stats_reply_cb = []; + table_stats_reply_cb = []; + port_status_cb = []; + } + in + let _ = init st in + (Channel.listen mgr (`TCPv4 (loc, (controller st) ))) let connect mgr loc init = - let st = init_controller () in - Channel.connect mgr (`TCPv4 (None, loc, - (controller init st loc) )) + let st = { dp_db = Hashtbl.create 0; + channel_dp = Hashtbl.create 0; + datapath_join_cb = []; + datapath_leave_cb = []; + packet_in_cb = []; + flow_removed_cb = []; + flow_stats_reply_cb = []; + aggr_flow_stats_reply_cb = []; + desc_stats_reply_cb = []; + port_stats_reply_cb = []; + table_stats_reply_cb = []; + port_status_cb = []; + } + in + let _ = init st in + Net.Channel.connect mgr (`TCPv4 (None, loc, + (controller st loc) )) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index e8cc6b0..4b5a312 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -17,8 +17,6 @@ open Printf open Lwt open Int32 -(* open Cstruct *) - let sp = Printf.sprintf let pp = Printf.printf @@ -112,19 +110,19 @@ let contain_exc l v = let int_of_bool = function | true -> 1 | false -> 0 -let get_int32_bit f off = (Int32.logand f (Int32.shift_left 1l off)) > 0l +let get_int32_bit f off = (Int32.logand f (shift_left 1l off)) > 0l let set_int32_bit f off v = - logor f (Int32.shift_left (Int32.of_int(int_of_bool v)) off) + logor f (shift_left (Int32.of_int(int_of_bool v)) off) let get_int32_byte f off = - let ret = Int32.shift_left (f logand (Int32.shift_left 13l off)) off in + let ret = shift_left (f logand (shift_left 13l off)) off in char_of_int (0x00ff land (Int32.to_int ret)) let set_int32_byte f off v = let value = Int32.of_int ((int_of_char v) lsl off) in logor f value let get_int32_nw_mask f off = - let ret = Int32.shift_left (logand f (Int32.shift_left 13l off)) off in + let ret = shift_left (logand f (shift_left 13l off)) off in char_of_int (0x003f land (Int32.to_int ret)) let set_int32_nw_mask f off v = let value = Int32.of_int ((0x3f land v) lsl off) in @@ -150,7 +148,7 @@ module Header = struct uint32_t xid } as big_endian - cenum msg_code { + (*cenum msg_code { HELLO = 0; ERROR = 1; ECHO_REQ = 2; @@ -173,8 +171,107 @@ module Header = struct BARRIER_RESP = 19; QUEUE_GET_CONFIG_REQ = 20; QUEUE_GET_CONFIG_RESP = 21 - } as uint8_t - + } as uint8_t *) + type msg_code = + HELLO + | ERROR + | ECHO_REQ + | ECHO_RESP + | VENDOR + | FEATURES_REQ + | FEATURES_RESP + | GET_CONFIG_REQ + | GET_CONFIG_RESP + | SET_CONFIG + | PACKET_IN + | FLOW_REMOVED + | PORT_STATUS + | PACKET_OUT + | FLOW_MOD + | PORT_MOD + | STATS_REQ + | STATS_RESP + | BARRIER_REQ + | BARRIER_RESP + | QUEUE_GET_CONFIG_REQ + | QUEUE_GET_CONFIG_RESP + + let msg_code_of_int = + function + | 0 -> Some HELLO + | 1 -> Some ERROR + | 2 -> Some ECHO_REQ + | 3 -> Some ECHO_RESP + | 4 -> Some VENDOR + | 5 -> Some FEATURES_REQ + | 6 -> Some FEATURES_RESP + | 7 -> Some GET_CONFIG_REQ + | 8 -> Some GET_CONFIG_RESP + | 9 -> Some SET_CONFIG + | 10 -> Some PACKET_IN + | 11 -> Some FLOW_REMOVED + | 12 -> Some PORT_STATUS + | 13 -> Some PACKET_OUT + | 14 -> Some FLOW_MOD + | 15 -> Some PORT_MOD + | 16 -> Some STATS_REQ + | 17 -> Some STATS_RESP + | 18 -> Some BARRIER_REQ + | 19 -> Some BARRIER_RESP + | 20 -> Some QUEUE_GET_CONFIG_REQ + | 21 -> Some QUEUE_GET_CONFIG_RESP + | _ -> None + + let msg_code_to_int = + function + | HELLO -> 0 + | ERROR -> 1 + | ECHO_REQ -> 2 + | ECHO_RESP -> 3 + | VENDOR -> 4 + | FEATURES_REQ -> 5 + | FEATURES_RESP -> 6 + | GET_CONFIG_REQ -> 7 + | GET_CONFIG_RESP -> 8 + | SET_CONFIG -> 9 + | PACKET_IN -> 10 + | FLOW_REMOVED -> 11 + | PORT_STATUS -> 12 + | PACKET_OUT -> 13 + | FLOW_MOD -> 14 + | PORT_MOD -> 15 + | STATS_REQ -> 16 + | STATS_RESP -> 17 + | BARRIER_REQ -> 18 + | BARRIER_RESP -> 19 + | QUEUE_GET_CONFIG_REQ -> 20 + | QUEUE_GET_CONFIG_RESP -> 21 + + let msg_code_to_string = + function + | HELLO -> "HELLO" + | ERROR -> "ERROR" + | ECHO_REQ -> "ECHO_REQ" + | ECHO_RESP -> "ECHO_RESP" + | VENDOR -> "VENDOR" + | FEATURES_REQ -> "FEATURES_REQ" + | FEATURES_RESP -> "FEATURES_RESP" + | GET_CONFIG_REQ -> "GET_CONFIG_REQ" + | GET_CONFIG_RESP -> "GET_CONFIG_RESP" + | SET_CONFIG -> "SET_CONFIG" + | PACKET_IN -> "PACKET_IN" + | FLOW_REMOVED -> "FLOW_REMOVED" + | PORT_STATUS -> "PORT_STATUS" + | PACKET_OUT -> "PACKET_OUT" + | FLOW_MOD -> "FLOW_MOD" + | PORT_MOD -> "PORT_MOD" + | STATS_REQ -> "STATS_REQ" + | STATS_RESP -> "STATS_RESP" + | BARRIER_REQ -> "BARRIER_REQ" + | BARRIER_RESP -> "BARRIER_RESP" + | QUEUE_GET_CONFIG_REQ -> "QUEUE_GET_CONFIG_REQ" + | QUEUE_GET_CONFIG_RESP -> "QUEUE_GET_CONFIG_RESP" + type h = { ver: uint8; ty: msg_code; @@ -186,7 +283,7 @@ module Header = struct let parse_header bits = match ((get_ofp_header_version bits), - (int_to_msg_code (get_ofp_header_typ bits))) with + (msg_code_of_int (get_ofp_header_typ bits))) with | (1, Some(ty)) -> let ret = { ver=(char_of_int (get_ofp_header_version bits)); @@ -338,10 +435,10 @@ module Port = struct } let get_link_down f = (logand f 1l) > 0l - let get_stp_listen f = (logand f (Int32.shift_left 0l 8)) > 0l - let get_stp_learn f = (logand f (Int32.shift_left 1l 8)) > 0l - let get_stp_forward f = (logand f (Int32.shift_left 2l 8)) > 0l - let get_stp_block f = (logand f (Int32.shift_left 3l 8)) > 0l + let get_stp_listen f = (logand f (shift_left 0l 8)) > 0l + let get_stp_learn f = (logand f (shift_left 1l 8)) > 0l + let get_stp_forward f = (logand f (shift_left 2l 8)) > 0l + let get_stp_block f = (logand f (shift_left 3l 8)) > 0l (*TODO this parsing is incorrect. use get_int32_bit and I think * set_stp_forward is a byte *) @@ -509,12 +606,23 @@ module Port = struct h.rx_frame_err h.rx_over_err h.rx_crc_err h.collisions (string_of_port_stats_reply q)) - cenum reason { +(* cenum reason { ADD = 0; DEL = 1; MOD = 2 - } as uint8_t + } as uint8_t*) + type reason = ADD | DEL | MOD + + let reason_of_int = + function | 0 -> Some ADD | 1 -> Some DEL | 2 -> Some MOD | _ -> None + + let reason_to_int = function | ADD -> 0 | DEL -> 1 | MOD -> 2 + + let reason_to_string = + function | ADD -> "ADD" | DEL -> "DEL" | MOD -> "MOD" + + (* type reason = ADD | DEL | MOD let reason_of_int = function | 0 -> ADD @@ -540,21 +648,21 @@ module Port = struct uint8_t pad[7] } as big_endian + let create_port_status reason desc = + {reason; desc;} + let string_of_status st = (sp "Port status,reason:%s,%s" (reason_to_string st.reason) (string_of_phy st.desc) ) let parse_status bits = let reason = - match (int_to_reason (get_ofp_port_status_reason bits)) with + match (reason_of_int (get_ofp_port_status_reason bits)) with | Some(reason) -> reason | None -> raise(Unparsable("reason_of_int", bits)) in let _ = Cstruct.shift_left bits sizeof_ofp_port_status in {reason; desc=(parse_phy bits)} - let create_port_status reason desc = - {reason; desc;} - let marshal_port_status ?(xid=0l) status bits = let len = Header.get_len + sizeof_ofp_port_status + phy_len in let header = Header.create Header.PORT_STATUS len xid in @@ -895,6 +1003,12 @@ module Match = struct nw_src; nw_dst; nw_tos; nw_proto; tp_src; tp_dst; } + let translate_port m p = + {wildcards=m.wildcards; in_port=p; dl_src=m.dl_src; dl_dst=m.dl_dst; + dl_vlan=m.dl_vlan; dl_vlan_pcp=m.dl_vlan_pcp; dl_type=m.dl_type; + nw_tos=m.nw_tos; nw_proto=m.nw_proto; nw_src=m.nw_src; nw_dst=m.nw_dst; + tp_src=m.tp_src; tp_dst=m.tp_dst;} + cstruct dl_header { uint8_t dl_dst[6]; uint8_t dl_src[6]; @@ -1879,14 +1993,17 @@ module Stats = struct Match.sizeof_ofp_match + sizeof_ofp_flow_stats_request ) xid in - let _ = Header.marshal_header header bits in + let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits Header.sizeof_ofp_header in let _ = set_ofp_stats_request_typ bits (int_of_req_type FLOW) in let _ = set_ofp_stats_request_flags bits 0 in - let _ = Cstruct.shift bits sizeof_ofp_stats_request in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = Match.marshal_match flow_match bits in + let bits = Cstruct.shift bits Match.sizeof_ofp_match in let _ = set_ofp_flow_stats_request_table_id bits table_id in let _ = set_ofp_flow_stats_request_out_port bits (Port.int_of_port out_port) in - Cstruct.shift bits sizeof_ofp_flow_stats_request + Header.sizeof_ofp_header + sizeof_ofp_stats_request + + Match.sizeof_ofp_match + sizeof_ofp_flow_stats_request let create_aggr_flow_stat_req flow_match ?(table_id=0xff) ?(out_port=Port.No_port) ?(xid=(Random.int32 Int32.max_int)) bits = @@ -1897,13 +2014,16 @@ module Stats = struct sizeof_ofp_flow_stats_request ) xid in let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits Header.sizeof_ofp_header in let _ = set_ofp_stats_request_typ bits (int_of_req_type AGGREGATE) in let _ = set_ofp_stats_request_flags bits 0 in - let _ = Cstruct.shift bits sizeof_ofp_stats_request in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = Match.marshal_match flow_match bits in + let bits = Cstruct.shift bits Match.sizeof_ofp_match in let _ = set_ofp_flow_stats_request_table_id bits table_id in let _ = set_ofp_flow_stats_request_out_port bits (Port.int_of_port out_port) in - Cstruct.shift bits sizeof_ofp_flow_stats_request + Header.sizeof_ofp_header + sizeof_ofp_stats_request + + Match.sizeof_ofp_match + sizeof_ofp_flow_stats_request (* struct ofp_vendor_header { uint32_t vendor; @@ -1918,9 +2038,10 @@ module Stats = struct (Header.sizeof_ofp_header + sizeof_ofp_stats_request) xid in let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits Header.sizeof_ofp_header in let _ = set_ofp_stats_request_typ bits (int_of_req_type TABLE) in let _ = set_ofp_stats_request_flags bits 0 in - Cstruct.shift bits sizeof_ofp_stats_request + Header.sizeof_ofp_header + sizeof_ofp_stats_request cstruct ofp_queue_stats_request { uint16_t port_no; @@ -1935,12 +2056,14 @@ module Stats = struct sizeof_ofp_stats_request + sizeof_ofp_queue_stats_request) xid in let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_stats_request_typ bits (int_of_req_type QUEUE) in let _ = set_ofp_stats_request_flags bits 0 in - let _ = Cstruct.shift bits sizeof_ofp_stats_request in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_queue_stats_request_port_no bits (Port.int_of_port port) in let _ = set_ofp_queue_stats_request_queue_id bits queue_id in - Cstruct.shift bits sizeof_ofp_queue_stats_request + Header.sizeof_ofp_header + sizeof_ofp_stats_request + + sizeof_ofp_queue_stats_request cstruct ofp_port_stats_request { uint16_t port_no; @@ -1954,11 +2077,13 @@ module Stats = struct sizeof_ofp_stats_request + sizeof_ofp_port_stats_request) xid in let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_stats_request_typ bits (int_of_req_type PORT) in let _ = set_ofp_stats_request_flags bits 0 in - let _ = Cstruct.shift bits sizeof_ofp_stats_request in + let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_port_stats_request_port_no bits (Port.int_of_port port) in - Cstruct.shift bits sizeof_ofp_port_stats_request + Header.sizeof_ofp_header + sizeof_ofp_stats_request + + sizeof_ofp_port_stats_request type req = | Desc_req of req_hdr @@ -2041,7 +2166,6 @@ module Stats = struct let rec parse_table_stats_reply bits = match (Cstruct.len bits ) with - | 0 -> [] | l -> let table_id = table_id_of_int (get_ofp_table_stats_table_id bits) in let name = get_ofp_table_stats_name bits in @@ -2056,6 +2180,7 @@ module Stats = struct matched_count;} in let _ = Cstruct.shift bits sizeof_ofp_table_stats in [ret] @ (parse_table_stats_reply bits) + | 0 -> [] let rec string_of_table_stats_reply tables = match tables with diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index 886be37..f64c68d 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -147,9 +147,9 @@ module Port : type reason = ADD | DEL | MOD val reason_to_string: reason -> string type status = { reason : reason; desc : phy; } + val create_port_status : reason -> phy -> status val string_of_status : status -> string - val create_port_status: reason -> phy -> status - val marshal_port_status: ?xid:int32 -> status -> Cstruct.buf -> int + val marshal_port_status : ?xid:int32 -> status -> Cstruct.buf -> int end module Switch : sig @@ -243,6 +243,7 @@ module Match : ?nw_proto:byte -> ?nw_src:uint32 -> ?nw_dst:uint32 -> ?tp_src:uint16 -> ?tp_dst:uint16 -> unit -> t + val translate_port : t -> Port.t -> t val raw_packet_to_match : Port.t -> Cstruct.buf -> t val match_to_string : t -> string end @@ -426,18 +427,18 @@ module Stats : val create_flow_stat_req : Match.t -> ?table_id:int -> - ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.buf -> Cstruct.buf + ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.buf -> int val create_aggr_flow_stat_req : Match.t -> ?table_id:int -> - ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.buf -> Cstruct.buf + ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.buf -> int (* val create_vendor_stat_req : ?xid:Int32.t -> Cstruct.buf -> unit *) - val create_table_stat_req : ?xid:Int32.t -> Cstruct.buf -> Cstruct.buf + val create_table_stat_req : ?xid:Int32.t -> Cstruct.buf -> int val create_queue_stat_req : ?xid:Int32.t -> - ?queue_id:int32 -> ?port:Port.t -> Cstruct.buf -> Cstruct.buf + ?queue_id:int32 -> ?port:Port.t -> Cstruct.buf -> int val create_port_stat_req : - ?xid:Int32.t -> ?port:Port.t -> Cstruct.buf -> Cstruct.buf + ?xid:Int32.t -> ?port:Port.t -> Cstruct.buf -> int type req = Desc_req of req_hdr | Flow_req of req_hdr * Match.t * table_id * Port.t From ae4e8d5ffeccd88565c42027879e5b99704de5ec Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Sun, 14 Oct 2012 13:32:33 +0000 Subject: [PATCH 07/75] build library for native compilation --- _oasis | 1 + _tags | 44 ++--- lib/META | 4 +- lib/ofcontroller.ml | 10 +- lib/ofpacket.ml | 6 +- myocamlbuild.ml | 123 ++---------- setup.ml | 473 ++++++++++---------------------------------- 7 files changed, 163 insertions(+), 498 deletions(-) diff --git a/_oasis b/_oasis index 551fe50..cabd689 100644 --- a/_oasis +++ b/_oasis @@ -28,6 +28,7 @@ Flag nettests Library openflow Path: lib Findlibname: openflow + CompiledObject: native Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch Pack: True BuildDepends: cstruct, cstruct.syntax, rpc, mirage, mirage-net (>= 0.3.0) diff --git a/_tags b/_tags index 7af304e..e36ecc5 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: b02617c692f6bf096916733d41523409) +# DO NOT EDIT (digest: 7ec51c624334462bbfa7ad2802e56fa2) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -20,47 +20,47 @@ "lib/ofswitch_config.cmx": for-pack(Openflow) "lib/ofswitch.cmx": for-pack(Openflow) # Executable ofswitch_ctrl -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_rpc -: pkg_mirage -: pkg_mirage-net +"lib/ofswitch_ctrl.native": use_openflow +"lib/ofswitch_ctrl.native": pkg_cstruct +"lib/ofswitch_ctrl.native": pkg_cstruct.syntax +"lib/ofswitch_ctrl.native": pkg_rpc +"lib/ofswitch_ctrl.native": pkg_mirage +"lib/ofswitch_ctrl.native": pkg_mirage-net : use_openflow : pkg_cstruct : pkg_cstruct.syntax : pkg_rpc : pkg_mirage : pkg_mirage-net -: custom +"lib/ofswitch_ctrl.native": custom # Executable learning_switch_lwt -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_rpc -: pkg_mirage -: pkg_mirage-net +"controller/learning_switch.native": use_openflow +"controller/learning_switch.native": pkg_cstruct +"controller/learning_switch.native": pkg_cstruct.syntax +"controller/learning_switch.native": pkg_rpc +"controller/learning_switch.native": pkg_mirage +"controller/learning_switch.native": pkg_mirage-net : use_openflow : pkg_cstruct : pkg_cstruct.syntax : pkg_rpc : pkg_mirage : pkg_mirage-net -: custom +"controller/learning_switch.native": custom # Executable basic_switch_lwt -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_rpc -: pkg_mirage -: pkg_mirage-net +"switch/basic_switch.native": use_openflow +"switch/basic_switch.native": pkg_cstruct +"switch/basic_switch.native": pkg_cstruct.syntax +"switch/basic_switch.native": pkg_rpc +"switch/basic_switch.native": pkg_mirage +"switch/basic_switch.native": pkg_mirage-net : use_openflow : pkg_cstruct : pkg_cstruct.syntax : pkg_rpc : pkg_mirage : pkg_mirage-net -: custom +"switch/basic_switch.native": custom # OASIS_STOP true: annot : syntax_camlp4o diff --git a/lib/META b/lib/META index b1e399d..e754af5 100644 --- a/lib/META +++ b/lib/META @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 6849fb3ace6d3535ac1163c91dc21113) +# DO NOT EDIT (digest: 0045d1e018354baf6501bc7d18bc32e3) version = "0.3.0" description = "OpenFlow protocol and switch implementations in pure OCaml" requires = "cstruct cstruct.syntax rpc mirage mirage-net" @@ -7,6 +7,6 @@ archive(byte) = "openflow.cma" archive(byte, plugin) = "openflow.cma" archive(native) = "openflow.cmxa" archive(native, plugin) = "openflow.cmxs" -exists_if = "openflow.cma" +exists_if = "openflow.cmxa" # OASIS_STOP diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 3b4f142..9e4dbd8 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -164,8 +164,12 @@ let process_of_packet state (remote_addr, remote_port) ofp t = | Echo_req (h, bs) (* Reply to ECHO requests *) -> ((* cp "ECHO_REQ"; *) - Channel.write_buffer t (build_echo_resp h bs (OS.Io_page.get ())); - Channel.flush t + let h = OP.Header.create OP.Header.ECHO_RESP + 8 h.OP.Header.xid in + let bits = OP.marshal_and_sub (OP.Header.marshal_header h) + (OS.Io_page.get ()) in + let _ = Channel.write_buffer t bits in + Channel.flush t ) | Features_resp (h, sfs) (* Generate a datapath join event *) @@ -330,7 +334,7 @@ let controller st (remote_addr, remote_port) t = | exn -> pp "{OpenFlow-controller} ERROR:%s\n%s\n%!" (Printexc.to_string exn) (Printexc.get_backtrace ()); - return true + return false in let continue = ref true in diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 4b5a312..22017a7 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -2506,7 +2506,11 @@ let build_features_req xid bits = Header.marshal_header (Header.(create FEATURES_REQ 8 xid)) bits let build_echo_resp h bs bits = - let _ = Header.(marshal_header (create ECHO_RESP get_len h.xid) bits ) in + let _ = + Header.(marshal_header + (create ECHO_RESP + (get_len + (Cstruct.len bits)) h.xid) + bits ) in let _ = Cstruct.blit_buffer bs 0 bits 0 (Cstruct.len bs) in Cstruct.shift bits (Cstruct.len bs) diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 1f90a8f..7fa231e 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 32161ea95f034567b4a3e8f24bb83d88) *) +(* DO NOT EDIT (digest: 956d7ad0919b568e7f4948fe9f0a1e66) *) module OASISGettext = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISGettext.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISGettext.ml" let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISExpr.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExpr.ml" @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -# 21 "/Users/cr409/oasis/src/base/BaseEnvLight.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) @@ -213,76 +213,8 @@ end # 215 "myocamlbuild.ml" -module MyOCamlbuildXen = struct -# 22 "/Users/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildXen.ml" - - open Ocamlbuild_plugin - - module Util = struct - let split s ch = - let x = ref [] in - let rec go s = - let pos = String.index s ch in - x := (String.before s pos)::!x; - go (String.after s (pos + 1)) - in - try - go s - with Not_found -> !x - - let split_nl s = split s '\n' - let run_and_read x = List.hd (split_nl (Ocamlbuild_pack.My_unix.run_and_read x)) - end - - module Xen = struct - (** Link to a standalone Xen microkernel *) - let cc_xen_link bc tags arg out env = - (* XXX check ocamlfind path here *) - let xenlib = Util.run_and_read "ocamlfind query mirage" in - let jmp_obj = Px (xenlib / "longjmp.o") in - let head_obj = Px (xenlib / "x86_64.o") in - let ocamllib = match bc with |true -> "ocamlbc" |false -> "ocaml" in - let ld = getenv ~default:"ld" "LD" in - let ldlibs = List.map (fun x -> Px (xenlib / ("lib" ^ x ^ ".a"))) - [ocamllib; "xen"; "xencaml"; "diet"; "m"] in - Cmd (S ( A ld :: [ T(tags++"link"++"xen"); - A"-d"; A"-nostdlib"; A"-m"; A"elf_x86_64"; A"-T"; - Px (xenlib / "mirage-x86_64.lds"); head_obj; P arg ] - @ ldlibs @ [jmp_obj; A"-o"; Px out])) - - let cc_xen_bc_link tags arg out env = cc_xen_link true tags arg out env - let cc_xen_nc_link tags arg out env = cc_xen_link false tags arg out env - - (* Rewrite sections for Xen LDS layout *) - let xen_objcopy dst src env builder = - let dst = env dst in - let src = env src in - let cmd = ["objcopy";"--rename-section";".bss=.mlbss";"--rename-section"; - ".data=.mldata";"--rename-section";".rodata=.mlrodata"; - "--rename-section";".text=.mltext"] in - let cmds = List.map (fun x -> A x) cmd in - Cmd (S (cmds @ [Px src; Px dst])) - - let rules () = - let cc_link_c_implem ?tag fn c o env build = - let c = env c and o = env o in - fn (tags_of_pathname c++"implem"+++tag) c o env - in - rule "final link: %.nobj.o -> %.xen" ~prod:"%(file).xen" ~dep:"%(file).nobj.o" - (cc_link_c_implem cc_xen_nc_link "%(file).nobj.o" "%(file).xen") - - end - - let dispatch = - function - | After_rules -> - Xen.rules () - | _ -> - () -end - module MyOCamlbuildFindlib = struct -# 21 "/Users/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -302,21 +234,19 @@ module MyOCamlbuildFindlib = struct Ocamlbuild_pack.Lexers.blank_sep_strings let split s ch = - let buf = Buffer.create 13 in - let x = ref [] in - let flush () = - x := (Buffer.contents buf) :: !x; - Buffer.clear buf + let x = + ref [] + in + let rec go s = + let pos = + String.index s ch + in + x := (String.before s pos)::!x; + go (String.after s (pos + 1)) in - String.iter - (fun c -> - if c = ch then - flush () - else - Buffer.add_char buf c) - s; - flush (); - List.rev !x + try + go s + with Not_found -> !x let split_nl s = split s '\n' @@ -351,7 +281,6 @@ module MyOCamlbuildFindlib = struct (* When one link an OCaml library/binary/package, one should use -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - flag ["ocaml"; "link"; "output_obj"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and @@ -394,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -# 21 "/Users/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -410,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -# 56 "/Users/cr409/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +# 56 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" type t = { @@ -523,15 +452,6 @@ module MyOCamlbuildBase = struct ) t.lib_c; - (* Add output_obj rules mapped to .nobj.o *) - let native_output_obj x = - OC.link_gen "cmx" "cmxa" !Options.ext_lib [!Options.ext_obj; "cmi"] - OC.ocamlopt_link_prog - (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") x - in - rule "ocaml: cmx* and o* -> .nobj.o" ~prod:"%.nobj.o" ~deps:["%.cmx"; "%.o"] - (native_output_obj "%.cmx" "%.nobj.o"); - (* Add flags *) List.iter (fun (tags, cond_specs) -> @@ -548,13 +468,12 @@ module MyOCamlbuildBase = struct [ dispatch t; MyOCamlbuildFindlib.dispatch; - MyOCamlbuildXen.dispatch; ] end -# 557 "myocamlbuild.ml" +# 476 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -567,6 +486,6 @@ let package_default = let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 571 "myocamlbuild.ml" +# 490 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index 3242726..de2f55e 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.2.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: e29e9bf67d9b44260daea4788e1f0556) *) +(* DO NOT EDIT (digest: 2b917b7dc8d0ebbebe824e55790c7621) *) (* - Regenerated by OASIS v0.3.1 + Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISGettext.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISGettext.ml" let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISContext.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISContext.ml" open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -# 1 "/Users/cr409/oasis/src/oasis/OASISString.ml" +# 1 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISString.ml" @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISUtils.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISUtils.ml" open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -# 21 "/Users/cr409/oasis/src/oasis/PropList.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/PropList.ml" open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -# 71 "/Users/cr409/oasis/src/oasis/PropList.ml" +# 71 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/PropList.ml" end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISMessage.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISMessage.ml" open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISVersion.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISVersion.ml" open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISLicense.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISLicense.ml" (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISExpr.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExpr.ml" @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISTypes.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISTypes.ml" @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -# 102 "/Users/cr409/oasis/src/oasis/OASISTypes.ml" +# 102 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISTypes.ml" type 'a conditional = 'a OASISExpr.choices @@ -1066,18 +1066,10 @@ module OASISTypes = struct lib_findlib_containers: findlib_name list; } - - type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - } - type executable = { exec_custom: bool; exec_main_is: unix_filename; - exec_target: string option; } type flag = @@ -1134,7 +1126,6 @@ module OASISTypes = struct type section = | Library of common_section * build_section * library - | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository @@ -1143,7 +1134,7 @@ module OASISTypes = struct type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { @@ -1185,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISUnixPath.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISUnixPath.ml" type unix_filename = string type unix_dirname = string @@ -1269,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISHostPath.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISHostPath.ml" open Filename @@ -1302,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISSection.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISSection.ml" open OASISTypes @@ -1310,8 +1301,6 @@ module OASISSection = struct function | Library (cs, _, _) -> `Library, cs - | Object (cs, _, _) -> - `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> @@ -1329,7 +1318,6 @@ module OASISSection = struct let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) - | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) @@ -1350,7 +1338,6 @@ module OASISSection = struct in (match k with | `Library -> "library" - | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" @@ -1385,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISBuildSection.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISBuildSection.ml" end module OASISExecutable = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISExecutable.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExecutable.ml" open OASISTypes @@ -1421,15 +1408,30 @@ module OASISExecutable = struct end module OASISLibrary = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISLibrary.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISLibrary.ml" open OASISTypes open OASISUtils open OASISGettext open OASISSection + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + library * + group_t list) + (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists bs modul = + let find_module source_file_exists (cs, bs, lib) modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) @@ -1470,7 +1472,7 @@ module OASISLibrary = struct let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> - match find_module source_file_exists bs modul with + match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> @@ -1494,7 +1496,7 @@ module OASISLibrary = struct let find_modules lst ext = let find_module modul = - match find_module source_file_exists bs modul with + match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, _) -> [base_fn] | `No_sources lst -> @@ -1596,100 +1598,7 @@ module OASISLibrary = struct acc_nopath) (headers @ cmxs) -end - -module OASISObject = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISObject.ml" - - open OASISTypes - open OASISGettext - - let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = - List.fold_left - (fun acc modul -> - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name; - acc) - [] - obj.obj_modules - - - let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = - - let find_module ext modul = - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, _) -> [base_fn ^ ext] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name ; - lst - in - - let header, byte, native, c_object, f = - match obj.obj_modules with - | [ m ] -> (find_module ".cmi" m, - find_module ".cmo" m, - find_module ".cmx" m, - find_module ".o" m, - fun x -> x) - | _ -> ([cs.cs_name ^ ".cmi"], - [cs.cs_name ^ ".cmo"], - [cs.cs_name ^ ".cmx"], - [cs.cs_name ^ ".o"], - OASISUnixPath.concat bs.bs_path) - in - List.map (List.map f) ( - match bs.bs_compiled_object with - | Native -> - native :: c_object :: byte :: header :: [] - | Best when is_native -> - native :: c_object :: byte :: header :: [] - | Byte | Best -> - byte :: header :: []) - -end - -module OASISFindlib = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISFindlib.ml" - - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - [`Library of library | `Object of object_] * - group_t list) - - type data = common_section * - build_section * - [`Library of library | `Object of object_] + type data = common_section * build_section * library type tree = | Node of (data option) * (tree MapString.t) | Leaf of data @@ -1732,23 +1641,6 @@ module OASISFindlib = struct mp end - | Object (cs, _, obj) -> - begin - let obj_name = cs.cs_name in - if MapString.mem obj_name mp then - failwithf - (f_ "The object name '%s' is used more than once.") - obj_name; - let findlib_full_name = match obj.obj_findlib_fullname with - | Some ns -> String.concat "." ns - | None -> obj_name - in - MapString.add - obj_name - (`Solved findlib_full_name) - mp - end - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty @@ -1886,9 +1778,7 @@ module OASISFindlib = struct (fun mp -> function | Library (cs, bs, lib) -> - add (cs, bs, `Library lib) mp - | Object (cs, bs, obj) -> - add (cs, bs, `Object obj) mp + add (cs, bs, lib) mp | _ -> mp) MapString.empty @@ -1951,32 +1841,32 @@ module OASISFindlib = struct end module OASISFlag = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISFlag.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISFlag.ml" end module OASISPackage = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISPackage.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISPackage.ml" end module OASISSourceRepository = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISSourceRepository.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISSourceRepository.ml" end module OASISTest = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISTest.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISTest.ml" end module OASISDocument = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISDocument.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISDocument.ml" end module OASISExec = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISExec.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExec.ml" open OASISGettext open OASISUtils @@ -2054,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -# 21 "/Users/cr409/oasis/src/oasis/OASISFileUtil.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISFileUtil.ml" open OASISGettext @@ -2249,9 +2139,9 @@ module OASISFileUtil = struct end -# 2252 "setup.ml" +# 2142 "setup.ml" module BaseEnvLight = struct -# 21 "/Users/cr409/oasis/src/base/BaseEnvLight.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) @@ -2347,9 +2237,9 @@ module BaseEnvLight = struct end -# 2350 "setup.ml" +# 2240 "setup.ml" module BaseContext = struct -# 21 "/Users/cr409/oasis/src/base/BaseContext.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseContext.ml" open OASISContext @@ -2360,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -# 21 "/Users/cr409/oasis/src/base/BaseMessage.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseMessage.ml" (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2379,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -# 21 "/Users/cr409/oasis/src/base/BaseEnv.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseEnv.ml" open OASISGettext open OASISUtils @@ -2839,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -# 21 "/Users/cr409/oasis/src/base/BaseArgExt.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseArgExt.ml" open OASISUtils open OASISGettext @@ -2867,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -# 21 "/Users/cr409/oasis/src/base/BaseCheck.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseCheck.ml" open BaseEnv open BaseMessage @@ -2993,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -# 21 "/Users/cr409/oasis/src/base/BaseOCamlcConfig.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseOCamlcConfig.ml" open BaseEnv @@ -3109,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -# 21 "/Users/cr409/oasis/src/base/BaseStandardVar.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseStandardVar.ml" open OASISGettext @@ -3473,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -# 21 "/Users/cr409/oasis/src/base/BaseFileAB.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseFileAB.ml" open BaseEnv open OASISGettext @@ -3521,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -# 21 "/Users/cr409/oasis/src/base/BaseLog.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseLog.ml" open OASISUtils @@ -3640,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -# 21 "/Users/cr409/oasis/src/base/BaseBuilt.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseBuilt.ml" open OASISTypes open OASISGettext @@ -3651,7 +3541,6 @@ module BaseBuilt = struct | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) - | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = @@ -3660,7 +3549,6 @@ module BaseBuilt = struct | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" - | BObj -> "obj" | BDoc -> "doc")^ "_"^nm @@ -3724,8 +3612,6 @@ module BaseBuilt = struct (f_ "executable %s") | BLib -> (f_ "library %s") - | BObj -> - (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); @@ -3788,27 +3674,10 @@ module BaseBuilt = struct in evs, unix_lst - - let of_object ffn (cs, bs, obj) = - let unix_lst = - OASISObject.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - (cs, bs, obj) - in - let evs = - [BObj, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - end module BaseCustom = struct -# 21 "/Users/cr409/oasis/src/base/BaseCustom.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseCustom.ml" open BaseEnv open BaseMessage @@ -3858,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -# 21 "/Users/cr409/oasis/src/base/BaseDynVar.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseDynVar.ml" open OASISTypes @@ -3899,13 +3768,13 @@ module BaseDynVar = struct (f_ "Executable '%s' not yet built.") cs.cs_name))))) - | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct -# 21 "/Users/cr409/oasis/src/base/BaseTest.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseTest.ml" open BaseEnv open BaseMessage @@ -3995,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -# 21 "/Users/cr409/oasis/src/base/BaseDoc.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseDoc.ml" open BaseEnv open BaseMessage @@ -4030,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -# 21 "/Users/cr409/oasis/src/base/BaseSetup.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseSetup.ml" open BaseEnv open BaseMessage @@ -4277,7 +4146,6 @@ module BaseSetup = struct (f t.package (cs, doc)) args | Library _ - | Object _ | Executable _ | Flag _ | SrcRepo _ -> @@ -4609,9 +4477,9 @@ module BaseSetup = struct end -# 4612 "setup.ml" +# 4480 "setup.ml" module InternalConfigurePlugin = struct -# 21 "/Users/cr409/oasis/src/plugins/internal/InternalConfigurePlugin.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" (** Configure using internal scheme @author Sylvain Le Gall @@ -4788,20 +4656,6 @@ module InternalConfigurePlugin = struct | None -> () end; - (* Make sure the findlib version is fine for the OCaml compiler. *) - begin - let ocaml_ge4 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) - (OASISVersion.version_of_string "4.0.0") >= 0 in - if ocaml_ge4 then - let findlib_lt132 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) - (OASISVersion.version_of_string "1.3.2") < 0 in - if findlib_lt132 then - add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" - end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || @@ -4867,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -# 21 "/Users/cr409/oasis/src/plugins/internal/InternalInstallPlugin.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/internal/InternalInstallPlugin.ml" (** Install using internal scheme @author Sylvain Le Gall @@ -4877,7 +4731,7 @@ module InternalInstallPlugin = struct open BaseStandardVar open BaseMessage open OASISTypes - open OASISFindlib + open OASISLibrary open OASISGettext open OASISUtils @@ -4887,9 +4741,6 @@ module InternalInstallPlugin = struct let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) - let obj_hook = - ref (fun (cs, bs, obj) -> cs, bs, obj, []) - let doc_hook = ref (fun (cs, doc) -> cs, doc) @@ -5110,75 +4961,6 @@ module InternalInstallPlugin = struct begin (f_data, acc) end - and files_of_object (f_data, acc) data_obj = - let cs, bs, obj, obj_extra = - !obj_hook data_obj - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then - begin - let acc = - (* Start with acc + obj_extra *) - List.rev_append obj_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - acc - end) - acc - obj.obj_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BObj - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the object *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - in (* Install one group of library *) @@ -5189,10 +4971,8 @@ module InternalInstallPlugin = struct match grp with | Container (_, children) -> data_and_files, children - | Package (_, cs, bs, `Library lib, children) -> + | Package (_, cs, bs, lib, children) -> files_of_library data_and_files (cs, bs, lib), children - | Package (_, cs, bs, `Object obj, children) -> - files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux @@ -5450,9 +5230,9 @@ module InternalInstallPlugin = struct end -# 5453 "setup.ml" +# 5233 "setup.ml" module OCamlbuildCommon = struct -# 21 "/Users/cr409/oasis/src/plugins/ocamlbuild/OCamlbuildCommon.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" (** Functions common to OCamlbuild build and doc plugin *) @@ -5554,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -# 21 "/Users/cr409/oasis/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" (** Build using ocamlbuild @author Sylvain Le Gall @@ -5585,19 +5365,6 @@ module OCamlbuildPlugin = struct in_build_dir (OASISHostPath.of_unix fn) in - (* Checks if the string [fn] ends with [nd] *) - let ends_with nd fn = - let nd_len = - String.length nd - in - (String.length fn >= nd_len) - && - (String.sub - fn - (String.length fn - nd_len) - nd_len) = nd - in - let cond_targets = List.fold_left (fun acc -> @@ -5610,6 +5377,18 @@ module OCamlbuildPlugin = struct (cs, bs, lib) in + let ends_with nd fn = + let nd_len = + String.length nd + in + (String.length fn >= nd_len) + && + (String.sub + fn + (String.length fn - nd_len) + nd_len) = nd + in + let tgts = List.flatten (List.filter @@ -5634,35 +5413,6 @@ module OCamlbuildPlugin = struct cs.cs_name end - | Object (cs, bs, obj) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_object - in_build_dir_of_unix - (cs, bs, obj) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ".cmo" fn - || ends_with ".cmx" fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for object %s") - cs.cs_name - end - | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = @@ -5693,21 +5443,19 @@ module OCamlbuildPlugin = struct (* Add executable *) let acc = - match exec.exec_target, bs.bs_compiled_object with - | Some t, _ -> - (target ("." ^ t)) :: acc - | None, Native -> - (target ".native") :: (target ".nobj.o") :: acc - | None, Best when bool_of_string (is_native ()) -> - (target ".native") :: (target ".nobj.o") :: acc - | None, Byte - | None, Best -> + match bs.bs_compiled_object with + | Native -> + (target ".native") :: acc + | Best when bool_of_string (is_native ()) -> + (target ".native") :: acc + | Byte + | Best -> (target ".byte") :: acc in acc end - | Library _ | Object _ | Executable _ | Test _ + | Library _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] @@ -5759,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -# 21 "/Users/cr409/oasis/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" +# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5807,7 +5555,7 @@ module OCamlbuildDocPlugin = struct end -# 5810 "setup.ml" +# 5558 "setup.ml" open OASISTypes;; let setup_t = @@ -5940,7 +5688,7 @@ let setup_t = bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; - bs_compiled_object = Best; + bs_compiled_object = Native; bs_build_depends = [ FindlibPackage ("cstruct", None); @@ -6029,11 +5777,7 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - { - exec_custom = true; - exec_main_is = "ofswitch_ctrl.ml"; - exec_target = None; - }); + {exec_custom = true; exec_main_is = "ofswitch_ctrl.ml"; }); Executable ({ cs_name = "learning_switch_lwt"; @@ -6065,11 +5809,8 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - { - exec_custom = true; - exec_main_is = "learning_switch.ml"; - exec_target = None; - }); + {exec_custom = true; exec_main_is = "learning_switch.ml"; + }); Executable ({ cs_name = "basic_switch_lwt"; @@ -6096,19 +5837,15 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - { - exec_custom = true; - exec_main_is = "basic_switch.ml"; - exec_target = None; - }) + {exec_custom = true; exec_main_is = "basic_switch.ml"; }) ]; plugins = [(`Extra, "META", Some "0.2")]; schema_data = PropList.Data.create (); plugin_data = []; }; oasis_fn = Some "_oasis"; - oasis_version = "0.3.1"; - oasis_digest = Some "$ºÉÛ&W¬fõÂ\139\142íÝÒ}"; + oasis_version = "0.3.0"; + oasis_digest = Some "(\248R{)\224\015\003Tnm,\r\228\207\158"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6116,6 +5853,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6120 "setup.ml" +# 5857 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 946fe9a9fb62ec493c07c9404af273906d340420 Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Sun, 14 Oct 2012 13:34:21 +0000 Subject: [PATCH 08/75] remove lib/openflow.mllib --- lib/openflow.mllib | 6 ------ 1 file changed, 6 deletions(-) delete mode 100644 lib/openflow.mllib diff --git a/lib/openflow.mllib b/lib/openflow.mllib deleted file mode 100644 index 6c8c3c6..0000000 --- a/lib/openflow.mllib +++ /dev/null @@ -1,6 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 419f6e5b9b73a447d44e781983ac3cbe) -Ofcontroller -Ofpacket -Ofswitch -# OASIS_STOP From 0c453cb6540fabe183c4bd7767296a8551e69f04 Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Sun, 14 Oct 2012 13:52:32 +0000 Subject: [PATCH 09/75] fixing echo response code --- lib/ofcontroller.ml | 5 ++--- lib/ofpacket.ml | 14 +++++++------- lib/ofpacket.mli | 3 ++- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 9e4dbd8..b57c4cc 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -164,9 +164,8 @@ let process_of_packet state (remote_addr, remote_port) ofp t = | Echo_req (h, bs) (* Reply to ECHO requests *) -> ((* cp "ECHO_REQ"; *) - let h = OP.Header.create OP.Header.ECHO_RESP - 8 h.OP.Header.xid in - let bits = OP.marshal_and_sub (OP.Header.marshal_header h) + let bits = OP.marshal_and_sub + (OP.build_echo_resp h bs) (OS.Io_page.get ()) in let _ = Channel.write_buffer t bits in Channel.flush t diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 22017a7..ac2fed7 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -279,7 +279,7 @@ module Header = struct xid: uint32; } - let get_len = 8 + let get_len = sizeof_ofp_header let parse_header bits = match ((get_ofp_header_version bits), @@ -2505,14 +2505,14 @@ let marshal_error errornum data xid bits = let build_features_req xid bits = Header.marshal_header (Header.(create FEATURES_REQ 8 xid)) bits -let build_echo_resp h bs bits = +let build_echo_resp h bs bits = + let len = Header.get_len + (Cstruct.len bs) in let _ = Header.(marshal_header - (create ECHO_RESP - (get_len + (Cstruct.len bits)) h.xid) - bits ) in - let _ = Cstruct.blit_buffer bs 0 bits 0 (Cstruct.len bs) in - Cstruct.shift bits (Cstruct.len bs) + (create ECHO_RESP len h.xid) bits ) in + let _ = Cstruct.blit_buffer bs 0 bits Header.get_len + (Cstruct.len bs) in + len type t = | Hello of Header.h diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index f64c68d..2322570 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -57,6 +57,7 @@ module Header : | QUEUE_GET_CONFIG_REQ | QUEUE_GET_CONFIG_RESP type h = { ver : uint8; ty : msg_code; len : uint16; xid : uint32; } + val get_len : int val parse_header : Cstruct.buf -> h val header_to_string : h -> string val create : msg_code -> uint16 -> uint32 -> h @@ -501,7 +502,7 @@ val int_of_error_code : error_code -> uint32 val string_of_error_code : error_code -> string val marshal_error : error_code -> Cstruct.buf -> int32 -> Cstruct.buf -> int val build_features_req : uint32 -> Cstruct.buf -> int -val build_echo_resp : Header.h -> Cstruct.buf-> Cstruct.buf -> Cstruct.buf +val build_echo_resp : Header.h -> Cstruct.buf-> Cstruct.buf -> int type t = Hello of Header.h | Error of Header.h * error_code From c43fadee822684d7ed93d3a0d9050e1308261bc2 Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Thu, 18 Oct 2012 09:55:46 +0000 Subject: [PATCH 10/75] fix port state parsing --- lib/ofpacket.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index ac2fed7..69f9561 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -661,8 +661,9 @@ module Port = struct | Some(reason) -> reason | None -> raise(Unparsable("reason_of_int", bits)) in - let _ = Cstruct.shift_left bits sizeof_ofp_port_status in + let bits = Cstruct.shift bits sizeof_ofp_port_status in {reason; desc=(parse_phy bits)} + let marshal_port_status ?(xid=0l) status bits = let len = Header.get_len + sizeof_ofp_port_status + phy_len in let header = Header.create Header.PORT_STATUS len xid in From 1ee1f87ee64858053a03cce34319671773708575 Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 18 Oct 2012 15:29:49 +0000 Subject: [PATCH 11/75] nw_addr action had wrong size --- lib/ofpacket.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 69f9561..fbe505c 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -1337,7 +1337,7 @@ module Flow = struct | Set_nw_src (ip) | Set_nw_dst (ip) -> let _ = set_ofp_action_nw_addr_typ bits (int_of_action m) in - let _ = set_ofp_action_nw_addr_len bits 16 in + let _ = set_ofp_action_nw_addr_len bits 8 in let _ = set_ofp_action_nw_addr_nw_addr bits ip in sizeof_ofp_action_nw_addr | Set_nw_tos (tos) -> From 16f078597807ecd0962a4cb61d4ce98296a9004c Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Fri, 26 Oct 2012 16:14:51 +0200 Subject: [PATCH 12/75] remove the requirement to compile the setup.ml file --- Makefile | 38 +++++++++++++++----------------------- 1 file changed, 15 insertions(+), 23 deletions(-) diff --git a/Makefile b/Makefile index 218223a..5ee4682 100644 --- a/Makefile +++ b/Makefile @@ -9,41 +9,33 @@ MIRAGE ?= $(shell if ocamlfind query mirage-net >/dev/null 2>&1; then echo --ena -include Makefile.config -clean: setup.data setup.bin - ./setup.bin -clean $(OFLAGS) - rm -f setup.data setup.log setup.bin +clean: setup.ml setup.data + ocaml setup.ml -clean $(OFLAGS) + rm -f setup.data setup.log setup.ml -distclean: setup.data setup.bin - ./setup.bin -distclean $(OFLAGS) - rm -f setup.data setup.log setup.bin +distclean: setup.ml setup.data + ocaml setup.ml -distclean $(OFLAGS) + rm -f setup.data setup.log setup.ml -setup: setup.data setup.bin +setup: setup.ml setup.data -build: setup.data setup.bin $(wildcard lib/*.ml) - ./setup.bin -build -j $(J) $(OFLAGS) +build: setup.ml setup.data $(wildcard lib/*.ml) + ocaml setup.ml -build -j $(J) $(OFLAGS) -doc: setup.data setup.bin - ./setup.bin -doc -j $(J) $(OFLAGS) +doc: setup.data setup.ml + ocaml setup.ml -doc -j $(J) $(OFLAGS) install: ocamlfind remove $(NAME) - ./setup.bin -install $(OFLAGS) + ocaml setup.ml -install $(OFLAGS) test: build - ./setup.bin -test + ocaml setup.ml -test ## -setup.bin: setup.ml - ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< - rm -f setup.cmx setup.cmi setup.o setup.cmo - setup.ml: _oasis oasis setup -setup.bin: setup.ml - ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< - $(RM) setup.cmx setup.cmi setup.o setup.cmo - -setup.data: setup.bin - ./setup.bin -configure $(LWT) --disable-mirage +setup.data: setup.ml + ocaml setup.ml -configure $(LWT) --disable-mirage From 52a2af26564c906faeec911716eaa6c5285c1ff1 Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Fri, 26 Oct 2012 16:04:37 +0100 Subject: [PATCH 13/75] disable apps of ocaml-openflow by default --- _oasis | 10 ++--- myocamlbuild.ml | 14 +++---- setup.ml | 102 ++++++++++++++++++++++++------------------------ 3 files changed, 63 insertions(+), 63 deletions(-) diff --git a/_oasis b/_oasis index cabd689..d8ab23d 100644 --- a/_oasis +++ b/_oasis @@ -43,7 +43,7 @@ Document openflow Executable ofswitch_ctrl Path: lib MainIs: ofswitch_ctrl.ml - Build$: flag(lwt) + Build$: flag(nettests) Custom: true CompiledObject: native Install: false @@ -53,7 +53,7 @@ Executable ofswitch_ctrl Executable learning_switch_lwt Path: controller MainIs: learning_switch.ml - Build$: flag(lwt) + Build$: flag(nettests) Custom: true CompiledObject: native Install: false @@ -62,7 +62,7 @@ Executable learning_switch_lwt Executable basic_switch_lwt Path: switch MainIs: basic_switch.ml - Build$: flag(lwt) + Build$: flag(nettests) Custom: true CompiledObject: native Install: false @@ -71,7 +71,7 @@ Executable basic_switch_lwt (*Executable learning_switch_mirage Path: controller MainIs: learning_switch.ml - Build$: flag(mirage) + Build$: flag(nettests) Custom: true CompiledObject: native Target: xen @@ -81,7 +81,7 @@ Executable basic_switch_lwt Executable basic_switch_mirage Path: switch MainIs: basic_switch.ml - Build$: flag(mirage) + Build$: flag(nettests) Custom: true CompiledObject: native Target: xen diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 7fa231e..a095fef 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 956d7ad0919b568e7f4948fe9f0a1e66) *) +(* DO NOT EDIT (digest: 784bacf2664b4bcaecc9cf0ae93e0416) *) module OASISGettext = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISGettext.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISGettext.ml" let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExpr.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISExpr.ml" @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseEnvLight.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -# 56 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +# 56 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" type t = { diff --git a/setup.ml b/setup.ml index de2f55e..35523be 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.2.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 2b917b7dc8d0ebbebe824e55790c7621) *) +(* DO NOT EDIT (digest: 0d0b44846f149ae60dd097fc6bf29a9a) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISGettext.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISGettext.ml" let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISContext.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISContext.ml" open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -# 1 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISString.ml" +# 1 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISString.ml" @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISUtils.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISUtils.ml" open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/PropList.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/PropList.ml" open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -# 71 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/PropList.ml" +# 71 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/PropList.ml" end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISMessage.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISMessage.ml" open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISVersion.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISVersion.ml" open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISLicense.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISLicense.ml" (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExpr.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISExpr.ml" @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISTypes.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISTypes.ml" @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -# 102 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISTypes.ml" +# 102 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISTypes.ml" type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISUnixPath.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISHostPath.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISSection.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISSection.ml" open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISBuildSection.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" end module OASISExecutable = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExecutable.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISLibrary.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISFlag.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISFlag.ml" end module OASISPackage = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISPackage.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISPackage.ml" end module OASISSourceRepository = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISSourceRepository.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" end module OASISTest = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISTest.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISTest.ml" end module OASISDocument = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISDocument.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISDocument.ml" end module OASISExec = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExec.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISExec.ml" open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISFileUtil.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseEnvLight.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseContext.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseContext.ml" open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseMessage.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseMessage.ml" (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseEnv.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseEnv.ml" open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseArgExt.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseArgExt.ml" open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseCheck.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseCheck.ml" open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseOCamlcConfig.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseStandardVar.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseStandardVar.ml" open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseFileAB.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseFileAB.ml" open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseLog.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseLog.ml" open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseBuilt.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseBuilt.ml" open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseCustom.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseCustom.ml" open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseDynVar.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseDynVar.ml" open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseTest.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseTest.ml" open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseDoc.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseDoc.ml" open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseSetup.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/base/BaseSetup.ml" open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/internal/InternalInstallPlugin.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" +# 21 "/auto/homes/cr409/.opam/3.12.1+mirage-ns3-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5761,7 +5761,7 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "lwt", true) + (OASISExpr.EFlag "nettests", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "lib"; @@ -5788,7 +5788,7 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "lwt", true) + (OASISExpr.EFlag "nettests", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "controller"; @@ -5821,7 +5821,7 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "lwt", true) + (OASISExpr.EFlag "nettests", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "switch"; @@ -5845,7 +5845,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "(\248R{)\224\015\003Tnm,\r\228\207\158"; + oasis_digest = Some "|\025&\129\015^\150\139\001{5z\170\164\027\221"; oasis_exec = None; oasis_setup_args = []; setup_update = false; From dc37e8150275f8db67d6287b90cdb57e6244dff8 Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 29 Nov 2012 13:52:33 +0000 Subject: [PATCH 14/75] change rpc library to rpclib --- _oasis | 2 +- _tags | 20 ++++++---- lib/META | 4 +- myocamlbuild.ml | 14 +++---- setup.ml | 101 ++++++++++++++++++++++++------------------------ 5 files changed, 74 insertions(+), 67 deletions(-) diff --git a/_oasis b/_oasis index cabd689..383f57b 100644 --- a/_oasis +++ b/_oasis @@ -31,7 +31,7 @@ Library openflow CompiledObject: native Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch Pack: True - BuildDepends: cstruct, cstruct.syntax, rpc, mirage, mirage-net (>= 0.3.0) + BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0) Document openflow Title: OpenFlow docs diff --git a/_tags b/_tags index e36ecc5..283bf7b 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 7ec51c624334462bbfa7ad2802e56fa2) +# DO NOT EDIT (digest: 8b713f0a8b07fba3ca07598399e032b1) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -23,13 +23,15 @@ "lib/ofswitch_ctrl.native": use_openflow "lib/ofswitch_ctrl.native": pkg_cstruct "lib/ofswitch_ctrl.native": pkg_cstruct.syntax -"lib/ofswitch_ctrl.native": pkg_rpc +"lib/ofswitch_ctrl.native": pkg_rpclib +"lib/ofswitch_ctrl.native": pkg_rpclib.json "lib/ofswitch_ctrl.native": pkg_mirage "lib/ofswitch_ctrl.native": pkg_mirage-net : use_openflow : pkg_cstruct : pkg_cstruct.syntax -: pkg_rpc +: pkg_rpclib +: pkg_rpclib.json : pkg_mirage : pkg_mirage-net "lib/ofswitch_ctrl.native": custom @@ -37,13 +39,15 @@ "controller/learning_switch.native": use_openflow "controller/learning_switch.native": pkg_cstruct "controller/learning_switch.native": pkg_cstruct.syntax -"controller/learning_switch.native": pkg_rpc +"controller/learning_switch.native": pkg_rpclib +"controller/learning_switch.native": pkg_rpclib.json "controller/learning_switch.native": pkg_mirage "controller/learning_switch.native": pkg_mirage-net : use_openflow : pkg_cstruct : pkg_cstruct.syntax -: pkg_rpc +: pkg_rpclib +: pkg_rpclib.json : pkg_mirage : pkg_mirage-net "controller/learning_switch.native": custom @@ -51,13 +55,15 @@ "switch/basic_switch.native": use_openflow "switch/basic_switch.native": pkg_cstruct "switch/basic_switch.native": pkg_cstruct.syntax -"switch/basic_switch.native": pkg_rpc +"switch/basic_switch.native": pkg_rpclib +"switch/basic_switch.native": pkg_rpclib.json "switch/basic_switch.native": pkg_mirage "switch/basic_switch.native": pkg_mirage-net : use_openflow : pkg_cstruct : pkg_cstruct.syntax -: pkg_rpc +: pkg_rpclib +: pkg_rpclib.json : pkg_mirage : pkg_mirage-net "switch/basic_switch.native": custom diff --git a/lib/META b/lib/META index e754af5..255711b 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 0045d1e018354baf6501bc7d18bc32e3) +# DO NOT EDIT (digest: 5137e40263b875c2f23901ea9b742a8e) version = "0.3.0" description = "OpenFlow protocol and switch implementations in pure OCaml" -requires = "cstruct cstruct.syntax rpc mirage mirage-net" +requires = "cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net" archive(byte) = "openflow.cma" archive(byte, plugin) = "openflow.cma" archive(native) = "openflow.cmxa" diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 7fa231e..76b2b2d 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 956d7ad0919b568e7f4948fe9f0a1e66) *) +(* DO NOT EDIT (digest: a35a236ddf762327db44f569ec0c2480) *) module OASISGettext = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISGettext.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISGettext.ml" let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExpr.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISExpr.ml" @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseEnvLight.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -# 56 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +# 56 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" type t = { diff --git a/setup.ml b/setup.ml index de2f55e..fce2784 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.2.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 2b917b7dc8d0ebbebe824e55790c7621) *) +(* DO NOT EDIT (digest: 7c5e4b15a5fbad39cd9b2d3bebda35d9) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISGettext.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISGettext.ml" let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISContext.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISContext.ml" open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -# 1 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISString.ml" +# 1 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISString.ml" @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISUtils.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISUtils.ml" open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/PropList.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/PropList.ml" open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -# 71 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/PropList.ml" +# 71 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/PropList.ml" end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISMessage.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISMessage.ml" open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISVersion.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISVersion.ml" open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISLicense.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISLicense.ml" (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExpr.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISExpr.ml" @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISTypes.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISTypes.ml" @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -# 102 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISTypes.ml" +# 102 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISTypes.ml" type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISUnixPath.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISHostPath.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISSection.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISSection.ml" open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISBuildSection.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" end module OASISExecutable = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExecutable.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISLibrary.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISFlag.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISFlag.ml" end module OASISPackage = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISPackage.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISPackage.ml" end module OASISSourceRepository = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISSourceRepository.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" end module OASISTest = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISTest.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISTest.ml" end module OASISDocument = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISDocument.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISDocument.ml" end module OASISExec = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISExec.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISExec.ml" open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/oasis/OASISFileUtil.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseEnvLight.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseContext.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseContext.ml" open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseMessage.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseMessage.ml" (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseEnv.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseEnv.ml" open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseArgExt.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseArgExt.ml" open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseCheck.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseCheck.ml" open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseOCamlcConfig.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseStandardVar.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseStandardVar.ml" open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseFileAB.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseFileAB.ml" open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseLog.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseLog.ml" open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseBuilt.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseBuilt.ml" open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseCustom.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseCustom.ml" open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseDynVar.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseDynVar.ml" open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseTest.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseTest.ml" open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseDoc.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseDoc.ml" open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/base/BaseSetup.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseSetup.ml" open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/internal/InternalInstallPlugin.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -# 21 "/home/ubuntu/obj/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" +# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5693,7 +5693,8 @@ let setup_t = [ FindlibPackage ("cstruct", None); FindlibPackage ("cstruct.syntax", None); - FindlibPackage ("rpc", None); + FindlibPackage ("rpclib", None); + FindlibPackage ("rpclib.json", None); FindlibPackage ("mirage", None); FindlibPackage ("mirage-net", @@ -5845,7 +5846,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "(\248R{)\224\015\003Tnm,\r\228\207\158"; + oasis_digest = Some "\135\133\192tx#\236s\022+\162\223s\015\193\\"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5853,6 +5854,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5857 "setup.ml" +# 5858 "setup.ml" (* OASIS_STOP *) let () = setup ();; From f4f7fff997e88de3b2400d72a7dc7d1b17c16e75 Mon Sep 17 00:00:00 2001 From: root Date: Tue, 4 Dec 2012 10:30:28 +0000 Subject: [PATCH 15/75] Error in parsing packet in --- lib/ofpacket.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index fbe505c..2e692cd 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -1621,8 +1621,7 @@ module Packet_in = struct let total_len = get_ofp_packet_in_total_len bits in let in_port = Port.port_of_int (get_ofp_packet_in_in_port bits) in let reason = reason_of_int (get_ofp_packet_in_reason bits) in - let data = Cstruct.sub bits sizeof_ofp_packet_in - (total_len - sizeof_ofp_packet_in) in + let data = Cstruct.sub bits sizeof_ofp_packet_in total_len in { buffer_id; in_port; reason; data} let packet_in_to_string p = From 82647f50284af9863c905ad4ebcf11b05be0c278 Mon Sep 17 00:00:00 2001 From: crotsos Date: Sat, 15 Dec 2012 21:15:38 +0000 Subject: [PATCH 16/75] fixing switch working on macosx --- _oasis | 20 +- _tags | 4 +- lib/ofcontroller.ml | 323 +++++++++++++--------------- lib/ofcontroller.mli | 7 +- lib/ofpacket.ml | 300 ++++++++++++++++---------- lib/ofpacket.mli | 29 ++- lib/ofsocket.ml | 177 +++++++++++++++- lib/ofsocket.mli | 18 +- lib/ofswitch.ml | 411 +++++++++++++++++++----------------- lib/ofswitch.mli | 7 +- lib/ofswitch_ctrl.ml | 6 +- lib/ofswitch_standalone.ml | 149 +++++++++++++ lib/ofswitch_standalone.mli | 19 ++ lib/openflow.mlpack | 4 +- lib/openflow.odocl | 4 +- myocamlbuild.ml | 14 +- setup.ml | 114 +++++----- switch/basic_switch.ml | 32 +-- 18 files changed, 1048 insertions(+), 590 deletions(-) create mode 100644 lib/ofswitch_standalone.ml create mode 100644 lib/ofswitch_standalone.mli diff --git a/_oasis b/_oasis index 5cf911f..ebbcd07 100644 --- a/_oasis +++ b/_oasis @@ -29,7 +29,7 @@ Library openflow Path: lib Findlibname: openflow CompiledObject: native - Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch + Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch, Ofsocket, Ofswitch_standalone Pack: True BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0) @@ -38,31 +38,31 @@ Document openflow Type: ocamlbuild (0.2) BuildTools+: ocamldoc XOCamlbuildPath: lib - XOCamlbuildModules: Ofpacket, Ofcontroller, Ofswitch + XOCamlbuildModules: Ofpacket, Ofcontroller, Ofswitch, Ofsocket, Ofswitch_config Executable ofswitch_ctrl Path: lib MainIs: ofswitch_ctrl.ml - Build$: flag(nettests) + Build$: flag(lwt) Custom: true CompiledObject: native - Install: false + Install: true BuildDepends: openflow Executable learning_switch_lwt Path: controller MainIs: learning_switch.ml - Build$: flag(nettests) + Build$: flag(lwt) Custom: true CompiledObject: native - Install: false + Install: true BuildDepends: cstruct, cstruct.syntax, openflow Executable basic_switch_lwt Path: switch MainIs: basic_switch.ml - Build$: flag(nettests) + Build$: flag(lwt) Custom: true CompiledObject: native Install: false @@ -71,7 +71,7 @@ Executable basic_switch_lwt (*Executable learning_switch_mirage Path: controller MainIs: learning_switch.ml - Build$: flag(nettests) + Build$: flag(mirage) Custom: true CompiledObject: native Target: xen @@ -81,9 +81,9 @@ Executable basic_switch_lwt Executable basic_switch_mirage Path: switch MainIs: basic_switch.ml - Build$: flag(nettests) + Build$: flag(mirage) Custom: true CompiledObject: native Target: xen Install: false - BuildDepends: openflow*) + BuildDepends: openflow *) diff --git a/_tags b/_tags index 283bf7b..921ce91 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 8b713f0a8b07fba3ca07598399e032b1) +# DO NOT EDIT (digest: 89cfc75151445422183dc48c904b7297) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -19,6 +19,8 @@ "lib/ofcontroller.cmx": for-pack(Openflow) "lib/ofswitch_config.cmx": for-pack(Openflow) "lib/ofswitch.cmx": for-pack(Openflow) +"lib/ofsocket.cmx": for-pack(Openflow) +"lib/ofswitch_standalone.cmx": for-pack(Openflow) # Executable ofswitch_ctrl "lib/ofswitch_ctrl.native": use_openflow "lib/ofswitch_ctrl.native": pkg_cstruct diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index b57c4cc..c2eb1ee 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -17,7 +17,9 @@ open Lwt open Lwt_list open Net -open Printexc +open Printexc +open Printf +open Ofsocket let sp = Printf.sprintf let pp = Printf.printf @@ -26,7 +28,6 @@ let cp = OS.Console.log module OP = Ofpacket -let resolve t = Lwt.on_success t (fun _ -> ()) exception ReadError @@ -89,8 +90,7 @@ module Event = struct end type t = { - mutable dp_db: (OP.datapath_id, Channel.t) Hashtbl.t; - mutable channel_dp: ((Nettypes.ipv4_addr * int) , OP.datapath_id) Hashtbl.t; + mutable dp_db: (OP.datapath_id, conn_state) Hashtbl.t; mutable datapath_join_cb: (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; mutable datapath_leave_cb: @@ -147,148 +147,120 @@ let register_cb controller e cb = -> controller.port_status_cb <- controller.port_status_cb @ [cb] ) -let process_of_packet state (remote_addr, remote_port) ofp t = +let process_of_packet state conn ofp = OP.( - let ep = (remote_addr, remote_port) in match ofp with - | Hello (h) (* Reply to HELLO with a HELLO and a feature request *) - -> ( cp "HELLO"; - let bits = OP.marshal_and_sub (Header.marshal_header h) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - let bits = OP.marshal_and_sub (OP.build_features_req 1l) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - ) - - | Echo_req (h, bs) (* Reply to ECHO requests *) - -> ((* cp "ECHO_REQ"; *) - let bits = OP.marshal_and_sub - (OP.build_echo_resp h bs) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - ) - - | Features_resp (h, sfs) (* Generate a datapath join event *) - -> ((* cp "FEATURES_RESP";*) - let dpid = sfs.Switch.datapath_id in - let evt = Event.Datapath_join (dpid, sfs.Switch.ports) in - if (Hashtbl.mem state.dp_db dpid) then ( - Printf.printf "Deleting old state \n%!"; - Hashtbl.remove state.dp_db dpid; - Hashtbl.remove state.channel_dp ep - ); - Hashtbl.add state.dp_db dpid t; - Hashtbl.add state.channel_dp ep dpid; - Lwt_list.iter_p (fun cb -> cb state dpid evt) state.datapath_join_cb - ) - - | Packet_in (h, p) (* Generate a packet_in event *) - -> ( + | Hello (h) -> begin (* Reply to HELLO with a HELLO and a feature request *) + let _ = cp "HELLO" in + lwt _ = send_packet conn (OP.Hello (h)) in + let h = OP.Header.create OP.Header.FEATURES_RESP OP.Header.get_len in + send_packet conn (OP.Features_req (h) ) + end + | Echo_req h -> begin (* Reply to ECHO requests *) + cp "ECHO_REQ"; + let h = OP.Header.(create ~xid:h.xid ECHO_RESP get_len) in + send_packet conn (OP.Echo_resp h) + end + | Features_resp (h, sfs) -> begin (* Generate a datapath join event *) + cp "FEATURES_RESP"; + let dpid = sfs.Switch.datapath_id in + let _ = conn.dpid <- dpid in + let evt = Event.Datapath_join (dpid, sfs.Switch.ports) in + let _ = + if (Hashtbl.mem state.dp_db dpid) then + Printf.printf "Deleting old state \n%!" + in + let _ = Hashtbl.replace state.dp_db dpid conn in + Lwt_list.iter_p (fun cb -> cb state dpid evt) state.datapath_join_cb + end + | Packet_in (h, p) -> begin (* Generate a packet_in event *) cp (sp "+ %s|%s" (OP.Header.header_to_string h) (OP.Packet_in.packet_in_to_string p)); - let dpid = Hashtbl.find state.channel_dp ep in let evt = Event.Packet_in ( p.Packet_in.in_port, p.Packet_in.buffer_id, - p.Packet_in.data, dpid) + p.Packet_in.data, conn.dpid) in - iter_p (fun cb -> cb state dpid evt) + iter_p (fun cb -> cb state conn.dpid evt) state.packet_in_cb - ) - + end | Flow_removed (h, p) - -> ((* cp (sp "+ %s|%s" - (OP.Header.string_of_h h) - (OP.Flow_removed.string_of_flow_removed p)); *) - let dpid = Hashtbl.find state.channel_dp ep in + -> (cp (sp "+ %s|%s" + (OP.Header.header_to_string h) + (OP.Flow_removed.string_of_flow_removed p)); let evt = Event.Flow_removed ( p.Flow_removed.of_match, p.Flow_removed.reason, p.Flow_removed.duration_sec, p.Flow_removed.duration_nsec, - p.Flow_removed.packet_count, p.Flow_removed.byte_count, dpid) + p.Flow_removed.packet_count, p.Flow_removed.byte_count, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state dpid evt) state.flow_removed_cb + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_removed_cb ) - | Stats_resp(h, resp) - -> ((* cp (sp "+ %s|%s" (OP.Header.string_of_h h) - (OP.Stats.string_of_stats resp)); *) + | Stats_resp(h, resp) -> begin + cp (sp "+ %s|%s" (OP.Header.header_to_string h) + (OP.Stats.string_of_stats resp)); match resp with - | OP.Stats.Flow_resp(resp_h, flows) -> - (let dpid = Hashtbl.find state.channel_dp ep in - let evt = Event.Flow_stats_reply( - h.Header.xid, resp_h.Stats.more_to_follow, flows, dpid) + | OP.Stats.Flow_resp(resp_h, flows) -> begin + let evt = Event.Flow_stats_reply( + h.Header.xid, resp_h.Stats.more_to_follow, flows, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state dpid evt) + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_stats_reply_cb - ) - | OP.Stats.Aggregate_resp(resp_h, aggr) -> - (let dpid = Hashtbl.find state.channel_dp ep in + end + | OP.Stats.Aggregate_resp(resp_h, aggr) -> begin let evt = Event.Aggr_flow_stats_reply( h.Header.xid, aggr.Stats.packet_count, - aggr.Stats.byte_count, aggr.Stats.flow_count, dpid) + aggr.Stats.byte_count, aggr.Stats.flow_count, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state dpid evt) + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.aggr_flow_stats_reply_cb - ) - | OP.Stats.Desc_resp (resp_h, aggr) -> - (let dpid = Hashtbl.find state.channel_dp ep in + end + | OP.Stats.Desc_resp (resp_h, aggr) -> begin let evt = Event.Desc_stats_reply( aggr.Stats.imfr_desc, aggr.Stats.hw_desc, aggr.Stats.sw_desc, aggr.Stats.serial_num, - aggr.Stats.dp_desc, dpid) + aggr.Stats.dp_desc, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state dpid evt) + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.desc_stats_reply_cb - ) + end - | OP.Stats.Port_resp (resp_h, ports) -> - (let dpid = Hashtbl.find state.channel_dp ep in - let evt = Event.Port_stats_reply(h.Header.xid, ports, dpid) + | OP.Stats.Port_resp (resp_h, ports) -> begin + let evt = Event.Port_stats_reply(h.Header.xid, ports, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state dpid evt) + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_stats_reply_cb - ) + end - | OP.Stats.Table_resp (resp_h, tables) -> - (let dpid = Hashtbl.find state.channel_dp ep in - let evt = Event.Table_stats_reply(h.Header.xid, tables, dpid) - in - Lwt_list.iter_p (fun cb -> cb state dpid evt) + | OP.Stats.Table_resp (resp_h, tables) -> begin + let evt = Event.Table_stats_reply(h.Header.xid, tables, conn.dpid) in + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.table_stats_reply_cb - ) + end | _ -> OS.Console.log "New stats response received"; return (); - ) + end - | Port_status(h, st) - -> ( (* cp (sp "+ %s|%s" (OP.Header.string_of_h h) - (OP.Port.string_of_status st)); *) - let dpid = Hashtbl.find state.channel_dp ep in - let evt = Event.Port_status (st.Port.reason, st.Port.desc, dpid) + | Port_status(h, st) -> begin + cp (sp "+ %s|%s" (OP.Header.header_to_string h) + (OP.Port.string_of_status st)); + let evt = Event.Port_status (st.Port.reason, st.Port.desc, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state dpid evt) state.port_status_cb - ) - - | _ -> OS.Console.log "New packet received"; return () + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_status_cb + end + | _ -> + let _ = OS.Console.log (sp "Packet type not supported %s" + (OP.to_string ofp)) in + return () ) -let send_of_data controller dpid bits = - let t = Hashtbl.find controller.dp_db dpid in - match (Cstruct.len bits) with - | l when l <= 1400 -> - let _ = Channel.write_buffer t bits in - Channel.flush t - | _ -> - let buf = Cstruct.sub_buffer bits 0 1400 in - let _ = Channel.write_buffer t buf in - let buf = Cstruct.sub_buffer bits 1400 ((Cstruct.len bits) - 1400) in - let _ = Channel.write_buffer t buf in - lwt _ = Channel.flush t in - return () -(* let _ = Channel.write_buffer t.ch data in -Channel.flush t.ch *) +let send_of_data controller dpid bits = + let conn = Hashtbl.find controller.dp_db dpid in + Ofsocket.send_data_raw conn bits + +let send_data controller dpid ofp = + let conn = Hashtbl.find controller.dp_db dpid in + Ofsocket.send_packet conn ofp + let mem_dbg name = (* Gc.compact (); *) @@ -296,88 +268,81 @@ let mem_dbg name = Printf.printf "blocks %s: l=%d f=%d \n %!" name s.Gc.live_blocks s.Gc.free_blocks let terminate st = - Hashtbl.iter (fun _ ch -> resolve (Channel.close ch) ) st.dp_db; - Printf.printf "Terminating controller...\n" - -let controller st (remote_addr, remote_port) t = - let rs = Nettypes.ipv4_addr_to_string remote_addr in - let cached_socket = Ofsocket.create_socket t in - let _ = pp "OpenFlow Controller+ %s:%d\n%!" rs remote_port in - let echo () = - try_lwt - lwt hbuf = Ofsocket.read_data cached_socket OP.Header.sizeof_ofp_header in - let ofh = OP.Header.parse_header hbuf in - let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in - lwt dbuf = Ofsocket.read_data cached_socket dlen in - let ofp = OP.parse ofh dbuf in - lwt () = process_of_packet st (remote_addr, remote_port) ofp t in - return true - with + let _ = Hashtbl.iter + (fun _ c -> Ofsocket.close c ) st.dp_db in + Printf.printf "Terminating controller...\n%!" + +let controller_run st conn = + let continue = ref true in + lwt _ = + while_lwt !continue do + try_lwt + lwt pkt = read_packet conn in + process_of_packet st conn pkt + with | Nettypes.Closed -> begin - let dpid = Hashtbl.find st.channel_dp (remote_addr, remote_port) in - let evt = Event.Datapath_leave (dpid) in - lwt _ = Lwt_list.iter_p (fun cb -> cb st dpid evt) - st.datapath_leave_cb in - let _ = Hashtbl.remove st.channel_dp (remote_addr, remote_port) in - let _ = Hashtbl.remove st.dp_db dpid in - return false + let _ = printf "XXXXX switch disconnected\n%!" in + return (continue := false) end | OP.Unparsed(m, bs) | OP.Unparsable(m, bs) -> - cp (sp "# unparsed! m=%s" m); - Cstruct.hexdump bs; - return true + let _ = cp (sp "# unparsed! m=%s" m) in + return (Cstruct.hexdump bs) | Not_found -> - Printf.printf "Error: Not found %s\n%!" (Printexc.get_backtrace ()); - return true + return (Printf.printf "Error: Not found %s\n%!" + (Printexc.get_backtrace ()) ) | exn -> - pp "{OpenFlow-controller} ERROR:%s\n%s\n%!" (Printexc.to_string exn) - (Printexc.get_backtrace ()); - return false + pp "{OpenFlow-controller} ERROR:%s\n%s\n%!" (Printexc.to_string exn) + (Printexc.get_backtrace ()); + return (continue := false) + done + in + if (conn.dpid > 0L) then + let evt = Event.Datapath_leave (conn.dpid) in + lwt _ = Lwt_list.iter_p (fun cb -> cb st conn.dpid evt) + st.datapath_leave_cb in + let _ = Hashtbl.remove st.dp_db conn.dpid in + return () + else + return () + - in - let continue = ref true in - let count = (ref 0) in - while_lwt !continue do - incr count; - lwt x = echo () in - continue := x; - return () - done + +let socket_controller st (remote_addr, remote_port) t = + let rs = Nettypes.ipv4_addr_to_string remote_addr in + let _ = pp "OpenFlow Controller+ %s:%d\n%!" rs remote_port in + let conn = init_socket_conn_state t in + controller_run st conn + +let init_controller () = + { dp_db = Hashtbl.create 0; + datapath_join_cb = []; + datapath_leave_cb = []; + packet_in_cb = []; + flow_removed_cb = []; + flow_stats_reply_cb = []; + aggr_flow_stats_reply_cb = []; + desc_stats_reply_cb = []; + port_stats_reply_cb = []; + table_stats_reply_cb = []; + port_status_cb = []; } let listen mgr loc init = - let st = { dp_db = Hashtbl.create 0; - channel_dp = Hashtbl.create 0; - datapath_join_cb = []; - datapath_leave_cb = []; - packet_in_cb = []; - flow_removed_cb = []; - flow_stats_reply_cb = []; - aggr_flow_stats_reply_cb = []; - desc_stats_reply_cb = []; - port_stats_reply_cb = []; - table_stats_reply_cb = []; - port_status_cb = []; - } - in + let st = init_controller () in let _ = init st in - (Channel.listen mgr (`TCPv4 (loc, (controller st) ))) + (Channel.listen mgr (`TCPv4 (loc, (socket_controller st) ))) let connect mgr loc init = - let st = { dp_db = Hashtbl.create 0; - channel_dp = Hashtbl.create 0; - datapath_join_cb = []; - datapath_leave_cb = []; - packet_in_cb = []; - flow_removed_cb = []; - flow_stats_reply_cb = []; - aggr_flow_stats_reply_cb = []; - desc_stats_reply_cb = []; - port_stats_reply_cb = []; - table_stats_reply_cb = []; - port_status_cb = []; - } - in + let st = init_controller () in let _ = init st in Net.Channel.connect mgr (`TCPv4 (None, loc, - (controller st loc) )) + (socket_controller st loc) )) + +let init_controller init = + let st = init_controller () in + let _ = init st in + st + +let local_connect mgr st (input, output) init = + let conn = init_local_conn_state input output in + controller_run st conn diff --git a/lib/ofcontroller.mli b/lib/ofcontroller.mli index e6f1ded..da77d31 100644 --- a/lib/ofcontroller.mli +++ b/lib/ofcontroller.mli @@ -47,12 +47,17 @@ module Event : sig val string_of_event : e -> string end -type t +type t val register_cb : t -> Event.t -> (t -> Ofpacket.datapath_id -> Event.e -> unit Lwt.t) -> unit val send_of_data : t -> Ofpacket.datapath_id -> Cstruct.buf -> unit Lwt.t +val send_data : t -> Ofpacket.datapath_id -> Ofpacket.t -> unit Lwt.t val terminate : t -> unit val mem_dbg : string -> unit val listen : Manager.t -> Nettypes.ipv4_src -> (t -> 'a) -> unit Lwt.t val connect : Manager.t -> Nettypes.ipv4_dst -> (t -> 'a) -> unit Lwt.t +val init_controller : (t -> 'a) -> t +val local_connect : Manager.t -> t -> + (Ofpacket.t Lwt_stream.t * (Ofpacket.t option -> unit )) -> + (t -> 'a) -> unit Lwt.t diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 2e692cd..82c714a 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -298,7 +298,7 @@ module Header = struct sp "ver:%d type:%s len:%d xid:0x%08lx" (int_of_byte h.ver) (msg_code_to_string h.ty) h.len h.xid - let create ty len xid = + let create ?(xid=Random.int32 Int32.max_int) ty len = { ver=byte 1; ty; len; xid } let marshal_header h bits = @@ -649,7 +649,8 @@ module Port = struct } as big_endian let create_port_status reason desc = - {reason; desc;} + ((Header.(create PORT_STATUS (get_len + sizeof_ofp_port_status)) ), + {reason; desc;}) let string_of_status st = (sp "Port status,reason:%s,%s" (reason_to_string st.reason) @@ -666,7 +667,7 @@ module Port = struct let marshal_port_status ?(xid=0l) status bits = let len = Header.get_len + sizeof_ofp_port_status + phy_len in - let header = Header.create Header.PORT_STATUS len xid in + let header = Header.create ~xid Header.PORT_STATUS len in let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in let _ = set_ofp_port_status_reason bits (reason_to_int status.reason) in let bits = Cstruct.shift bits sizeof_ofp_port_status in @@ -776,12 +777,16 @@ module Switch = struct | head :: tail -> let bits = Port.marshal_phy head bits in marshal_phy_ports tail bits + let get_len t = + Header.get_len + sizeof_ofp_switch_features + + ((List.length t.ports) * Port.phy_len) + let marshal_reply_features xid feat bits = let ports_count = (List.length feat.ports) in let len = Header.get_len + sizeof_ofp_switch_features + ports_count*Port.phy_len in - let header = Header.create Header.FEATURES_RESP len xid in + let header = Header.create ~xid Header.FEATURES_RESP len in let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in let _ = set_ofp_switch_features_datapath_id bits feat.datapath_id in let _ = set_ofp_switch_features_n_buffers bits feat.n_buffers in @@ -821,9 +826,11 @@ module Switch = struct uint16_t miss_send_len } as big_endian + let config_get_len = Header.get_len + sizeof_ofp_switch_config + let marshal_switch_config xid config bits = - let header = (Header.create Header.GET_CONFIG_RESP - (Header.get_len + sizeof_ofp_switch_config) xid) in + let header = (Header.create ~xid Header.GET_CONFIG_RESP + (Header.get_len + sizeof_ofp_switch_config)) in let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in let _ = set_ofp_switch_config_flags bits 0 in let _ = set_ofp_switch_config_miss_send_len bits config.miss_send_len in @@ -1572,10 +1579,12 @@ module Packet_out = struct ~data ~in_port () = {buffer_id; in_port; actions; data;} - let marshal_packet_out m bits = - let size = (Header.sizeof_ofp_header + sizeof_ofp_packet_out + - (Flow.actions_len m.actions) + (Cstruct.len m.data)) in - let of_header=(Header.(create PACKET_OUT size 0l)) in + let get_len t = Header.sizeof_ofp_header + sizeof_ofp_packet_out + + (Flow.actions_len t.actions) + (Cstruct.len t.data) + + let marshal_packet_out ?(xid=Random.int32 Int32.max_int) m bits = + let size = get_len m in + let of_header=Header.(create ~xid PACKET_OUT size) in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in let _ = set_ofp_packet_out_buffer_id bits m.buffer_id in @@ -1628,8 +1637,13 @@ module Packet_in = struct sp "Packet_in: buffer_id:%ld in_port:%s reason:%s" p.buffer_id (Port.string_of_port p.in_port) (string_of_reason p.reason) - let create_pkt_in ?(buffer_id=(-1l)) ~in_port ~reason ~data = - {buffer_id; in_port; reason; data;} + let get_len t = Header.get_len + sizeof_ofp_packet_in + + (Cstruct.len t.data) + + let create_pkt_in ?(buffer_id=(-1l)) ~in_port ~reason ~data = + let pkt_in = {buffer_id; in_port; reason; data;} in + let h = Header.create Header.PACKET_IN (get_len pkt_in) in + (h, pkt_in) let marshal_pkt_in ?(xid=(Random.int32 Int32.max_int)) ?(data_len=0) t bits = @@ -1643,8 +1657,8 @@ module Packet_in = struct Cstruct.len t.data ) in - let h = Header.create Header.PACKET_IN (Header.sizeof_ofp_header + - sizeof_ofp_packet_in + data_len) xid in + let h = Header.create ~xid Header.PACKET_IN (Header.sizeof_ofp_header + + sizeof_ofp_packet_in + data_len) in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header h) bits in let _ = set_ofp_packet_in_buffer_id bits t.buffer_id in let _ = set_ofp_packet_in_total_len bits (sizeof_ofp_packet_in + data_len) in @@ -1741,7 +1755,7 @@ module Flow_mod = struct let marshal_flow_mod ?(xid=(Random.int32 Int32.max_int)) m bits = let len = Header.sizeof_ofp_header + Match.sizeof_ofp_match + sizeof_ofp_flow_mod + (Flow.actions_len m.actions) in - let header = Header.create Header.FLOW_MOD len xid in + let header = Header.create ~xid Header.FLOW_MOD len in let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in let (_, bits) = marshal_and_shift (Match.marshal_match m.of_match) bits in let _ = set_ofp_flow_mod_cookie bits m.cookie in @@ -1843,10 +1857,12 @@ module Flow_removed = struct {of_match; cookie; priority; reason; duration_sec; duration_nsec; idle_timeout; packet_count; byte_count;} + let get_len = Header.sizeof_ofp_header + Match.sizeof_ofp_match + + sizeof_ofp_flow_removed + let marshal_flow_removed ?(xid=(Random.int32 Int32.max_int)) m bits = - let len = Header.sizeof_ofp_header + Match.sizeof_ofp_match + - sizeof_ofp_flow_removed in - let header = Header.create Header.FLOW_REMOVED len xid in + let len = get_len in + let header = Header.create ~xid Header.FLOW_REMOVED len in let (_, bits) = marshal_and_shift (Header.marshal_header header) bits in let (_, bits) = marshal_and_shift (Match.marshal_match m.of_match) bits in let _ = set_ofp_flow_removed_cookie bits m.cookie in @@ -1966,14 +1982,7 @@ module Stats = struct | 6 -> VENDOR | v -> raise(Unsupported("req_type_of_int")) - let get_len = function - | FLOW -> (Header.sizeof_ofp_header + 4 + Match.sizeof_ofp_match + 4 ) - | AGGREGATE -> (Header.sizeof_ofp_header + 4 + Match.sizeof_ofp_match + 4 ) - | PORT -> (Header.sizeof_ofp_header + 12) - | QUEUE -> (Header.sizeof_ofp_header + 12) - | _ -> (Header.sizeof_ofp_header + 4) - - cstruct ofp_stats_request { + cstruct ofp_stats_request { uint16_t typ; uint16_t flags } as big_endian @@ -1984,15 +1993,43 @@ module Stats = struct uint16_t out_port } as big_endian - let create_flow_stat_req flow_match ?(table_id=0xff) ?(out_port=(Port.No_port)) -(* ?(xid=0l) bits () = *) - ?(xid=(Random.int32 Int32.max_int)) bits = - let header = Header.create Header.STATS_REQ - (Header.sizeof_ofp_header + - sizeof_ofp_stats_request + - Match.sizeof_ofp_match + - sizeof_ofp_flow_stats_request ) - xid in + cstruct ofp_queue_stats_request { + uint16_t port_no; + uint8_t pad[2]; + uint32_t queue_id + } as big_endian + + cstruct ofp_port_stats_request { + uint16_t port_no; + uint8_t pad[6] + } as big_endian + + let get_len = function + | TABLE + | DESC -> Header.sizeof_ofp_header + sizeof_ofp_stats_request + | AGGREGATE + | FLOW -> + (Header.sizeof_ofp_header + sizeof_ofp_stats_request + + Match.sizeof_ofp_match + sizeof_ofp_flow_stats_request ) + | QUEUE -> (Header.sizeof_ofp_header + sizeof_ofp_stats_request + + sizeof_ofp_queue_stats_request) + | PORT -> (Header.sizeof_ofp_header + sizeof_ofp_stats_request + + sizeof_ofp_port_stats_request) + | _ -> (Header.sizeof_ofp_header + 4) + + let create_desc_stat_req ?(xid=(Random.int32 Int32.max_int)) bits = + let len = get_len DESC in + let header = Header.create ~xid Header.STATS_REQ len in + let _ = Header.marshal_header header bits in + let bits = Cstruct.shift bits Header.sizeof_ofp_header in + let _ = set_ofp_stats_request_typ bits (int_of_req_type DESC) in + let _ = set_ofp_stats_request_flags bits 0 in + len + + let create_flow_stat_req flow_match ?(table_id=All) ?(out_port=(Port.No_port)) + ?(xid=(Random.int32 Int32.max_int)) bits = + let len = get_len FLOW in + let header = Header.create ~xid Header.STATS_REQ len in let _ = Header.marshal_header header bits in let bits = Cstruct.shift bits Header.sizeof_ofp_header in let _ = set_ofp_stats_request_typ bits (int_of_req_type FLOW) in @@ -2000,19 +2037,14 @@ module Stats = struct let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = Match.marshal_match flow_match bits in let bits = Cstruct.shift bits Match.sizeof_ofp_match in - let _ = set_ofp_flow_stats_request_table_id bits table_id in + let _ = set_ofp_flow_stats_request_table_id bits (int_of_table_id table_id) in let _ = set_ofp_flow_stats_request_out_port bits (Port.int_of_port out_port) in - Header.sizeof_ofp_header + sizeof_ofp_stats_request + - Match.sizeof_ofp_match + sizeof_ofp_flow_stats_request + len - let create_aggr_flow_stat_req flow_match ?(table_id=0xff) ?(out_port=Port.No_port) + let create_aggr_flow_stat_req flow_match ?(table_id=All) ?(out_port=Port.No_port) ?(xid=(Random.int32 Int32.max_int)) bits = - let header = Header.create Header.STATS_REQ - (Header.sizeof_ofp_header + - sizeof_ofp_stats_request + - Match.sizeof_ofp_match + - sizeof_ofp_flow_stats_request ) - xid in + let len = get_len AGGREGATE in + let header = Header.create ~xid Header.STATS_REQ len in let _ = Header.marshal_header header bits in let bits = Cstruct.shift bits Header.sizeof_ofp_header in let _ = set_ofp_stats_request_typ bits (int_of_req_type AGGREGATE) in @@ -2020,10 +2052,9 @@ module Stats = struct let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = Match.marshal_match flow_match bits in let bits = Cstruct.shift bits Match.sizeof_ofp_match in - let _ = set_ofp_flow_stats_request_table_id bits table_id in + let _ = set_ofp_flow_stats_request_table_id bits (int_of_table_id table_id) in let _ = set_ofp_flow_stats_request_out_port bits (Port.int_of_port out_port) in - Header.sizeof_ofp_header + sizeof_ofp_stats_request + - Match.sizeof_ofp_match + sizeof_ofp_flow_stats_request + len (* struct ofp_vendor_header { uint32_t vendor; @@ -2033,28 +2064,19 @@ module Stats = struct let header = (Header.build_h (Header.create Header.STATS_REQ (get_len VENDOR) snd_xid)) in BITSTRING{(header):(Header.get_len * 8):bitstring; (int_of_req_type DESC):16;0:16}*) - let create_table_stat_req ?(xid=(Random.int32 Int32.max_int)) bits = - let header = Header.create Header.STATS_REQ - (Header.sizeof_ofp_header + - sizeof_ofp_stats_request) xid in + let create_table_stat_req ?(xid=(Random.int32 Int32.max_int)) bits = + let len = get_len TABLE in + let header = Header.create ~xid Header.STATS_REQ len in let _ = Header.marshal_header header bits in let bits = Cstruct.shift bits Header.sizeof_ofp_header in let _ = set_ofp_stats_request_typ bits (int_of_req_type TABLE) in let _ = set_ofp_stats_request_flags bits 0 in - Header.sizeof_ofp_header + sizeof_ofp_stats_request - - cstruct ofp_queue_stats_request { - uint16_t port_no; - uint8_t pad[2]; - uint32_t queue_id - } as big_endian + len - let create_queue_stat_req ?(xid=(Random.int32 Int32.max_int)) + let create_queue_stat_req ?(xid=(Random.int32 Int32.max_int)) ?(queue_id=0xffffffffl) ?(port=Port.No_port) bits = - let header = Header.create Header.STATS_REQ - (Header.sizeof_ofp_header + - sizeof_ofp_stats_request + - sizeof_ofp_queue_stats_request) xid in + let len = get_len QUEUE in + let header = Header.create ~xid Header.STATS_REQ len in let _ = Header.marshal_header header bits in let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_stats_request_typ bits (int_of_req_type QUEUE) in @@ -2062,28 +2084,19 @@ module Stats = struct let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_queue_stats_request_port_no bits (Port.int_of_port port) in let _ = set_ofp_queue_stats_request_queue_id bits queue_id in - Header.sizeof_ofp_header + sizeof_ofp_stats_request + - sizeof_ofp_queue_stats_request + len - cstruct ofp_port_stats_request { - uint16_t port_no; - uint8_t pad[6] - } as big_endian - - let create_port_stat_req ?(xid=(Random.int32 Int32.max_int)) - ?(port=Port.No_port) bits = - let header = Header.create Header.STATS_REQ - (Header.sizeof_ofp_header + - sizeof_ofp_stats_request + - sizeof_ofp_port_stats_request) xid in + let create_port_stat_req ?(xid=(Random.int32 Int32.max_int)) + ?(port=Port.No_port) bits = + let len = get_len PORT in + let header = Header.create ~xid Header.STATS_REQ len in let _ = Header.marshal_header header bits in let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_stats_request_typ bits (int_of_req_type PORT) in let _ = set_ofp_stats_request_flags bits 0 in let bits = Cstruct.shift bits sizeof_ofp_stats_request in let _ = set_ofp_port_stats_request_port_no bits (Port.int_of_port port) in - Header.sizeof_ofp_header + sizeof_ofp_stats_request + - sizeof_ofp_port_stats_request + len type req = | Desc_req of req_hdr @@ -2094,6 +2107,21 @@ module Stats = struct | Queue_req of req_hdr * Port.t * queue_id | Vendor_req of req_hdr + let marshal_stats_req ?(xid=Random.int32 Int32.max_int) req bits = + match req with + | Desc_req _ -> create_desc_stat_req ~xid bits + | Table_req _ -> create_table_stat_req ~xid bits + | Flow_req (_, m, table_id, out_port) -> + create_flow_stat_req m ~table_id ~out_port ~xid bits + | Aggregate_req (_, m, table_id, out_port) -> + create_aggr_flow_stat_req m ~table_id ~out_port ~xid bits + | Port_req (_, port) -> + create_port_stat_req ~xid ~port bits + | Queue_req (_, port, queue_id) -> + create_queue_stat_req ~xid ~queue_id ~port bits +(* | Vendor_req _ -> failwith "Vendor queue req not supported" *) + + let parse_stats_req bits = let flags = get_ofp_stats_request_flags bits in let ty = get_ofp_stats_request_typ bits in @@ -2266,7 +2294,14 @@ module Stats = struct let resp_get_len = function | Desc_resp(_, _) -> Header.sizeof_ofp_header + sizeof_ofp_desc_stats - | Table_resp (_, tables) -> 4 + (List.length tables) *(1+3+32+4+4+4+8+8) + | Flow_resp (_, f) -> + let flow_len = List.fold_right + (fun f l -> l + (Flow.flow_stats_len f) ) f 0 in + Header.get_len + sizeof_ofp_stats_reply +flow_len + | Aggregate_resp _ -> + Header.get_len + sizeof_ofp_stats_reply + + sizeof_ofp_aggregate_stats_reply + | Table_resp (_, tables) -> 4 + (List.length tables) *(1+3+32+4+4+4+8+8) | _ -> failwith "resp_get_len" let marshal_stats_resp xid resp bits = @@ -2274,7 +2309,7 @@ module Stats = struct | Desc_resp(resp_hdr, desc) -> let len = (Header.sizeof_ofp_header + sizeof_ofp_stats_reply + sizeof_ofp_desc_stats) in - let of_header = Header.create Header.STATS_RESP len xid in + let of_header = Header.create ~xid Header.STATS_RESP len in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type DESC) in @@ -2292,7 +2327,7 @@ module Stats = struct (fun f l -> l + (Flow.flow_stats_len f) ) flows 0 in let len = (Header.sizeof_ofp_header + sizeof_ofp_stats_reply + flow_len) in - let of_header = Header.create Header.STATS_RESP len xid in + let of_header = Header.create ~xid Header.STATS_RESP len in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type FLOW) in @@ -2306,7 +2341,7 @@ module Stats = struct | Aggregate_resp(resp, stats) -> let len = Header.sizeof_ofp_header + sizeof_ofp_stats_reply + sizeof_ofp_aggregate_stats_reply in - let of_header = Header.create Header.STATS_RESP len xid in + let of_header = Header.create ~xid Header.STATS_RESP len in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type AGGREGATE) in @@ -2490,8 +2525,8 @@ and string_of_error_code = function let marshal_error errornum data xid bits = let req_len = Cstruct.len data in - let req_h = (Header.create Header.ERROR - (Header.get_len + sizeof_ofp_error_msg + req_len) xid) in + let req_h = Header.create ~xid Header.ERROR + (Header.get_len + sizeof_ofp_error_msg + req_len) in let (len, bits) = marshal_and_shift (Header.marshal_header req_h) bits in let errornum = int_of_error_code errornum in let _ = set_ofp_error_msg_typ bits @@ -2503,22 +2538,20 @@ let marshal_error errornum data xid bits = (Header.get_len + sizeof_ofp_error_msg + req_len) let build_features_req xid bits = - Header.marshal_header (Header.(create FEATURES_REQ 8 xid)) bits + Header.marshal_header (Header.(create ~xid FEATURES_REQ 8)) bits -let build_echo_resp h bs bits = - let len = Header.get_len + (Cstruct.len bs) in +let build_echo_resp h bits = + let len = Header.get_len in let _ = Header.(marshal_header - (create ECHO_RESP len h.xid) bits ) in - let _ = Cstruct.blit_buffer bs 0 bits Header.get_len - (Cstruct.len bs) in - len + (create ~xid:h.xid ECHO_RESP len ) bits) in + len type t = | Hello of Header.h - | Error of Header.h * error_code - | Echo_req of Header.h * Cstruct.buf - | Echo_resp of Header.h * Cstruct.buf + | Error of Header.h * error_code * Cstruct.buf + | Echo_req of Header.h + | Echo_resp of Header.h | Vendor of Header.h * vendor * Cstruct.buf | Features_req of Header.h @@ -2548,8 +2581,8 @@ let parse h bits = Header.(match h.ty with | HELLO -> Hello (h) | ERROR -> raise (Unparsed ("ERROR", bits)) - | ECHO_REQ -> Echo_req (h, bits) - | ECHO_RESP -> Echo_resp (h, bits) + | ECHO_REQ -> Echo_req h + | ECHO_RESP -> Echo_resp h | VENDOR -> raise (Unparsed ("VENDOR", bits)) | FEATURES_REQ -> Features_req (h) | FEATURES_RESP -> Features_resp (h, Switch.parse_features bits) @@ -2569,13 +2602,66 @@ let parse h bits = | _ -> raise (Unparsed ("_", bits)) ) -(* let new_parse bits = - bitmatch bits with - | { 1:8:int; t:8; len:16; xid:32; body:-1:bitstring } - -> ( - (parse (Header.({ ver=byte 1; ty=(msg_code_of_int t); - len; xid;})) body, - (Bitstring.dropbits (len*8) bits) ) - ) - | { _ } -> raise (Unparsable ("parse_h", bits)) *) - +let to_string = function + | Features_req h + | Get_config_req h + | Barrier_req h + | Barrier_resp h + | Echo_req h + | Echo_resp h + | Get_config_req h + | Get_config_resp (h, _) + | Set_config (h, _) + | Flow_removed (h, _) + | Packet_in (h, _) + | Features_resp (h, _) + | Port_status (h, _) + | Stats_req (h, _) + | Stats_resp (h, _) + | Error (h, _, _) + | Packet_out (h, _) + | Flow_mod (h, _) + | Hello h -> Header.header_to_string h + | _ -> failwith "Unsupported message" + +let marshal msg = + let marshal = + match msg with + | Features_req h + | Get_config_req h + | Barrier_req h + | Barrier_resp h + | Echo_req h + | Echo_resp h + | Get_config_req h + | Hello h -> Header.marshal_header h + | Flow_removed (h, frm) -> + Flow_removed.marshal_flow_removed ~xid:(h.Header.xid) frm + | Packet_in (h, pkt_in) -> + Packet_in.marshal_pkt_in ~xid:h.Header.xid pkt_in + | Features_resp (h, p) -> + Switch.marshal_reply_features h.Header.xid p + | Get_config_resp (h, c) + | Set_config (h, c) -> + Switch.marshal_switch_config h.Header.xid c + | Port_status (h, p) -> + Port.marshal_port_status ~xid:h.Header.xid p + | Stats_req (h, p) -> + Stats.marshal_stats_req ~xid:h.Header.xid p + | Stats_resp (h, p) -> + Stats.marshal_stats_resp h.Header.xid p + | Error (h, err, bits) -> + marshal_error err bits h.Header.xid + | Packet_out (h, p) -> + Packet_out.marshal_packet_out ~xid:h.Header.xid p + | Flow_mod (h, fm) -> + Flow_mod.marshal_flow_mod ~xid:h.Header.xid fm + | _ -> failwith "Unsupported message" + in +(* + | Vendor of Header.h * vendor * Cstruct.buf + | Port_mod of Header.h * Port_mod.t + | Queue_get_config_req of Header.h * Port.t + | Queue_get_config_resp of Header.h * Port.t * Queue.t array + *) + marshal_and_sub marshal (OS.Io_page.get ()) diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index 2322570..7cb3baf 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -60,7 +60,7 @@ module Header : val get_len : int val parse_header : Cstruct.buf -> h val header_to_string : h -> string - val create : msg_code -> uint16 -> uint32 -> h + val create : ?xid:uint32 -> msg_code -> uint16 -> h val marshal_header : h -> Cstruct.buf -> int val sizeof_ofp_header : int end @@ -148,7 +148,7 @@ module Port : type reason = ADD | DEL | MOD val reason_to_string: reason -> string type status = { reason : reason; desc : phy; } - val create_port_status : reason -> phy -> status + val create_port_status : reason -> phy -> Header.h * status val string_of_status : status -> string val marshal_port_status : ?xid:int32 -> status -> Cstruct.buf -> int end @@ -187,8 +187,10 @@ module Switch : mutable ports : Port.phy list; } val marshal_reply_features : int32 -> features -> Cstruct.buf -> int + val get_len : features -> int type config = { drop : bool; reasm : bool; miss_send_len : uint16; } val init_switch_config : config + val config_get_len : int val marshal_switch_config : int32 -> config -> Cstruct.buf -> int end module Wildcards : @@ -303,7 +305,7 @@ module Packet_in : } val packet_in_to_string : t -> string val create_pkt_in : ?buffer_id:uint32 -> in_port:Port.t -> - reason:reason -> data:Cstruct.buf -> t + reason:reason -> data:Cstruct.buf -> (Header.h * t) val marshal_pkt_in : ?xid:int32 -> ?data_len:int -> t -> Cstruct.buf -> int end @@ -321,7 +323,7 @@ module Packet_out : ?actions:Flow.action list -> data:Cstruct.buf -> in_port:Port.t -> unit -> t - val marshal_packet_out : t -> Cstruct.buf -> int + val marshal_packet_out : ?xid:int32 -> t -> Cstruct.buf -> int val packet_out_to_string: t -> string end module Flow_mod : @@ -359,6 +361,7 @@ module Flow_removed : val reason_of_int : int -> reason val int_of_reason : reason -> int val string_of_reason : reason -> string + val get_len : int type t = { of_match : Match.t; cookie : uint64; @@ -427,13 +430,14 @@ module Stats : val int_of_req_type : stats_type -> int val create_flow_stat_req : Match.t -> - ?table_id:int -> + ?table_id:table_id -> ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.buf -> int val create_aggr_flow_stat_req : Match.t -> - ?table_id:int -> + ?table_id:table_id -> ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.buf -> int (* val create_vendor_stat_req : ?xid:Int32.t -> Cstruct.buf -> unit *) + val create_desc_stat_req : ?xid:Int32.t -> Cstruct.buf -> int val create_table_stat_req : ?xid:Int32.t -> Cstruct.buf -> int val create_queue_stat_req : ?xid:Int32.t -> @@ -448,6 +452,8 @@ module Stats : | Port_req of req_hdr * Port.t | Queue_req of req_hdr * Port.t * queue_id | Vendor_req of req_hdr + val marshal_stats_req : ?xid:int32 -> req -> Cstruct.buf -> int + type resp_hdr = { st_ty : stats_type; more_to_follow : bool; } val int_of_stats_type : stats_type -> int val stats_type_of_int : int -> stats_type @@ -459,6 +465,7 @@ module Stats : | Port_resp of resp_hdr * Port.stats list | Queue_resp of resp_hdr * queue list | Vendor_resp of resp_hdr + val resp_get_len : resp -> int val marshal_stats_resp : int32 -> resp -> Cstruct.buf -> int val string_of_stats : resp -> string end @@ -502,12 +509,12 @@ val int_of_error_code : error_code -> uint32 val string_of_error_code : error_code -> string val marshal_error : error_code -> Cstruct.buf -> int32 -> Cstruct.buf -> int val build_features_req : uint32 -> Cstruct.buf -> int -val build_echo_resp : Header.h -> Cstruct.buf-> Cstruct.buf -> int +val build_echo_resp : Header.h -> Cstruct.buf -> int type t = Hello of Header.h - | Error of Header.h * error_code - | Echo_req of Header.h * Cstruct.buf - | Echo_resp of Header.h * Cstruct.buf + | Error of Header.h * error_code * Cstruct.buf + | Echo_req of Header.h + | Echo_resp of Header.h | Vendor of Header.h * vendor * Cstruct.buf | Features_req of Header.h | Features_resp of Header.h * Switch.features @@ -527,3 +534,5 @@ type t = | Queue_get_config_req of Header.h * Port.t | Queue_get_config_resp of Header.h * Port.t * Queue.t array val parse : Header.h -> Cstruct.buf -> t +val marshal : t -> Cstruct.buf +val to_string : t -> string diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index 4611863..a5dd4ae 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -13,9 +13,11 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -(* open Openflow_net_lwt *) open Net open Lwt +open Printf +module OP = Ofpacket + exception ReadError let sp = Printf.sprintf @@ -23,6 +25,9 @@ let pp = Printf.printf let ep = Printf.eprintf let cp = pp "%s\n%!" +let resolve t = Lwt.on_success t (fun _ -> ()) + +module Socket = struct type t = { sock: Channel.t; data_cache: Cstruct.buf list ref; @@ -31,6 +36,21 @@ type t = { let create_socket sock = { sock; data_cache=(ref []);} +let write_buffer t bits = + match (Cstruct.len bits) with + | l when l <= 1400 -> + let _ = Channel.write_buffer t.sock bits in + Channel.flush t.sock + | _ -> + let buf = Cstruct.sub_buffer bits 0 1400 in + let _ = Channel.write_buffer t.sock buf in + let buf = Cstruct.sub_buffer bits 1400 ((Cstruct.len bits) - 1400) in + let _ = Channel.write_buffer t.sock buf in + lwt _ = Channel.flush t.sock in + return () + +let close t = Channel.close t.sock + let rec read_data t len = (* Printf.printf "let rec read_data t data_cache %d = \n%!" len; *) match (len, !(t.data_cache)) with @@ -85,3 +105,158 @@ let rec read_data t len = (* pp "| (_, _) ->\n%!"; *) Printf.printf "read_data and not match found\n%!"; return (Cstruct.sub (OS.Io_page.get ()) 0 0 ) +end + +module Unix_socket = struct + type t = { + sock: Lwt_unix.file_descr; + data_cache: Cstruct.buf list ref; + } + + let create_socket sock = + { sock; data_cache=(ref []);} + + let rec write_buffer t bits = + let rec write_buffer_inner t bits = function + | len when len >= (Cstruct.len bits) -> return () + | len -> + lwt l = Lwt_bytes.write t.sock bits len ((Cstruct.len bits) - len) in + let _ = + if (l = 0) then + raise Net.Nettypes.Closed + in + write_buffer_inner t bits (len + l) + in + try_lwt + write_buffer_inner t bits 0 + with exn -> + let _ = printf "[socket] write error: %s\n%!" (Printexc.to_string exn) in + raise Net.Nettypes.Closed + + let close t = return (Lwt_unix.shutdown t.sock Lwt_unix.SHUTDOWN_ALL) + + let buf_size ar = + List.fold_right (fun a b -> (Cstruct.len a) + b) ar 0 + + let rec read_data t len = + try_lwt + match (len, !(t.data_cache)) with + | (0, _) -> return (Lwt_bytes.create 0 ) + | (_, []) -> + let p = OS.Io_page.get () in + lwt l = Lwt_bytes.read t.sock p 0 (Cstruct.len p) in + let _ = if (l = 0) then raise Net.Nettypes.Closed in + let _ = t.data_cache := [(Cstruct.sub p 0 l)] in + read_data t len + | (_, head::tail) when (buf_size !(t.data_cache)) >= len -> begin + let ret = OS.Io_page.get () in + let ret_len = ref 0 in + let rec read_data_inner = function + | head::tail when ((!ret_len + (Cstruct.len head)) < len) -> + let _ = Cstruct.blit_buffer head 0 ret !ret_len (Cstruct.len head) in + ret_len := !ret_len + (Cstruct.len head); + read_data_inner tail + | head::tail when ((!ret_len + (Cstruct.len head)) = len) -> + let _ = Cstruct.blit_buffer head 0 ret !ret_len (Cstruct.len head) in + ret_len := !ret_len + (Cstruct.len head); + t.data_cache := tail; + return () + | head::tail when ((!ret_len + (Cstruct.len head)) > len) -> + let len_rest = len - !ret_len in + let _ = Cstruct.blit_buffer head 0 ret !ret_len len_rest in + let head = Cstruct.shift head len_rest in + ret_len := !ret_len + len_rest; + t.data_cache := [head] @ tail; + return () + | rest -> + pp "read_data:Invalid state(req_len:%d,read_len:%d,avail_data:%d)\n%!" + len !ret_len (List.fold_right (fun a b -> b + (Cstruct.len a)) rest 0); + raise ReadError + in + lwt _ = read_data_inner !(t.data_cache) in + let ret = Cstruct.sub_buffer ret 0 len in + return (ret) + end + | (_, head::tail) when (buf_size !(t.data_cache)) < len -> + let p = OS.Io_page.get () in + lwt l = Lwt_bytes.read t.sock p 0 (Cstruct.len p) in + let _ = if (l = 0) then raise Net.Nettypes.Closed in + let _ = t.data_cache := !(t.data_cache) @ [(Cstruct.sub p 0 l)] in + read_data t len + | (_, _) -> + let _ = Printf.printf "read_data and not match found\n%!" in + return (Lwt_bytes.create 0 ) + with exn -> + let _ = printf "[socket] read error: %s\n%!" (Printexc.to_string exn) in + raise Net.Nettypes.Closed + +end + +type conn_type = + | Socket of Socket.t + | Local of OP.t Lwt_stream.t * (OP.t option -> unit) + | Unix of Unix_socket.t + +type conn_state = { + mutable dpid : OP.datapath_id; + t : conn_type; +} + +let init_socket_conn_state t = + {dpid=0L;t=(Socket (Socket.create_socket t));} +let init_local_conn_state input output = + {dpid=0L;t=(Local (input, output));} +let init_unix_conn_state fd = + {dpid=0L;t=(Unix (Unix_socket.create_socket fd));} + +let read_packet conn = + match conn.t with + | Socket t -> + lwt hbuf = Socket.read_data t OP.Header.sizeof_ofp_header in + let ofh = OP.Header.parse_header hbuf in + let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in + lwt dbuf = Socket.read_data t dlen in + let ofp = OP.parse ofh dbuf in + return ofp + | Unix t -> + lwt hbuf = Unix_socket.read_data t OP.Header.sizeof_ofp_header in + let ofh = OP.Header.parse_header hbuf in + let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in + lwt dbuf = Unix_socket.read_data t dlen in + let ofp = OP.parse ofh dbuf in + return ofp + | Local (input, _) -> + match_lwt (Lwt_stream.get input) with + | None -> raise Nettypes.Closed + | Some ofp -> return ofp + +let send_packet conn ofp = + match conn.t with + | Socket t -> Socket.write_buffer t (OP.marshal ofp) + | Unix t -> Unix_socket.write_buffer t (OP.marshal ofp) + | Local (_, output) -> return (output (Some ofp )) + +let send_data_raw t bits = + match t.t with + | Local _ -> failwith "send_of_data is not supported in Local mode" + | Unix t -> Unix_socket.write_buffer t bits + | Socket t -> Socket.write_buffer t bits + +let close conn = + match conn.t with + | Socket t -> + resolve ( + try_lwt + Socket.close t + with exn -> + return (printf "[socket] close error: %s\n%!" (Printexc.to_string exn)) + ) + | Unix t -> + resolve ( + try_lwt + Unix_socket.close t + with exn -> + return (printf "[socket] close error: %s\n%!" (Printexc.to_string exn)) + ) + | Local (_, output) -> output None + diff --git a/lib/ofsocket.mli b/lib/ofsocket.mli index c5bc1d6..109904d 100644 --- a/lib/ofsocket.mli +++ b/lib/ofsocket.mli @@ -15,10 +15,20 @@ *) exception ReadError -type t -(* open Openflow_net_lwt *) open Net -val create_socket: Channel.t -> t -val read_data: t -> int -> Cstruct.buf Lwt.t +type conn_type +type conn_state = { + mutable dpid : Ofpacket.datapath_id; + t : conn_type; +} + +val init_socket_conn_state : Channel.t -> conn_state +val init_unix_conn_state : Lwt_unix.file_descr -> conn_state +val init_local_conn_state: Ofpacket.t Lwt_stream.t -> + (Ofpacket.t option -> unit) -> conn_state +val read_packet : conn_state -> Ofpacket.t Lwt.t +val send_packet : conn_state -> Ofpacket.t -> unit Lwt.t +val send_data_raw : conn_state -> Cstruct.buf -> unit Lwt.t +val close : conn_state -> unit diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 68dc862..728e7aa 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -19,6 +19,7 @@ open Lwt open Net open Nettypes open Ofswitch_config +open Printf module OP = Ofpacket @@ -126,7 +127,7 @@ module Table = struct lookup_count=0L; matched_count=0L});} (* TODO fix flow_mod flag support. overlap is not considered *) - let add_flow table t = + let add_flow st table t = (* TODO check if the details are correct e.g. IP type etc. *) Hashtbl.replace table.entries t.OP.Flow_mod.of_match (Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); @@ -139,8 +140,8 @@ module Table = struct | OP.Flow.Output(port, _)::_ when (port = out_port) -> true | head::tail -> is_output_port out_port tail - let del_flow table ?(xid=(Random.int32 Int32.max_int)) ?(reason=OP.Flow_removed.DELETE) - t tuple out_port = + let del_flow table ?(xid=(Random.int32 Int32.max_int)) + ?(reason=OP.Flow_removed.DELETE) tuple out_port t = (* Delete all matching entries from the flow table*) let remove_flow = Hashtbl.fold ( @@ -164,8 +165,7 @@ module Table = struct (* Check for notification flag in flow and send * flow modification warnings *) - let _ = - List.iter ( + Lwt_list.iter_s ( fun (of_match, flow) -> if (flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) then let duration_sec = Int32.sub (Int32.of_float (OS.Clock.time ())) @@ -176,12 +176,12 @@ module Table = struct reason; duration_sec; duration_nsec=0l; idle_timeout=flow.Entry.counters.Entry.idle_timeout; packet_count=flow.Entry.counters.Entry.n_packets; - byte_count=flow.Entry.counters.Entry.n_bytes;}) in - let bits = OP.marshal_and_sub (OP.Flow_removed.marshal_flow_removed fl_rm) - (OS.Io_page.get ()) in - Channel.write_buffer t bits - ) remove_flow in - Channel.flush t + byte_count=flow.Entry.counters.Entry.n_bytes;}) in + let h = OP.Header.(create ~xid FLOW_REMOVED (OP.Flow_removed.get_len)) in + Ofsocket.send_packet t (OP.Flow_removed (h,fl_rm)) + else + return () + ) remove_flow (* table stat update methods *) let update_table_found table = @@ -212,7 +212,7 @@ module Table = struct ) table.entries [] in Lwt_list.iter_s ( fun (of_match, entry, reason) -> - del_flow table ~reason t of_match OP.Port.No_port + del_flow table ~reason of_match OP.Port.No_port t ) flows @@ -279,7 +279,7 @@ module Switch = struct (* Mapping port ids to port numbers *) mutable int_to_port: (int, port ref) Hashtbl.t; mutable ports : port list; - mutable controllers: (Net.Channel.t) list; + mutable controller: Ofsocket.conn_state option; table: Table.t; stats: stats; p_sflow: uint32; (** probability for sFlow sampling *) @@ -499,49 +499,50 @@ type t = Switch.t (* * let process_frame_depr intf_name frame = *) -let process_frame_inner st intf frame = +let process_frame_inner st p intf frame = try_lwt - let p = (!(Hashtbl.find st.Switch.dev_to_port intf)) in +(* let p = (!(Hashtbl.find st.Switch.dev_to_port intf)) in *) let in_port = (OP.Port.port_of_int p.Switch.port_id) in let tupple = (OP.Match.raw_packet_to_match in_port frame ) in + (* Update port rx statistics *) let _ = Switch.update_port_rx_stats (Int64.of_int (Cstruct.len frame)) p in (* What is the size of the frame? Need to get sub_buffer in order to * process it *) - let frame = +(* let frame = match (Switch.size_of_raw_packet frame) with | Some(len) -> Cstruct.sub_buffer frame 0 len | None -> raise Packet_type_unknw - in + in *) +(* let _ = + printf "XXX received on port %d (%d) [%s] \n%!" + p.Switch.port_id (Cstruct.len frame) (OP.Match.match_to_string tupple) + in *) (* Lookup packet flow to existing flows in table *) let entry = (Switch.lookup_flow st tupple) in match entry with - | Switch.NOT_FOUND -> + | Switch.NOT_FOUND -> begin let _ = Table.update_table_missed st.Switch.table in let buffer_id = st.Switch.packet_buffer_id in (*TODO Move this code in the Switch module *) st.Switch.packet_buffer_id <- Int32.add st.Switch.packet_buffer_id 1l; - let pkt_in = OP.Packet_in.create_pkt_in ~buffer_id ~in_port + let (_, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id ~in_port ~reason:OP.Packet_in.NO_MATCH ~data:frame in - st.Switch.packet_buffer <- st.Switch.packet_buffer @ [pkt_in]; - let bits = OP.marshal_and_sub (OP.Packet_in.marshal_pkt_in ~data_len:64 pkt_in) - (OS.Io_page.get ()) in - Lwt_list.iter_p - (fun t -> - match (Cstruct.len bits) with - | l when l <= 1400 -> - let _ = Channel.write_buffer t bits in - Channel.flush t - | _ -> - let buf = Cstruct.sub_buffer bits 0 1400 in - let _ = Channel.write_buffer t buf in - let buf = Cstruct.sub_buffer bits 1400 ((Cstruct.len bits) - 1400) in - let _ = Channel.write_buffer t buf in - lwt _ = Channel.flush t in - return () - ) - st.Switch.controllers + let _ = st.Switch.packet_buffer <- st.Switch.packet_buffer @ [pkt_in] in + let size = + if (Cstruct.len frame > 64) then + 64 + else + Cstruct.len frame + in + let (h, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id ~in_port + ~reason:OP.Packet_in.NO_MATCH + ~data:(Cstruct.sub frame 0 size) in + match st.Switch.controller with + | None -> return () + | Some conn -> Ofsocket.send_packet conn (OP.Packet_in (h, pkt_in)) + end (* generate a packet in event *) | Switch.Found(entry) -> let _ = Table.update_table_found st.Switch.table in @@ -554,10 +555,10 @@ let process_frame_inner st intf frame = return () | Packet_type_unknw -> return () -let process_frame st intf_name frame = +let process_frame p st intf_name frame = try_lwt - let p = Hashtbl.find st.Switch.dev_to_port intf_name in - process_frame_inner st intf_name frame + (*let p = Hashtbl.find st.Switch.dev_to_port intf_name in *) + process_frame_inner st p intf_name frame (* if (st.Switch.queue_len < 256) then ( st.Switch.queue_len <- st.Switch.queue_len + 1; @@ -574,7 +575,7 @@ let process_frame st intf_name frame = | exn -> return (pr "%03.6f: switch error: %s\n%!" (OS.Clock.time ()) (Printexc.to_string exn)) -let data_plane st () = +(*let data_plane st () = try_lwt while_lwt true do lwt a = Lwt_stream.get st.Switch.packet_queue in @@ -583,7 +584,7 @@ let data_plane st () = st.Switch.queue_len <- st.Switch.queue_len - 1; process_frame_inner st p pkt | None -> return () - done + done *) (************************************************* @@ -595,41 +596,36 @@ type endhost = { port: int; } -let process_openflow st t bits = function +let process_openflow st t msg = + match msg with | OP.Hello (h) -> (* Reply to HELLO with a HELLO and a feature request *) cp "HELLO"; return () - | OP.Echo_req (h, bs) -> (* Reply to ECHO requests *) + | OP.Echo_req h -> (* Reply to ECHO requests *) cp "ECHO_REQ"; - let h = OP.Header.(create ECHO_RESP sizeof_ofp_header h.xid) in - let bits = OP.marshal_and_sub (OP.Header.marshal_header h) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Features_req (h) -> + Ofsocket.send_packet t + (OP.Echo_req + OP.Header.(create ~xid:h.xid ECHO_RESP sizeof_ofp_header)) + | OP.Features_req (h) -> cp "FEAT_REQ"; - let bits = OP.marshal_and_sub - (OP.Switch.marshal_reply_features h.OP.Header.xid st.Switch.features ) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Stats_req(h, req) -> begin + let h = OP.Header.create ~xid:(h.OP.Header.xid) OP.Header.FEATURES_RESP + (OP.Switch.get_len st.Switch.features) in + Ofsocket.send_packet t (OP.Features_resp (h, st.Switch.features)) + | OP.Stats_req(h, req) -> begin let xid = h.OP.Header.xid in - cp "STATS_REQ\n%!"; + cp "STATS_REQ"; match req with | OP.Stats.Desc_req(req) -> - let desc = OP.Stats.({ imfr_desc="Mirage"; hw_desc="Mirage"; - sw_desc="Mirage"; serial_num="0.1";dp_desc="Mirage";}) - in - let resp_h = OP.Stats.({st_ty=DESC; more_to_follow=false;}) in - let bits = OP.marshal_and_sub - (OP.Stats.marshal_stats_resp xid (OP.Stats.Desc_resp(resp_h, - desc))) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> + let p = + OP.Stats.(Desc_resp ( + {st_ty=DESC; more_to_follow=false;}, + { imfr_desc="Mirage"; hw_desc="Mirage"; + sw_desc="Mirage"; serial_num="0.1";dp_desc="Mirage";} + )) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len p) in + Ofsocket.send_packet t (OP.Stats_resp (h, p)) + | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> (*TODO Need to consider the table_id and the out_port and * split reply over multiple openflow packets if they don't * fit a single packet. *) @@ -646,12 +642,10 @@ let process_openflow st t bits = function Hashtbl.fold (fun key value r -> match_flows of_match key value r) st.Switch.table.Table.entries [] in let stats = OP.Stats.({st_ty=FLOW; more_to_follow=false;}) in - let reply = OP.Stats.Flow_resp(stats, flows) in - let bits = OP.marshal_and_sub (OP.Stats.marshal_stats_resp xid reply) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Stats.Aggregate_req (req_h, of_match, table, port) -> + let r = OP.Stats.Flow_resp(stats, flows) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + Ofsocket.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Aggregate_req (req_h, of_match, table, port) -> let aggr_flow_bytes = ref 0L in let aggr_flow_pkts = ref 0L in let aggr_flows = ref 0l in @@ -667,68 +661,57 @@ let process_openflow st t bits = function Hashtbl.iter (fun key value -> match_flows_aggr of_match key value) st.Switch.table.Table.entries; let stats = OP.Stats.({st_ty=AGGREGATE; more_to_follow=false;}) in - let reply = OP.Stats.Aggregate_resp(stats, + let r = OP.Stats.Aggregate_resp(stats, OP.Stats.({byte_count=(!aggr_flow_bytes); packet_count=(!aggr_flow_pkts); flow_count=(!aggr_flows);})) in - let bits = OP.marshal_and_sub (OP.Stats.marshal_stats_resp xid reply) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Stats.Table_req(req) -> + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + Ofsocket.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Table_req(req) -> let stats = OP.Stats.({st_ty=TABLE; more_to_follow=false;}) in - let reply = OP.Stats.Table_resp(stats, [st.Switch.table.Table.stats]) in - let bits = OP.marshal_and_sub (OP.Stats.marshal_stats_resp xid reply) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Stats.Port_req(req_h, port) -> begin + let r = OP.Stats.Table_resp(stats, [st.Switch.table.Table.stats]) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + Ofsocket.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Port_req(req_h, port) -> begin match port with | OP.Port.No_port -> let port_stats = List.map (fun p -> p.Switch.counter) st.Switch.ports in let stats = OP.Stats.({st_ty=PORT; more_to_follow=false;}) in - let reply = OP.Stats.Port_resp(stats, port_stats) in - let bits = OP.marshal_and_sub (OP.Stats.marshal_stats_resp xid reply) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t + let r = OP.Stats.Port_resp(stats, port_stats) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + Ofsocket.send_packet t (OP.Stats_resp (h, r)) | OP.Port.Port(port_id) -> try_lwt let port = Hashtbl.find st.Switch.int_to_port port_id in let stats = OP.Stats.({st_ty=PORT; more_to_follow=false;}) in - let reply = OP.Stats.Port_resp(stats, [(!port).Switch.counter]) in - let bits = OP.marshal_and_sub (OP.Stats.marshal_stats_resp xid reply) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - with Not_found -> + let r = OP.Stats.Port_resp(stats, [(!port).Switch.counter]) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + Ofsocket.send_packet t (OP.Stats_resp (h, r)) + with Not_found -> (* TODO reply with right error code *) pr "Invalid port_id in stats\n%!"; return () end - | _ -> - let bits = OP.marshal_and_sub (OP.marshal_error - OP.REQUEST_BAD_SUBTYPE bits xid) (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t + | _ -> + let bits = OP.marshal msg in + let h = OP.Header.create ~xid OP.Header.ERROR + (OP.Header.get_len + 4 + (Cstruct.len bits)) in + Ofsocket.send_packet t (OP.Error (h, OP.REQUEST_BAD_SUBTYPE, bits)) end - | OP.Get_config_req(h) -> - let resp = OP.Switch.init_switch_config in - let bits = OP.marshal_and_sub (OP.Switch.marshal_switch_config - h.OP.Header.xid resp) (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Barrier_req(h) -> - cp (sp "BARRIER_REQ: %s\n%!" (OP.Header.header_to_string h)); - let resp_h = (OP.Header.create OP.Header.BARRIER_RESP - (OP.Header.sizeof_ofp_header) h.OP.Header.xid) in - let bits = OP.marshal_and_sub (OP.Header.marshal_header resp_h) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - | OP.Packet_out(h, pkt) -> - cp (sp "PACKET_OUT: %s\n%!" (OP.Packet_out.packet_out_to_string pkt)); + | OP.Get_config_req(h) -> + let resp = OP.Switch.init_switch_config in + let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.GET_CONFIG_RESP + OP.Switch.config_get_len in + Ofsocket.send_packet t (OP.Get_config_resp(h, resp)) + | OP.Barrier_req(h) -> + cp (sp "BARRIER_REQ: %s" (OP.Header.header_to_string h)); + let resp_h = (OP.Header.create ~xid:h.OP.Header.xid OP.Header.BARRIER_RESP + (OP.Header.sizeof_ofp_header)) in + Ofsocket.send_packet t (OP.Barrier_resp(resp_h)) + + | OP.Packet_out(h, pkt) -> + cp (sp "PACKET_OUT: %s" (OP.Packet_out.packet_out_to_string pkt)); if (pkt.OP.Packet_out.buffer_id = -1l) then Switch.apply_of_actions st pkt.OP.Packet_out.in_port pkt.OP.Packet_out.data pkt.OP.Packet_out.actions @@ -744,20 +727,19 @@ let process_openflow st t bits = function ) st.Switch.packet_buffer in match (!pkt_in) with - | None -> - let bs = OP.marshal_and_sub - (OP.marshal_error OP.REQUEST_BUFFER_UNKNOWN bits h.OP.Header.xid) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bs in - Channel.flush t - | Some(pkt_in) -> - let _ = pr "Sending as packet_out data %d\n%!" - (Cstruct.len pkt_in.OP.Packet_in.data) in + | None -> + let bits = OP.marshal msg in + let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR + (OP.Header.get_len + 4 + (Cstruct.len bits)) in + Ofsocket.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) + | Some(pkt_in) -> +(* let _ = pr "Sending as packet_out data %d\n%!" + (Cstruct.len pkt_in.OP.Packet_in.data) in *) Switch.apply_of_actions st pkt_in.OP.Packet_in.in_port pkt_in.OP.Packet_in.data pkt.OP.Packet_out.actions end | OP.Flow_mod(h,fm) -> - cp (sp "FLOW_MOD: %s\n%!" (OP.Flow_mod.flow_mod_to_string fm)); + cp (sp "FLOW_MOD: %s" (OP.Flow_mod.flow_mod_to_string fm)); let of_match = fm.OP.Flow_mod.of_match in let of_actions = fm.OP.Flow_mod.actions in lwt _ = @@ -765,10 +747,10 @@ let process_openflow st t bits = function | OP.Flow_mod.ADD | OP.Flow_mod.MODIFY | OP.Flow_mod.MODIFY_STRICT -> - return (Table.add_flow st.Switch.table fm) + return (Table.add_flow st st.Switch.table fm) | OP.Flow_mod.DELETE | OP.Flow_mod.DELETE_STRICT -> - Table.del_flow st.Switch.table t of_match fm.OP.Flow_mod.out_port + Table.del_flow st.Switch.table of_match fm.OP.Flow_mod.out_port t in if (fm.OP.Flow_mod.buffer_id = -1l) then return () @@ -784,14 +766,12 @@ let process_openflow st t bits = function ) st.Switch.packet_buffer in match (!pkt_in) with - | None -> - let bs = - OP.marshal_and_sub - (OP.marshal_error OP.REQUEST_BUFFER_UNKNOWN bits h.OP.Header.xid) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bs in - Channel.flush t - | Some(pkt_in) -> + | None -> + let bits = OP.marshal msg in + let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR + (OP.Header.get_len + 4 + (Cstruct.len bits)) in + Ofsocket.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) + | Some(pkt_in) -> (* TODO check if the match is accurate? *) Switch.apply_of_actions st pkt_in.OP.Packet_in.in_port pkt_in.OP.Packet_in.data of_actions @@ -808,78 +788,84 @@ let process_openflow st t bits = function | OP.Get_config_resp (h, _) | OP.Features_resp (h, _) | OP.Vendor (h, _, _) - | OP.Echo_resp (h, _) - | OP.Error (h, _) -> - let bits = OP.marshal_and_sub (OP.marshal_error - OP.REQUEST_BAD_TYPE bits h.OP.Header.xid) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - Channel.flush t - -let control_channel st (remote_addr, remote_port) t = - let rs = Nettypes.ipv4_addr_to_string remote_addr in - Printf.eprintf "OpenFlow Switch: controller %s:%d" rs remote_port; - st.Switch.controllers <- (st.Switch.controllers @ [t]); - + | OP.Echo_resp h + | OP.Error (h, _, _) -> + let bits = OP.marshal msg in + let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR + (OP.Header.get_len + 4 + (Cstruct.len bits)) in + Ofsocket.send_packet t (OP.Error(h, OP.REQUEST_BAD_TYPE, bits)) + +let control_channel_run st conn t = (* Trigger the dance between the 2 nodes *) - let h = OP.Header.(create HELLO sizeof_ofp_header 1l) in - let bits = OP.marshal_and_sub (OP.Header.marshal_header h) - (OS.Io_page.get ()) in - let _ = Channel.write_buffer t bits in - lwt _ = Channel.flush t in - let cached_socket = Ofsocket.create_socket t in - + let h = OP.Header.(create ~xid:1l HELLO sizeof_ofp_header) in + lwt _ = Ofsocket.send_packet conn (OP.Hello(h)) in let rec echo () = try_lwt - lwt hbuf = Ofsocket.read_data cached_socket OP.Header.sizeof_ofp_header in - let ofh = OP.Header.parse_header hbuf in - let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in - lwt dbuf = Ofsocket.read_data cached_socket dlen in - let ofp = OP.parse ofh dbuf in - process_openflow st t dbuf ofp (* Bitstring.concat [hbuf; dbuf] *) + lwt ofp = Ofsocket.read_packet conn in + process_openflow st conn ofp (* Bitstring.concat [hbuf; dbuf] *) >> echo () with | Nettypes.Closed -> - (* TODO Need to remove the t from st.Switch.controllers *) - pr "Controller channel closed....\n%!"; - return () + pr "Controller channel closed....\n%!"; + return () | OP.Unparsed (m, bs) -> (pr "# unparsed! m=%s\n %!" m); echo () | exn -> pr "[OpenFlow-Switch-Control] ERROR:%s\n" (Printexc.to_string exn); (echo () ) - in - echo () <&> (Table.monitor_flow_timeout st.Switch.table t) + in + lwt _ = + ( lwt _ = t in return (printf "thread terminated\n%!")) + echo () + (lwt _ = Table.monitor_flow_timeout st.Switch.table conn in return (pp + "[switch] terminated flow_timeout thread") ) + in + let _ = Ofsocket.close conn in + let _ = st.Switch.controller <- None in + return (printf "control channel thread returned\n%!") + +let control_channel st (remote_addr, remote_port) t = + let rs = Nettypes.ipv4_addr_to_string remote_addr in + Printf.eprintf "OpenFlow Switch: controller %s:%d" rs remote_port; + let conn = Ofsocket.init_socket_conn_state t in + let _ = st.Switch.controller <- (Some conn) in + let t, _ = Lwt.task () in + control_channel_run st conn t (* * Interaface with external applications * *) -let add_port mgr sw ethif = +let add_port mgr ?(use_mac=false) sw ethif = sw.Switch.portnum <- sw.Switch.portnum + 1; - let _ = pr "Adding port %d (%s)\n %!" sw.Switch.portnum - (Net.Manager.get_intf_name mgr ethif) in - let port = Switch.init_port mgr sw.Switch.portnum ethif in + let hw_addr = + (Net.Nettypes.ethernet_mac_to_string + (Manager.get_intf_mac mgr ethif)) in + let _ = pr "Adding port %d (%s) '%s' \n %!" sw.Switch.portnum + (Net.Manager.get_intf_name mgr ethif) hw_addr in + lwt _ = + if (use_mac) then + lwt _ = Lwt_unix.system (sprintf "ifconfig tap0 lladdr %s" hw_addr) in + return () + else + return () + in + let port = Switch.init_port mgr sw.Switch.portnum ethif in sw.Switch.ports <- sw.Switch.ports @ [port]; Hashtbl.add sw.Switch.int_to_port sw.Switch.portnum (ref port); Hashtbl.add sw.Switch.dev_to_port ethif (ref port); sw.Switch.features.OP.Switch.ports <- sw.Switch.features.OP.Switch.ports @ [port.Switch.phy]; - let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw) in - let port_status = OP.Port.create_port_status OP.Port.ADD port.Switch.phy in - let bits = OP.marshal_and_sub (OP.Port.marshal_port_status port_status) - (Lwt_bytes.create 2048) in - lwt _ = Lwt_list.iter_p - (fun t -> - let _ = Net.Channel.write_buffer t bits in - Net.Channel.flush t - ) - sw.Switch.controllers in - return () + let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw port) in + let h,p = OP.Port.create_port_status OP.Port.ADD port.Switch.phy in + lwt _ = + match sw.Switch.controller with + | None -> return () + | Some t -> Ofsocket.send_packet t (OP.Port_status (h,p)) + in + return () let add_port_local mgr sw ethif = - let _ = pr "Adding port 0 (%s)\n %!" - (Net.Manager.get_intf_name mgr ethif) in - (*TODO Find first if a port is already registered as port 0 + (*TODO Find first if a port is already registered as port 0 * as port 0 and disable it *) let port = Switch.init_port mgr 0 ethif in sw.Switch.ports <- @@ -897,7 +883,7 @@ let add_port_local mgr sw ethif = (List.filter (fun a -> (a.OP.Port.port_no <> 0)) sw.Switch.features.OP.Switch.ports ) @ [port.Switch.phy]; - let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw) in + let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw port) in () @@ -905,17 +891,52 @@ let create_switch () = let (packet_queue, push_packet) = Lwt_stream.create () in Switch.( { ports = []; int_to_port = (Hashtbl.create 64); dev_to_port=(Hashtbl.create 64); - p_sflow = 0_l; controllers=[]; errornum = 0l; portnum=0; packet_queue; push_packet; + p_sflow = 0_l; controller=None; errornum = 0l; portnum=0; packet_queue; push_packet; queue_len = 0; stats={n_frags=0L; n_hits=0L;n_missed=0L;n_lost=0L;}; table = (Table.init_table ()); features=(Switch.switch_features ()); - packet_buffer=[]; packet_buffer_id=0l};) + packet_buffer=[]; packet_buffer_id=0l;}) let listen st mgr loc = - Channel.listen mgr (`TCPv4 (loc, (control_channel st))) <&> - (Ofswitch_config.listen_t mgr 6634) <&> - (data_plane st ()) + Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> + (Ofswitch_config.listen_t mgr 6634) let connect st mgr loc = Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> - (Ofswitch_config.listen_t mgr 6634) <&> - (data_plane st ()) + (Ofswitch_config.listen_t mgr 6634) + +let local_connect st mgr input output = + let conn = Ofsocket.init_local_conn_state input output in + let _ = st.Switch.controller <- (Some conn) in + let t, _ = Lwt.task () in + (control_channel_run st conn t) <&> + (Ofswitch_config.listen_t mgr 6634) + +let lwt_connect st ?(standalone=true) mgr loc = + let of_ctrl = Ofswitch_standalone.init_controller () in + let fd = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in + let _ = Lwt_unix.setsockopt fd Unix.SO_REUSEADDR true in + let _ = Lwt_unix.bind fd (Unix.ADDR_INET(Unix.inet_addr_any, 6633)) in + let _ = Lwt_unix.listen fd 1 in + let _ = printf "[switch] Listening socket...\n%!" in + while_lwt true do + let t,u = Lwt.task () in + (( + let _ = printf "[switch] standalone controller connected...\n%!" in + lwt (switch_in, switch_out) = + Ofswitch_standalone.run_controller mgr of_ctrl in + let conn = Ofsocket.init_local_conn_state switch_in switch_out in + let _ = st.Switch.controller <- (Some conn) in + lwt _ = control_channel_run st conn t in + let _ = printf "[switch] standalone controller stopped...\n%!" in + return () + ) <&> + ( + lwt (sock, loc) = Lwt_unix.accept fd in + let conn = Ofsocket.init_unix_conn_state sock in + let _ = wakeup u () in + let t,_ = Lwt.task () in + let _ = st.Switch.controller <- (Some conn) in + let _ = printf "[switch] remote controller connected...\n%!" in + control_channel_run st conn t + )) + done diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index dabd768..d4de6ad 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -16,10 +16,15 @@ *) type t -val add_port : Net.Manager.t -> t -> Net.Manager.id -> unit Lwt.t +val add_port : Net.Manager.t -> ?use_mac:bool -> t -> Net.Manager.id -> unit Lwt.t val add_port_local : Net.Manager.t -> t -> Net.Manager.id -> unit val create_switch : unit -> t val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> unit Lwt.t val connect : t -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> unit Lwt.t +val lwt_connect : t -> ?standalone:bool -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> + unit Lwt.t +val local_connect : t -> Net.Manager.t -> + Ofpacket.t Lwt_stream.t -> (Ofpacket.t option -> unit ) -> + unit Lwt.t diff --git a/lib/ofswitch_ctrl.ml b/lib/ofswitch_ctrl.ml index 9865a01..80ace87 100644 --- a/lib/ofswitch_ctrl.ml +++ b/lib/ofswitch_ctrl.ml @@ -17,7 +17,7 @@ open Lwt open Printf -open Ofswitch_config +open Openflow.Ofswitch_config open Lwt_unix let check_cmd_args cmd count = @@ -34,7 +34,7 @@ let send_cmd cl = match (Sys.argv.(1)) with | "add-port" -> let _ = check_cmd_args "add_port" 1 in - lwt _ = Ofswitch_config.add_port cl Sys.argv.(2) in + lwt _ = add_port cl Sys.argv.(2) in return () | _ -> let _ = printf "Fail: unknown cmd: %s\n%!" Sys.argv.(1) in @@ -44,7 +44,7 @@ let send_cmd cl = lwt _ = try_lwt - lwt cl = Ofswitch_config.connect_client () in + lwt cl = connect_client () in lwt _ = send_cmd cl in return () with e -> diff --git a/lib/ofswitch_standalone.ml b/lib/ofswitch_standalone.ml new file mode 100644 index 0000000..015a842 --- /dev/null +++ b/lib/ofswitch_standalone.ml @@ -0,0 +1,149 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +open Lwt +open Printf +open Net +open Net.Nettypes + +let resolve t = Lwt.on_success t (fun _ -> ()) + +module OP = Ofpacket +module OC = Ofcontroller +module OE = Ofcontroller.Event + +let pp = Printf.printf +let sp = Printf.sprintf + + +(* TODO this the mapping is incorrect. the datapath must be moved to the key + * of the hashtbl *) +type mac_switch = { + addr: OP.eaddr; + switch: OP.datapath_id; +} + +type switch_state = { + mutable mac_cache: (OP.eaddr, OP.Port.t) Hashtbl.t; + req_count: int ref; +} + +let switch_data = + { mac_cache = Hashtbl.create 0; req_count=(ref 0);} + + +let datapath_join_cb controller dpid evt = + let dp = + match evt with + | OE.Datapath_join (c, _) -> c + | _ -> invalid_arg "bogus datapath_join event match!" + in + return (pp "+ datapath:0x%012Lx\n" dp) + +let datapath_leave_cb controller dpid evt = + let dp = + match evt with + | OE.Datapath_leave (c) -> c + | _ -> invalid_arg "bogus datapath_leave event match!" + in + let _ = Hashtbl.clear switch_data.mac_cache in + let _ = switch_data.req_count := 0 in + return (pp "- datapath:0x%012Lx\n" dp) + + +let req_count = (ref 0) + +let add_entry_in_hashtbl mac_cache ix in_port = + if not (Hashtbl.mem mac_cache ix ) then + Hashtbl.add mac_cache ix in_port + else + Hashtbl.replace mac_cache ix in_port + +let packet_in_cb controller dpid evt = + incr switch_data.req_count; + let (in_port, buffer_id, data, dp) = + match evt with + | OE.Packet_in (inp, buf, dat, dp) -> (inp, buf, dat, dp) + | _ -> invalid_arg "bogus datapath_join event match!" + in + (* Parse Ethernet header *) + let m = OP.Match.raw_packet_to_match in_port data in + + (* Store src mac address and incoming port *) + let ix = m.OP.Match.dl_src in + let _ = Hashtbl.replace switch_data.mac_cache ix in_port in + + (* check if I know the output port in order to define what type of message + * we need to send *) +(* let broadcast = String.make 6 '\255' in + let ix = m.OP.Match.dl_dst in + if ( (ix = broadcast) + || (not (Hashtbl.mem switch_data.mac_cache ix)) ) + then ( *) + let bs = + (OP.Packet_out.create ~buffer_id:buffer_id + ~actions:[ OP.(Flow.Output(Port.All , 2000))] + ~data:data ~in_port:in_port () ) in + let h = OP.Header.create OP.Header.PACKET_OUT 0 in + OC.send_data controller dpid (OP.Packet_out (h, bs)) +(* ) else ( + let out_port = (Hashtbl.find switch_data.mac_cache ix) in + let flags = OP.Flow_mod.({send_flow_rem=true; emerg=false; overlap=false;}) in + lwt _ = + if (buffer_id = -1l) then + (* Need to send also the packet in cache the packet is not cached *) + let bs = + OP.Packet_out.create + ~buffer_id:buffer_id + ~actions:[ OP.(Flow.Output(out_port, 2000))] + ~data:data ~in_port:in_port () in + let h = OP.Header.create OP.Header.PACKET_OUT 0 in + OC.send_data controller dpid (OP.Packet_out (h, bs)) + else + return () + in + let pkt = + (OP.Flow_mod.create m 0_L OP.Flow_mod.ADD ~hard_timeout:0 + ~idle_timeout:0 ~buffer_id:(Int32.to_int buffer_id) ~flags + [OP.Flow.Output(out_port, 2000)] ()) in + let h = OP.Header.create OP.Header.FLOW_MOD 0 in + OC.send_data controller dpid (OP.Flow_mod (h, pkt)) + ) *) + +let init controller = + pp "test controller register datapath cb\n%!"; + OC.register_cb controller OE.DATAPATH_JOIN datapath_join_cb; + pp "test controller register leave cb\n%!"; + OC.register_cb controller OE.DATAPATH_LEAVE datapath_leave_cb; + pp "test controller register packet_in cb\n%!"; + OC.register_cb controller OE.PACKET_IN packet_in_cb + +let init_controller () = + OC.init_controller init + +let run_controller mgr st = + let (controller_input, switch_output) = Lwt_stream.create () in + let (switch_input, controller_output) = Lwt_stream.create () in + let _ = Lwt.ignore_result ( + try_lwt + OC.local_connect mgr st (controller_input, controller_output) init + with exn -> + return (printf "[switch] standalone controller dailed %s\n%!" (Printexc.to_string + exn)) + ) in + return (switch_input, switch_output) + + + diff --git a/lib/ofswitch_standalone.mli b/lib/ofswitch_standalone.mli new file mode 100644 index 0000000..3d6e981 --- /dev/null +++ b/lib/ofswitch_standalone.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2012 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val init_controller : unit -> Ofcontroller.t +val run_controller : Net.Manager.t -> Ofcontroller.t -> + (Ofpacket.t Lwt_stream.t * (Ofpacket.t option -> unit)) Lwt.t diff --git a/lib/openflow.mlpack b/lib/openflow.mlpack index 5828c2a..57ffe79 100644 --- a/lib/openflow.mlpack +++ b/lib/openflow.mlpack @@ -1,7 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: dd263c48adf310d29b88feb5aef173c7) +# DO NOT EDIT (digest: 58fcea190f28357e050fe23bbcbd01b3) Ofpacket Ofcontroller Ofswitch_config Ofswitch +Ofsocket +Ofswitch_standalone # OASIS_STOP diff --git a/lib/openflow.odocl b/lib/openflow.odocl index 26a1c02..065ffa4 100644 --- a/lib/openflow.odocl +++ b/lib/openflow.odocl @@ -1,6 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 169e106a3d54b9d1a37dc1f99698ecbb) +# DO NOT EDIT (digest: a1ecbcce9d30ec0a1efa572ec81d47c0) Ofpacket Ofcontroller Ofswitch +Ofsocket +Ofswitch_config # OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 76b2b2d..b025f19 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: a35a236ddf762327db44f569ec0c2480) *) +(* DO NOT EDIT (digest: ce054306119a8bd9c19b2decbd79bde5) *) module OASISGettext = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISGettext.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISExpr.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseEnvLight.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -# 56 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +(* # 56 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index 49f5a21..ec28388 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ -(* setup.ml generated for the first time by OASIS v0.2.0 *) +(* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: f4de681b6b969b0aec2dc6b5d02e584e) *) +(* DO NOT EDIT (digest: d51b1b7039a52449e8230e5f2444f1df) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISGettext.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISContext.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -# 1 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISString.ml" +(* # 1 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISUtils.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/PropList.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -# 71 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/PropList.ml" +(* # 71 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISMessage.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISVersion.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISLicense.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISExpr.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISTypes.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -# 102 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISTypes.ml" +(* # 102 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISSection.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISFlag.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISPackage.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISTest.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISDocument.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISExec.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseEnvLight.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseContext.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseMessage.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseEnv.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseArgExt.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseCheck.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseStandardVar.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseFileAB.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseLog.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseLog.ml" *) open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseBuilt.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseCustom.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseDynVar.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseTest.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseDoc.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/base/BaseSetup.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -# 21 "/root/.opam/4.00.1+raspberrypi/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" +(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5716,7 +5716,9 @@ let setup_t = "Ofpacket"; "Ofcontroller"; "Ofswitch_config"; - "Ofswitch" + "Ofswitch"; + "Ofsocket"; + "Ofswitch_standalone" ]; lib_pack = true; lib_internal_modules = []; @@ -5762,9 +5764,9 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "nettests", true) + (OASISExpr.EFlag "lwt", true) ]; - bs_install = [(OASISExpr.EBool true, false)]; + bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; bs_compiled_object = Native; bs_build_depends = [InternalLibrary "openflow"]; @@ -5789,9 +5791,9 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "nettests", true) + (OASISExpr.EFlag "lwt", true) ]; - bs_install = [(OASISExpr.EBool true, false)]; + bs_install = [(OASISExpr.EBool true, true)]; bs_path = "controller"; bs_compiled_object = Native; bs_build_depends = @@ -5822,7 +5824,7 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "nettests", true) + (OASISExpr.EFlag "lwt", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "switch"; @@ -5846,7 +5848,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "\163\143\018\201d\221C?huj\011\175\168\234_"; + oasis_digest = Some "F¿\030##Ì»o¸\016R¢\027t\136Æ"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5854,6 +5856,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5858 "setup.ml" +# 5860 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index 3206a5b..39f50ec 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -19,6 +19,16 @@ open Printf open Net open Net.Nettypes +let resolve t = Lwt.on_success t (fun _ -> ()) + +module OP = Openflow.Ofpacket +module OC = Openflow.Ofcontroller +module OE = Openflow.Ofcontroller.Event +open Openflow.Ofswitch + +let pp = Printf.printf +let sp = Printf.sprintf + (**************************************************************** * OpenFlow Switch configuration *****************************************************************) @@ -30,24 +40,20 @@ let print_time () = done let switch_run () = - let sw = Ofswitch.create_switch () in + let sw = create_switch () in try_lwt - Manager.create ~devs:2 ~attached:(["vboxnet0"]) + Manager.create ~devs:1 ~attached:(["en0"]) (fun mgr interface id -> match (Manager.get_intf_name mgr id) with | "tap0" | "0" -> - let ip = - (ipv4_addr_of_tuple (10l,0l,0l,2l), - ipv4_addr_of_tuple (255l,255l,255l,0l), []) in - lwt _ = Manager.configure interface (`IPv4 ip) in - let dst_ip = ipv4_addr_of_tuple (10l,0l,0l,1l) in - let _ = printf "connecting switch...\n%!" in - lwt _ = Ofswitch.connect sw mgr (dst_ip, 6633) in - let _ = printf "connect returned...\n%!" in - return () - | "1" -> return (Ofswitch.add_port_local mgr sw id) - | _ -> Ofswitch.add_port mgr sw id + let _ = printf "connecting switch...\n%!" in + let _ = add_port_local mgr sw id in + let dst_ip = ipv4_addr_of_tuple (0l,0l,0l,0l) in + lwt _ = lwt_connect sw mgr (dst_ip, 6633) in + let _ = printf "connect returned...\n%!" in + return () + | _ -> add_port mgr ~use_mac:true sw id ) with e -> Printf.eprintf "Error: %s" (Printexc.to_string e); From 5725b368b0ab19c8f6057c6a483f3489eb3e7f3a Mon Sep 17 00:00:00 2001 From: crotsos Date: Sun, 16 Dec 2012 14:48:47 +0000 Subject: [PATCH 17/75] Fixing switch control tool --- lib/ofcontroller.ml | 4 +-- lib/ofpacket.ml | 8 ++++- lib/ofpacket.mli | 1 + lib/ofswitch.ml | 63 ++++++++++++++++++++++++++++++++------ lib/ofswitch.mli | 4 ++- lib/ofswitch_config.ml | 51 ++++++++++++++++++------------ lib/ofswitch_config.mli | 3 +- lib/ofswitch_ctrl.ml | 33 +++++++++++++++----- lib/ofswitch_standalone.ml | 29 ++++++++++++------ switch/basic_switch.ml | 2 +- 10 files changed, 146 insertions(+), 52 deletions(-) diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index c2eb1ee..85976dd 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -174,9 +174,9 @@ let process_of_packet state conn ofp = Lwt_list.iter_p (fun cb -> cb state dpid evt) state.datapath_join_cb end | Packet_in (h, p) -> begin (* Generate a packet_in event *) - cp (sp "+ %s|%s" +(* cp (sp "+ %s|%s" (OP.Header.header_to_string h) - (OP.Packet_in.packet_in_to_string p)); + (OP.Packet_in.packet_in_to_string p)); *) let evt = Event.Packet_in ( p.Packet_in.in_port, p.Packet_in.buffer_id, p.Packet_in.data, conn.dpid) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 82c714a..30b002e 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -853,7 +853,13 @@ module Wildcards = struct dl_vlan_pcp: bool; nw_tos: bool; } - let full_wildcard = + let in_port = + { in_port=false; dl_vlan=true; dl_src=true; + dl_dst=true; dl_type=true; nw_proto=true; + tp_src=true; tp_dst=true; nw_src=(char_of_int 32); + nw_dst=(char_of_int 32); dl_vlan_pcp=true; nw_tos=true; + } + let full_wildcard = { in_port=true; dl_vlan=true; dl_src=true; dl_dst=true; dl_type=true; nw_proto=true; tp_src=true; tp_dst=true; nw_src=(char_of_int 32); diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index 7cb3baf..c64da01 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -209,6 +209,7 @@ module Wildcards : dl_vlan_pcp : bool; nw_tos : bool; } + val in_port : t val full_wildcard : t val exact_match : t val l2_match : t diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 728e7aa..1aeb283 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -167,7 +167,9 @@ module Table = struct * flow modification warnings *) Lwt_list.iter_s ( fun (of_match, flow) -> - if (flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) then + if (t <> None) && + (flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) then + let Some(t) = t in let duration_sec = Int32.sub (Int32.of_float (OS.Clock.time ())) flow.Entry.counters.Entry.insert_sec in let fl_rm = OP.Flow_removed.( @@ -332,7 +334,7 @@ module Switch = struct Lwt_list.iter_p (fun port -> if(port.port_id != (OP.Port.int_of_port in_port)) then ( - update_port_tx_stats (Int64.of_int (Cstruct.len frame)) port; + update_port_tx_stats (Int64.of_int (Cstruct.len frame)) port; Net.Manager.inject_packet port.mgr port.ethif frame ) else return () @@ -711,7 +713,7 @@ let process_openflow st t msg = Ofsocket.send_packet t (OP.Barrier_resp(resp_h)) | OP.Packet_out(h, pkt) -> - cp (sp "PACKET_OUT: %s" (OP.Packet_out.packet_out_to_string pkt)); +(* cp (sp "PACKET_OUT: %s" (OP.Packet_out.packet_out_to_string pkt)); *) if (pkt.OP.Packet_out.buffer_id = -1l) then Switch.apply_of_actions st pkt.OP.Packet_out.in_port pkt.OP.Packet_out.data pkt.OP.Packet_out.actions @@ -739,7 +741,7 @@ let process_openflow st t msg = pkt_in.OP.Packet_in.data pkt.OP.Packet_out.actions end | OP.Flow_mod(h,fm) -> - cp (sp "FLOW_MOD: %s" (OP.Flow_mod.flow_mod_to_string fm)); +(* cp (sp "FLOW_MOD: %s" (OP.Flow_mod.flow_mod_to_string fm)); *) let of_match = fm.OP.Flow_mod.of_match in let of_actions = fm.OP.Flow_mod.actions in lwt _ = @@ -750,7 +752,8 @@ let process_openflow st t msg = return (Table.add_flow st st.Switch.table fm) | OP.Flow_mod.DELETE | OP.Flow_mod.DELETE_STRICT -> - Table.del_flow st.Switch.table of_match fm.OP.Flow_mod.out_port t + Table.del_flow st.Switch.table of_match fm.OP.Flow_mod.out_port + (Some t) in if (fm.OP.Flow_mod.buffer_id = -1l) then return () @@ -817,7 +820,7 @@ let control_channel_run st conn t = lwt _ = ( lwt _ = t in return (printf "thread terminated\n%!")) echo () - (lwt _ = Table.monitor_flow_timeout st.Switch.table conn in return (pp + (lwt _ = Table.monitor_flow_timeout st.Switch.table (Some conn) in return (pp "[switch] terminated flow_timeout thread") ) in let _ = Ofsocket.close conn in @@ -864,6 +867,46 @@ let add_port mgr ?(use_mac=false) sw ethif = in return () +let del_port mgr sw name = + try_lwt + let port = + List.find ( + fun a -> + name = (Net.Manager.get_intf_name mgr a.Switch.ethif) + ) sw.Switch.ports in + let _ = sw.Switch.ports <- List.filter ( + fun a -> + if (name = (Net.Manager.get_intf_name mgr a.Switch.ethif)) then + let _ = printf "removing port %s\n%!" (Net.Manager.get_intf_name mgr + a.Switch.ethif) in + false + else + true +(* not (name = (Net.Manager.get_intf_name mgr a.Switch.ethif) ) *) + ) sw.Switch.ports in + let _ = Hashtbl.find sw.Switch.int_to_port port.Switch.port_id in + let _ = Hashtbl.remove sw.Switch.int_to_port port.Switch.port_id in + let _ = Hashtbl.find sw.Switch.int_to_port port.Switch.port_id in + let _ = Hashtbl.remove sw.Switch.dev_to_port port.Switch.ethif in + let h,p = OP.Port.create_port_status OP.Port.DEL port.Switch.phy in + let of_match = OP.Match.create_flow_match OP.Wildcards.full_wildcard () in + lwt _ = Table.del_flow sw.Switch.table of_match + (OP.Port.port_of_int port.Switch.port_id) + sw.Switch.controller in + let of_match = OP.Match.create_flow_match OP.Wildcards.in_port + ~in_port:(port.Switch.port_id) () in + lwt _ = Table.del_flow sw.Switch.table of_match + OP.Port.No_port sw.Switch.controller in + lwt _ = + match sw.Switch.controller with + | None -> return () + | Some t -> Ofsocket.send_packet t (OP.Port_status (h,p)) + in + return () + with exn -> + let _ = printf "[switch] device not found %s\n%!" name in + return () + let add_port_local mgr sw ethif = (*TODO Find first if a port is already registered as port 0 * as port 0 and disable it *) @@ -898,21 +941,23 @@ let create_switch () = let listen st mgr loc = Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> - (Ofswitch_config.listen_t mgr 6634) + (Ofswitch_config.listen_t mgr (del_port mgr st) 6634) let connect st mgr loc = Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> - (Ofswitch_config.listen_t mgr 6634) + (Ofswitch_config.listen_t mgr (del_port mgr st) 6634) let local_connect st mgr input output = let conn = Ofsocket.init_local_conn_state input output in let _ = st.Switch.controller <- (Some conn) in let t, _ = Lwt.task () in (control_channel_run st conn t) <&> - (Ofswitch_config.listen_t mgr 6634) + (Ofswitch_config.listen_t mgr (del_port mgr st) 6634) let lwt_connect st ?(standalone=true) mgr loc = let of_ctrl = Ofswitch_standalone.init_controller () in + + let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (del_port mgr st) 6634) in let fd = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in let _ = Lwt_unix.setsockopt fd Unix.SO_REUSEADDR true in let _ = Lwt_unix.bind fd (Unix.ADDR_INET(Unix.inet_addr_any, 6633)) in diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index d4de6ad..cb503d2 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -15,8 +15,10 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) + type t -val add_port : Net.Manager.t -> ?use_mac:bool -> t -> Net.Manager.id -> unit Lwt.t +val add_port : Net.Manager.t -> ?use_mac:bool -> t -> string -> unit Lwt.t +val del_port : Net.Manager.t -> t -> string -> unit Lwt.t val add_port_local : Net.Manager.t -> t -> Net.Manager.id -> unit val create_switch : unit -> t val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 0596c6e..0688343 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -83,7 +83,7 @@ let connect_client mgr dst = let connect_client () = try_lwt let sock = socket PF_INET SOCK_STREAM 0 in - let dst = ADDR_INET( (Unix.inet_addr_of_string "10.0.0.2"), + let dst = ADDR_INET( (Unix.inet_addr_of_string "127.0.0.1"), 6634) in lwt _ = connect sock dst in let cl = {fd=sock;} in @@ -92,23 +92,34 @@ let connect_client () = failwith (sprintf "ofswitch_config client failed: %s" (Printexc.to_string ex)) -let listen_t mgr port = - let listen_inner mgr dst t = - while_lwt true do - lwt req = Net.Channel.read_some t in - let req = Jsonrpc.call_of_string - (Cstruct.to_string req) in - lwt success = - match (req.Rpc.name, req.Rpc.params) with - | ("add_port", (Rpc.String (dev))::_) -> Net.Manager.attach mgr dev - | ("del_port", (Rpc.String (dev))::_) -> Net.Manager.detach mgr dev - | (_, _) -> return false - in - let resp = - Jsonrpc.string_of_response (Rpc.success (Rpc.Null)) in - let _ = Net.Channel.write_string t resp in - Net.Channel.flush t - done +let listen_t mgr del_port port = + let listen_inner mgr st (input, output) = + lwt req = Lwt_io.read_line input in + let req = Jsonrpc.call_of_string req in + lwt success = + match (req.Rpc.name, req.Rpc.params) with + | ("add-port", (Rpc.String (dev))::_) -> + let _ = printf "attaching port %s\n%!" dev in + Net.Manager.attach mgr dev + | ("del-port", (Rpc.String (dev))::_) -> + let _ = printf "attaching port %s\n%!" dev in + lwt _ = del_port dev in + lwt _ = Net.Manager.detach mgr dev in + return true + | (_, _) -> + let _ = printf "[ofswitch-config] invalid action %s\n%!" + (req.Rpc.name) in + return false in - Net.Channel.listen mgr - (`TCPv4 ((None, port), (listen_inner mgr) )) + let resp = + Jsonrpc.string_of_response (Rpc.success (Rpc.Null)) in + lwt _ = Lwt_io.write_line output resp in + lwt _ = Lwt_io.close output in + lwt _ = Lwt_io.close input in + return () + in + let addr = Unix.ADDR_INET(Unix.inet_addr_any, 6634) in + let _ = Lwt_io.establish_server addr + (fun a -> Lwt.ignore_result (listen_inner mgr del_port a) ) in + return () + diff --git a/lib/ofswitch_config.mli b/lib/ofswitch_config.mli index 8e8f4fb..70e7be8 100644 --- a/lib/ofswitch_config.mli +++ b/lib/ofswitch_config.mli @@ -23,5 +23,4 @@ val connect_client: Net.Manager.t -> Net.Nettypes.ipv4_dst -> t Lwt.t *) val connect_client: unit -> t Lwt.t -val listen_t: Net.Manager.t -> - int -> unit Lwt.t +val listen_t: Net.Manager.t -> (string -> unit Lwt.t) -> int -> unit Lwt.t diff --git a/lib/ofswitch_ctrl.ml b/lib/ofswitch_ctrl.ml index 80ace87..164473a 100644 --- a/lib/ofswitch_ctrl.ml +++ b/lib/ofswitch_ctrl.ml @@ -25,18 +25,28 @@ let check_cmd_args cmd count = failwith (sprintf "Insufficient args for command %s (required %d)" cmd count) -let send_cmd cl = - try_lwt +let send_cmd (input, output) = + try_lwt let _ = if ((Array.length Sys.argv) < 2) then failwith "No command defined" in match (Sys.argv.(1)) with | "add-port" -> - let _ = check_cmd_args "add_port" 1 in - lwt _ = add_port cl Sys.argv.(2) in + let _ = check_cmd_args Sys.argv.(1) 1 in + let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String + Sys.argv.(2))];}) in + lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in + lwt _ = Lwt_io.read_line input in return () - | _ -> + | "del-port" -> + let _ = check_cmd_args Sys.argv.(1) 1 in + let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String + Sys.argv.(2))];}) in + lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in + lwt _ = Lwt_io.read_line input in + return () + | _ -> let _ = printf "Fail: unknown cmd: %s\n%!" Sys.argv.(1) in return () with ex -> @@ -44,8 +54,17 @@ let send_cmd cl = lwt _ = try_lwt - lwt cl = connect_client () in - lwt _ = send_cmd cl in + (* lwt cl = connect_client () in *) +(* let sock = socket PF_INET SOCK_STREAM 0 in *) + let dst = ADDR_INET( (Unix.inet_addr_of_string "127.0.0.1"), + 6634) in + lwt _ = Lwt_io.with_connection dst (send_cmd) in +(* lwt _ = Lwt_unix.connect sock dst in + let output = Lwt_io.of_fd ~mode:Lwt_io.output sock in + let = Lwt_io.of_fd ~mode:Lwt_io.output sock in + (* lwt _ = connect sock dst in *) + + lwt _ = send_cmd output in *) return () with e -> Printf.eprintf "Error: %s" (Printexc.to_string e); diff --git a/lib/ofswitch_standalone.ml b/lib/ofswitch_standalone.ml index 015a842..cc0c082 100644 --- a/lib/ofswitch_standalone.ml +++ b/lib/ofswitch_standalone.ml @@ -64,7 +64,18 @@ let datapath_leave_cb controller dpid evt = let req_count = (ref 0) - +let port_status_cb controller dpid = function + | OE.Port_status (OP.Port.DEL, port, _) -> + let macs = Hashtbl.fold ( + fun mac p r -> + if(p = (OP.Port.port_of_int port.OP.Port.port_no) ) then + r @ [mac] + else + r ) switch_data.mac_cache [] + in + return ( + List.iter (Hashtbl.remove switch_data.mac_cache) macs) + | _ -> return () let add_entry_in_hashtbl mac_cache ix in_port = if not (Hashtbl.mem mac_cache ix ) then Hashtbl.add mac_cache ix in_port @@ -87,18 +98,18 @@ let packet_in_cb controller dpid evt = (* check if I know the output port in order to define what type of message * we need to send *) -(* let broadcast = String.make 6 '\255' in + let broadcast = String.make 6 '\255' in let ix = m.OP.Match.dl_dst in if ( (ix = broadcast) || (not (Hashtbl.mem switch_data.mac_cache ix)) ) - then ( *) + then ( let bs = (OP.Packet_out.create ~buffer_id:buffer_id ~actions:[ OP.(Flow.Output(Port.All , 2000))] ~data:data ~in_port:in_port () ) in let h = OP.Header.create OP.Header.PACKET_OUT 0 in OC.send_data controller dpid (OP.Packet_out (h, bs)) -(* ) else ( + ) else ( let out_port = (Hashtbl.find switch_data.mac_cache ix) in let flags = OP.Flow_mod.({send_flow_rem=true; emerg=false; overlap=false;}) in lwt _ = @@ -120,7 +131,7 @@ let packet_in_cb controller dpid evt = [OP.Flow.Output(out_port, 2000)] ()) in let h = OP.Header.create OP.Header.FLOW_MOD 0 in OC.send_data controller dpid (OP.Flow_mod (h, pkt)) - ) *) + ) let init controller = pp "test controller register datapath cb\n%!"; @@ -128,7 +139,10 @@ let init controller = pp "test controller register leave cb\n%!"; OC.register_cb controller OE.DATAPATH_LEAVE datapath_leave_cb; pp "test controller register packet_in cb\n%!"; - OC.register_cb controller OE.PACKET_IN packet_in_cb + OC.register_cb controller OE.PACKET_IN packet_in_cb; + pp "test controller register packet_in cb\n%!"; + OC.register_cb controller OE.PORT_STATUS_CHANGE port_status_cb + let init_controller () = OC.init_controller init @@ -144,6 +158,3 @@ let run_controller mgr st = exn)) ) in return (switch_input, switch_output) - - - diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index 39f50ec..a449ed8 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -42,7 +42,7 @@ let print_time () = let switch_run () = let sw = create_switch () in try_lwt - Manager.create ~devs:1 ~attached:(["en0"]) + Manager.create ~devs:1 (* ~attached:(["en0"]) *) (fun mgr interface id -> match (Manager.get_intf_name mgr id) with | "tap0" From a328fe7c502e8fe966f89eda6bae1af04fc2b283 Mon Sep 17 00:00:00 2001 From: crotsos Date: Sun, 16 Dec 2012 18:11:06 +0000 Subject: [PATCH 18/75] Fixing a name collision for a function --- lib/ofpacket.ml | 2 +- lib/ofpacket.mli | 2 +- lib/ofswitch.ml | 4 +--- 3 files changed, 3 insertions(+), 5 deletions(-) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 30b002e..21f7d04 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -853,7 +853,7 @@ module Wildcards = struct dl_vlan_pcp: bool; nw_tos: bool; } - let in_port = + let in_port_match = { in_port=false; dl_vlan=true; dl_src=true; dl_dst=true; dl_type=true; nw_proto=true; tp_src=true; tp_dst=true; nw_src=(char_of_int 32); diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index c64da01..1d59123 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -209,7 +209,7 @@ module Wildcards : dl_vlan_pcp : bool; nw_tos : bool; } - val in_port : t + val in_port_match : t val full_wildcard : t val exact_match : t val l2_match : t diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 1aeb283..65d905d 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -884,16 +884,14 @@ let del_port mgr sw name = true (* not (name = (Net.Manager.get_intf_name mgr a.Switch.ethif) ) *) ) sw.Switch.ports in - let _ = Hashtbl.find sw.Switch.int_to_port port.Switch.port_id in let _ = Hashtbl.remove sw.Switch.int_to_port port.Switch.port_id in - let _ = Hashtbl.find sw.Switch.int_to_port port.Switch.port_id in let _ = Hashtbl.remove sw.Switch.dev_to_port port.Switch.ethif in let h,p = OP.Port.create_port_status OP.Port.DEL port.Switch.phy in let of_match = OP.Match.create_flow_match OP.Wildcards.full_wildcard () in lwt _ = Table.del_flow sw.Switch.table of_match (OP.Port.port_of_int port.Switch.port_id) sw.Switch.controller in - let of_match = OP.Match.create_flow_match OP.Wildcards.in_port + let of_match = OP.Match.create_flow_match OP.Wildcards.in_port_match ~in_port:(port.Switch.port_id) () in lwt _ = Table.del_flow sw.Switch.table of_match OP.Port.No_port sw.Switch.controller in From 935e505ea297025a6acfe2d5e153c67975bf8575 Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 17 Dec 2012 01:59:51 +0000 Subject: [PATCH 19/75] make switch connect to controller and retry on fail --- lib/ofswitch.ml | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 65d905d..c0ed92a 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -804,16 +804,19 @@ let control_channel_run st conn t = lwt _ = Ofsocket.send_packet conn (OP.Hello(h)) in let rec echo () = try_lwt + let _ = printf "reading packet...\n%!" in lwt ofp = Ofsocket.read_packet conn in - process_openflow st conn ofp (* Bitstring.concat [hbuf; dbuf] *) - >> echo () + let _ = printf "read packet...\n%!" in + lwt _ = process_openflow st conn ofp in + let _ = printf "processed packet...\n%!" in + echo () with | Nettypes.Closed -> pr "Controller channel closed....\n%!"; return () | OP.Unparsed (m, bs) -> (pr "# unparsed! m=%s\n %!" m); echo () | exn -> - pr "[OpenFlow-Switch-Control] ERROR:%s\n" (Printexc.to_string exn); + pr "[OpenFlow-Switch-Control] ERROR:%s\n%!" (Printexc.to_string exn); (echo () ) in @@ -956,10 +959,9 @@ let lwt_connect st ?(standalone=true) mgr loc = let of_ctrl = Ofswitch_standalone.init_controller () in let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (del_port mgr st) 6634) in - let fd = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in - let _ = Lwt_unix.setsockopt fd Unix.SO_REUSEADDR true in +(* let _ = Lwt_unix.setsockopt fd Unix.SO_REUSEADDR true in let _ = Lwt_unix.bind fd (Unix.ADDR_INET(Unix.inet_addr_any, 6633)) in - let _ = Lwt_unix.listen fd 1 in + let _ = Lwt_unix.listen fd 1 in *) let _ = printf "[switch] Listening socket...\n%!" in while_lwt true do let t,u = Lwt.task () in @@ -974,7 +976,20 @@ let lwt_connect st ?(standalone=true) mgr loc = return () ) <&> ( - lwt (sock, loc) = Lwt_unix.accept fd in + let rec connect_socket () = + try_lwt + let sock = Lwt_unix.socket + Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in + let dst = Unix.ADDR_INET( + (Unix.inet_addr_of_string "127.0.0.1"), 6633) in + lwt addr = Lwt_unix.connect sock dst in + return sock + with exn -> + lwt _ = Lwt_unix.sleep 5.0 in + connect_socket () + in + (* lwt (sock, loc) = Lwt_unix.accept fd in *) + lwt sock = connect_socket () in let conn = Ofsocket.init_unix_conn_state sock in let _ = wakeup u () in let t,_ = Lwt.task () in From 2454446c61a595caf972ac6b7b0fb5338bac8ea1 Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 17 Dec 2012 02:00:18 +0000 Subject: [PATCH 20/75] fix am arshal error on pkt_in --- lib/ofpacket.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 21f7d04..b6f7689 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -1667,7 +1667,7 @@ module Packet_in = struct sizeof_ofp_packet_in + data_len) in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header h) bits in let _ = set_ofp_packet_in_buffer_id bits t.buffer_id in - let _ = set_ofp_packet_in_total_len bits (sizeof_ofp_packet_in + data_len) in + let _ = set_ofp_packet_in_total_len bits data_len in let _ = set_ofp_packet_in_in_port bits (Port.int_of_port t.in_port) in let _ = set_ofp_packet_in_reason bits (int_of_reason t.reason) in let _ = Cstruct.blit_buffer t.data 0 bits sizeof_ofp_packet_in From 7b25a115181d2673d513228b120f7c834d147e3f Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 17 Dec 2012 02:02:13 +0000 Subject: [PATCH 21/75] bug fix on controller --- lib/ofcontroller.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 85976dd..1dc9190 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -153,7 +153,7 @@ let process_of_packet state conn ofp = | Hello (h) -> begin (* Reply to HELLO with a HELLO and a feature request *) let _ = cp "HELLO" in lwt _ = send_packet conn (OP.Hello (h)) in - let h = OP.Header.create OP.Header.FEATURES_RESP OP.Header.get_len in + let h = OP.Header.create OP.Header.FEATURES_REQ OP.Header.get_len in send_packet conn (OP.Features_req (h) ) end | Echo_req h -> begin (* Reply to ECHO requests *) From 7ec62d92e10132478c4db6b842c067e0e4cd8d3e Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 17 Dec 2012 17:09:18 +0000 Subject: [PATCH 22/75] fixing the network mask length --- lib/ofpacket.ml | 36 ++++++++++++++++++++++++++++++++---- 1 file changed, 32 insertions(+), 4 deletions(-) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index b6f7689..c750f87 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -122,7 +122,7 @@ let set_int32_byte f off v = logor f value let get_int32_nw_mask f off = - let ret = shift_left (logand f (shift_left 13l off)) off in + let ret = shift_right (logand f (shift_left 0x3fl off)) off in char_of_int (0x003f land (Int32.to_int ret)) let set_int32_nw_mask f off v = let value = Int32.of_int ((0x3f land v) lsl off) in @@ -1115,7 +1115,34 @@ module Match = struct nw_tos=(char_of_int 0); nw_proto=(char_of_int 0); tp_src=0; tp_dst=0} - let match_to_string m = + let print_field flag name value = + if (flag) then + "" + else + sprintf "%s:%s," name value + + let match_to_string m = + sprintf + "%s%s%s%s%s%s%s%s%s%s%s%s" + (print_field m.wildcards.Wildcards.in_port "in_port" (Port.string_of_port m.in_port)) + (print_field m.wildcards.Wildcards.dl_src "dl_src" (eaddr_to_string m.dl_src)) + (print_field m.wildcards.Wildcards.dl_dst "dl_dst" (eaddr_to_string m.dl_dst)) + (print_field m.wildcards.Wildcards.dl_vlan "dl_vlan" (string_of_int m.dl_vlan)) + (print_field m.wildcards.Wildcards.dl_vlan_pcp "dl_pcp" + (string_of_int (int_of_char m.dl_vlan_pcp) )) + (print_field m.wildcards.Wildcards.dl_type "dl_type" (string_of_int m.dl_type)) + (print_field (m.wildcards.Wildcards.nw_src >= '\x20') "nw_src" + (sprintf "%s/%d" (Net.Nettypes.ipv4_addr_to_string (Net.Nettypes.ipv4_addr_of_uint32 m.nw_src)) + (int_of_char m.wildcards.Wildcards.nw_src) )) + (print_field (m.wildcards.Wildcards.nw_dst >= '\x20') "nw_dst" + (sprintf "%s/%d" (Net.Nettypes.ipv4_addr_to_string (Net.Nettypes.ipv4_addr_of_uint32 m.nw_dst) ) + (int_of_char m.wildcards.Wildcards.nw_dst) )) + (print_field m.wildcards.Wildcards.nw_tos "nw_tos" (string_of_int (int_of_char m.nw_tos))) + (print_field m.wildcards.Wildcards.nw_proto "nw_proto" (string_of_int (int_of_char m.nw_proto))) + (print_field m.wildcards.Wildcards.tp_src "tp_src" (string_of_int m.tp_src)) + (print_field m.wildcards.Wildcards.tp_dst "tp_dst" (string_of_int m.tp_dst)) + +(* let _ = switch_data.dpid <- dp in match (m.dl_type, (int_of_char m.nw_proto)) with | (0x0800, 17) -> (sp "in_port:%s,dl_src:%s,dl_dst:%s,dl_type:ip,nw_src:%s/%d,nw_dst:%s/%d,\ @@ -1136,9 +1163,10 @@ module Match = struct | (_, _) -> (sp "in_port:%s,dl_src:%s,dl_dst:%s,dl_type:0x%x" (Port.string_of_port m.in_port) (eaddr_to_string m.dl_src) (eaddr_to_string m.dl_dst) m.dl_type - ) + ) *) + let flow_match_compare flow flow_def wildcard = -(* Printf.printf "comparing flows %s \n%s\n%s \n%!" (Wildcards.string_of_wildcard wildcard) +(* Printf.printf "comparing flows %s \n%s\n%s \n%!" (Wildcards.wildcard_to_string wildcard) (match_to_string flow) (match_to_string flow_def); Printf.printf "in_port:%s,dl_vlan:%s,dl_src:%s(%d %d),dl_dst:%s,dl_type:%s,\ nw_proto:%s,tp_src:%s(%d %d),tp_dst:%s,nw_src:%s,nw_dst:%s,\ From 7c10473132c33470c45d38a47cd5bf4408853d2a Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 17 Dec 2012 17:10:17 +0000 Subject: [PATCH 23/75] Adding local port handling, increase pkt_in size --- lib/ofswitch.ml | 32 +++++++++++++++++++++----------- 1 file changed, 21 insertions(+), 11 deletions(-) diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index c0ed92a..31fe994 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -324,6 +324,7 @@ module Switch = struct let forward_frame st in_port frame pkt_size = function | OP.Port.Port(port) -> if Hashtbl.mem st.int_to_port port then( + let _ = printf "sending to port %d\n%!" port in let out_p = (!( Hashtbl.find st.int_to_port port)) in Net.Manager.inject_packet out_p.mgr out_p.ethif frame ) else @@ -342,11 +343,22 @@ module Switch = struct | OP.Port.In_port -> let port = (OP.Port.int_of_port in_port) in if Hashtbl.mem st.int_to_port port then + let _ = printf "sending to port %d\n%!" port in let out_p = !(Hashtbl.find st.int_to_port port) in update_port_tx_stats (Int64.of_int (Cstruct.len frame)) out_p; Net.Manager.inject_packet out_p.mgr out_p.ethif frame else - return (Printf.printf "Port %d not registered \n" port) + return (Printf.printf "Port %d not registered \n%!" port) + | OP.Port.Local -> + let local_port_id = OP.Port.int_of_port OP.Port.Local in + if Hashtbl.mem st.int_to_port local_port_id then + let out_p = !(Hashtbl.find st.int_to_port local_port_id) in + let _ = printf "sending to port %d\n%!" local_port_id in + let _ = update_port_tx_stats (Int64.of_int (Cstruct.len frame)) out_p in + Net.Manager.inject_packet out_p.mgr out_p.ethif frame + else + return (Printf.printf "Port %d not registered \n%!" local_port_id) + (* | Table * | Normal * | Controller -> generate a packet out. @@ -533,8 +545,8 @@ let process_frame_inner st p intf frame = ~reason:OP.Packet_in.NO_MATCH ~data:frame in let _ = st.Switch.packet_buffer <- st.Switch.packet_buffer @ [pkt_in] in let size = - if (Cstruct.len frame > 64) then - 64 + if (Cstruct.len frame > 92) then + 92 else Cstruct.len frame in @@ -741,7 +753,7 @@ let process_openflow st t msg = pkt_in.OP.Packet_in.data pkt.OP.Packet_out.actions end | OP.Flow_mod(h,fm) -> -(* cp (sp "FLOW_MOD: %s" (OP.Flow_mod.flow_mod_to_string fm)); *) + cp (sp "FLOW_MOD: %s" (OP.Flow_mod.flow_mod_to_string fm)); let of_match = fm.OP.Flow_mod.of_match in let of_actions = fm.OP.Flow_mod.actions in lwt _ = @@ -804,11 +816,8 @@ let control_channel_run st conn t = lwt _ = Ofsocket.send_packet conn (OP.Hello(h)) in let rec echo () = try_lwt - let _ = printf "reading packet...\n%!" in lwt ofp = Ofsocket.read_packet conn in - let _ = printf "read packet...\n%!" in lwt _ = process_openflow st conn ofp in - let _ = printf "processed packet...\n%!" in echo () with | Nettypes.Closed -> @@ -911,20 +920,21 @@ let del_port mgr sw name = let add_port_local mgr sw ethif = (*TODO Find first if a port is already registered as port 0 * as port 0 and disable it *) - let port = Switch.init_port mgr 0 ethif in + let local_port_id = OP.Port.int_of_port OP.Port.Local in + let port = Switch.init_port mgr local_port_id ethif in sw.Switch.ports <- (List.filter (fun a -> (a.Switch.port_id <> 0)) sw.Switch.ports) @ [port]; - Hashtbl.replace sw.Switch.int_to_port 0 (ref port); + Hashtbl.replace sw.Switch.int_to_port local_port_id (ref port); Hashtbl.iter (fun a b -> - if (!b.Switch.port_id = 0) then + if (!b.Switch.port_id = local_port_id) then Hashtbl.remove sw.Switch.dev_to_port a ) sw.Switch.dev_to_port; Hashtbl.add sw.Switch.dev_to_port ethif (ref port); (*TODO Need to filter out any 0 port *) sw.Switch.features.OP.Switch.ports <- - (List.filter (fun a -> (a.OP.Port.port_no <> 0)) + (List.filter (fun a -> (a.OP.Port.port_no <> local_port_id)) sw.Switch.features.OP.Switch.ports ) @ [port.Switch.phy]; let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw port) in From 9a8bc0fe7cc0ad568a74c9702a3f19f1fb6e9e57 Mon Sep 17 00:00:00 2001 From: crotsos Date: Sun, 23 Dec 2012 23:50:40 +0200 Subject: [PATCH 24/75] adding support for flow export through the ofswitch_ctrl tool --- _oasis | 4 +- _tags | 8 +- lib/META | 5 +- lib/ofpacket.ml | 90 +++++++--------- lib/ofpacket.mli | 52 ++++----- lib/ofswitch.ml | 81 ++++++++------ lib/ofswitch.mli | 3 +- lib/ofswitch_config.ml | 232 +++++++++++++++++++++++++--------------- lib/ofswitch_config.mli | 9 +- lib/ofswitch_ctrl.ml | 62 ++++++++--- setup.ml | 15 ++- 11 files changed, 334 insertions(+), 227 deletions(-) diff --git a/_oasis b/_oasis index ebbcd07..87225b8 100644 --- a/_oasis +++ b/_oasis @@ -31,7 +31,7 @@ Library openflow CompiledObject: native Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch, Ofsocket, Ofswitch_standalone Pack: True - BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0) + BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0), re.str Document openflow Title: OpenFlow docs @@ -47,7 +47,7 @@ Executable ofswitch_ctrl Custom: true CompiledObject: native Install: true - BuildDepends: openflow + BuildDepends: openflow, re.str Executable learning_switch_lwt diff --git a/_tags b/_tags index 921ce91..de4c57e 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 89cfc75151445422183dc48c904b7297) +# DO NOT EDIT (digest: 2cf03af4e1bd1948e39b38ed0ec49a73) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -25,6 +25,7 @@ "lib/ofswitch_ctrl.native": use_openflow "lib/ofswitch_ctrl.native": pkg_cstruct "lib/ofswitch_ctrl.native": pkg_cstruct.syntax +"lib/ofswitch_ctrl.native": pkg_re.str "lib/ofswitch_ctrl.native": pkg_rpclib "lib/ofswitch_ctrl.native": pkg_rpclib.json "lib/ofswitch_ctrl.native": pkg_mirage @@ -32,6 +33,7 @@ : use_openflow : pkg_cstruct : pkg_cstruct.syntax +: pkg_re.str : pkg_rpclib : pkg_rpclib.json : pkg_mirage @@ -41,6 +43,7 @@ "controller/learning_switch.native": use_openflow "controller/learning_switch.native": pkg_cstruct "controller/learning_switch.native": pkg_cstruct.syntax +"controller/learning_switch.native": pkg_re.str "controller/learning_switch.native": pkg_rpclib "controller/learning_switch.native": pkg_rpclib.json "controller/learning_switch.native": pkg_mirage @@ -48,6 +51,7 @@ : use_openflow : pkg_cstruct : pkg_cstruct.syntax +: pkg_re.str : pkg_rpclib : pkg_rpclib.json : pkg_mirage @@ -57,6 +61,7 @@ "switch/basic_switch.native": use_openflow "switch/basic_switch.native": pkg_cstruct "switch/basic_switch.native": pkg_cstruct.syntax +"switch/basic_switch.native": pkg_re.str "switch/basic_switch.native": pkg_rpclib "switch/basic_switch.native": pkg_rpclib.json "switch/basic_switch.native": pkg_mirage @@ -64,6 +69,7 @@ : use_openflow : pkg_cstruct : pkg_cstruct.syntax +: pkg_re.str : pkg_rpclib : pkg_rpclib.json : pkg_mirage diff --git a/lib/META b/lib/META index 255711b..1a8e298 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: 5137e40263b875c2f23901ea9b742a8e) +# DO NOT EDIT (digest: cf826b73e7b89f065bfc4c5b9aa7ab3f) version = "0.3.0" description = "OpenFlow protocol and switch implementations in pure OCaml" -requires = "cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net" +requires = +"cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net re.str" archive(byte) = "openflow.cma" archive(byte, plugin) = "openflow.cma" archive(native) = "openflow.cmxa" diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index c750f87..70e53b8 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -78,8 +78,8 @@ let eaddr_to_string s = let hp s i = sp "%02x" (int_of_char s.[i]) in String.concat ":" (Array.init l (fun i -> hp s i) |> Array.to_list) -(* let bitstring_of_eaddr s = - (BITSTRING{s:48:string}) *) +external ipv4_addr_of_uint32: int32 -> Net.Nettypes.ipv4_addr = "%identity" +external ipv4_addr_to_uint32: Net.Nettypes.ipv4_addr -> int32 = "%identity" let eaddr_is_broadcast s = match s with @@ -840,18 +840,18 @@ end module Wildcards = struct type t = { - in_port: bool; - dl_vlan: bool; - dl_src: bool; - dl_dst: bool; - dl_type: bool; - nw_proto: bool; - tp_src: bool; - tp_dst: bool; - nw_src: byte; (* XXX *) - nw_dst: byte; (* XXX *) - dl_vlan_pcp: bool; - nw_tos: bool; + mutable in_port: bool; + mutable dl_vlan: bool; + mutable dl_src: bool; + mutable dl_dst: bool; + mutable dl_type: bool; + mutable nw_proto: bool; + mutable tp_src: bool; + mutable tp_dst: bool; + mutable nw_src: byte; (* XXX *) + mutable nw_dst: byte; (* XXX *) + mutable dl_vlan_pcp: bool; + mutable nw_tos: bool; } let in_port_match = { in_port=false; dl_vlan=true; dl_src=true; @@ -933,20 +933,27 @@ end module Match = struct type t = { - wildcards: Wildcards.t; - in_port: Port.t; - dl_src: eaddr; - dl_dst: eaddr; - dl_vlan: uint16; - dl_vlan_pcp: byte; - dl_type: uint16; - nw_src: uint32; - nw_dst: uint32; - nw_tos: byte; - nw_proto: byte; - tp_src: uint16; - tp_dst: uint16; - } + mutable wildcards: Wildcards.t; + mutable in_port: Port.t; + mutable dl_src: eaddr; + mutable dl_dst: eaddr; + mutable dl_vlan: uint16; + mutable dl_vlan_pcp: byte; + mutable dl_type: uint16; + mutable nw_src: uint32; + mutable nw_dst: uint32; + mutable nw_tos: byte; + mutable nw_proto: byte; + mutable tp_src: uint16; + mutable tp_dst: uint16; + } + + let wildcard () = + {wildcards=Wildcards.full_wildcard; in_port=Port.No_port; + dl_src="\000\000\000\000\000\000"; + dl_dst="\000\000\000\000\000\000"; + dl_vlan=0; dl_vlan_pcp='\000'; dl_type=0; nw_src=0l; nw_dst=0l; + nw_tos='\000';nw_proto='\000';tp_src=0; tp_dst=0;} cstruct ofp_match { uint32_t wildcards; @@ -1132,39 +1139,16 @@ module Match = struct (string_of_int (int_of_char m.dl_vlan_pcp) )) (print_field m.wildcards.Wildcards.dl_type "dl_type" (string_of_int m.dl_type)) (print_field (m.wildcards.Wildcards.nw_src >= '\x20') "nw_src" - (sprintf "%s/%d" (Net.Nettypes.ipv4_addr_to_string (Net.Nettypes.ipv4_addr_of_uint32 m.nw_src)) + (sprintf "%s/%d" (Net.Nettypes.ipv4_addr_to_string (ipv4_addr_of_uint32 m.nw_src)) (int_of_char m.wildcards.Wildcards.nw_src) )) (print_field (m.wildcards.Wildcards.nw_dst >= '\x20') "nw_dst" - (sprintf "%s/%d" (Net.Nettypes.ipv4_addr_to_string (Net.Nettypes.ipv4_addr_of_uint32 m.nw_dst) ) + (sprintf "%s/%d" (Net.Nettypes.ipv4_addr_to_string (ipv4_addr_of_uint32 m.nw_dst) ) (int_of_char m.wildcards.Wildcards.nw_dst) )) (print_field m.wildcards.Wildcards.nw_tos "nw_tos" (string_of_int (int_of_char m.nw_tos))) (print_field m.wildcards.Wildcards.nw_proto "nw_proto" (string_of_int (int_of_char m.nw_proto))) (print_field m.wildcards.Wildcards.tp_src "tp_src" (string_of_int m.tp_src)) (print_field m.wildcards.Wildcards.tp_dst "tp_dst" (string_of_int m.tp_dst)) -(* let _ = switch_data.dpid <- dp in - match (m.dl_type, (int_of_char m.nw_proto)) with - | (0x0800, 17) - -> (sp "in_port:%s,dl_src:%s,dl_dst:%s,dl_type:ip,nw_src:%s/%d,nw_dst:%s/%d,\ - nw_tos:%d,nw_proto:%d,tp_dst:%d,tp_src:%d" - (Port.string_of_port m.in_port) (eaddr_to_string m.dl_src) - (eaddr_to_string m.dl_dst) (ipv4_to_string m.nw_src) (int_of_char m.wildcards.Wildcards.nw_src) - (ipv4_to_string m.nw_dst) (int_of_char m.wildcards.Wildcards.nw_dst) (Char.code m.nw_tos) - (Char.code m.nw_proto) m.tp_dst m.tp_src - ) - | (0x0800, _) - -> (sp "in_port:%s,dl_src:%s,dl_dst:%s,dl_type:ip,nw_src:%s/%d,\ - nw_dst:%s/%d,nw_tos:%d,nw_proto:%d" - (Port.string_of_port m.in_port) (eaddr_to_string m.dl_src) - (eaddr_to_string m.dl_dst) (ipv4_to_string m.nw_src) (int_of_char m.wildcards.Wildcards.nw_src) - (ipv4_to_string m.nw_dst) (int_of_char m.wildcards.Wildcards.nw_dst) (Char.code m.nw_tos) - (Char.code m.nw_proto) - ) - | (_, _) -> (sp "in_port:%s,dl_src:%s,dl_dst:%s,dl_type:0x%x" - (Port.string_of_port m.in_port) (eaddr_to_string m.dl_src) - (eaddr_to_string m.dl_dst) m.dl_type - ) *) - let flow_match_compare flow flow_def wildcard = (* Printf.printf "comparing flows %s \n%s\n%s \n%!" (Wildcards.wildcard_to_string wildcard) (match_to_string flow) (match_to_string flow_def); diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index 1d59123..142361c 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -196,18 +196,18 @@ module Switch : module Wildcards : sig type t = { - in_port : bool; - dl_vlan : bool; - dl_src : bool; - dl_dst : bool; - dl_type : bool; - nw_proto : bool; - tp_src : bool; - tp_dst : bool; - nw_src : byte; - nw_dst : byte; - dl_vlan_pcp : bool; - nw_tos : bool; + mutable in_port : bool; + mutable dl_vlan : bool; + mutable dl_src : bool; + mutable dl_dst : bool; + mutable dl_type : bool; + mutable nw_proto : bool; + mutable tp_src : bool; + mutable tp_dst : bool; + mutable nw_src : byte; + mutable nw_dst : byte; + mutable dl_vlan_pcp : bool; + mutable nw_tos : bool; } val in_port_match : t val full_wildcard : t @@ -220,20 +220,22 @@ module Wildcards : module Match : sig type t = { - wildcards : Wildcards.t; - in_port : Port.t; - dl_src : eaddr; - dl_dst : eaddr; - dl_vlan : uint16; - dl_vlan_pcp : byte; - dl_type : uint16; - nw_src : uint32; - nw_dst : uint32; - nw_tos : byte; - nw_proto : byte; - tp_src : uint16; - tp_dst : uint16; + mutable wildcards : Wildcards.t; + mutable in_port : Port.t; + mutable dl_src : eaddr; + mutable dl_dst : eaddr; + mutable dl_vlan : uint16; + mutable dl_vlan_pcp : byte; + mutable dl_type : uint16; + mutable nw_src : uint32; + mutable nw_dst : uint32; + mutable nw_tos : byte; + mutable nw_proto : byte; + mutable tp_src : uint16; + mutable tp_dst : uint16; } + + val wildcard: unit -> t val flow_match_compare : t -> t -> Wildcards.t -> bool val create_flow_match : Wildcards.t -> diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 31fe994..1ff1d98 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -16,6 +16,8 @@ *) open Lwt +open Lwt_log + open Net open Nettypes open Ofswitch_config @@ -129,9 +131,13 @@ module Table = struct (* TODO fix flow_mod flag support. overlap is not considered *) let add_flow st table t = (* TODO check if the details are correct e.g. IP type etc. *) - Hashtbl.replace table.entries t.OP.Flow_mod.of_match - (Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); - cache_entries=[];})) + lwt _ = + log ~level:Notice + (sprintf "Adding flow %s" (OP.Match.match_to_string t.OP.Flow_mod.of_match)) in + let _ = Hashtbl.replace table.entries t.OP.Flow_mod.of_match + Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); + cache_entries=[];}) in + return () (* check if a list of actions has an output action forwarding packets to * out_port *) @@ -166,7 +172,11 @@ module Table = struct (* Check for notification flag in flow and send * flow modification warnings *) Lwt_list.iter_s ( - fun (of_match, flow) -> + fun (of_match, flow) -> + lwt _ = + log ~level:Notice + (sprintf "Adding flow %s" (OP.Match.match_to_string of_match)) in + if (t <> None) && (flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) then let Some(t) = t in @@ -324,7 +334,7 @@ module Switch = struct let forward_frame st in_port frame pkt_size = function | OP.Port.Port(port) -> if Hashtbl.mem st.int_to_port port then( - let _ = printf "sending to port %d\n%!" port in +(* let _ = printf "sending to port %d\n%!" port in *) let out_p = (!( Hashtbl.find st.int_to_port port)) in Net.Manager.inject_packet out_p.mgr out_p.ethif frame ) else @@ -343,7 +353,7 @@ module Switch = struct | OP.Port.In_port -> let port = (OP.Port.int_of_port in_port) in if Hashtbl.mem st.int_to_port port then - let _ = printf "sending to port %d\n%!" port in +(* let _ = printf "sending to port %d\n%!" port in *) let out_p = !(Hashtbl.find st.int_to_port port) in update_port_tx_stats (Int64.of_int (Cstruct.len frame)) out_p; Net.Manager.inject_packet out_p.mgr out_p.ethif frame @@ -353,7 +363,7 @@ module Switch = struct let local_port_id = OP.Port.int_of_port OP.Port.Local in if Hashtbl.mem st.int_to_port local_port_id then let out_p = !(Hashtbl.find st.int_to_port local_port_id) in - let _ = printf "sending to port %d\n%!" local_port_id in +(* let _ = printf "sending to port %d\n%!" local_port_id in *) let _ = update_port_tx_stats (Int64.of_int (Cstruct.len frame)) out_p in Net.Manager.inject_packet out_p.mgr out_p.ethif frame else @@ -610,6 +620,20 @@ type endhost = { port: int; } +let get_flow_stats st of_match = + let match_flows of_match key value ret = + if (OP.Match.flow_match_compare key of_match + of_match.OP.Match.wildcards) then ( + ret @ [ + (Entry.flow_counters_to_flow_stats + key (char_of_int 1) value)] + ) else + ret + in + Hashtbl.fold (fun key value r -> match_flows of_match key value r) + st.Switch.table.Table.entries [] + + let process_openflow st t msg = match msg with | OP.Hello (h) -> @@ -643,18 +667,7 @@ let process_openflow st t msg = (*TODO Need to consider the table_id and the out_port and * split reply over multiple openflow packets if they don't * fit a single packet. *) - let match_flows of_match key value ret = - if (OP.Match.flow_match_compare key of_match - of_match.OP.Match.wildcards) then ( - ret @ [ - (Entry.flow_counters_to_flow_stats - of_match (char_of_int 1) value)] - ) else - ret - in - let flows = - Hashtbl.fold (fun key value r -> match_flows of_match key value r) - st.Switch.table.Table.entries [] in + let flows = get_flow_stats st of_match in let stats = OP.Stats.({st_ty=FLOW; more_to_follow=false;}) in let r = OP.Stats.Flow_resp(stats, flows) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in @@ -761,9 +774,11 @@ let process_openflow st t msg = | OP.Flow_mod.ADD | OP.Flow_mod.MODIFY | OP.Flow_mod.MODIFY_STRICT -> - return (Table.add_flow st st.Switch.table fm) + Table.add_flow st st.Switch.table fm | OP.Flow_mod.DELETE | OP.Flow_mod.DELETE_STRICT -> + (* Need to implemente strict deletion in order to enable signpost + * switching *) Table.del_flow st.Switch.table of_match fm.OP.Flow_mod.out_port (Some t) in @@ -857,6 +872,8 @@ let add_port mgr ?(use_mac=false) sw ethif = (Manager.get_intf_mac mgr ethif)) in let _ = pr "Adding port %d (%s) '%s' \n %!" sw.Switch.portnum (Net.Manager.get_intf_name mgr ethif) hw_addr in + lwt _ = log ~level:Notice (sprintf "Adding port %s (port_id=%d)" ethif + sw.Switch.portnum) in lwt _ = if (use_mac) then lwt _ = Lwt_unix.system (sprintf "ifconfig tap0 lladdr %s" hw_addr) in @@ -907,6 +924,8 @@ let del_port mgr sw name = ~in_port:(port.Switch.port_id) () in lwt _ = Table.del_flow sw.Switch.table of_match OP.Port.No_port sw.Switch.controller in + lwt _ = log ~level:Notice (sprintf "Removing port %s (port_id=%d)" name + port.Switch.port_id) in lwt _ = match sw.Switch.controller with | None -> return () @@ -937,8 +956,10 @@ let add_port_local mgr sw ethif = (List.filter (fun a -> (a.OP.Port.port_no <> local_port_id)) sw.Switch.features.OP.Switch.ports ) @ [port.Switch.phy]; - let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw port) in - () + lwt _ = log ~level:Notice (sprintf "Adding port %s (port_id=%d)" ethif + local_port_id) in + let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw port) in + return () let create_switch () = @@ -952,23 +973,23 @@ let create_switch () = let listen st mgr loc = Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> - (Ofswitch_config.listen_t mgr (del_port mgr st) 6634) + (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) 6634) let connect st mgr loc = Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> - (Ofswitch_config.listen_t mgr (del_port mgr st) 6634) + (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) 6634) let local_connect st mgr input output = let conn = Ofsocket.init_local_conn_state input output in let _ = st.Switch.controller <- (Some conn) in let t, _ = Lwt.task () in (control_channel_run st conn t) <&> - (Ofswitch_config.listen_t mgr (del_port mgr st) 6634) + (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) 6634) let lwt_connect st ?(standalone=true) mgr loc = let of_ctrl = Ofswitch_standalone.init_controller () in - let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (del_port mgr st) 6634) in + let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) 6634) in (* let _ = Lwt_unix.setsockopt fd Unix.SO_REUSEADDR true in let _ = Lwt_unix.bind fd (Unix.ADDR_INET(Unix.inet_addr_any, 6633)) in let _ = Lwt_unix.listen fd 1 in *) @@ -976,13 +997,13 @@ let lwt_connect st ?(standalone=true) mgr loc = while_lwt true do let t,u = Lwt.task () in (( - let _ = printf "[switch] standalone controller connected...\n%!" in - lwt (switch_in, switch_out) = + lwt _ = log ~level:Notice "Standalone controller taking over..." in + lwt (switch_in, switch_out) = Ofswitch_standalone.run_controller mgr of_ctrl in let conn = Ofsocket.init_local_conn_state switch_in switch_out in let _ = st.Switch.controller <- (Some conn) in lwt _ = control_channel_run st conn t in - let _ = printf "[switch] standalone controller stopped...\n%!" in + lwt _ = log ~level:Notice "Standalone controller stopped..." in return () ) <&> ( @@ -1004,7 +1025,7 @@ let lwt_connect st ?(standalone=true) mgr loc = let _ = wakeup u () in let t,_ = Lwt.task () in let _ = st.Switch.controller <- (Some conn) in - let _ = printf "[switch] remote controller connected...\n%!" in + lwt _ = log ~level:Notice "Remote controller started..." in control_channel_run st conn t )) done diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index cb503d2..152d3a3 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -19,7 +19,8 @@ type t val add_port : Net.Manager.t -> ?use_mac:bool -> t -> string -> unit Lwt.t val del_port : Net.Manager.t -> t -> string -> unit Lwt.t -val add_port_local : Net.Manager.t -> t -> Net.Manager.id -> unit +val add_port_local : Net.Manager.t -> t -> Net.Manager.id -> unit Lwt.t +val get_flow_stats : t -> Ofpacket.Match.t -> Ofpacket.Flow.stats list val create_switch : unit -> t val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> unit Lwt.t diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 0688343..a2f9502 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -18,68 +18,12 @@ open Lwt open Lwt_unix open Printf +module OP = Ofpacket + type t = { -(* - dev_m: (string * string) Lwt_condition.t; - res_m: bool Lwt_condition.t; - *) - fd: Lwt_unix.file_descr; + fd: Lwt_unix.file_descr; } -let add_port t dev = - let buf = String.create 4096 in - let req = Jsonrpc.string_of_call - (Rpc.call "add_port" [Rpc.String dev]) in - lwt _ = send t.fd req 0 (String.length req) [] in - lwt len = recv t.fd buf 0 4096 [] in - let resp = Jsonrpc.response_of_string buf in - return (resp.Rpc.success) - (* - let _ = Lwt_condition.signal t.dev_m ("add_port", dev) in - Lwt_condition.wait t.res_m - - *) -let del_port t dev = - return false - (* - let _ = Lwt_condition.signal t.dev_m ("add_port", dev) in - Lwt_condition.wait t.res_m - *) - - (* -let client_t mgr client t = - let _ = Lwt_condition.signal client.res_m true in - while_lwt true do - lwt (op, dev) = Lwt_condition.wait client.dev_m in - let req = Jsonrpc.string_of_call - (Rpc.call op [Rpc.String dev]) in - let _ = Net.Channel.write_string t req 0 (String.length req) in - lwt _ = Net.Channel.flush t in - lwt resp_str = Net.Channel.read_some t in - let resp = - Jsonrpc.response_of_string - (Cstruct.to_string resp_str) in - return (Lwt_condition.signal client.res_m resp.Rpc.success) - done - -let connect_client mgr dst = - try_lwt - let dev_m = Lwt_condition.create () in - let res_m = Lwt_condition.create () in - let cl = {dev_m; res_m;} in - let _ = - Lwt.ignore_result - (Net.Channel.connect mgr - (`TCPv4 (None, dst, (client_t mgr cl)))) in - lwt res = Lwt_condition.wait cl.res_m in - match res with - | true -> return cl - | false -> failwith "ofswitch_config client failed" - with ex -> - failwith (sprintf "ofswitch_config client failed: %s" - (Printexc.to_string ex)) - *) - let connect_client () = try_lwt let sock = socket PF_INET SOCK_STREAM 0 in @@ -91,34 +35,152 @@ let connect_client () = with ex -> failwith (sprintf "ofswitch_config client failed: %s" (Printexc.to_string ex)) - -let listen_t mgr del_port port = + +let hashtbl_to_flow_match map = + let of_match = OP.Match.wildcard () in + let _ = + Hashtbl.iter ( + fun name value -> + match name with + | "in_port" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.in_port <- false in + let _ = of_match.OP.Match.in_port <- OP.Port.port_of_int + (int_of_string value) in + () + | "dl_vlan" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan <- false in + let _ = of_match.OP.Match.dl_vlan <- int_of_string value in + () + | "dl_vlan_pcp" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan_pcp <- false in + let _ = of_match.OP.Match.dl_vlan_pcp <- char_of_int (int_of_string value) in + () + | "dl_src" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_src <- false in + let _ = + match (Net.Nettypes.ethernet_mac_of_string value) with + | None -> printf "Invalid mac addr %s\n%!" value + | Some t -> of_match.OP.Match.dl_src <- Net.Nettypes.ethernet_mac_to_bytes t + in + () + | "dl_dst" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_dst <- false in + let _ = + match (Net.Nettypes.ethernet_mac_of_string value) with + | None -> printf "Invalid mac addr %s\n%!" value + | Some t -> of_match.OP.Match.dl_dst <- Net.Nettypes.ethernet_mac_to_bytes t + in + () + | "dl_type" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_type <- false in + let _ = of_match.OP.Match.dl_type <- int_of_string value in + () + | "nw_src" -> + let fields = + match (Re_str.split (Re_str.regexp "\/") value) with + | ip::mask::_ -> + match (Net.Nettypes.ipv4_addr_of_string ip) with + | None -> printf "Invalid ip definition" + | Some ip -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_src <- + char_of_int (int_of_string mask) in + let _ = of_match.OP.Match.nw_src <- + Net.Nettypes.ipv4_addr_to_uint32 ip in + () + | _ -> printf "Invalid ip definition" + in + () + | "nw_dst" -> + let fields = + match (Re_str.split (Re_str.regexp "\/") value) with + | ip::mask::_ -> + match (Net.Nettypes.ipv4_addr_of_string ip) with + | None -> printf "Invalid ip definition" + | Some ip -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_dst <- + char_of_int (int_of_string mask) in + let _ = of_match.OP.Match.nw_dst <- + Net.Nettypes.ipv4_addr_to_uint32 ip in + () + | _ -> printf "Invalid ip definition" + in + () + | "nw_tos" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan <- false in + let _ = of_match.OP.Match.nw_tos <- char_of_int (int_of_string + value) in + () + | "nw_proto" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_proto <- false in + let _ = of_match.OP.Match.nw_proto <- char_of_int (int_of_string + value) in + () + | "tp_src" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.tp_src <- false in + let _ = of_match.OP.Match.tp_src <- int_of_string value in + () + | "tp_dst" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.tp_dst <- false in + let _ = of_match.OP.Match.tp_dst <- int_of_string value in + () + | _ -> + let _ = eprintf "Invalid field name %s" name in + () + ) map in + of_match + + +let listen_t mgr del_port get_stats port = let listen_inner mgr st (input, output) = - lwt req = Lwt_io.read_line input in - let req = Jsonrpc.call_of_string req in - lwt success = - match (req.Rpc.name, req.Rpc.params) with - | ("add-port", (Rpc.String (dev))::_) -> - let _ = printf "attaching port %s\n%!" dev in - Net.Manager.attach mgr dev - | ("del-port", (Rpc.String (dev))::_) -> - let _ = printf "attaching port %s\n%!" dev in - lwt _ = del_port dev in - lwt _ = Net.Manager.detach mgr dev in - return true - | (_, _) -> - let _ = printf "[ofswitch-config] invalid action %s\n%!" - (req.Rpc.name) in - return false + try_lwt + lwt req = Lwt_io.read_line input in + let req = Jsonrpc.call_of_string req in + lwt success = + match (req.Rpc.name, req.Rpc.params) with + | ("add-port", (Rpc.String (dev))::_) -> + let _ = Net.Manager.attach mgr dev in + return (Rpc.Enum [(Rpc.String "true")]) + | ("del-port", (Rpc.String (dev))::_) -> + lwt _ = del_port dev in + lwt _ = Net.Manager.detach mgr dev in + return (Rpc.Enum [(Rpc.String "true")]) + | ("dump-flows", (Rpc.Dict t)::_) -> + let _ = printf "dumpflows for %s\n%!" (Rpc.string_of_call req) in + let map = + List.fold_right ( + fun (name, value) r -> + let _ = Hashtbl.add r name (Rpc.string_of_rpc value) in + let _ = printf "Adding %s = %s\n%!" name (Rpc.string_of_rpc + value) in + r + ) t (Hashtbl.create 10) in + let of_match = hashtbl_to_flow_match map in + let _ = printf "Find rules matching %s\n%!" + (OP.Match.match_to_string of_match) in + let flows = get_stats of_match in + let res = + List.fold_right ( + fun a r -> + r @ [(Rpc.String (OP.Flow.string_of_flow_stat a))] + + ) flows [] in + return (Rpc.Enum res) + | (_, _) -> + let _ = printf "[ofswitch-config] invalid action %s\n%!" + (req.Rpc.name) in + return (Rpc.Enum [(Rpc.String "false")]) + in + let resp = + Jsonrpc.string_of_response (Rpc.success success) in + lwt _ = Lwt_io.write_line output resp in + lwt _ = Lwt_io.close output in + lwt _ = Lwt_io.close input in + return () + with exn -> + Lwt_log.log ~exn ~level:Lwt_log.Notice "[ofswitch_config] server error" + in - let resp = - Jsonrpc.string_of_response (Rpc.success (Rpc.Null)) in - lwt _ = Lwt_io.write_line output resp in - lwt _ = Lwt_io.close output in - lwt _ = Lwt_io.close input in - return () - in - let addr = Unix.ADDR_INET(Unix.inet_addr_any, 6634) in + let addr = Unix.ADDR_INET(Unix.inet_addr_any, 6634) in let _ = Lwt_io.establish_server addr (fun a -> Lwt.ignore_result (listen_inner mgr del_port a) ) in return () diff --git a/lib/ofswitch_config.mli b/lib/ofswitch_config.mli index 70e7be8..82970c6 100644 --- a/lib/ofswitch_config.mli +++ b/lib/ofswitch_config.mli @@ -16,11 +16,6 @@ type t -val add_port: t -> string -> bool Lwt.t -val del_port: t -> string -> bool Lwt.t -(* -val connect_client: Net.Manager.t -> - Net.Nettypes.ipv4_dst -> t Lwt.t - *) val connect_client: unit -> t Lwt.t -val listen_t: Net.Manager.t -> (string -> unit Lwt.t) -> int -> unit Lwt.t +val listen_t: Net.Manager.t -> (string -> unit Lwt.t) -> + (Ofpacket.Match.t -> Ofpacket.Flow.stats list) -> int -> unit Lwt.t diff --git a/lib/ofswitch_ctrl.ml b/lib/ofswitch_ctrl.ml index 164473a..be47a50 100644 --- a/lib/ofswitch_ctrl.ml +++ b/lib/ofswitch_ctrl.ml @@ -25,47 +25,77 @@ let check_cmd_args cmd count = failwith (sprintf "Insufficient args for command %s (required %d)" cmd count) +let flow_element = + ["in_port"; "dl_src"; "dl_dst"; "dl_vlan"; "dl_pcp"; "dl_type"; "nw_src"; + "nw_tos"; "nw_proto"; "tp_src"; "tp_dst"; ] + +let process_flow_description flow = + let fields = Re_str.split (Re_str.regexp ",") flow in + let rec process_flow_inner = function + | [] -> [] + | hd::tl -> + let name::value::_ = Re_str.split (Re_str.regexp "=") hd in + let _ = + if (not (List.mem name flow_element) ) then + failwith (sprintf "Invalid flow field %s" name) + in + [(name, (Rpc.String value))] @ (process_flow_inner tl) + in + process_flow_inner fields + + + let send_cmd (input, output) = try_lwt let _ = if ((Array.length Sys.argv) < 2) then failwith "No command defined" in + lwt resp = match (Sys.argv.(1)) with | "add-port" -> let _ = check_cmd_args Sys.argv.(1) 1 in let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String Sys.argv.(2))];}) in lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in - lwt _ = Lwt_io.read_line input in - return () + lwt resp = Lwt_io.read_line input in + let resp = Jsonrpc.response_of_string resp in + return (string_of_bool resp.Rpc.success) | "del-port" -> let _ = check_cmd_args Sys.argv.(1) 1 in let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String Sys.argv.(2))];}) in lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in - lwt _ = Lwt_io.read_line input in - return () - | _ -> - let _ = printf "Fail: unknown cmd: %s\n%!" Sys.argv.(1) in - return () + lwt resp = Lwt_io.read_line input in + let resp = Jsonrpc.response_of_string resp in + return (string_of_bool resp.Rpc.success) + | "dump-flows" -> begin + let _ = check_cmd_args Sys.argv.(1) 1 in + let fields = process_flow_description Sys.argv.(2) in + let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.Dict fields)];}) in + lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in + lwt resp = Lwt_io.read_line input in + let resp = Jsonrpc.response_of_string resp in + match resp.Rpc.contents with + | Rpc.Enum flows -> + return (List.fold_right + (fun a r -> sprintf "%s%s\n%!" r (Rpc.string_of_rpc a)) flows "") + | _ -> return "" + end + | _ -> + return (sprintf "Fail: unknown cmd: %s\n%!" Sys.argv.(1)) + in + let _ = printf "result:\n%s\n%!" resp in + return () with ex -> return (printf "Fail: %s" (Printexc.to_string ex)) lwt _ = try_lwt - (* lwt cl = connect_client () in *) -(* let sock = socket PF_INET SOCK_STREAM 0 in *) let dst = ADDR_INET( (Unix.inet_addr_of_string "127.0.0.1"), 6634) in lwt _ = Lwt_io.with_connection dst (send_cmd) in -(* lwt _ = Lwt_unix.connect sock dst in - let output = Lwt_io.of_fd ~mode:Lwt_io.output sock in - let = Lwt_io.of_fd ~mode:Lwt_io.output sock in - (* lwt _ = connect sock dst in *) - - lwt _ = send_cmd output in *) - return () + return () with e -> Printf.eprintf "Error: %s" (Printexc.to_string e); return () diff --git a/setup.ml b/setup.ml index ec28388..6963e2c 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: d51b1b7039a52449e8230e5f2444f1df) *) +(* DO NOT EDIT (digest: 5d3eb5b54441c2c780c5eb00da5fc0a4) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5698,7 +5698,8 @@ let setup_t = FindlibPackage ("mirage", None); FindlibPackage ("mirage-net", - Some (OASISVersion.VGreaterEqual "0.3.0")) + Some (OASISVersion.VGreaterEqual "0.3.0")); + FindlibPackage ("re.str", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -5769,7 +5770,11 @@ let setup_t = bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; bs_compiled_object = Native; - bs_build_depends = [InternalLibrary "openflow"]; + bs_build_depends = + [ + InternalLibrary "openflow"; + FindlibPackage ("re.str", None) + ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -5848,7 +5853,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "F¿\030##Ì»o¸\016R¢\027t\136Æ"; + oasis_digest = Some "²Ütc4VY4ApÂ^\000(±¡"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5856,6 +5861,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5860 "setup.ml" +# 5865 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 290ae08847083cf480202d2861cb74971968e443 Mon Sep 17 00:00:00 2001 From: crotsos Date: Fri, 28 Dec 2012 13:32:05 +0200 Subject: [PATCH 25/75] fixes --- _oasis | 2 +- _tags | 4 +- lib/ofpacket.ml | 65 +++++++------- lib/ofpacket.mli | 23 ++--- lib/ofswitch.ml | 187 +++++++++++++++++++++++----------------- lib/ofswitch.mli | 2 + lib/ofswitch_config.ml | 187 ++++++++++++++++++++++++++++++++-------- lib/ofswitch_config.mli | 8 +- lib/ofswitch_ctrl.ml | 32 ++++--- setup.ml | 6 +- switch/basic_switch.ml | 6 +- 11 files changed, 347 insertions(+), 175 deletions(-) diff --git a/_oasis b/_oasis index 87225b8..5c1cb0b 100644 --- a/_oasis +++ b/_oasis @@ -40,7 +40,7 @@ Document openflow XOCamlbuildPath: lib XOCamlbuildModules: Ofpacket, Ofcontroller, Ofswitch, Ofsocket, Ofswitch_config -Executable ofswitch_ctrl +Executable "ovs-vsctl" Path: lib MainIs: ofswitch_ctrl.ml Build$: flag(lwt) diff --git a/_tags b/_tags index de4c57e..6069146 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 2cf03af4e1bd1948e39b38ed0ec49a73) +# DO NOT EDIT (digest: c07db1f17ad31bd9de21d6ae41f3283a) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -21,7 +21,7 @@ "lib/ofswitch.cmx": for-pack(Openflow) "lib/ofsocket.cmx": for-pack(Openflow) "lib/ofswitch_standalone.cmx": for-pack(Openflow) -# Executable ofswitch_ctrl +# Executable ovs-vsctl "lib/ofswitch_ctrl.native": use_openflow "lib/ofswitch_ctrl.native": pkg_cstruct "lib/ofswitch_ctrl.native": pkg_cstruct.syntax diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 70e53b8..f45e8a7 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -322,7 +322,10 @@ module Port = struct | Max | In_port | Table | Normal | Flood | All | Controller | Local | No_port | Port of int16 - + + let is_num value = + try let _ = int_of_string value in true with _ -> false + let port_of_int = function | 0xff00 -> Max | 0xfff8 -> In_port @@ -356,7 +359,19 @@ module Port = struct | Local -> sp "LOCAL" | No_port -> sp "NO_PORT" | Port p -> sp "PORT(%d)" p - + and port_of_string = function + | "MAX" -> Some(Max) + | "IN_PORT" -> Some(In_port) + | "TABLE" -> Some(Table) + | "NORMAL" -> Some(Normal) + | "FLOOD" -> Some(Flood) + | "ALL" -> Some(All) + | "CONTROLLER" -> Some(Controller) + | "LOCAL" -> Some(Local) + | "NO_PORT" -> Some(No_port) + | num when (is_num num) -> Some(Port(int_of_string num)) + | _ -> None + type config = { port_down: bool; no_stp: bool; @@ -853,36 +868,36 @@ module Wildcards = struct mutable dl_vlan_pcp: bool; mutable nw_tos: bool; } - let in_port_match = + let in_port_match () = { in_port=false; dl_vlan=true; dl_src=true; dl_dst=true; dl_type=true; nw_proto=true; tp_src=true; tp_dst=true; nw_src=(char_of_int 32); nw_dst=(char_of_int 32); dl_vlan_pcp=true; nw_tos=true; } - let full_wildcard = + let full_wildcard () = { in_port=true; dl_vlan=true; dl_src=true; dl_dst=true; dl_type=true; nw_proto=true; tp_src=true; tp_dst=true; nw_src=(char_of_int 32); nw_dst=(char_of_int 32); dl_vlan_pcp=true; nw_tos=true; } - let exact_match = + let exact_match () = { in_port=false; dl_vlan=false; dl_src=false; dl_dst=false; dl_type=false; nw_proto=false; tp_src=false; tp_dst=false; nw_src=(char_of_int 0); nw_dst=(char_of_int 0); dl_vlan_pcp=false; nw_tos=false; } - let l2_match = + let l2_match () = { in_port=false;dl_vlan=false;dl_src=false;dl_dst=false; dl_type=false;nw_proto=true;tp_src=true;tp_dst=true; nw_src=(char_of_int 32);nw_dst=(char_of_int 32);dl_vlan_pcp=false; nw_tos=true } - let l3_match = + let l3_match () = { in_port=false;dl_vlan=false;dl_vlan_pcp=false;dl_src=false; dl_dst=false;dl_type=false;nw_proto=false;nw_tos=false; nw_src=(char_of_int 0);nw_dst=(char_of_int 0);tp_src=true;tp_dst=true; } - let arp_match = + let arp_match () = { in_port=false;dl_vlan=false;dl_vlan_pcp=false;dl_src=false; dl_dst=false;dl_type=false;nw_proto=false;nw_tos=true; nw_src=(char_of_int 32);nw_dst=(char_of_int 32);tp_src=true;tp_dst=true; @@ -949,7 +964,7 @@ module Match = struct } let wildcard () = - {wildcards=Wildcards.full_wildcard; in_port=Port.No_port; + {wildcards=(Wildcards.full_wildcard ()); in_port=Port.No_port; dl_src="\000\000\000\000\000\000"; dl_dst="\000\000\000\000\000\000"; dl_vlan=0; dl_vlan_pcp='\000'; dl_type=0; nw_src=0l; nw_dst=0l; @@ -1086,28 +1101,28 @@ module Match = struct match (nw_proto) with | 17 | 6 -> - {wildcards=Wildcards.exact_match; + {wildcards=(Wildcards.exact_match ()); in_port; dl_src; dl_dst; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0);dl_type; nw_src; nw_dst; nw_tos; nw_proto=(char_of_int nw_proto); tp_src=(get_tp_header_tp_src bits); tp_dst=(get_tp_header_tp_dst bits);} | 1 -> - { wildcards =Wildcards.exact_match; + { wildcards =(Wildcards.exact_match ()); in_port;dl_src; dl_dst; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0);dl_type; nw_src; nw_dst; nw_tos; nw_proto=(char_of_int nw_proto); tp_src=(get_icmphdr_typ bits); tp_dst=(get_icmphdr_code bits); } | _ -> - { wildcards =Wildcards.l3_match; + { wildcards =(Wildcards.l3_match ()); in_port;dl_src; dl_dst; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0);dl_type; nw_src; nw_dst; nw_tos; nw_proto=(char_of_int nw_proto); tp_src=0; tp_dst=0; } end | 0x0806 -> - {wildcards=Wildcards.arp_match; + {wildcards=(Wildcards.arp_match ()); in_port; dl_src; dl_dst; dl_type; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0); nw_src=(get_arphdr_nw_src bits); @@ -1115,7 +1130,7 @@ module Match = struct nw_proto=( char_of_int (get_arphdr_ar_op bits)); nw_tos=(char_of_int 0); tp_src=0; tp_dst=0} | _ -> - {wildcards=Wildcards.l2_match; + {wildcards=(Wildcards.l2_match ()); in_port; dl_src; dl_dst; dl_type; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0); nw_src=0l; nw_dst=0l; @@ -1732,16 +1747,16 @@ module Flow_mod = struct {send_flow_rem; overlap; emerg; } type t = { - of_match: Match.t; + mutable of_match: Match.t; cookie: uint64; command: command; - idle_timeout: uint16; - hard_timeout: uint16; - priority: uint16; + mutable idle_timeout: uint16; + mutable hard_timeout: uint16; + mutable priority: uint16; buffer_id: int32; out_port: Port.t; flags: flags; - actions: Flow.action list; + mutable actions: Flow.action list; } cstruct ofp_flow_mod { @@ -1759,16 +1774,8 @@ module Flow_mod = struct ?(idle_timeout = 60) ?(hard_timeout = 0) ?(buffer_id = -1 ) ?(out_port = Port.No_port) ?(flags ={send_flow_rem=false;emerg=false;overlap=false;}) actions () = - - let size = ref (sizeof_ofp_flow_mod + Header.sizeof_ofp_header + - Match.sizeof_ofp_match) in - (List.iter (fun a -> size:= !size + (Flow.len_of_action a)) actions); - { -(* of_header=(Header.(create FLOW_MOD !size (Int32.of_int 0))); *) - of_match=flow_match; cookie; command=command; - idle_timeout; hard_timeout; priority; - buffer_id=(Int32.of_int buffer_id); out_port;flags; actions; - } + {of_match=flow_match; cookie; command=command; idle_timeout; hard_timeout; + priority; buffer_id=(Int32.of_int buffer_id); out_port;flags; actions;} let marshal_flow_mod ?(xid=(Random.int32 Int32.max_int)) m bits = let len = Header.sizeof_ofp_header + Match.sizeof_ofp_match + diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index 142361c..ec25693 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -85,6 +85,7 @@ module Port : val port_of_int : int16 -> t val int_of_port : t -> int16 val string_of_port : t -> string + val port_of_string : string -> t option type config = { port_down : bool; no_stp : bool; @@ -209,12 +210,12 @@ module Wildcards : mutable dl_vlan_pcp : bool; mutable nw_tos : bool; } - val in_port_match : t - val full_wildcard : t - val exact_match : t - val l2_match : t - val l3_match : t - val arp_match : t + val in_port_match : unit -> t + val full_wildcard : unit -> t + val exact_match : unit -> t + val l2_match : unit -> t + val l3_match : unit -> t + val arp_match : unit -> t val wildcard_to_string : t -> string end module Match : @@ -337,16 +338,16 @@ module Flow_mod : val string_of_command : command -> string type flags = { send_flow_rem : bool; emerg : bool; overlap : bool; } type t = { - of_match : Match.t; + mutable of_match : Match.t; cookie : uint64; command : command; - idle_timeout : uint16; - hard_timeout : uint16; - priority : uint16; + mutable idle_timeout : uint16; + mutable hard_timeout : uint16; + mutable priority : uint16; buffer_id : int32; out_port : Port.t; flags : flags; - actions : Flow.action list; (* array; *) + mutable actions : Flow.action list; (* array; *) } val flow_mod_to_string: t -> string val create : diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 1ff1d98..dbdb1b3 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -125,7 +125,7 @@ module Table = struct { tid = 0_L; entries = (Hashtbl.create 10000); cache = (Hashtbl.create 10000); stats = OP.Stats.( {table_id=(OP.Stats.table_id_of_int 1); name="main_tbl"; - wildcards=OP.Wildcards.exact_match; max_entries=1024l; active_count=0l; + wildcards=(OP.Wildcards.exact_match ()); max_entries=1024l; active_count=0l; lookup_count=0L; matched_count=0L});} (* TODO fix flow_mod flag support. overlap is not considered *) @@ -331,7 +331,64 @@ module Switch = struct port.counter.OP.Port.rx_bytes <- (Int64.add port.counter.OP.Port.rx_bytes pkt_len) - let forward_frame st in_port frame pkt_size = function + cstruct dl_header { + uint8_t dl_dst[6]; + uint8_t dl_src[6]; + uint16_t dl_type + } as big_endian + + cstruct arphdr { + uint16_t ar_hrd; + uint16_t ar_pro; + uint8_t ar_hln; + uint8_t ar_pln; + uint16_t ar_op; + uint8_t ar_sha[6]; + uint32_t nw_src; + uint8_t ar_tha[6]; + uint32_t nw_dst + } as big_endian + + cstruct nw_header { + uint8_t hlen_version; + uint8_t nw_tos; + uint16_t total_len; + uint8_t pad[5]; + uint8_t nw_proto; + uint16_t csum; + uint32_t nw_src; + uint32_t nw_dst + } as big_endian + + cstruct tp_header { + uint16_t tp_src; + uint16_t tp_dst + } as big_endian + + cstruct icmphdr { + uint8_t typ; + uint8_t code; + uint16_t checksum + } as big_endian + + + let forward_frame st in_port frame pkt_size checksum port = + let _ = + if ((checksum) && ((get_dl_header_dl_type frame) = 0x800)) then + let ip_data = Cstruct.shift frame sizeof_dl_header in + let _ = set_nw_header_csum ip_data 0 in + let csm = Net.Checksum.ones_complement ip_data sizeof_nw_header in + let _ = set_nw_header_csum ip_data csm in + let _ = + match (get_nw_header_nw_proto ip_data) with + | 6 (* TCP *) -> () + | 17 (* UDP *) -> () + () + | _ -> () + in + () + in + match port with | OP.Port.Port(port) -> if Hashtbl.mem st.int_to_port port then( (* let _ = printf "sending to port %d\n%!" port in *) @@ -376,114 +433,75 @@ module Switch = struct * stack? *) | _ -> return (Printf.printf "Not implemented output port\n") - cstruct dl_header { - uint8_t dl_dst[6]; - uint8_t dl_src[6]; - uint16_t dl_type - } as big_endian - - cstruct arphdr { - uint16_t ar_hrd; - uint16_t ar_pro; - uint8_t ar_hln; - uint8_t ar_pln; - uint16_t ar_op; - uint8_t ar_sha[6]; - uint32_t nw_src; - uint8_t ar_tha[6]; - uint32_t nw_dst - } as big_endian - - cstruct nw_header { - uint8_t hlen_version; - uint8_t nw_tos; - uint16_t total_len; - uint8_t pad[5]; - uint8_t nw_proto; - uint16_t csum; - uint32_t nw_src; - uint32_t nw_dst - } as big_endian - - cstruct tp_header { - uint16_t tp_src; - uint16_t tp_dst - } as big_endian - - cstruct icmphdr { - uint8_t typ; - uint8_t code; - uint16_t checksum - } as big_endian - - (* TODO: Minor util function which I put it here as I have the - * header laready defined. Maybe need to make a new module - * and include this utils. *) - let size_of_raw_packet bits = - let dl_type = get_dl_header_dl_type bits in - let bits = Cstruct.shift bits sizeof_dl_header in - match (dl_type) with - | 0x0800 -> - Some( sizeof_dl_header + (get_nw_header_total_len bits)) - | 0x0806 -> - Some(sizeof_dl_header + sizeof_arphdr) - | _ -> - let _ = ep "dropping packet of ethtype %x\n%!" dl_type in -(* let _ = Cstruct.hexdump bits in *) - None - (* Assumwe that action are valid. I will not get a flow that sets an ip * address unless it defines that the ethType is ip. Need to enforce * these rule in the parsing process of the flow_mod packets *) let apply_of_actions st in_port bits actions = - let apply_of_actions_inner st in_port bits = function + let apply_of_actions_inner st in_port bits checksum action = + try_lwt + match action with | OP.Flow.Output (port, pkt_size) -> (* Make a packet copy in case the buffer is modified and multiple * outputs are defined? *) - forward_frame st in_port bits pkt_size port + lwt _ = forward_frame st in_port bits pkt_size checksum port in + return false | OP.Flow.Set_dl_src(eaddr) -> - return (set_dl_header_dl_src eaddr 6 bits) + let _ = set_dl_header_dl_src eaddr 0 bits in + return checksum | OP.Flow.Set_dl_dst(eaddr) -> - return (set_dl_header_dl_dst eaddr 6 bits) + let _ = set_dl_header_dl_dst eaddr 0 bits in + return checksum (* TODO: Add for this actions to check when inserted if * the flow is an ip flow *) | OP.Flow.Set_nw_tos(tos) -> let ip_data = Cstruct.shift bits sizeof_dl_header in - return (set_nw_header_nw_tos ip_data (int_of_char tos)) + let _ = set_nw_header_nw_tos ip_data (int_of_char tos) in + return true (* TODO: wHAT ABOUT ARP? * *) | OP.Flow.Set_nw_src(ip) -> let ip_data = Cstruct.shift bits sizeof_dl_header in - return (set_nw_header_nw_src ip_data ip) + let _ = set_nw_header_nw_src ip_data ip in + return true | OP.Flow.Set_nw_dst(ip) -> let ip_data = Cstruct.shift bits sizeof_dl_header in - return (set_nw_header_nw_dst ip_data ip) + let _ = set_nw_header_nw_dst ip_data ip in + return true | OP.Flow.Set_tp_src(port) -> let ip_data = Cstruct.shift bits sizeof_dl_header in let len = (get_nw_header_hlen_version bits) land 0xf in let tp_data = Cstruct.shift ip_data (len*4) in - return (set_tp_header_tp_src tp_data port) + let _ = set_tp_header_tp_src tp_data port in + return true | OP.Flow.Set_tp_dst(port) -> let ip_data = Cstruct.shift bits sizeof_dl_header in let len = (get_nw_header_hlen_version bits) land 0xf in let tp_data = Cstruct.shift ip_data (len*4) in - return (set_tp_header_tp_dst tp_data port ) + let _ = set_tp_header_tp_dst tp_data port in + return true | OP.Flow.Enqueue(_, _) | OP.Flow.Set_vlan_pcp _ | OP.Flow.Set_vlan_vid _ | OP.Flow.VENDOR_ACT | OP.Flow.STRIP_VLAN -> (* VLAN manupulation actions *) - return (pr "Unsupported action STRIP_VLAN\n") + let _ = pr "Unsupported action STRIP_VLAN\n" in + return checksum + with exn -> + let _ = eprintf "apply of action failed (packet size %d) %s %s\n%!" + (Cstruct.len bits) + (OP.Flow.string_of_action action) (Printexc.to_string exn ) in + return checksum in - let rec apply_of_actions_rec st in_port actions = function - | [] -> return () + let rec apply_of_actions_rec st in_port bits checksum = function + | [] -> return false | head :: actions -> - let _ = apply_of_actions_inner st in_port bits head in - apply_of_actions_rec st in_port bits actions + lwt checksum = apply_of_actions_inner st in_port bits checksum head in + apply_of_actions_rec st in_port bits checksum actions in - apply_of_actions_rec st in_port bits actions - + lwt _ = apply_of_actions_rec st in_port bits false actions in + return () + let lookup_flow st of_match = (* Check first the match table cache * NOTE an exact match flow will be found on this step and thus @@ -916,11 +934,11 @@ let del_port mgr sw name = let _ = Hashtbl.remove sw.Switch.int_to_port port.Switch.port_id in let _ = Hashtbl.remove sw.Switch.dev_to_port port.Switch.ethif in let h,p = OP.Port.create_port_status OP.Port.DEL port.Switch.phy in - let of_match = OP.Match.create_flow_match OP.Wildcards.full_wildcard () in + let of_match = OP.Match.create_flow_match (OP.Wildcards.full_wildcard ()) () in lwt _ = Table.del_flow sw.Switch.table of_match (OP.Port.port_of_int port.Switch.port_id) sw.Switch.controller in - let of_match = OP.Match.create_flow_match OP.Wildcards.in_port_match + let of_match = OP.Match.create_flow_match (OP.Wildcards.in_port_match ()) ~in_port:(port.Switch.port_id) () in lwt _ = Table.del_flow sw.Switch.table of_match OP.Port.No_port sw.Switch.controller in @@ -961,7 +979,10 @@ let add_port_local mgr sw ethif = let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw port) in return () - +let add_flow st fm = Table.add_flow st st.Switch.table fm +let del_flow st m = + Table.del_flow st.Switch.table m OP.Port.No_port st.Switch.controller + let create_switch () = let (packet_queue, push_packet) = Lwt_stream.create () in Switch.( @@ -973,23 +994,27 @@ let create_switch () = let listen st mgr loc = Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> - (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) 6634) + (Ofswitch_config.listen_t mgr + (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) let connect st mgr loc = Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> - (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) 6634) + (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) + (add_flow st) (del_flow st) 6634) let local_connect st mgr input output = let conn = Ofsocket.init_local_conn_state input output in let _ = st.Switch.controller <- (Some conn) in let t, _ = Lwt.task () in (control_channel_run st conn t) <&> - (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) 6634) + (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) + (add_flow st) (del_flow st) 6634) let lwt_connect st ?(standalone=true) mgr loc = let of_ctrl = Ofswitch_standalone.init_controller () in - let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) 6634) in + let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (del_port mgr st) + (get_flow_stats st) (add_flow st) (del_flow st) 6634) in (* let _ = Lwt_unix.setsockopt fd Unix.SO_REUSEADDR true in let _ = Lwt_unix.bind fd (Unix.ADDR_INET(Unix.inet_addr_any, 6633)) in let _ = Lwt_unix.listen fd 1 in *) diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index 152d3a3..aa03d3f 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -20,6 +20,8 @@ type t val add_port : Net.Manager.t -> ?use_mac:bool -> t -> string -> unit Lwt.t val del_port : Net.Manager.t -> t -> string -> unit Lwt.t val add_port_local : Net.Manager.t -> t -> Net.Manager.id -> unit Lwt.t +val add_flow : t -> Ofpacket.Flow_mod.t -> unit Lwt.t +val del_flow : t -> Ofpacket.Match.t -> unit Lwt.t val get_flow_stats : t -> Ofpacket.Match.t -> Ofpacket.Flow.stats list val create_switch : unit -> t val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index a2f9502..b454fa3 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -35,19 +35,102 @@ let connect_client () = with ex -> failwith (sprintf "ofswitch_config client failed: %s" (Printexc.to_string ex)) + +let parse_actions actions = + let actions = Re_str.split (Re_str.regexp "/") actions in + let split_action = Re_str.regexp ":" in + List.fold_right ( + fun action actions -> + try + match (Re_str.split split_action action) with + | "output"::port::_ -> begin + match (OP.Port.port_of_string port) with + | Some port -> + actions @ [(OP.Flow.Output(port, 2000))] + | None -> + let _ = printf "[ofswitch-config] Invalid port %s\n%!" port in + actions + end + | "set_vlan_vid"::vif::_ -> + actions @ [(OP.Flow.Set_vlan_vid(int_of_string vif))] + | "set_vlan_pcp"::pcp::_ -> + actions @ [(OP.Flow.Set_vlan_pcp(int_of_string pcp))] + | "set_dl_src"::addr::_ -> begin + match (Net.Nettypes.ethernet_mac_of_string addr) with + | None -> + let _ = printf "[ofswitch-config] Invalid mac %s\n%!" action in + actions + | Some addr -> + actions @ + [(OP.Flow.Set_dl_src(Net.Nettypes.ethernet_mac_to_bytes addr))] + end + | "set_dl_dst"::addr::_ -> begin + match (Net.Nettypes.ethernet_mac_of_string addr) with + | None -> + let _ = printf "[ofswitch-config] Invalid mac %s\n%!" action in + actions + | Some addr -> + actions @ + [(OP.Flow.Set_dl_dst(Net.Nettypes.ethernet_mac_to_bytes addr))] + end + | "set_nw_src"::addr::_ -> begin + match (Net.Nettypes.ipv4_addr_of_string addr) with + | None -> + let _ = printf "[ofswitch-config] invalid ip %s\n%!" addr in + actions + | Some ip -> + actions @ + [(OP.Flow.Set_nw_src(Net.Nettypes.ipv4_addr_to_uint32 ip))] + end + | "set_nw_dst"::addr::_ -> begin + match (Net.Nettypes.ipv4_addr_of_string addr) with + | None -> + let _ = printf "[ofswitch-config] invalid ip %s\n%!" addr in + actions + | Some ip -> actions @ + [(OP.Flow.Set_nw_dst(Net.Nettypes.ipv4_addr_to_uint32 ip))] + end + | "set_nw_tos"::tos::_ -> + actions @ [(OP.Flow.Set_nw_tos(char_of_int (int_of_string tos)))] + | "set_tp_src"::port::_ -> + actions @ [(OP.Flow.Set_tp_src(int_of_string port))] + | "set_tp_dst"::port::_ -> + actions @ [(OP.Flow.Set_tp_dst(int_of_string port))] + | _ -> + let _ = eprintf "[ofswitch-config] invalid action %s" action in + actions + with exn -> + let _ = printf "[ofswitch-config] error parsing action %s\n%!" action in + actions + ) actions [] + -let hashtbl_to_flow_match map = +let hashtbl_to_flow_match t = let of_match = OP.Match.wildcard () in + let map = + List.fold_right ( + fun (name, value) r -> + let _ = Hashtbl.add r name (Rpc.string_of_rpc value) in + let _ = printf "Adding %s = %s\n%!" name + (Rpc.string_of_rpc value) in + r + ) t (Hashtbl.create 10) in let _ = Hashtbl.iter ( fun name value -> match name with - | "in_port" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.in_port <- false in - let _ = of_match.OP.Match.in_port <- OP.Port.port_of_int - (int_of_string value) in - () - | "dl_vlan" -> + | "in_port" -> begin + match (OP.Port.port_of_string value) with + | Some port -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.in_port <- + false in + let _ = of_match.OP.Match.in_port <- port in + () + | None -> + let _ = printf "[ofswitch-config] Invalid port %s\n%!" value in + () + end + | "dl_vlan" -> let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan <- false in let _ = of_match.OP.Match.dl_vlan <- int_of_string value in () @@ -75,10 +158,9 @@ let hashtbl_to_flow_match map = let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_type <- false in let _ = of_match.OP.Match.dl_type <- int_of_string value in () - | "nw_src" -> - let fields = - match (Re_str.split (Re_str.regexp "\/") value) with - | ip::mask::_ -> + | "nw_src" -> begin + match (Re_str.split (Re_str.regexp "/") value) with + | ip::mask::_ -> begin match (Net.Nettypes.ipv4_addr_of_string ip) with | None -> printf "Invalid ip definition" | Some ip -> @@ -87,13 +169,12 @@ let hashtbl_to_flow_match map = let _ = of_match.OP.Match.nw_src <- Net.Nettypes.ipv4_addr_to_uint32 ip in () + end | _ -> printf "Invalid ip definition" - in - () - | "nw_dst" -> - let fields = - match (Re_str.split (Re_str.regexp "\/") value) with - | ip::mask::_ -> + end + | "nw_dst" -> begin + match (Re_str.split (Re_str.regexp "/") value) with + | ip::mask::_ -> begin match (Net.Nettypes.ipv4_addr_of_string ip) with | None -> printf "Invalid ip definition" | Some ip -> @@ -102,11 +183,11 @@ let hashtbl_to_flow_match map = let _ = of_match.OP.Match.nw_dst <- Net.Nettypes.ipv4_addr_to_uint32 ip in () + end | _ -> printf "Invalid ip definition" - in - () + end | "nw_tos" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan <- false in + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_tos <- false in let _ = of_match.OP.Match.nw_tos <- char_of_int (int_of_string value) in () @@ -130,7 +211,7 @@ let hashtbl_to_flow_match map = of_match -let listen_t mgr del_port get_stats port = +let listen_t mgr del_port get_stats add_flow del_flow port = let listen_inner mgr st (input, output) = try_lwt lwt req = Lwt_io.read_line input in @@ -145,16 +226,7 @@ let listen_t mgr del_port get_stats port = lwt _ = Net.Manager.detach mgr dev in return (Rpc.Enum [(Rpc.String "true")]) | ("dump-flows", (Rpc.Dict t)::_) -> - let _ = printf "dumpflows for %s\n%!" (Rpc.string_of_call req) in - let map = - List.fold_right ( - fun (name, value) r -> - let _ = Hashtbl.add r name (Rpc.string_of_rpc value) in - let _ = printf "Adding %s = %s\n%!" name (Rpc.string_of_rpc - value) in - r - ) t (Hashtbl.create 10) in - let of_match = hashtbl_to_flow_match map in + let of_match = hashtbl_to_flow_match t in let _ = printf "Find rules matching %s\n%!" (OP.Match.match_to_string of_match) in let flows = get_stats of_match in @@ -162,10 +234,45 @@ let listen_t mgr del_port get_stats port = List.fold_right ( fun a r -> r @ [(Rpc.String (OP.Flow.string_of_flow_stat a))] - ) flows [] in return (Rpc.Enum res) - | (_, _) -> + | ("add-flow", (Rpc.Dict t)::_) -> + let _ = printf "adding flow %s\n%!" (Rpc.string_of_call req) in + let fm = OP.Flow_mod.create (OP.Match.wildcard () ) + 0L OP.Flow_mod.ADD [] () in + let map = + List.fold_right ( + fun (name, value) r -> + match name with + | "actions" -> + let _ = fm.OP.Flow_mod.actions <- + (parse_actions (Rpc.string_of_rpc value) ) in + r + | "idle_timeout" -> + let _ = + fm.OP.Flow_mod.idle_timeout <- (Rpc.int_of_rpc value) in + r + | "hard_timeout" -> + let _ = + fm.OP.Flow_mod.hard_timeout <- (Rpc.int_of_rpc value) in + r + | "priority" -> + let _ = + fm.OP.Flow_mod.priority <- (Rpc.int_of_rpc value) in + r + | _ -> r @ [(name, value)] + ) t [] in + let _ = fm.OP.Flow_mod.of_match <- hashtbl_to_flow_match map in + let _ = printf "Add flow %s\n%!" (OP.Flow_mod.flow_mod_to_string fm) in + lwt _ = add_flow fm in + return (Rpc.Enum [(Rpc.String "true")] ) + | ("del-flow", (Rpc.Dict t)::_) -> + let of_match = hashtbl_to_flow_match t in + let _ = printf "Find rules matching %s\n%!" + (OP.Match.match_to_string of_match) in + lwt _ = del_flow of_match in + return (Rpc.Enum [(Rpc.String "true")] ) + | (_, _) -> let _ = printf "[ofswitch-config] invalid action %s\n%!" (req.Rpc.name) in return (Rpc.Enum [(Rpc.String "false")]) @@ -176,8 +283,18 @@ let listen_t mgr del_port get_stats port = lwt _ = Lwt_io.close output in lwt _ = Lwt_io.close input in return () - with exn -> - Lwt_log.log ~exn ~level:Lwt_log.Notice "[ofswitch_config] server error" + with + | End_of_file -> return () + | exn -> + lwt _ = Lwt_log.log ~exn ~level:Lwt_log.Notice + "[ofswitch_config] server error" in +(* let resp = Jsonrpc.string_of_response + (Rpc.failure (Rpc.Enum [(Rpc.String "false")])) in + lwt _ = Lwt_io.write_line output resp in + lwt _ = Lwt_io.close output in + lwt _ = Lwt_io.close input in *) + return () + in let addr = Unix.ADDR_INET(Unix.inet_addr_any, 6634) in diff --git a/lib/ofswitch_config.mli b/lib/ofswitch_config.mli index 82970c6..63d8bfe 100644 --- a/lib/ofswitch_config.mli +++ b/lib/ofswitch_config.mli @@ -17,5 +17,9 @@ type t val connect_client: unit -> t Lwt.t -val listen_t: Net.Manager.t -> (string -> unit Lwt.t) -> - (Ofpacket.Match.t -> Ofpacket.Flow.stats list) -> int -> unit Lwt.t +val listen_t: Net.Manager.t -> + (string -> unit Lwt.t) -> + (Ofpacket.Match.t -> Ofpacket.Flow.stats list) -> + (Ofpacket.Flow_mod.t -> unit Lwt.t) -> + (Ofpacket.Match.t -> unit Lwt.t) -> + int -> unit Lwt.t diff --git a/lib/ofswitch_ctrl.ml b/lib/ofswitch_ctrl.ml index be47a50..15a1b46 100644 --- a/lib/ofswitch_ctrl.ml +++ b/lib/ofswitch_ctrl.ml @@ -26,8 +26,10 @@ let check_cmd_args cmd count = cmd count) let flow_element = - ["in_port"; "dl_src"; "dl_dst"; "dl_vlan"; "dl_pcp"; "dl_type"; "nw_src"; - "nw_tos"; "nw_proto"; "tp_src"; "tp_dst"; ] + ["in_port"; "dl_src"; "dl_dst"; "dl_vlan"; "dl_pcp"; "dl_type"; + "nw_src";"nw_dst"; + "nw_tos"; "nw_proto"; "tp_src"; "tp_dst"; "actions";"priority"; + "idle_timeout"; "hard_timeout"; ] let process_flow_description flow = let fields = Re_str.split (Re_str.regexp ",") flow in @@ -54,34 +56,44 @@ let send_cmd (input, output) = lwt resp = match (Sys.argv.(1)) with | "add-port" -> - let _ = check_cmd_args Sys.argv.(1) 1 in + let _ = check_cmd_args Sys.argv.(1) 2 in let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String - Sys.argv.(2))];}) in + Sys.argv.(3))];}) in lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in lwt resp = Lwt_io.read_line input in let resp = Jsonrpc.response_of_string resp in return (string_of_bool resp.Rpc.success) | "del-port" -> - let _ = check_cmd_args Sys.argv.(1) 1 in + let _ = check_cmd_args Sys.argv.(1) 2 in let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String - Sys.argv.(2))];}) in + Sys.argv.(3))];}) in lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in lwt resp = Lwt_io.read_line input in let resp = Jsonrpc.response_of_string resp in return (string_of_bool resp.Rpc.success) | "dump-flows" -> begin - let _ = check_cmd_args Sys.argv.(1) 1 in - let fields = process_flow_description Sys.argv.(2) in + let _ = check_cmd_args Sys.argv.(1) 2 in + let fields = process_flow_description Sys.argv.(3) in let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.Dict fields)];}) in lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in lwt resp = Lwt_io.read_line input in let resp = Jsonrpc.response_of_string resp in match resp.Rpc.contents with | Rpc.Enum flows -> - return (List.fold_right - (fun a r -> sprintf "%s%s\n%!" r (Rpc.string_of_rpc a)) flows "") + return + (List.fold_right + (fun a r -> sprintf "%s%s\n%!" r (Rpc.string_of_rpc a)) flows "") | _ -> return "" end + | "add-flow" -> begin + let _ = check_cmd_args Sys.argv.(1) 2 in + let fields = process_flow_description Sys.argv.(3) in + let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.Dict fields)];}) in + lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in + lwt resp = Lwt_io.read_line input in + let resp = Jsonrpc.response_of_string resp in + return (string_of_bool resp.Rpc.success) + end | _ -> return (sprintf "Fail: unknown cmd: %s\n%!" Sys.argv.(1)) in diff --git a/setup.ml b/setup.ml index 6963e2c..f303423 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 5d3eb5b54441c2c780c5eb00da5fc0a4) *) +(* DO NOT EDIT (digest: 77807950f77d37deb0eec45df427174e) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5757,7 +5757,7 @@ let setup_t = }); Executable ({ - cs_name = "ofswitch_ctrl"; + cs_name = "ovs-vsctl"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -5853,7 +5853,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "²Ütc4VY4ApÂ^\000(±¡"; + oasis_digest = Some "¾$R/û\158\b&=Êâ\030òÔ£ü"; oasis_exec = None; oasis_setup_args = []; setup_update = false; diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index a449ed8..1544a55 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -41,6 +41,7 @@ let print_time () = let switch_run () = let sw = create_switch () in + let use_mac = ref true in try_lwt Manager.create ~devs:1 (* ~attached:(["en0"]) *) (fun mgr interface id -> @@ -53,7 +54,10 @@ let switch_run () = lwt _ = lwt_connect sw mgr (dst_ip, 6633) in let _ = printf "connect returned...\n%!" in return () - | _ -> add_port mgr ~use_mac:true sw id + | _ -> + lwt _ = add_port mgr ~use_mac:(!use_mac) sw id in + let _ = use_mac := false in + return () ) with e -> Printf.eprintf "Error: %s" (Printexc.to_string e); From 2433b5632fce093d37ae8b9fd47c17ed2a0f0e03 Mon Sep 17 00:00:00 2001 From: crotsos Date: Fri, 28 Dec 2012 17:39:28 +0200 Subject: [PATCH 26/75] use new cstruct API --- controller/learning_switch.ml | 7 +-- lib/ofcontroller.ml | 2 +- lib/ofcontroller.mli | 4 +- lib/ofpacket.ml | 38 +++++++------- lib/ofpacket.mli | 74 +++++++++++++-------------- lib/ofsocket.ml | 46 ++++++++--------- lib/ofsocket.mli | 2 +- lib/ofswitch.ml | 45 +++++++---------- myocamlbuild.ml | 14 +++--- setup.ml | 94 +++++++++++++++++------------------ 10 files changed, 160 insertions(+), 166 deletions(-) diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index b5d63ae..f5ae290 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -95,7 +95,7 @@ let packet_in_cb controller dpid evt = (OP.Packet_out.create ~buffer_id:buffer_id ~actions:[ OP.(Flow.Output(Port.All , 2000))] - ~data:data ~in_port:in_port () )) (OS.Io_page.get ()) in + ~data:data ~in_port:in_port () )) (Cstruct.of_bigarray (OS.Io_page.get ())) in OC.send_of_data controller dpid bs ) else ( let out_port = (Hashtbl.find switch_data.mac_cache ix) in @@ -109,7 +109,8 @@ let packet_in_cb controller dpid evt = (OP.Packet_out.create ~buffer_id:buffer_id ~actions:[ OP.(Flow.Output(out_port, 2000))] - ~data:data ~in_port:in_port () )) (OS.Io_page.get ()) in + ~data:data ~in_port:in_port () )) + (Cstruct.of_bigarray (OS.Io_page.get ())) in OC.send_of_data controller dpid bs else return () @@ -120,7 +121,7 @@ let packet_in_cb controller dpid evt = (OP.Flow_mod.create m 0_L OP.Flow_mod.ADD ~hard_timeout:0 ~idle_timeout:0 ~buffer_id:(Int32.to_int buffer_id) ~flags [OP.Flow.Output(out_port, 2000)] ())) - (OS.Io_page.get ()) in + (Cstruct.of_bigarray (OS.Io_page.get ())) in OC.send_of_data controller dpid pkt ) diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 1dc9190..812db68 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -40,7 +40,7 @@ module Event = struct type e = | Datapath_join of OP.datapath_id * OP.Port.phy list | Datapath_leave of OP.datapath_id - | Packet_in of OP.Port.t * int32 * Cstruct.buf * OP.datapath_id + | Packet_in of OP.Port.t * int32 * Cstruct.t * OP.datapath_id | Flow_removed of OP.Match.t * OP.Flow_removed.reason * int32 * int32 * int64 * int64 * OP.datapath_id diff --git a/lib/ofcontroller.mli b/lib/ofcontroller.mli index da77d31..abc7ba2 100644 --- a/lib/ofcontroller.mli +++ b/lib/ofcontroller.mli @@ -35,7 +35,7 @@ module Event : sig type e = Datapath_join of datapath_id * Ofpacket.Port.phy list | Datapath_leave of datapath_id - | Packet_in of Port.t * int32 * Cstruct.buf * datapath_id + | Packet_in of Port.t * int32 * Cstruct.t * datapath_id | Flow_removed of Match.t * Flow_removed.reason * int32 * int32 * int64 * int64 * datapath_id | Flow_stats_reply of int32 * bool * Flow.stats list * datapath_id @@ -49,7 +49,7 @@ module Event : sig type t val register_cb : t -> Event.t -> (t -> Ofpacket.datapath_id -> Event.e -> unit Lwt.t) -> unit -val send_of_data : t -> Ofpacket.datapath_id -> Cstruct.buf -> unit Lwt.t +val send_of_data : t -> Ofpacket.datapath_id -> Cstruct.t -> unit Lwt.t val send_data : t -> Ofpacket.datapath_id -> Ofpacket.t -> unit Lwt.t val terminate : t -> unit val mem_dbg : string -> unit diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index f45e8a7..fee650d 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -22,8 +22,8 @@ let sp = Printf.sprintf let pp = Printf.printf let ep = Printf.eprintf -exception Unparsable of string * Cstruct.buf -exception Unparsed of string * Cstruct.buf +exception Unparsable of string * Cstruct.t +exception Unparsed of string * Cstruct.t exception Unsupported of string let resolve t = Lwt.on_success t (fun _ -> ()) @@ -604,7 +604,7 @@ module Port = struct rx_over_err=(get_ofp_port_stats_rx_over_err bits); rx_crc_err=(get_ofp_port_stats_rx_crc_err bits); collisions=(get_ofp_port_stats_collisions bits);}] in - let _ = Cstruct.shift_left bits sizeof_ofp_port_stats in + let _ = Cstruct.shift bits sizeof_ofp_port_stats in record @ (parse_port_stats_reply (bits) ) let rec string_of_port_stats_reply ports = @@ -1585,7 +1585,7 @@ module Packet_out = struct buffer_id: uint32; in_port: Port.t; actions: Flow.action list; - data : Cstruct.buf; + data : Cstruct.t; } cstruct ofp_packet_out { @@ -1625,7 +1625,7 @@ module Packet_out = struct let _ = set_ofp_packet_out_actions_len bits (Flow.actions_len m.actions) in let bits = Cstruct.shift bits sizeof_ofp_packet_out in let (act_len, bits) = marshal_and_shift (Flow.marshal_actions m.actions) bits in - let _ = Cstruct.blit_buffer m.data 0 bits 0 (Cstruct.len m.data) in + let _ = Cstruct.blit m.data 0 bits 0 (Cstruct.len m.data) in size end @@ -1647,7 +1647,7 @@ module Packet_in = struct buffer_id: uint32; in_port: Port.t; reason: reason; - data: Cstruct.buf; + data: Cstruct.t; } cstruct ofp_packet_in { @@ -1697,7 +1697,7 @@ module Packet_in = struct let _ = set_ofp_packet_in_total_len bits data_len in let _ = set_ofp_packet_in_in_port bits (Port.int_of_port t.in_port) in let _ = set_ofp_packet_in_reason bits (int_of_reason t.reason) in - let _ = Cstruct.blit_buffer t.data 0 bits sizeof_ofp_packet_in + let _ = Cstruct.blit t.data 0 bits sizeof_ofp_packet_in data_len in ofp_len + sizeof_ofp_packet_in + data_len end @@ -2222,7 +2222,7 @@ module Stats = struct | l -> let table_id = table_id_of_int (get_ofp_table_stats_table_id bits) in let name = get_ofp_table_stats_name bits in - let name = Cstruct.copy_buffer name 0 (Cstruct.len name) in + let name = Cstruct.copy name 0 (Cstruct.len name) in let wildcards = Wildcards.parse_wildcards (get_ofp_table_stats_wildcards bits) in let max_entries = get_ofp_table_stats_max_entries bits in @@ -2290,12 +2290,12 @@ module Stats = struct match typ with | DESC -> - let imfr_desc = Cstruct.copy_buffer (get_ofp_desc_stats_mfr_desc bits) 0 256 in - let hw_desc= Cstruct.copy_buffer (get_ofp_desc_stats_hw_desc bits) 0 256 in - let sw_desc = Cstruct.copy_buffer (get_ofp_desc_stats_sw_desc bits) 0 256 in - let serial_num = Cstruct.copy_buffer (get_ofp_desc_stats_serial_num bits) + let imfr_desc = Cstruct.copy (get_ofp_desc_stats_mfr_desc bits) 0 256 in + let hw_desc= Cstruct.copy (get_ofp_desc_stats_hw_desc bits) 0 256 in + let sw_desc = Cstruct.copy (get_ofp_desc_stats_sw_desc bits) 0 256 in + let serial_num = Cstruct.copy (get_ofp_desc_stats_serial_num bits) 0 32 in - let dp_desc = Cstruct.copy_buffer (get_ofp_desc_stats_dp_desc bits) 0 256 + let dp_desc = Cstruct.copy (get_ofp_desc_stats_dp_desc bits) 0 256 in Desc_resp(resp, {imfr_desc; hw_desc; sw_desc; serial_num; dp_desc;}) @@ -2559,7 +2559,7 @@ let marshal_error errornum data xid bits = let _ = set_ofp_error_msg_code bits (Int32.to_int (Int32.logand errornum 0xffff0000l)) in let bits = Cstruct.shift bits sizeof_ofp_error_msg in - let _ = Cstruct.blit_buffer data 0 bits 0 (Cstruct.len data) in + let _ = Cstruct.blit data 0 bits 0 (Cstruct.len data) in (Header.get_len + sizeof_ofp_error_msg + req_len) let build_features_req xid bits = @@ -2574,10 +2574,10 @@ let build_echo_resp h bits = type t = | Hello of Header.h - | Error of Header.h * error_code * Cstruct.buf + | Error of Header.h * error_code * Cstruct.t | Echo_req of Header.h | Echo_resp of Header.h - | Vendor of Header.h * vendor * Cstruct.buf + | Vendor of Header.h * vendor * Cstruct.t | Features_req of Header.h | Features_resp of Header.h * Switch.features @@ -2589,7 +2589,7 @@ type t = | Flow_removed of Header.h * Flow_removed.t | Port_status of Header.h * Port.status - | Packet_out of Header.h * Packet_out.t (* Cstruct.buf *) + | Packet_out of Header.h * Packet_out.t (* Cstruct.t *) | Flow_mod of Header.h * Flow_mod.t | Port_mod of Header.h * Port_mod.t @@ -2684,9 +2684,9 @@ let marshal msg = | _ -> failwith "Unsupported message" in (* - | Vendor of Header.h * vendor * Cstruct.buf + | Vendor of Header.h * vendor * Cstruct.t | Port_mod of Header.h * Port_mod.t | Queue_get_config_req of Header.h * Port.t | Queue_get_config_resp of Header.h * Port.t * Queue.t array *) - marshal_and_sub marshal (OS.Io_page.get ()) + marshal_and_sub marshal (Cstruct.of_bigarray (OS.Io_page.get ())) diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index ec25693..d0002a9 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -15,8 +15,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -exception Unparsable of string * Cstruct.buf -exception Unparsed of string * Cstruct.buf +exception Unparsable of string * Cstruct.t +exception Unparsed of string * Cstruct.t type int16 = int type uint8 = char @@ -58,10 +58,10 @@ module Header : | QUEUE_GET_CONFIG_RESP type h = { ver : uint8; ty : msg_code; len : uint16; xid : uint32; } val get_len : int - val parse_header : Cstruct.buf -> h + val parse_header : Cstruct.t -> h val header_to_string : h -> string val create : ?xid:uint32 -> msg_code -> uint16 -> h - val marshal_header : h -> Cstruct.buf -> int + val marshal_header : h -> Cstruct.t -> int val sizeof_ofp_header : int end module Queue : @@ -151,7 +151,7 @@ module Port : type status = { reason : reason; desc : phy; } val create_port_status : reason -> phy -> Header.h * status val string_of_status : status -> string - val marshal_port_status : ?xid:int32 -> status -> Cstruct.buf -> int + val marshal_port_status : ?xid:int32 -> status -> Cstruct.t -> int end module Switch : sig @@ -187,12 +187,12 @@ module Switch : actions : actions; mutable ports : Port.phy list; } - val marshal_reply_features : int32 -> features -> Cstruct.buf -> int + val marshal_reply_features : int32 -> features -> Cstruct.t -> int val get_len : features -> int type config = { drop : bool; reasm : bool; miss_send_len : uint16; } val init_switch_config : config val config_get_len : int - val marshal_switch_config : int32 -> config -> Cstruct.buf -> int + val marshal_switch_config : int32 -> config -> Cstruct.t -> int end module Wildcards : sig @@ -251,7 +251,7 @@ module Match : ?nw_src:uint32 -> ?nw_dst:uint32 -> ?tp_src:uint16 -> ?tp_dst:uint16 -> unit -> t val translate_port : t -> Port.t -> t - val raw_packet_to_match : Port.t -> Cstruct.buf -> t + val raw_packet_to_match : Port.t -> Cstruct.t -> t val match_to_string : t -> string end module Flow : @@ -274,7 +274,7 @@ module Flow : val int_of_action : action -> int val string_of_action : action -> string val string_of_actions : action list -> string - val marshal_action : action -> Cstruct.buf -> int + val marshal_action : action -> Cstruct.t -> int type reason = IDLE_TIMEOUT | HARD_TIMEOUT | DELETE val reason_of_int : int -> reason val int_of_reason : reason -> int @@ -292,7 +292,7 @@ module Flow : mutable byte_count : uint64; mutable action : action list; } - val marshal_flow_stats : stats list -> Cstruct.buf -> int + val marshal_flow_stats : stats list -> Cstruct.t -> int val string_of_flow_stat : stats -> string end module Packet_in : @@ -305,13 +305,13 @@ module Packet_in : buffer_id : uint32; in_port : Port.t; reason : reason; - data : Cstruct.buf; + data : Cstruct.t; } val packet_in_to_string : t -> string val create_pkt_in : ?buffer_id:uint32 -> in_port:Port.t -> - reason:reason -> data:Cstruct.buf -> (Header.h * t) + reason:reason -> data:Cstruct.t -> (Header.h * t) val marshal_pkt_in : ?xid:int32 -> ?data_len:int -> t -> - Cstruct.buf -> int + Cstruct.t -> int end module Packet_out : sig @@ -319,15 +319,15 @@ module Packet_out : buffer_id : uint32; in_port : Port.t; actions : Flow.action list; - data : Cstruct.buf; + data : Cstruct.t; } val create : ?xid:uint32 -> ?buffer_id:uint32 -> ?actions:Flow.action list -> - data:Cstruct.buf -> in_port:Port.t -> + data:Cstruct.t -> in_port:Port.t -> unit -> t - val marshal_packet_out : ?xid:int32 -> t -> Cstruct.buf -> int + val marshal_packet_out : ?xid:int32 -> t -> Cstruct.t -> int val packet_out_to_string: t -> string end module Flow_mod : @@ -357,7 +357,7 @@ module Flow_mod : ?hard_timeout:uint16 -> ?buffer_id:int -> ?out_port:Port.t -> ?flags:flags -> Flow.action list -> unit -> t - val marshal_flow_mod : ?xid:int32 -> t -> Cstruct.buf -> int + val marshal_flow_mod : ?xid:int32 -> t -> Cstruct.t -> int end module Flow_removed : sig @@ -377,8 +377,8 @@ module Flow_removed : packet_count : uint64; byte_count : uint64; } - val parse_flow_removed: Cstruct.buf -> t - val marshal_flow_removed: ?xid:int32 -> t -> Cstruct.buf -> int + val parse_flow_removed: Cstruct.t -> t + val marshal_flow_removed: ?xid:int32 -> t -> Cstruct.t -> int val flow_to_flow_removed: ?reason:reason -> duration_sec:int32 -> duration_nsec:int32 -> packet_count:int64 -> byte_count:int64 -> Flow_mod.t -> t @@ -435,19 +435,19 @@ module Stats : val create_flow_stat_req : Match.t -> ?table_id:table_id -> - ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.buf -> int + ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.t -> int val create_aggr_flow_stat_req : Match.t -> ?table_id:table_id -> - ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.buf -> int -(* val create_vendor_stat_req : ?xid:Int32.t -> Cstruct.buf -> unit *) - val create_desc_stat_req : ?xid:Int32.t -> Cstruct.buf -> int - val create_table_stat_req : ?xid:Int32.t -> Cstruct.buf -> int + ?out_port:Port.t -> ?xid:Int32.t -> Cstruct.t -> int +(* val create_vendor_stat_req : ?xid:Int32.t -> Cstruct.t -> unit *) + val create_desc_stat_req : ?xid:Int32.t -> Cstruct.t -> int + val create_table_stat_req : ?xid:Int32.t -> Cstruct.t -> int val create_queue_stat_req : ?xid:Int32.t -> - ?queue_id:int32 -> ?port:Port.t -> Cstruct.buf -> int + ?queue_id:int32 -> ?port:Port.t -> Cstruct.t -> int val create_port_stat_req : - ?xid:Int32.t -> ?port:Port.t -> Cstruct.buf -> int + ?xid:Int32.t -> ?port:Port.t -> Cstruct.t -> int type req = Desc_req of req_hdr | Flow_req of req_hdr * Match.t * table_id * Port.t @@ -456,7 +456,7 @@ module Stats : | Port_req of req_hdr * Port.t | Queue_req of req_hdr * Port.t * queue_id | Vendor_req of req_hdr - val marshal_stats_req : ?xid:int32 -> req -> Cstruct.buf -> int + val marshal_stats_req : ?xid:int32 -> req -> Cstruct.t -> int type resp_hdr = { st_ty : stats_type; more_to_follow : bool; } val int_of_stats_type : stats_type -> int @@ -470,7 +470,7 @@ module Stats : | Queue_resp of resp_hdr * queue list | Vendor_resp of resp_hdr val resp_get_len : resp -> int - val marshal_stats_resp : int32 -> resp -> Cstruct.buf -> int + val marshal_stats_resp : int32 -> resp -> Cstruct.t -> int val string_of_stats : resp -> string end type error_code = @@ -505,21 +505,21 @@ type error_code = | QUEUE_OP_BAD_PORT | QUEUE_OP_BAD_QUEUE | QUEUE_OP_EPERM -val marshal_and_sub : (Cstruct.buf -> int) -> Cstruct.buf -> Cstruct.buf -val marshal_and_shift : (Cstruct.buf -> int) -> Cstruct.buf -> (int * Cstruct.buf) +val marshal_and_sub : (Cstruct.t -> int) -> Cstruct.t -> Cstruct.t +val marshal_and_shift : (Cstruct.t -> int) -> Cstruct.t -> (int * Cstruct.t) (* val contain_exc : string -> `a -> `a option *) val error_code_of_int : int -> error_code val int_of_error_code : error_code -> uint32 val string_of_error_code : error_code -> string -val marshal_error : error_code -> Cstruct.buf -> int32 -> Cstruct.buf -> int -val build_features_req : uint32 -> Cstruct.buf -> int -val build_echo_resp : Header.h -> Cstruct.buf -> int +val marshal_error : error_code -> Cstruct.t -> int32 -> Cstruct.t -> int +val build_features_req : uint32 -> Cstruct.t -> int +val build_echo_resp : Header.h -> Cstruct.t -> int type t = Hello of Header.h - | Error of Header.h * error_code * Cstruct.buf + | Error of Header.h * error_code * Cstruct.t | Echo_req of Header.h | Echo_resp of Header.h - | Vendor of Header.h * vendor * Cstruct.buf + | Vendor of Header.h * vendor * Cstruct.t | Features_req of Header.h | Features_resp of Header.h * Switch.features | Get_config_req of Header.h @@ -537,6 +537,6 @@ type t = | Barrier_resp of Header.h | Queue_get_config_req of Header.h * Port.t | Queue_get_config_resp of Header.h * Port.t * Queue.t array -val parse : Header.h -> Cstruct.buf -> t -val marshal : t -> Cstruct.buf +val parse : Header.h -> Cstruct.t -> t +val marshal : t -> Cstruct.t val to_string : t -> string diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index a5dd4ae..5479442 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -30,7 +30,7 @@ let resolve t = Lwt.on_success t (fun _ -> ()) module Socket = struct type t = { sock: Channel.t; - data_cache: Cstruct.buf list ref; + data_cache: Cstruct.t list ref; } let create_socket sock = @@ -42,9 +42,9 @@ let write_buffer t bits = let _ = Channel.write_buffer t.sock bits in Channel.flush t.sock | _ -> - let buf = Cstruct.sub_buffer bits 0 1400 in + let buf = Cstruct.sub bits 0 1400 in let _ = Channel.write_buffer t.sock buf in - let buf = Cstruct.sub_buffer bits 1400 ((Cstruct.len bits) - 1400) in + let buf = Cstruct.sub bits 1400 ((Cstruct.len bits) - 1400) in let _ = Channel.write_buffer t.sock buf in lwt _ = Channel.flush t.sock in return () @@ -56,7 +56,7 @@ let rec read_data t len = match (len, !(t.data_cache)) with | (0, _) -> (* pp "| (0, _) ->\n%!"; *) - return (Cstruct.sub (OS.Io_page.get ()) 0 0 ) + return (Cstruct.create 0) | (_, []) -> (* pp " | (_, []) ->\n%!"; *) lwt data = Channel.read_some t.sock in @@ -66,21 +66,21 @@ let rec read_data t len = when ((List.fold_right (fun a b ->b+(Cstruct.len a)) tail (Cstruct.len head))>=len) -> ( (* pp "| (_, head::tail) when ((List.fold_right (f a b * ->b+(Cstruct.len b)) tail (Cstruct.len head)) >= len) ->\n%!"; *) - let ret = OS.Io_page.get () in + let ret = Cstruct.create len in let ret_len = ref 0 in let rec read_data_inner = function | head::tail when ((!ret_len + (Cstruct.len head)) < len) -> - let _ = Cstruct.blit_buffer head 0 ret !ret_len (Cstruct.len head) in + let _ = Cstruct.blit head 0 ret !ret_len (Cstruct.len head) in ret_len := !ret_len + (Cstruct.len head); read_data_inner tail | head::tail when ((!ret_len + (Cstruct.len head)) = len) -> - let _ = Cstruct.blit_buffer head 0 ret !ret_len (Cstruct.len head) in + let _ = Cstruct.blit head 0 ret !ret_len (Cstruct.len head) in ret_len := !ret_len + (Cstruct.len head); t.data_cache := tail; return () | head::tail when ((!ret_len + (Cstruct.len head)) > len) -> let len_rest = len - !ret_len in - let _ = Cstruct.blit_buffer head 0 ret !ret_len len_rest in + let _ = Cstruct.blit head 0 ret !ret_len len_rest in let head = Cstruct.shift head len_rest in ret_len := !ret_len + len_rest; t.data_cache := [head] @ tail; @@ -91,7 +91,7 @@ let rec read_data t len = raise ReadError in lwt _ = read_data_inner !(t.data_cache) in - let ret = Cstruct.sub_buffer ret 0 len in + let ret = Cstruct.sub ret 0 len in return (ret) ) | (_, head::tail) @@ -104,13 +104,13 @@ let rec read_data t len = | (_, _) -> (* pp "| (_, _) ->\n%!"; *) Printf.printf "read_data and not match found\n%!"; - return (Cstruct.sub (OS.Io_page.get ()) 0 0 ) + return (Cstruct.create 0 ) end module Unix_socket = struct type t = { sock: Lwt_unix.file_descr; - data_cache: Cstruct.buf list ref; + data_cache: Cstruct.t list ref; } let create_socket sock = @@ -120,7 +120,7 @@ module Unix_socket = struct let rec write_buffer_inner t bits = function | len when len >= (Cstruct.len bits) -> return () | len -> - lwt l = Lwt_bytes.write t.sock bits len ((Cstruct.len bits) - len) in + lwt l = Lwt_bytes.write t.sock bits.Cstruct.buffer (bits.Cstruct.off + len) ((Cstruct.len bits) - len) in let _ = if (l = 0) then raise Net.Nettypes.Closed @@ -141,29 +141,29 @@ module Unix_socket = struct let rec read_data t len = try_lwt match (len, !(t.data_cache)) with - | (0, _) -> return (Lwt_bytes.create 0 ) + | (0, _) -> return (Cstruct.create 0 ) | (_, []) -> - let p = OS.Io_page.get () in - lwt l = Lwt_bytes.read t.sock p 0 (Cstruct.len p) in + let p = Cstruct.of_bigarray (OS.Io_page.get ()) in + lwt l = Lwt_bytes.read t.sock p.Cstruct.buffer 0 (Cstruct.len p) in let _ = if (l = 0) then raise Net.Nettypes.Closed in let _ = t.data_cache := [(Cstruct.sub p 0 l)] in read_data t len | (_, head::tail) when (buf_size !(t.data_cache)) >= len -> begin - let ret = OS.Io_page.get () in + let ret = Cstruct.of_bigarray (OS.Io_page.get ()) in let ret_len = ref 0 in let rec read_data_inner = function | head::tail when ((!ret_len + (Cstruct.len head)) < len) -> - let _ = Cstruct.blit_buffer head 0 ret !ret_len (Cstruct.len head) in + let _ = Cstruct.blit head 0 ret !ret_len (Cstruct.len head) in ret_len := !ret_len + (Cstruct.len head); read_data_inner tail | head::tail when ((!ret_len + (Cstruct.len head)) = len) -> - let _ = Cstruct.blit_buffer head 0 ret !ret_len (Cstruct.len head) in + let _ = Cstruct.blit head 0 ret !ret_len (Cstruct.len head) in ret_len := !ret_len + (Cstruct.len head); t.data_cache := tail; return () | head::tail when ((!ret_len + (Cstruct.len head)) > len) -> let len_rest = len - !ret_len in - let _ = Cstruct.blit_buffer head 0 ret !ret_len len_rest in + let _ = Cstruct.blit head 0 ret !ret_len len_rest in let head = Cstruct.shift head len_rest in ret_len := !ret_len + len_rest; t.data_cache := [head] @ tail; @@ -174,18 +174,18 @@ module Unix_socket = struct raise ReadError in lwt _ = read_data_inner !(t.data_cache) in - let ret = Cstruct.sub_buffer ret 0 len in + let ret = Cstruct.sub ret 0 len in return (ret) end | (_, head::tail) when (buf_size !(t.data_cache)) < len -> - let p = OS.Io_page.get () in - lwt l = Lwt_bytes.read t.sock p 0 (Cstruct.len p) in + let p = Cstruct.of_bigarray (OS.Io_page.get ()) in + lwt l = Lwt_bytes.read t.sock p.Cstruct.buffer 0 (Cstruct.len p) in let _ = if (l = 0) then raise Net.Nettypes.Closed in let _ = t.data_cache := !(t.data_cache) @ [(Cstruct.sub p 0 l)] in read_data t len | (_, _) -> let _ = Printf.printf "read_data and not match found\n%!" in - return (Lwt_bytes.create 0 ) + return (Cstruct.create 0 ) with exn -> let _ = printf "[socket] read error: %s\n%!" (Printexc.to_string exn) in raise Net.Nettypes.Closed diff --git a/lib/ofsocket.mli b/lib/ofsocket.mli index 109904d..3c05748 100644 --- a/lib/ofsocket.mli +++ b/lib/ofsocket.mli @@ -30,5 +30,5 @@ val init_local_conn_state: Ofpacket.t Lwt_stream.t -> (Ofpacket.t option -> unit) -> conn_state val read_packet : conn_state -> Ofpacket.t Lwt.t val send_packet : conn_state -> Ofpacket.t -> unit Lwt.t -val send_data_raw : conn_state -> Cstruct.buf -> unit Lwt.t +val send_data_raw : conn_state -> Cstruct.t -> unit Lwt.t val close : conn_state -> unit diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index dbdb1b3..e3fef90 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -297,8 +297,8 @@ module Switch = struct p_sflow: uint32; (** probability for sFlow sampling *) mutable errornum : uint32; mutable portnum : int; - packet_queue : (Cstruct.buf * Net.Manager.id) Lwt_stream.t; - push_packet : ((Cstruct.buf * Net.Manager.id) option -> unit); + packet_queue : (Cstruct.t * Net.Manager.id) Lwt_stream.t; + push_packet : ((Cstruct.t * Net.Manager.id) option -> unit); (* TODO: add this in the port definition and make also * packet output assyncronous *) mutable queue_len : int; @@ -372,28 +372,30 @@ module Switch = struct } as big_endian - let forward_frame st in_port frame pkt_size checksum port = + let forward_frame st in_port bits pkt_size checksum port = let _ = - if ((checksum) && ((get_dl_header_dl_type frame) = 0x800)) then - let ip_data = Cstruct.shift frame sizeof_dl_header in + if ((checksum) && ((get_dl_header_dl_type bits) = 0x800)) then + let ip_data = Cstruct.shift bits sizeof_dl_header in let _ = set_nw_header_csum ip_data 0 in - let csm = Net.Checksum.ones_complement ip_data sizeof_nw_header in + let csm = Net.Checksum.ones_complement (Cstruct.sub ip_data 0 + sizeof_nw_header) in let _ = set_nw_header_csum ip_data csm in let _ = match (get_nw_header_nw_proto ip_data) with | 6 (* TCP *) -> () | 17 (* UDP *) -> () - () | _ -> () in () in + let frame = Net.Frame.of_buffer bits (Cstruct.len bits) in match port with | OP.Port.Port(port) -> if Hashtbl.mem st.int_to_port port then( (* let _ = printf "sending to port %d\n%!" port in *) let out_p = (!( Hashtbl.find st.int_to_port port)) in - Net.Manager.inject_packet out_p.mgr out_p.ethif frame ) + Net.Manager.inject_packet out_p.mgr out_p.ethif frame + ) else return (Printf.printf "Port %d not registered \n" port) | OP.Port.No_port -> return () @@ -402,7 +404,7 @@ module Switch = struct Lwt_list.iter_p (fun port -> if(port.port_id != (OP.Port.int_of_port in_port)) then ( - update_port_tx_stats (Int64.of_int (Cstruct.len frame)) port; + update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; Net.Manager.inject_packet port.mgr port.ethif frame ) else return () @@ -412,7 +414,7 @@ module Switch = struct if Hashtbl.mem st.int_to_port port then (* let _ = printf "sending to port %d\n%!" port in *) let out_p = !(Hashtbl.find st.int_to_port port) in - update_port_tx_stats (Int64.of_int (Cstruct.len frame)) out_p; + update_port_tx_stats (Int64.of_int (Cstruct.len bits)) out_p; Net.Manager.inject_packet out_p.mgr out_p.ethif frame else return (Printf.printf "Port %d not registered \n%!" port) @@ -421,7 +423,7 @@ module Switch = struct if Hashtbl.mem st.int_to_port local_port_id then let out_p = !(Hashtbl.find st.int_to_port local_port_id) in (* let _ = printf "sending to port %d\n%!" local_port_id in *) - let _ = update_port_tx_stats (Int64.of_int (Cstruct.len frame)) out_p in + let _ = update_port_tx_stats (Int64.of_int (Cstruct.len bits)) out_p in Net.Manager.inject_packet out_p.mgr out_p.ethif frame else return (Printf.printf "Port %d not registered \n%!" local_port_id) @@ -542,26 +544,17 @@ type t = Switch.t (* * let process_frame_depr intf_name frame = *) let process_frame_inner st p intf frame = - try_lwt -(* let p = (!(Hashtbl.find st.Switch.dev_to_port intf)) in *) + match frame with + | Net.Ethif.Output _ -> return () + | Net.Ethif.Input frame -> begin + try_lwt let in_port = (OP.Port.port_of_int p.Switch.port_id) in let tupple = (OP.Match.raw_packet_to_match in_port frame ) in (* Update port rx statistics *) let _ = Switch.update_port_rx_stats (Int64.of_int (Cstruct.len frame)) p in - (* What is the size of the frame? Need to get sub_buffer in order to - * process it *) -(* let frame = - match (Switch.size_of_raw_packet frame) with - | Some(len) -> Cstruct.sub_buffer frame 0 len - | None -> raise Packet_type_unknw - in *) -(* let _ = - printf "XXX received on port %d (%d) [%s] \n%!" - p.Switch.port_id (Cstruct.len frame) (OP.Match.match_to_string tupple) - in *) - (* Lookup packet flow to existing flows in table *) + (* Lookup packet flow to existing flows in table *) let entry = (Switch.lookup_flow st tupple) in match entry with | Switch.NOT_FOUND -> begin @@ -595,7 +588,7 @@ let process_frame_inner st p intf frame = pp "control channel error: %s\nbt: %s\n%!" (Printexc.to_string exn) (Printexc.get_backtrace ()); return () - | Packet_type_unknw -> return () + end let process_frame p st intf_name frame = try_lwt diff --git a/myocamlbuild.ml b/myocamlbuild.ml index b025f19..47bcc8e 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: ce054306119a8bd9c19b2decbd79bde5) *) +(* DO NOT EDIT (digest: d87fcaba6f39ad9c0642e55b81165748) *) module OASISGettext = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index f303423..f7de632 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 77807950f77d37deb0eec45df427174e) *) +(* DO NOT EDIT (digest: b00280699c77df11b18896c4eb3ca8be) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISString.ml" *) +(* # 1 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 71 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 102 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseContext.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseMessage.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseEnv.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseCheck.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseLog.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseLog.ml" *) open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseCustom.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseTest.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseDoc.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/base/BaseSetup.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/Users/cr409/.opam/3.12.1+mirage-unix-direct/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall From 50ce07a6dc4462c99dbfa8909ce5455ca9c5484c Mon Sep 17 00:00:00 2001 From: crotsos Date: Sun, 6 Jan 2013 02:59:22 +0200 Subject: [PATCH 27/75] Adding checksum calculation. Adding cache managment on flow insertion --- lib/ofpacket.ml | 7 +-- lib/ofswitch.ml | 141 +++++++++++++++++++++++++++++++++--------------- 2 files changed, 103 insertions(+), 45 deletions(-) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index fee650d..9656749 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -1191,7 +1191,8 @@ module Match = struct flow_def.dl_vlan_pcp));*) (((wildcard.Wildcards.in_port)|| ((Port.int_of_port flow.in_port) == (Port.int_of_port flow_def.in_port))) && - ((wildcard.Wildcards.dl_vlan) || (flow.dl_vlan == flow_def.dl_vlan)) && +(* ((wildcard.Wildcards.dl_vlan) || (flow.dl_vlan == flow_def.dl_vlan)) + * &&*) ((wildcard.Wildcards.dl_src) || (flow.dl_src = flow_def.dl_src)) && ((wildcard.Wildcards.dl_dst) || (flow.dl_dst = flow_def.dl_dst)) && ((wildcard.Wildcards.dl_type) || (flow.dl_type== flow_def.dl_type)) && @@ -1605,8 +1606,8 @@ module Packet_out = struct let bits = Cstruct.shift bits sizeof_ofp_packet_out in let action_bits = Cstruct.sub bits 0 act_len in let (_, actions) = Flow.parse_actions action_bits in - let data = Cstruct.shift bits act_len in - { buffer_id; in_port; actions; data; } + let data = Cstruct.shift bits act_len in + { buffer_id; in_port; actions; data; } let create ?(xid=0l) ?(buffer_id =(-1l)) ?(actions = [] ) ~data ~in_port () = diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index e3fef90..3889673 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -131,12 +131,29 @@ module Table = struct (* TODO fix flow_mod flag support. overlap is not considered *) let add_flow st table t = (* TODO check if the details are correct e.g. IP type etc. *) + let _ = + if (t.OP.Flow_mod.of_match.OP.Match.wildcards=(OP.Wildcards.exact_match ())) then + t.OP.Flow_mod.priority <- 0x1001 + in lwt _ = log ~level:Notice (sprintf "Adding flow %s" (OP.Match.match_to_string t.OP.Flow_mod.of_match)) in - let _ = Hashtbl.replace table.entries t.OP.Flow_mod.of_match - Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); - cache_entries=[];}) in + let entry = Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); + cache_entries=[];}) in + let _ = Hashtbl.replace table.entries t.OP.Flow_mod.of_match entry in + (* In the fast path table, I need to delete any conflicting entries *) + let _ = + Hashtbl.iter ( + fun a e -> + if ((OP.Match.flow_match_compare a t.OP.Flow_mod.of_match + t.OP.Flow_mod.of_match.OP.Match.wildcards) && + (entry.Entry.counters.Entry.priority >= (!e).Entry.counters.Entry.priority)) then ( + let _ = (!e).Entry.cache_entries <- + List.filter (fun c -> not (a = c)) (!e).Entry.cache_entries in + let _ = Hashtbl.replace table.cache a (ref entry) in + entry.Entry.cache_entries <- entry.Entry.cache_entries @ [a] + ) + ) table.cache in return () (* check if a list of actions has an output action forwarding packets to @@ -156,8 +173,8 @@ module Table = struct tuple.OP.Match.wildcards) && ((out_port = OP.Port.No_port) || (is_output_port out_port flow.Entry.actions))) then ( - Hashtbl.remove table.entries of_match; - ret @ [(of_match, flow)] + let _ = Hashtbl.remove table.entries of_match in + ret @ [(of_match, flow)] ) else ret ) table.entries [] in @@ -177,9 +194,8 @@ module Table = struct log ~level:Notice (sprintf "Adding flow %s" (OP.Match.match_to_string of_match)) in - if (t <> None) && - (flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) then - let Some(t) = t in + match(t, flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) with + | (Some t, true) -> let duration_sec = Int32.sub (Int32.of_float (OS.Clock.time ())) flow.Entry.counters.Entry.insert_sec in let fl_rm = OP.Flow_removed.( @@ -191,16 +207,14 @@ module Table = struct byte_count=flow.Entry.counters.Entry.n_bytes;}) in let h = OP.Header.(create ~xid FLOW_REMOVED (OP.Flow_removed.get_len)) in Ofsocket.send_packet t (OP.Flow_removed (h,fl_rm)) - else - return () + | _ -> return () ) remove_flow (* table stat update methods *) - let update_table_found table = - table.stats.OP.Stats.lookup_count <- Int64.add - table.stats.OP.Stats.lookup_count 1L; - table.stats.OP.Stats.matched_count <- - Int64.add table.stats.OP.Stats.matched_count 1L + let update_table_found table = + let open OP.Stats in + table.stats.lookup_count <- Int64.add table.stats.lookup_count 1L; + table.stats.matched_count <- Int64.add table.stats.matched_count 1L let update_table_missed table = table.stats.OP.Stats.lookup_count <- Int64.add @@ -371,18 +385,52 @@ module Switch = struct uint16_t checksum } as big_endian + cstruct tcpv4 { + uint16_t src_port; + uint16_t dst_port; + uint32_t sequence; + uint32_t ack_number; + uint32_t dataoff_flags_window; + uint16_t checksum + } as big_endian + + cstruct pseudo_header { + uint32_t src; + uint32_t dst; + uint8_t res; + uint8_t proto; + uint16_t len + } as big_endian + + let tcp_checksum ~src ~dst = + let pbuf = Cstruct.sub (Cstruct.of_bigarray (OS.Io_page.get ())) 0 sizeof_pseudo_header in + fun data -> + set_pseudo_header_src pbuf (ipv4_addr_to_uint32 src); + set_pseudo_header_dst pbuf (ipv4_addr_to_uint32 dst); + set_pseudo_header_res pbuf 0; + set_pseudo_header_proto pbuf 6; + set_pseudo_header_len pbuf (Cstruct.lenv data); + Net.Checksum.ones_complement_list (pbuf::data) let forward_frame st in_port bits pkt_size checksum port = let _ = if ((checksum) && ((get_dl_header_dl_type bits) = 0x800)) then let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in let _ = set_nw_header_csum ip_data 0 in - let csm = Net.Checksum.ones_complement (Cstruct.sub ip_data 0 - sizeof_nw_header) in + let csm = Net.Checksum.ones_complement (Cstruct.sub ip_data 0 (len*4)) in let _ = set_nw_header_csum ip_data csm in let _ = match (get_nw_header_nw_proto ip_data) with - | 6 (* TCP *) -> () + | 6 (* TCP *) -> + let src = Net.Nettypes.ipv4_addr_of_uint32 (get_nw_header_nw_src + ip_data) in + let dst = Net.Nettypes.ipv4_addr_of_uint32 (get_nw_header_nw_dst + ip_data) in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tcpv4_checksum tp_data 0 in + let csm = tcp_checksum ~src ~dst [tp_data] in + set_tcpv4_checksum tp_data csm | 17 (* UDP *) -> () | _ -> () in @@ -392,7 +440,6 @@ module Switch = struct match port with | OP.Port.Port(port) -> if Hashtbl.mem st.int_to_port port then( -(* let _ = printf "sending to port %d\n%!" port in *) let out_p = (!( Hashtbl.find st.int_to_port port)) in Net.Manager.inject_packet out_p.mgr out_p.ethif frame ) @@ -420,19 +467,30 @@ module Switch = struct return (Printf.printf "Port %d not registered \n%!" port) | OP.Port.Local -> let local_port_id = OP.Port.int_of_port OP.Port.Local in - if Hashtbl.mem st.int_to_port local_port_id then - let out_p = !(Hashtbl.find st.int_to_port local_port_id) in -(* let _ = printf "sending to port %d\n%!" local_port_id in *) - let _ = update_port_tx_stats (Int64.of_int (Cstruct.len bits)) out_p in - Net.Manager.inject_packet out_p.mgr out_p.ethif frame - else - return (Printf.printf "Port %d not registered \n%!" local_port_id) - + if Hashtbl.mem st.int_to_port local_port_id then + let out_p = !(Hashtbl.find st.int_to_port local_port_id) in + let _ = update_port_tx_stats (Int64.of_int (Cstruct.len bits)) out_p in + let _ = Cstruct.hexdump (Net.Frame.get_whole_buffer frame) in + Net.Manager.inject_packet out_p.mgr out_p.ethif frame + else + return (Printf.printf "Port %d not registered \n%!" local_port_id) + | OP.Port.Controller -> begin + let size = + if (Cstruct.len (Net.Frame.get_whole_buffer frame) > pkt_size) then + pkt_size + else + Cstruct.len (Net.Frame.get_whole_buffer frame) + in + let (h, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id:(-1l) ~in_port + ~reason:OP.Packet_in.ACTION + ~data:(Cstruct.sub (Net.Frame.get_whole_buffer frame) 0 size) in +(* let _ = printf "[ofswitch] sending packet to controller\n%!" in *) + match st.controller with + | None -> return () + | Some conn -> Ofsocket.send_packet conn (OP.Packet_in (h, pkt_in)) + end (* | Table - * | Normal - * | Controller -> generate a packet out. - * | Local -> can I inject this frame to the network - * stack? *) + * | Normal *) | _ -> return (Printf.printf "Not implemented output port\n") (* Assumwe that action are valid. I will not get a flow that sets an ip @@ -471,13 +529,13 @@ module Switch = struct return true | OP.Flow.Set_tp_src(port) -> let ip_data = Cstruct.shift bits sizeof_dl_header in - let len = (get_nw_header_hlen_version bits) land 0xf in - let tp_data = Cstruct.shift ip_data (len*4) in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let tp_data = Cstruct.shift ip_data (len*4) in let _ = set_tp_header_tp_src tp_data port in return true | OP.Flow.Set_tp_dst(port) -> let ip_data = Cstruct.shift bits sizeof_dl_header in - let len = (get_nw_header_hlen_version bits) land 0xf in + let len = (get_nw_header_hlen_version ip_data) land 0xf in let tp_data = Cstruct.shift ip_data (len*4) in let _ = set_tp_header_tp_dst tp_data port in return true @@ -519,6 +577,8 @@ module Switch = struct flow.OP.Match.wildcards)) with | (_, false) -> r | (None, true) -> Some(flow, entry) +(* | (Some(f,e), true) when (flow.OP.Match.wildcards = OP.Match.full_wildcards ()) -> + Some(flow, entry) *) | (Some(f,e), true) when (Entry.(e.counters.priority > entry.counters.priority)) -> r | (Some(f,e), true) when (Entry.(e.counters.priority <= entry.counters.priority)) -> Some(flow, entry) @@ -749,7 +809,7 @@ let process_openflow st t msg = Ofsocket.send_packet t (OP.Barrier_resp(resp_h)) | OP.Packet_out(h, pkt) -> -(* cp (sp "PACKET_OUT: %s" (OP.Packet_out.packet_out_to_string pkt)); *) + cp (sp "PACKET_OUT: %s" (OP.Packet_out.packet_out_to_string pkt)); if (pkt.OP.Packet_out.buffer_id = -1l) then Switch.apply_of_actions st pkt.OP.Packet_out.in_port pkt.OP.Packet_out.data pkt.OP.Packet_out.actions @@ -1008,9 +1068,6 @@ let lwt_connect st ?(standalone=true) mgr loc = let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) in -(* let _ = Lwt_unix.setsockopt fd Unix.SO_REUSEADDR true in - let _ = Lwt_unix.bind fd (Unix.ADDR_INET(Unix.inet_addr_any, 6633)) in - let _ = Lwt_unix.listen fd 1 in *) let _ = printf "[switch] Listening socket...\n%!" in while_lwt true do let t,u = Lwt.task () in @@ -1026,18 +1083,18 @@ let lwt_connect st ?(standalone=true) mgr loc = ) <&> ( let rec connect_socket () = - try_lwt - let sock = Lwt_unix.socket + let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in - let dst = Unix.ADDR_INET( + let dst = Unix.ADDR_INET( (Unix.inet_addr_of_string "127.0.0.1"), 6633) in + try_lwt lwt addr = Lwt_unix.connect sock dst in return sock with exn -> + lwt _ = Lwt_unix.close sock in lwt _ = Lwt_unix.sleep 5.0 in connect_socket () in - (* lwt (sock, loc) = Lwt_unix.accept fd in *) lwt sock = connect_socket () in let conn = Ofsocket.init_unix_conn_state sock in let _ = wakeup u () in From 3bf42ccf1b9e8ae83f57185d65c000d5c4f55d59 Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 7 Jan 2013 16:20:27 +0200 Subject: [PATCH 28/75] Adding usage details on the library --- USAGE.md | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 USAGE.md diff --git a/USAGE.md b/USAGE.md new file mode 100644 index 0000000..9d76c36 --- /dev/null +++ b/USAGE.md @@ -0,0 +1,56 @@ +API +=== + +The source code contains 3 main modules: ofpacket, ofswitch and ofcontroller. + +The ofpacket module contains all the code to parse, print and generate openflow messages. +The parsing uses cstruct.t objects. + +The ofcontroller implements an openflow controller library. The library is event driven. +The programmer can access any openflow message by registering event callback during +the init phase of the code for every connected switch. + +The ofswitch code implements an openflow switch. The module exposes a simple API through +which a user can add and remove ports to the controller and run the default openflow +processing switch functionality. + +Additionally the library contains a small number of helper functions that enhance the +functionality of openflow application. Ofswitch_config is a daemon that exposes a json +API through which other apps can have configure the ports of the switch and access the +content of the datapath table, using a simple tcp socket. Ofswitch_standalone is a minimum +learning switch implementation over openflow that can be enabled on the switch module when +no controller is accessible. + +Programs +======= + +The source code of the library contains a number of small appliances that provide simple +examples over the functionality of the library. + +basic_switch_lwt +================ + +This is a unix backend implementation of an openflow switch. The application exposes both +the json config web service and uses the standalone embedded controller. The application +tries to connect to locahost in order to connect to controller and also run the json-based +configuration daemon on port 6634. + +ovs-vsctl +========= + +This is a simple implementation of a configuration client for the switch code. The application +has a lot of similarities with the syntax of the ovs-vsctl code. Uses can access and modify the +state of the switch with the following command line parameters: + +* dump-flows intf tupple: this command will match all flows on the forwardign table of the switch +and return a dump of the matching flows to the provided tupple. +* del-flows intf tupple: delete matching flows. +* add-flows intf tupple: adding a tupple to the flow table. +* add-port intf network_device : adding a port under the control of the openflow switch. +* del-port intf network_device : remove a port from the control of the switch. + +learning_switch +=============== + +An openflow controller that implements a simple openflow-based learning switch. The program listens +on port 6633. From 6854a12a6248a663e7a4f79b6300691d216b083c Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 7 Jan 2013 16:21:33 +0200 Subject: [PATCH 29/75] Install basic_switch_lwt program and updte build files --- Makefile | 18 ++++----- _oasis | 2 +- myocamlbuild.ml | 14 +++---- setup.ml | 98 ++++++++++++++++++++++++------------------------- 4 files changed, 66 insertions(+), 66 deletions(-) diff --git a/Makefile b/Makefile index 5ee4682..0d8c932 100644 --- a/Makefile +++ b/Makefile @@ -9,7 +9,11 @@ MIRAGE ?= $(shell if ocamlfind query mirage-net >/dev/null 2>&1; then echo --ena -include Makefile.config -clean: setup.ml setup.data +setup.data: _oasis + oasis setup + ocaml setup.ml -configure $(LWT) --disable-mirage + +clean: setup.data ocaml setup.ml -clean $(OFLAGS) rm -f setup.data setup.log setup.ml @@ -17,9 +21,11 @@ distclean: setup.ml setup.data ocaml setup.ml -distclean $(OFLAGS) rm -f setup.data setup.log setup.ml -setup: setup.ml setup.data +setup: setup.data -build: setup.ml setup.data $(wildcard lib/*.ml) +build: setup.data $(wildcard lib/*.ml) + oasis setup + ocaml setup.ml -configure $(LWT) --disable-mirage ocaml setup.ml -build -j $(J) $(OFLAGS) doc: setup.data setup.ml @@ -32,10 +38,4 @@ install: test: build ocaml setup.ml -test -## -setup.ml: _oasis - oasis setup - -setup.data: setup.ml - ocaml setup.ml -configure $(LWT) --disable-mirage diff --git a/_oasis b/_oasis index 5c1cb0b..ed455c8 100644 --- a/_oasis +++ b/_oasis @@ -65,7 +65,7 @@ Executable basic_switch_lwt Build$: flag(lwt) Custom: true CompiledObject: native - Install: false + Install: true BuildDepends: openflow (*Executable learning_switch_mirage diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 47bcc8e..3c07a58 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: d87fcaba6f39ad9c0642e55b81165748) *) +(* DO NOT EDIT (digest: f4b06c69116042e630ee6632523090bb) *) module OASISGettext = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index f7de632..fc709ac 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: b00280699c77df11b18896c4eb3ca8be) *) +(* DO NOT EDIT (digest: 8b22b77c339892f41163315dc3f8e58d) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISString.ml" *) +(* # 1 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 71 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 102 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseContext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseMessage.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseEnv.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseCheck.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseLog.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseLog.ml" *) open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseCustom.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseTest.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseDoc.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/base/BaseSetup.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/Users/cr409/.opam/3.12.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5831,7 +5831,7 @@ let setup_t = (OASISExpr.EBool true, false); (OASISExpr.EFlag "lwt", true) ]; - bs_install = [(OASISExpr.EBool true, false)]; + bs_install = [(OASISExpr.EBool true, true)]; bs_path = "switch"; bs_compiled_object = Native; bs_build_depends = [InternalLibrary "openflow"]; @@ -5853,7 +5853,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "¾$R/û\158\b&=Êâ\030òÔ£ü"; + oasis_digest = Some "¦Ú\150Øù+#\025\143\018f\022BÙø?"; oasis_exec = None; oasis_setup_args = []; setup_update = false; From 40e27c62b9b72c61390ca71c819ffc8d4330b5a0 Mon Sep 17 00:00:00 2001 From: crotsos Date: Fri, 11 Jan 2013 13:56:11 +0000 Subject: [PATCH 30/75] quick hack to remove a mac problem faced with tap interfaces --- lib/ofswitch_ctrl.ml | 3 +-- switch/basic_switch.ml | 16 +++++++++++++--- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/lib/ofswitch_ctrl.ml b/lib/ofswitch_ctrl.ml index 15a1b46..324bb2f 100644 --- a/lib/ofswitch_ctrl.ml +++ b/lib/ofswitch_ctrl.ml @@ -57,8 +57,7 @@ let send_cmd (input, output) = match (Sys.argv.(1)) with | "add-port" -> let _ = check_cmd_args Sys.argv.(1) 2 in - let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String - Sys.argv.(3))];}) in + let cmd = Rpc.({name=Sys.argv.(1); params=[(Rpc.String Sys.argv.(3))];}) in lwt _ = Lwt_io.write_line output (Jsonrpc.string_of_call cmd) in lwt resp = Lwt_io.read_line input in let resp = Jsonrpc.response_of_string resp in diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index 1544a55..90b3461 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -54,9 +54,19 @@ let switch_run () = lwt _ = lwt_connect sw mgr (dst_ip, 6633) in let _ = printf "connect returned...\n%!" in return () - | _ -> - lwt _ = add_port mgr ~use_mac:(!use_mac) sw id in - let _ = use_mac := false in + | _ -> + let find dev = + try + let _ = Re_str.search_forward (Re_str.regexp "tap") dev 0 in true + with Not_found -> false + in + lwt _ = + if (not (find id) ) then + lwt _ = add_port mgr ~use_mac:(!use_mac) sw id in + return (use_mac := false) + else + add_port mgr ~use_mac:false sw id + in return () ) with e -> From 07c10ed771b3f28949946194740f649cf4d35c08 Mon Sep 17 00:00:00 2001 From: crotsos Date: Sun, 13 Jan 2013 16:48:36 +0000 Subject: [PATCH 31/75] xen backend fixes --- Makefile | 7 +- _oasis | 10 +- _tags | 28 +- controller/learning_switch.ml | 15 +- gen_xen.sh | 1 + learning_switch.cfg | 6 + lib/ofsocket.ml | 30 ++- lib/ofsocket.mli | 2 +- lib/ofswitch.ml | 87 +++--- lib/ofswitch.mli | 2 + lib/ofswitch_config.ml | 38 +-- lib/ofswitch_config.mli | 3 - myocamlbuild.ml | 82 ++++-- setup.ml | 489 +++++++++++++++++++++++++++------- 14 files changed, 576 insertions(+), 224 deletions(-) create mode 100644 gen_xen.sh create mode 100644 learning_switch.cfg diff --git a/Makefile b/Makefile index 0d8c932..cbb1265 100644 --- a/Makefile +++ b/Makefile @@ -5,13 +5,14 @@ NAME=openflow J=4 LWT ?= $(shell if ocamlfind query lwt.ssl >/dev/null 2>&1; then echo --enable-lwt; fi) -MIRAGE ?= $(shell if ocamlfind query mirage-net >/dev/null 2>&1; then echo --enable-mirage; fi) +MIRAGE ?= $(shell if [ $MIRAGE_OS = "xen" ]; then echo --enable-mirage; fi) +MIRAGE = --enable-mirage -include Makefile.config setup.data: _oasis oasis setup - ocaml setup.ml -configure $(LWT) --disable-mirage + ocaml setup.ml -configure $(LWT) $(MIRAGE) clean: setup.data ocaml setup.ml -clean $(OFLAGS) @@ -25,7 +26,7 @@ setup: setup.data build: setup.data $(wildcard lib/*.ml) oasis setup - ocaml setup.ml -configure $(LWT) --disable-mirage + ocaml setup.ml -configure $(LWT) $(MIRAGE) ocaml setup.ml -build -j $(J) $(OFLAGS) doc: setup.data setup.ml diff --git a/_oasis b/_oasis index ed455c8..f9294c1 100644 --- a/_oasis +++ b/_oasis @@ -68,22 +68,20 @@ Executable basic_switch_lwt Install: true BuildDepends: openflow -(*Executable learning_switch_mirage +Executable "learning_switch_mirage.o" Path: controller MainIs: learning_switch.ml Build$: flag(mirage) Custom: true - CompiledObject: native - Target: xen + CompiledObject: native_object Install: false BuildDepends: cstruct, cstruct.syntax, openflow -Executable basic_switch_mirage +(*Executable "basic_switch_mirage.o" Path: switch MainIs: basic_switch.ml Build$: flag(mirage) Custom: true - CompiledObject: native - Target: xen + CompiledObject: native_object Install: false BuildDepends: openflow *) diff --git a/_tags b/_tags index 6069146..89057d9 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: c07db1f17ad31bd9de21d6ae41f3283a) +# DO NOT EDIT (digest: 78cbcfbdbaa70295a1850d67f7c11f8a) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -48,14 +48,6 @@ "controller/learning_switch.native": pkg_rpclib.json "controller/learning_switch.native": pkg_mirage "controller/learning_switch.native": pkg_mirage-net -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_re.str -: pkg_rpclib -: pkg_rpclib.json -: pkg_mirage -: pkg_mirage-net "controller/learning_switch.native": custom # Executable basic_switch_lwt "switch/basic_switch.native": use_openflow @@ -75,6 +67,24 @@ : pkg_mirage : pkg_mirage-net "switch/basic_switch.native": custom +# Executable learning_switch_mirage.o +"controller/learning_switch.nobj.o": use_openflow +"controller/learning_switch.nobj.o": pkg_cstruct +"controller/learning_switch.nobj.o": pkg_cstruct.syntax +"controller/learning_switch.nobj.o": pkg_re.str +"controller/learning_switch.nobj.o": pkg_rpclib +"controller/learning_switch.nobj.o": pkg_rpclib.json +"controller/learning_switch.nobj.o": pkg_mirage +"controller/learning_switch.nobj.o": pkg_mirage-net +: use_openflow +: pkg_cstruct +: pkg_cstruct.syntax +: pkg_re.str +: pkg_rpclib +: pkg_rpclib.json +: pkg_mirage +: pkg_mirage-net +"controller/learning_switch.nobj.o": custom # OASIS_STOP true: annot : syntax_camlp4o diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index f5ae290..6a6ae9d 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -47,7 +47,7 @@ type switch_state = { } let switch_data = - { mac_cache = Hashtbl.create 0;dpid = []; + { mac_cache = Hashtbl.create 1024;dpid = []; of_ctrl = []; req_count=(ref 0);} @@ -62,12 +62,6 @@ let datapath_join_cb controller dpid evt = let req_count = (ref 0) -let add_entry_in_hashtbl mac_cache ix in_port = - if not (Hashtbl.mem mac_cache ix ) then - Hashtbl.add mac_cache ix in_port - else - Hashtbl.replace mac_cache ix in_port - let packet_in_cb controller dpid evt = incr switch_data.req_count; let (in_port, buffer_id, data, dp) = @@ -79,8 +73,8 @@ let packet_in_cb controller dpid evt = let m = OP.Match.raw_packet_to_match in_port data in (* Store src mac address and incoming port *) - let ix = m.OP.Match.dl_src in - let _ = Hashtbl.replace switch_data.mac_cache ix in_port in +(* let ix = m.OP.Match.dl_src in + let _ = Hashtbl.replace switch_data.mac_cache ix in_port in *) (* check if I know the output port in order to define what type of message * we need to send *) @@ -139,7 +133,8 @@ let run () = Net.Manager.create (fun mgr interface id -> try_lwt let ip = - (ipv4_addr_of_tuple (10l,0l,0l,3l), +(* (ipv4_addr_of_tuple (10l,0l,0l,253l), *) + ( ipv4_addr_of_tuple (128l, 232l, 32l, 229l), ipv4_addr_of_tuple (255l,255l,255l,0l), []) in lwt _ = Manager.configure interface (`IPv4 ip) in OC.listen mgr (None, port) init diff --git a/gen_xen.sh b/gen_xen.sh new file mode 100644 index 0000000..52b4be0 --- /dev/null +++ b/gen_xen.sh @@ -0,0 +1 @@ +mir-build -b xen-native -o ./_build/controller/learning_switch.xen ./_build/controller/learning_switch.nobj.o diff --git a/learning_switch.cfg b/learning_switch.cfg new file mode 100644 index 0000000..1ad3729 --- /dev/null +++ b/learning_switch.cfg @@ -0,0 +1,6 @@ +kernel = "_build/controller/learning_switch.xen" +name = "learning_switch" +vif = [ 'mac=00:16:3e:11:33:44, bridge=xenbr0' ] +memory = 1024 +on_crash = "preserve" +on_exit = "preserve" diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index 5479442..a9a4fbf 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -27,6 +27,10 @@ let cp = pp "%s\n%!" let resolve t = Lwt.on_success t (fun _ -> ()) +let get_new_buffer len = + let buf = OS.Io_page.to_cstruct (OS.Io_page.get ()) in + Cstruct.sub buf 0 len + module Socket = struct type t = { sock: Channel.t; @@ -56,7 +60,7 @@ let rec read_data t len = match (len, !(t.data_cache)) with | (0, _) -> (* pp "| (0, _) ->\n%!"; *) - return (Cstruct.create 0) + return (get_new_buffer 0) | (_, []) -> (* pp " | (_, []) ->\n%!"; *) lwt data = Channel.read_some t.sock in @@ -66,7 +70,7 @@ let rec read_data t len = when ((List.fold_right (fun a b ->b+(Cstruct.len a)) tail (Cstruct.len head))>=len) -> ( (* pp "| (_, head::tail) when ((List.fold_right (f a b * ->b+(Cstruct.len b)) tail (Cstruct.len head)) >= len) ->\n%!"; *) - let ret = Cstruct.create len in + let ret = get_new_buffer len in let ret_len = ref 0 in let rec read_data_inner = function | head::tail when ((!ret_len + (Cstruct.len head)) < len) -> @@ -104,9 +108,10 @@ let rec read_data t len = | (_, _) -> (* pp "| (_, _) ->\n%!"; *) Printf.printf "read_data and not match found\n%!"; - return (Cstruct.create 0 ) + return (get_new_buffer 0 ) end +(* module Unix_socket = struct type t = { sock: Lwt_unix.file_descr; @@ -191,11 +196,12 @@ module Unix_socket = struct raise Net.Nettypes.Closed end + *) type conn_type = | Socket of Socket.t | Local of OP.t Lwt_stream.t * (OP.t option -> unit) - | Unix of Unix_socket.t +(* | Unix of Unix_socket.t *) type conn_state = { mutable dpid : OP.datapath_id; @@ -206,8 +212,8 @@ let init_socket_conn_state t = {dpid=0L;t=(Socket (Socket.create_socket t));} let init_local_conn_state input output = {dpid=0L;t=(Local (input, output));} -let init_unix_conn_state fd = - {dpid=0L;t=(Unix (Unix_socket.create_socket fd));} +(*let init_unix_conn_state fd = + {dpid=0L;t=(Unix (Unix_socket.create_socket fd));}*) let read_packet conn = match conn.t with @@ -218,13 +224,13 @@ let read_packet conn = lwt dbuf = Socket.read_data t dlen in let ofp = OP.parse ofh dbuf in return ofp - | Unix t -> +(* | Unix t -> lwt hbuf = Unix_socket.read_data t OP.Header.sizeof_ofp_header in let ofh = OP.Header.parse_header hbuf in let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in lwt dbuf = Unix_socket.read_data t dlen in let ofp = OP.parse ofh dbuf in - return ofp + return ofp *) | Local (input, _) -> match_lwt (Lwt_stream.get input) with | None -> raise Nettypes.Closed @@ -233,13 +239,13 @@ let read_packet conn = let send_packet conn ofp = match conn.t with | Socket t -> Socket.write_buffer t (OP.marshal ofp) - | Unix t -> Unix_socket.write_buffer t (OP.marshal ofp) +(* | Unix t -> Unix_socket.write_buffer t (OP.marshal ofp) *) | Local (_, output) -> return (output (Some ofp )) let send_data_raw t bits = match t.t with | Local _ -> failwith "send_of_data is not supported in Local mode" - | Unix t -> Unix_socket.write_buffer t bits +(* | Unix t -> Unix_socket.write_buffer t bits *) | Socket t -> Socket.write_buffer t bits let close conn = @@ -251,12 +257,12 @@ let close conn = with exn -> return (printf "[socket] close error: %s\n%!" (Printexc.to_string exn)) ) - | Unix t -> +(* | Unix t -> resolve ( try_lwt Unix_socket.close t with exn -> return (printf "[socket] close error: %s\n%!" (Printexc.to_string exn)) - ) + ) *) | Local (_, output) -> output None diff --git a/lib/ofsocket.mli b/lib/ofsocket.mli index 3c05748..e349003 100644 --- a/lib/ofsocket.mli +++ b/lib/ofsocket.mli @@ -25,7 +25,7 @@ type conn_state = { } val init_socket_conn_state : Channel.t -> conn_state -val init_unix_conn_state : Lwt_unix.file_descr -> conn_state +(* val init_unix_conn_state : Lwt_unix.file_descr -> conn_state *) val init_local_conn_state: Ofpacket.t Lwt_stream.t -> (Ofpacket.t option -> unit) -> conn_state val read_packet : conn_state -> Ofpacket.t Lwt.t diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 3889673..36c23fe 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -16,7 +16,7 @@ *) open Lwt -open Lwt_log +open OS open Net open Nettypes @@ -47,6 +47,10 @@ type device = string (* XXX placeholder! *) let resolve t = Lwt.on_success t (fun _ -> ()) +let get_new_buffer len = + let buf = OS.Io_page.to_cstruct (OS.Io_page.get ()) in + Cstruct.sub buf 0 len + module Entry = struct type table_counter = { n_active: uint32; @@ -135,10 +139,13 @@ module Table = struct if (t.OP.Flow_mod.of_match.OP.Match.wildcards=(OP.Wildcards.exact_match ())) then t.OP.Flow_mod.priority <- 0x1001 in - lwt _ = +(* lwt _ = log ~level:Notice + (sprintf "Adding flow %s" (OP.Match.match_to_string t.OP.Flow_mod.of_match)) in *) + let _ = + Console.log (sprintf "Adding flow %s" (OP.Match.match_to_string t.OP.Flow_mod.of_match)) in - let entry = Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); + let entry = Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); cache_entries=[];}) in let _ = Hashtbl.replace table.entries t.OP.Flow_mod.of_match entry in (* In the fast path table, I need to delete any conflicting entries *) @@ -190,10 +197,13 @@ module Table = struct * flow modification warnings *) Lwt_list.iter_s ( fun (of_match, flow) -> - lwt _ = +(* lwt _ = log ~level:Notice + (sprintf "Adding flow %s" (OP.Match.match_to_string of_match)) in *) + let _ = + Console.log (sprintf "Adding flow %s" (OP.Match.match_to_string of_match)) in - + match(t, flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) with | (Some t, true) -> let duration_sec = Int32.sub (Int32.of_float (OS.Clock.time ())) @@ -436,12 +446,11 @@ module Switch = struct in () in - let frame = Net.Frame.of_buffer bits (Cstruct.len bits) in match port with | OP.Port.Port(port) -> if Hashtbl.mem st.int_to_port port then( let out_p = (!( Hashtbl.find st.int_to_port port)) in - Net.Manager.inject_packet out_p.mgr out_p.ethif frame + Net.Manager.inject_packet out_p.mgr out_p.ethif bits ) else return (Printf.printf "Port %d not registered \n" port) @@ -452,7 +461,7 @@ module Switch = struct (fun port -> if(port.port_id != (OP.Port.int_of_port in_port)) then ( update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; - Net.Manager.inject_packet port.mgr port.ethif frame + Net.Manager.inject_packet port.mgr port.ethif bits ) else return () ) st.ports @@ -462,7 +471,7 @@ module Switch = struct (* let _ = printf "sending to port %d\n%!" port in *) let out_p = !(Hashtbl.find st.int_to_port port) in update_port_tx_stats (Int64.of_int (Cstruct.len bits)) out_p; - Net.Manager.inject_packet out_p.mgr out_p.ethif frame + Net.Manager.inject_packet out_p.mgr out_p.ethif bits else return (Printf.printf "Port %d not registered \n%!" port) | OP.Port.Local -> @@ -470,20 +479,19 @@ module Switch = struct if Hashtbl.mem st.int_to_port local_port_id then let out_p = !(Hashtbl.find st.int_to_port local_port_id) in let _ = update_port_tx_stats (Int64.of_int (Cstruct.len bits)) out_p in - let _ = Cstruct.hexdump (Net.Frame.get_whole_buffer frame) in - Net.Manager.inject_packet out_p.mgr out_p.ethif frame + Net.Manager.inject_packet out_p.mgr out_p.ethif bits else return (Printf.printf "Port %d not registered \n%!" local_port_id) | OP.Port.Controller -> begin let size = - if (Cstruct.len (Net.Frame.get_whole_buffer frame) > pkt_size) then + if (Cstruct.len bits > pkt_size) then pkt_size else - Cstruct.len (Net.Frame.get_whole_buffer frame) + Cstruct.len bits in let (h, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id:(-1l) ~in_port ~reason:OP.Packet_in.ACTION - ~data:(Cstruct.sub (Net.Frame.get_whole_buffer frame) 0 size) in + ~data:(Cstruct.sub bits 0 size) in (* let _ = printf "[ofswitch] sending packet to controller\n%!" in *) match st.controller with | None -> return () @@ -785,17 +793,21 @@ let process_openflow st t msg = let stats = OP.Stats.({st_ty=PORT; more_to_follow=false;}) in let r = OP.Stats.Port_resp(stats, [(!port).Switch.counter]) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in - Ofsocket.send_packet t (OP.Stats_resp (h, r)) + Ofsocket.send_packet t (OP.Stats_resp (h, r)) with Not_found -> (* TODO reply with right error code *) pr "Invalid port_id in stats\n%!"; - return () + let h = OP.Header.create ~xid OP.Header.ERROR + (OP.Header.get_len + 4) in + Ofsocket.send_packet t + (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) end - | _ -> - let bits = OP.marshal msg in + | _ -> begin let h = OP.Header.create ~xid OP.Header.ERROR - (OP.Header.get_len + 4 + (Cstruct.len bits)) in - Ofsocket.send_packet t (OP.Error (h, OP.REQUEST_BAD_SUBTYPE, bits)) + (OP.Header.get_len + 4) in + Ofsocket.send_packet t + (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) + end end | OP.Get_config_req(h) -> let resp = OP.Switch.init_switch_config in @@ -943,15 +955,17 @@ let add_port mgr ?(use_mac=false) sw ethif = (Manager.get_intf_mac mgr ethif)) in let _ = pr "Adding port %d (%s) '%s' \n %!" sw.Switch.portnum (Net.Manager.get_intf_name mgr ethif) hw_addr in - lwt _ = log ~level:Notice (sprintf "Adding port %s (port_id=%d)" ethif +(* lwt _ = log ~level:Notice (sprintf "Adding port %s (port_id=%d)" ethif + sw.Switch.portnum) in *) + let _ = Console.log (sprintf "Adding port %s (port_id=%d)" ethif sw.Switch.portnum) in - lwt _ = +(* lwt _ = if (use_mac) then lwt _ = Lwt_unix.system (sprintf "ifconfig tap0 lladdr %s" hw_addr) in return () else return () - in + in*) let port = Switch.init_port mgr sw.Switch.portnum ethif in sw.Switch.ports <- sw.Switch.ports @ [port]; Hashtbl.add sw.Switch.int_to_port sw.Switch.portnum (ref port); @@ -995,9 +1009,13 @@ let del_port mgr sw name = ~in_port:(port.Switch.port_id) () in lwt _ = Table.del_flow sw.Switch.table of_match OP.Port.No_port sw.Switch.controller in +(* lwt _ = log ~level:Notice (sprintf "Removing port %s (port_id=%d)" name port.Switch.port_id) in - lwt _ = + *) + let _ = Console.log (sprintf "Removing port %s (port_id=%d)" name + port.Switch.port_id) in + lwt _ = match sw.Switch.controller with | None -> return () | Some t -> Ofsocket.send_packet t (OP.Port_status (h,p)) @@ -1027,8 +1045,12 @@ let add_port_local mgr sw ethif = (List.filter (fun a -> (a.OP.Port.port_no <> local_port_id)) sw.Switch.features.OP.Switch.ports ) @ [port.Switch.phy]; +(* lwt _ = log ~level:Notice (sprintf "Adding port %s (port_id=%d)" ethif local_port_id) in + *) + let _ = Console.log (sprintf "Adding port %s (port_id=%d)" ethif + local_port_id) in let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw port) in return () @@ -1062,7 +1084,7 @@ let local_connect st mgr input output = (control_channel_run st conn t) <&> (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) - +(* let lwt_connect st ?(standalone=true) mgr loc = let of_ctrl = Ofswitch_standalone.init_controller () in @@ -1072,14 +1094,17 @@ let lwt_connect st ?(standalone=true) mgr loc = while_lwt true do let t,u = Lwt.task () in (( - lwt _ = log ~level:Notice "Standalone controller taking over..." in - lwt (switch_in, switch_out) = +(* lwt _ = log ~level:Notice "Standalone controller taking over..." in + * *) + let _ = Console.log "Standalone controller taking over..." in + lwt (switch_in, switch_out) = Ofswitch_standalone.run_controller mgr of_ctrl in let conn = Ofsocket.init_local_conn_state switch_in switch_out in let _ = st.Switch.controller <- (Some conn) in lwt _ = control_channel_run st conn t in - lwt _ = log ~level:Notice "Standalone controller stopped..." in - return () +(* lwt _ = log ~level:Notice "Standalone controller stopped..." in *) + let _ = Console.log "Standalone controller stopped..." in + return () ) <&> ( let rec connect_socket () = @@ -1100,7 +1125,9 @@ let lwt_connect st ?(standalone=true) mgr loc = let _ = wakeup u () in let t,_ = Lwt.task () in let _ = st.Switch.controller <- (Some conn) in - lwt _ = log ~level:Notice "Remote controller started..." in +(* lwt _ = log ~level:Notice "Remote controller started..." in *) + let _ = Console.log "Remote controller started..." in control_channel_run st conn t )) done + *) diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index aa03d3f..80fe03d 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -28,8 +28,10 @@ val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> unit Lwt.t val connect : t -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> unit Lwt.t +(* val lwt_connect : t -> ?standalone:bool -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> unit Lwt.t + *) val local_connect : t -> Net.Manager.t -> Ofpacket.t Lwt_stream.t -> (Ofpacket.t option -> unit ) -> unit Lwt.t diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index b454fa3..9ccca81 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -15,27 +15,10 @@ *) open Lwt -open Lwt_unix open Printf module OP = Ofpacket -type t = { - fd: Lwt_unix.file_descr; -} - -let connect_client () = - try_lwt - let sock = socket PF_INET SOCK_STREAM 0 in - let dst = ADDR_INET( (Unix.inet_addr_of_string "127.0.0.1"), - 6634) in - lwt _ = connect sock dst in - let cl = {fd=sock;} in - return cl - with ex -> - failwith (sprintf "ofswitch_config client failed: %s" - (Printexc.to_string ex)) - let parse_actions actions = let actions = Re_str.split (Re_str.regexp "/") actions in let split_action = Re_str.regexp ":" in @@ -212,9 +195,14 @@ let hashtbl_to_flow_match t = let listen_t mgr del_port get_stats add_flow del_flow port = - let listen_inner mgr st (input, output) = + let manage (dip,dpt) t = try_lwt - lwt req = Lwt_io.read_line input in + lwt req = Net.Channel.read_line t in + let req = + List.fold_right ( + fun a r -> + r ^ (Cstruct.to_string a) + ) req "" in let req = Jsonrpc.call_of_string req in lwt success = match (req.Rpc.name, req.Rpc.params) with @@ -279,14 +267,14 @@ let listen_t mgr del_port get_stats add_flow del_flow port = in let resp = Jsonrpc.string_of_response (Rpc.success success) in - lwt _ = Lwt_io.write_line output resp in - lwt _ = Lwt_io.close output in - lwt _ = Lwt_io.close input in + let _ = Net.Channel.write_line t resp in + lwt _ = Net.Channel.flush t in + lwt _ = Net.Channel.close t in return () with | End_of_file -> return () | exn -> - lwt _ = Lwt_log.log ~exn ~level:Lwt_log.Notice + let _ = OS.Console.log "[ofswitch_config] server error" in (* let resp = Jsonrpc.string_of_response (Rpc.failure (Rpc.Enum [(Rpc.String "false")])) in @@ -297,8 +285,6 @@ let listen_t mgr del_port get_stats add_flow del_flow port = in - let addr = Unix.ADDR_INET(Unix.inet_addr_any, 6634) in - let _ = Lwt_io.establish_server addr - (fun a -> Lwt.ignore_result (listen_inner mgr del_port a) ) in + let _ = Net.Channel.listen mgr (`TCPv4 ((None, 6634), manage )) in return () diff --git a/lib/ofswitch_config.mli b/lib/ofswitch_config.mli index 63d8bfe..fbd661a 100644 --- a/lib/ofswitch_config.mli +++ b/lib/ofswitch_config.mli @@ -14,9 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -type t - -val connect_client: unit -> t Lwt.t val listen_t: Net.Manager.t -> (string -> unit Lwt.t) -> (Ofpacket.Match.t -> Ofpacket.Flow.stats list) -> diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 3c07a58..8cf86aa 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: f4b06c69116042e630ee6632523090bb) *) +(* DO NOT EDIT (digest: 37a5173c93faee9d5357566cf874a3b7) *) module OASISGettext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -234,19 +234,21 @@ module MyOCamlbuildFindlib = struct Ocamlbuild_pack.Lexers.blank_sep_strings let split s ch = - let x = - ref [] + let buf = Buffer.create 13 in + let x = ref [] in + let flush () = + x := (Buffer.contents buf) :: !x; + Buffer.clear buf in - let rec go s = - let pos = - String.index s ch - in - x := (String.before s pos)::!x; - go (String.after s (pos + 1)) - in - try - go s - with Not_found -> !x + String.iter + (fun c -> + if c = ch then + flush () + else + Buffer.add_char buf c) + s; + flush (); + List.rev !x let split_nl s = split s '\n' @@ -281,17 +283,27 @@ module MyOCamlbuildFindlib = struct (* When one link an OCaml library/binary/package, one should use -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + flag ["ocaml"; "link"; "output_obj"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> - flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; + let base_args = [A"-package"; A pkg] in + let syn_args = [A"-syntax"; A "camlp4o"] in + let args = + (* heuristic to identify syntax extensions: + whether they end in ".syntax"; some might not *) + if Filename.check_suffix pkg "syntax" + then syn_args @ base_args + else base_args + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; end (find_packages ()); @@ -323,7 +335,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +351,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { @@ -452,6 +464,24 @@ module MyOCamlbuildBase = struct ) t.lib_c; + (* Add output_obj rules mapped to .nobj.o *) + let native_output_obj x = + OC.link_gen "cmx" "cmxa" !Options.ext_lib [!Options.ext_obj; "cmi"] + OC.ocamlopt_link_prog + (fun tags -> tags++"ocaml"++"link"++"native"++"output_obj") x + in + rule "ocaml: cmx* and o* -> .nobj.o" ~prod:"%.nobj.o" ~deps:["%.cmx"; "%.o"] + (native_output_obj "%.cmx" "%.nobj.o"); + + (* Add output_obj rules mapped to .bobj.o *) + let bytecode_output_obj x = + OC.link_gen "cmo" "cma" !Options.ext_lib [!Options.ext_obj; "cmi"] + OC.ocamlc_link_prog + (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") x + in + rule "ocaml: cmo* -> .nobj.o" ~prod:"%.bobj.o" ~deps:["%.cmo"] + (bytecode_output_obj "%.cmo" "%.bobj.o"); + (* Add flags *) List.iter (fun (tags, cond_specs) -> @@ -473,7 +503,7 @@ module MyOCamlbuildBase = struct end -# 476 "myocamlbuild.ml" +# 506 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -486,6 +516,6 @@ let package_default = let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 490 "myocamlbuild.ml" +# 520 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index fc709ac..5323dfb 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ -(* setup.ml generated for the first time by OASIS v0.3.0 *) +(* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 8b22b77c339892f41163315dc3f8e58d) *) +(* DO NOT EDIT (digest: 4cd0a948b0709058a2f443a0f166b18f) *) (* - Regenerated by OASIS v0.3.0 + Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISString.ml" *) +(* # 1 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 71 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) @@ -964,6 +964,8 @@ module OASISTypes = struct type compiled_object = | Byte | Native + | Native_object + | Bytecode_object | Best @@ -1018,7 +1020,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 104 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1066,6 +1068,13 @@ module OASISTypes = struct lib_findlib_containers: findlib_name list; } + + type object_ = + { + obj_modules: string list; + obj_findlib_fullname: findlib_name list option; + } + type executable = { exec_custom: bool; @@ -1126,6 +1135,7 @@ module OASISTypes = struct type section = | Library of common_section * build_section * library + | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository @@ -1134,7 +1144,7 @@ module OASISTypes = struct type section_kind = - [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { @@ -1176,7 +1186,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1260,7 +1270,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISHostPath.ml" *) open Filename @@ -1293,7 +1303,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1301,6 +1311,8 @@ module OASISSection = struct function | Library (cs, _, _) -> `Library, cs + | Object (cs, _, _) -> + `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> @@ -1318,6 +1330,7 @@ module OASISSection = struct let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) + | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) @@ -1338,6 +1351,7 @@ module OASISSection = struct in (match k with | `Library -> "library" + | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" @@ -1372,12 +1386,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1390,6 +1404,8 @@ module OASISExecutable = struct let is_native_exec = match bs.bs_compiled_object with | Native -> true + | Native_object -> false + | Bytecode_object -> false | Best -> is_native () | Byte -> false in @@ -1408,30 +1424,15 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - library * - group_t list) - (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists (cs, bs, lib) modul = + let find_module source_file_exists bs modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) @@ -1472,7 +1473,7 @@ module OASISLibrary = struct let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> - match find_module source_file_exists (cs, bs, lib) modul with + match find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> @@ -1496,7 +1497,7 @@ module OASISLibrary = struct let find_modules lst ext = let find_module modul = - match find_module source_file_exists (cs, bs, lib) modul with + match find_module source_file_exists bs modul with | `Sources (base_fn, _) -> [base_fn] | `No_sources lst -> @@ -1531,6 +1532,8 @@ module OASISLibrary = struct (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true + | Native_object -> false + | Bytecode_object -> false | Best -> is_native | Byte -> false in @@ -1568,11 +1571,11 @@ module OASISLibrary = struct [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with - | Native -> + | Native | Native_object -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) - | Byte | Best -> + | Byte | Bytecode_object | Best -> byte acc_nopath in @@ -1598,7 +1601,100 @@ module OASISLibrary = struct acc_nopath) (headers @ cmxs) - type data = common_section * build_section * library +end + +module OASISObject = struct +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISObject.ml" *) + + open OASISTypes + open OASISGettext + + let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = + List.fold_left + (fun acc modul -> + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name; + acc) + [] + obj.obj_modules + + + let generated_unix_files + ~ctxt + ~is_native + ~source_file_exists + (cs, bs, obj) = + + let find_module ext modul = + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, _) -> [base_fn ^ ext] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name ; + lst + in + + let header, byte, native, c_object, f = + match obj.obj_modules with + | [ m ] -> (find_module ".cmi" m, + find_module ".cmo" m, + find_module ".cmx" m, + find_module ".o" m, + fun x -> x) + | _ -> ([cs.cs_name ^ ".cmi"], + [cs.cs_name ^ ".cmo"], + [cs.cs_name ^ ".cmx"], + [cs.cs_name ^ ".o"], + OASISUnixPath.concat bs.bs_path) + in + List.map (List.map f) ( + match bs.bs_compiled_object with + | Native | Native_object -> + native :: c_object :: byte :: header :: [] + | Best when is_native -> + native :: c_object :: byte :: header :: [] + | Byte | Bytecode_object | Best -> + byte :: header :: []) + +end + +module OASISFindlib = struct +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISFindlib.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + [`Library of library | `Object of object_] * + group_t list) + + type data = common_section * + build_section * + [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data @@ -1641,6 +1737,23 @@ module OASISLibrary = struct mp end + | Object (cs, _, obj) -> + begin + let obj_name = cs.cs_name in + if MapString.mem obj_name mp then + failwithf + (f_ "The object name '%s' is used more than once.") + obj_name; + let findlib_full_name = match obj.obj_findlib_fullname with + | Some ns -> String.concat "." ns + | None -> obj_name + in + MapString.add + obj_name + (`Solved findlib_full_name) + mp + end + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty @@ -1778,7 +1891,9 @@ module OASISLibrary = struct (fun mp -> function | Library (cs, bs, lib) -> - add (cs, bs, lib) mp + add (cs, bs, `Library lib) mp + | Object (cs, bs, obj) -> + add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty @@ -1841,32 +1956,32 @@ module OASISLibrary = struct end module OASISFlag = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -1944,7 +2059,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2139,9 +2254,9 @@ module OASISFileUtil = struct end -# 2142 "setup.ml" +# 2257 "setup.ml" module BaseEnvLight = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2237,9 +2352,9 @@ module BaseEnvLight = struct end -# 2240 "setup.ml" +# 2355 "setup.ml" module BaseContext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseContext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseContext.ml" *) open OASISContext @@ -2250,7 +2365,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseMessage.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2384,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnv.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2729,7 +2844,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2757,7 +2872,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseCheck.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2883,7 +2998,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -2999,7 +3114,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3363,7 +3478,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3411,7 +3526,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseLog.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseLog.ml" *) open OASISUtils @@ -3530,7 +3645,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3541,6 +3656,7 @@ module BaseBuilt = struct | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) + | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = @@ -3549,6 +3665,7 @@ module BaseBuilt = struct | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" + | BObj -> "obj" | BDoc -> "doc")^ "_"^nm @@ -3612,6 +3729,8 @@ module BaseBuilt = struct (f_ "executable %s") | BLib -> (f_ "library %s") + | BObj -> + (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); @@ -3674,10 +3793,27 @@ module BaseBuilt = struct in evs, unix_lst + + let of_object ffn (cs, bs, obj) = + let unix_lst = + OASISObject.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + (cs, bs, obj) + in + let evs = + [BObj, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + end module BaseCustom = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseCustom.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3727,7 +3863,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3768,13 +3904,13 @@ module BaseDynVar = struct (f_ "Executable '%s' not yet built.") cs.cs_name))))) - | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseTest.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3864,7 +4000,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseDoc.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -3899,7 +4035,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseSetup.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4146,6 +4282,7 @@ module BaseSetup = struct (f t.package (cs, doc)) args | Library _ + | Object _ | Executable _ | Flag _ | SrcRepo _ -> @@ -4477,9 +4614,9 @@ module BaseSetup = struct end -# 4480 "setup.ml" +# 4617 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4656,6 +4793,20 @@ module InternalConfigurePlugin = struct | None -> () end; + (* Make sure the findlib version is fine for the OCaml compiler. *) + begin + let ocaml_ge4 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) + (OASISVersion.version_of_string "4.0.0") >= 0 in + if ocaml_ge4 then + let findlib_lt132 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) + (OASISVersion.version_of_string "1.3.2") < 0 in + if findlib_lt132 then + add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" + end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || @@ -4721,7 +4872,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -4731,7 +4882,7 @@ module InternalInstallPlugin = struct open BaseStandardVar open BaseMessage open OASISTypes - open OASISLibrary + open OASISFindlib open OASISGettext open OASISUtils @@ -4741,6 +4892,9 @@ module InternalInstallPlugin = struct let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) + let obj_hook = + ref (fun (cs, bs, obj) -> cs, bs, obj, []) + let doc_hook = ref (fun (cs, doc) -> cs, doc) @@ -4961,6 +5115,75 @@ module InternalInstallPlugin = struct begin (f_data, acc) end + and files_of_object (f_data, acc) data_obj = + let cs, bs, obj, obj_extra = + !obj_hook data_obj + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then + begin + let acc = + (* Start with acc + obj_extra *) + List.rev_append obj_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + acc + end) + acc + obj.obj_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BObj + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the object *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + in (* Install one group of library *) @@ -4971,8 +5194,10 @@ module InternalInstallPlugin = struct match grp with | Container (_, children) -> data_and_files, children - | Package (_, cs, bs, lib, children) -> + | Package (_, cs, bs, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children + | Package (_, cs, bs, `Object obj, children) -> + files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux @@ -5230,9 +5455,9 @@ module InternalInstallPlugin = struct end -# 5233 "setup.ml" +# 5458 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5559,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5365,6 +5590,19 @@ module OCamlbuildPlugin = struct in_build_dir (OASISHostPath.of_unix fn) in + (* Checks if the string [fn] ends with [nd] *) + let ends_with nd fn = + let nd_len = + String.length nd + in + (String.length fn >= nd_len) + && + (String.sub + fn + (String.length fn - nd_len) + nd_len) = nd + in + let cond_targets = List.fold_left (fun acc -> @@ -5377,18 +5615,6 @@ module OCamlbuildPlugin = struct (cs, bs, lib) in - let ends_with nd fn = - let nd_len = - String.length nd - in - (String.length fn >= nd_len) - && - (String.sub - fn - (String.length fn - nd_len) - nd_len) = nd - in - let tgts = List.flatten (List.filter @@ -5413,6 +5639,35 @@ module OCamlbuildPlugin = struct cs.cs_name end + | Object (cs, bs, obj) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_object + in_build_dir_of_unix + (cs, bs, obj) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ".cmo" fn + || ends_with ".cmx" fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for object %s") + cs.cs_name + end + | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = @@ -5444,8 +5699,12 @@ module OCamlbuildPlugin = struct (* Add executable *) let acc = match bs.bs_compiled_object with + | Native_object -> + (target ".nobj.o") :: acc + | Bytecode_object -> + (target ".bobj.o") :: acc | Native -> - (target ".native") :: acc + (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte @@ -5455,7 +5714,7 @@ module OCamlbuildPlugin = struct acc end - | Library _ | Executable _ | Test _ + | Library _ | Object _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] @@ -5507,7 +5766,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5555,7 +5814,7 @@ module OCamlbuildDocPlugin = struct end -# 5558 "setup.ml" +# 5817 "setup.ml" open OASISTypes;; let setup_t = @@ -5845,15 +6104,49 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - {exec_custom = true; exec_main_is = "basic_switch.ml"; }) + {exec_custom = true; exec_main_is = "basic_switch.ml"; }); + Executable + ({ + cs_name = "learning_switch_mirage.o"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "mirage", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "controller"; + bs_compiled_object = Native_object; + bs_build_depends = + [ + FindlibPackage ("cstruct", None); + FindlibPackage ("cstruct.syntax", None); + InternalLibrary "openflow" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = true; exec_main_is = "learning_switch.ml"; + }) ]; plugins = [(`Extra, "META", Some "0.2")]; schema_data = PropList.Data.create (); plugin_data = []; }; oasis_fn = Some "_oasis"; - oasis_version = "0.3.0"; - oasis_digest = Some "¦Ú\150Øù+#\025\143\018f\022BÙø?"; + oasis_version = "0.3.1"; + oasis_digest = + Some "K\197R\003\255\007\214\027\159\246\230\175,\236m\247"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5861,6 +6154,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5865 "setup.ml" +# 6158 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 6651fdb19de82f8980f4cf1294358b7690c5b41d Mon Sep 17 00:00:00 2001 From: crotsos Date: Sun, 13 Jan 2013 17:05:29 +0000 Subject: [PATCH 32/75] fixing the code for unix backend --- controller/learning_switch.ml | 4 +- lib/ofcontroller.ml | 14 ++--- lib/ofsocket.ml | 88 ++++++++++++++++++-------------- lib/ofswitch.ml | 21 ++++---- myocamlbuild.ml | 14 ++--- setup.ml | 96 +++++++++++++++++------------------ 6 files changed, 123 insertions(+), 114 deletions(-) diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index f5ae290..8fe5ceb 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -47,7 +47,7 @@ type switch_state = { } let switch_data = - { mac_cache = Hashtbl.create 0;dpid = []; + { mac_cache = Hashtbl.create 2048;dpid = []; of_ctrl = []; req_count=(ref 0);} @@ -80,7 +80,7 @@ let packet_in_cb controller dpid evt = (* Store src mac address and incoming port *) let ix = m.OP.Match.dl_src in - let _ = Hashtbl.replace switch_data.mac_cache ix in_port in + let _ = Hashtbl.add switch_data.mac_cache ix in_port in (* check if I know the output port in order to define what type of message * we need to send *) diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 812db68..57f3fb8 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -157,7 +157,7 @@ let process_of_packet state conn ofp = send_packet conn (OP.Features_req (h) ) end | Echo_req h -> begin (* Reply to ECHO requests *) - cp "ECHO_REQ"; +(* cp "ECHO_REQ"; *) let h = OP.Header.(create ~xid:h.xid ECHO_RESP get_len) in send_packet conn (OP.Echo_resp h) end @@ -278,7 +278,7 @@ let controller_run st conn = while_lwt !continue do try_lwt lwt pkt = read_packet conn in - process_of_packet st conn pkt + process_of_packet st conn pkt with | Nettypes.Closed -> begin let _ = printf "XXXXX switch disconnected\n%!" in @@ -289,11 +289,9 @@ let controller_run st conn = let _ = cp (sp "# unparsed! m=%s" m) in return (Cstruct.hexdump bs) | Not_found -> - return (Printf.printf "Error: Not found %s\n%!" - (Printexc.get_backtrace ()) ) + return (Printf.printf "Error:Not found\n%!") | exn -> - pp "{OpenFlow-controller} ERROR:%s\n%s\n%!" (Printexc.to_string exn) - (Printexc.get_backtrace ()); + pp "{OpenFlow-controller} ERROR:%s\n%!" (Printexc.to_string ()); return (continue := false) done in @@ -305,9 +303,7 @@ let controller_run st conn = return () else return () - - - + let socket_controller st (remote_addr, remote_port) t = let rs = Nettypes.ipv4_addr_to_string remote_addr in let _ = pp "OpenFlow Controller+ %s:%d\n%!" rs remote_port in diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index 5479442..48f7a58 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -30,17 +30,20 @@ let resolve t = Lwt.on_success t (fun _ -> ()) module Socket = struct type t = { sock: Channel.t; - data_cache: Cstruct.t list ref; + mutable data_cache: Cstruct.t list; } let create_socket sock = - { sock; data_cache=(ref []);} + { sock; data_cache=[];} let write_buffer t bits = +(* match (Cstruct.len bits) with | l when l <= 1400 -> + *) let _ = Channel.write_buffer t.sock bits in Channel.flush t.sock +(* | _ -> let buf = Cstruct.sub bits 0 1400 in let _ = Channel.write_buffer t.sock buf in @@ -48,63 +51,55 @@ let write_buffer t bits = let _ = Channel.write_buffer t.sock buf in lwt _ = Channel.flush t.sock in return () + *) let close t = Channel.close t.sock + let cache_size t = + List.fold_right ( + fun a r -> + r + (Cstruct.len a) ) t.data_cache 0 + let rec read_data t len = (* Printf.printf "let rec read_data t data_cache %d = \n%!" len; *) - match (len, !(t.data_cache)) with + match (len, t.data_cache) with | (0, _) -> (* pp "| (0, _) ->\n%!"; *) return (Cstruct.create 0) - | (_, []) -> -(* pp " | (_, []) ->\n%!"; *) - lwt data = Channel.read_some t.sock in - t.data_cache := [data]; - read_data t len - | (_, head::tail) - when ((List.fold_right (fun a b ->b+(Cstruct.len a)) tail (Cstruct.len head))>=len) -> ( + | (_, head::tail) when ((cache_size t) >=len) -> ( (* pp "| (_, head::tail) when ((List.fold_right (f a b * ->b+(Cstruct.len b)) tail (Cstruct.len head)) >= len) ->\n%!"; *) let ret = Cstruct.create len in - let ret_len = ref 0 in - let rec read_data_inner = function - | head::tail when ((!ret_len + (Cstruct.len head)) < len) -> - let _ = Cstruct.blit head 0 ret !ret_len (Cstruct.len head) in - ret_len := !ret_len + (Cstruct.len head); - read_data_inner tail - | head::tail when ((!ret_len + (Cstruct.len head)) = len) -> - let _ = Cstruct.blit head 0 ret !ret_len (Cstruct.len head) in - ret_len := !ret_len + (Cstruct.len head); - t.data_cache := tail; - return () - | head::tail when ((!ret_len + (Cstruct.len head)) > len) -> + let rec read_data_inner off = function + | head::tail when ((off + (Cstruct.len head)) < len) -> + let sz = Cstruct.len head in + let _ = Cstruct.blit head 0 ret off sz in + read_data_inner (off + sz) tail + | head::tail when ((off + (Cstruct.len head)) = len) -> + let len = Cstruct.len head in + let _ = Cstruct.blit head 0 ret off sz in + t.data_cache <- tail + | head::tail when ((off + (Cstruct.len head)) > len) -> let len_rest = len - !ret_len in - let _ = Cstruct.blit head 0 ret !ret_len len_rest in + let _ = Cstruct.blit head 0 ret off len_rest in let head = Cstruct.shift head len_rest in - ret_len := !ret_len + len_rest; - t.data_cache := [head] @ tail; - return () + t.data_cache <- head::tail | rest -> pp "read_data:Invalid state(req_len:%d,read_len:%d,avail_data:%d)\n%!" - len !ret_len (List.fold_right (fun a b -> b + (Cstruct.len a)) rest 0); + len off (List.fold_right (fun a b -> b + (Cstruct.len a)) rest 0); raise ReadError in - lwt _ = read_data_inner !(t.data_cache) in + let _ = read_data_inner 0 t.data_cache in let ret = Cstruct.sub ret 0 len in return (ret) ) - | (_, head::tail) - when ((List.fold_right (fun a b ->b+(Cstruct.len a)) tail (Cstruct.len head)) < len) -> ( + | (_, _) -> begin (* pp "| (_, head::tail) when ((List.fold_right (f a b ->b+(Cstruct.len * b)) tail (Cstruct.len head)) < len) ->\n%!"; *) lwt data = Channel.read_some t.sock in t.data_cache := !(t.data_cache) @ [data]; - read_data t len) - | (_, _) -> -(* pp "| (_, _) ->\n%!"; *) - Printf.printf "read_data and not match found\n%!"; - return (Cstruct.create 0 ) + read_data t len + end end module Unix_socket = struct @@ -120,7 +115,8 @@ module Unix_socket = struct let rec write_buffer_inner t bits = function | len when len >= (Cstruct.len bits) -> return () | len -> - lwt l = Lwt_bytes.write t.sock bits.Cstruct.buffer (bits.Cstruct.off + len) ((Cstruct.len bits) - len) in + lwt l = Lwt_bytes.write t.sock bits.Cstruct.buffer + (bits.Cstruct.off + len) ((Cstruct.len bits) - len) in let _ = if (l = 0) then raise Net.Nettypes.Closed @@ -212,10 +208,18 @@ let init_unix_conn_state fd = let read_packet conn = match conn.t with | Socket t -> - lwt hbuf = Socket.read_data t OP.Header.sizeof_ofp_header in + lwt hbuf = Socket.read_data t OP.Header.sizeof_ofp_header in +(* lwt hbuf = Channel.read_some ~len:OP.Header.sizeof_ofp_header + * t.Socket.sock in *) let ofh = OP.Header.parse_header hbuf in let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in lwt dbuf = Socket.read_data t dlen in +(* lwt dbuf = + if (dlen = 0) then + return (Cstruct.create 0) + else + Channel.read_some ~len:dlen t.Socket.sock + in*) let ofp = OP.parse ofh dbuf in return ofp | Unix t -> @@ -232,7 +236,10 @@ let read_packet conn = let send_packet conn ofp = match conn.t with - | Socket t -> Socket.write_buffer t (OP.marshal ofp) + | Socket t -> + (* Socket.write_buffer t (OP.marshal ofp) *) + let _ = Channel.write_buffer t.Socket.sock (OP.marshal ofp) in + Channel.flush t.Socket.sock | Unix t -> Unix_socket.write_buffer t (OP.marshal ofp) | Local (_, output) -> return (output (Some ofp )) @@ -240,7 +247,10 @@ let send_data_raw t bits = match t.t with | Local _ -> failwith "send_of_data is not supported in Local mode" | Unix t -> Unix_socket.write_buffer t bits - | Socket t -> Socket.write_buffer t bits + | Socket t -> + (* Socket.write_buffer t bits *) + let _ = Channel.write_buffer t.Socket.sock bits in + Channel.flush t.Socket.sock let close conn = match conn.t with diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 3889673..184e0ec 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -436,12 +436,12 @@ module Switch = struct in () in - let frame = Net.Frame.of_buffer bits (Cstruct.len bits) in match port with | OP.Port.Port(port) -> if Hashtbl.mem st.int_to_port port then( let out_p = (!( Hashtbl.find st.int_to_port port)) in - Net.Manager.inject_packet out_p.mgr out_p.ethif frame + Net.Manager.inject_packet out_p.mgr out_p.ethif bits + (*Net.Ethif.write (Net.Manager.get_netif out_p.mgr out_p.ethif) bits*) ) else return (Printf.printf "Port %d not registered \n" port) @@ -452,7 +452,8 @@ module Switch = struct (fun port -> if(port.port_id != (OP.Port.int_of_port in_port)) then ( update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; - Net.Manager.inject_packet port.mgr port.ethif frame + Net.Manager.inject_packet port.mgr port.ethif bits +(* Net.Ethif.write (Net.Manager.get_netif port.mgr port.ethif) bits*) ) else return () ) st.ports @@ -462,7 +463,8 @@ module Switch = struct (* let _ = printf "sending to port %d\n%!" port in *) let out_p = !(Hashtbl.find st.int_to_port port) in update_port_tx_stats (Int64.of_int (Cstruct.len bits)) out_p; - Net.Manager.inject_packet out_p.mgr out_p.ethif frame + Net.Manager.inject_packet out_p.mgr out_p.ethif bits +(* Net.Ethif.write (Net.Manager.get_netif out_p.mgr out_p.ethif) bits*) else return (Printf.printf "Port %d not registered \n%!" port) | OP.Port.Local -> @@ -470,20 +472,21 @@ module Switch = struct if Hashtbl.mem st.int_to_port local_port_id then let out_p = !(Hashtbl.find st.int_to_port local_port_id) in let _ = update_port_tx_stats (Int64.of_int (Cstruct.len bits)) out_p in - let _ = Cstruct.hexdump (Net.Frame.get_whole_buffer frame) in - Net.Manager.inject_packet out_p.mgr out_p.ethif frame + Net.Manager.inject_packet out_p.mgr out_p.ethif bits +(* Net.Ethif.write (Net.Manager.get_netif out_p.mgr out_p.ethif) + * bits*) else return (Printf.printf "Port %d not registered \n%!" local_port_id) | OP.Port.Controller -> begin let size = - if (Cstruct.len (Net.Frame.get_whole_buffer frame) > pkt_size) then + if (Cstruct.len bits > pkt_size) then pkt_size else - Cstruct.len (Net.Frame.get_whole_buffer frame) + Cstruct.len bits in let (h, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id:(-1l) ~in_port ~reason:OP.Packet_in.ACTION - ~data:(Cstruct.sub (Net.Frame.get_whole_buffer frame) 0 size) in + ~data:(Cstruct.sub bits 0 size) in (* let _ = printf "[ofswitch] sending packet to controller\n%!" in *) match st.controller with | None -> return () diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 3c07a58..d7f908b 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: f4b06c69116042e630ee6632523090bb) *) +(* DO NOT EDIT (digest: eb256e7e5e2662771dedb4bce0bc0cc9) *) module OASISGettext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index fc709ac..e492e50 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 8b22b77c339892f41163315dc3f8e58d) *) +(* DO NOT EDIT (digest: c13b37c4403b506e70e67de9eb00f5b7) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISString.ml" *) +(* # 1 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 71 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 102 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseContext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseMessage.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnv.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseCheck.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseLog.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseLog.ml" *) open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseCustom.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseTest.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseDoc.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseSetup.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5853,7 +5853,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "¦Ú\150Øù+#\025\143\018f\022BÙø?"; + oasis_digest = Some "\166\218\150\216\249+#\025\143\018f\022B\217\248?"; oasis_exec = None; oasis_setup_args = []; setup_update = false; From d990a759bb47a8fd528cf80d07612fa6488860fa Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 17 Jan 2013 00:50:33 +0000 Subject: [PATCH 33/75] fixing compilation for xen --- controller/learning_switch.ml | 18 +++--- lib/ofcontroller.ml | 70 +++++++++++++++-------- lib/ofpacket.ml | 2 +- lib/ofsocket.ml | 101 +++++++++++----------------------- myocamlbuild.ml | 14 ++--- setup.ml | 98 ++++++++++++++++----------------- 6 files changed, 146 insertions(+), 157 deletions(-) diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index 036a58b..ac77a61 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -41,14 +41,14 @@ type mac_switch = { type switch_state = { (* mutable mac_cache: (mac_switch, OP.Port.t) Hashtbl.t; *) mutable mac_cache: (OP.eaddr, OP.Port.t) Hashtbl.t; - mutable dpid: OP.datapath_id list; - mutable of_ctrl: OC.t list; +(* mutable dpid: OP.datapath_id list; + mutable of_ctrl: OC.t list; *) req_count: int ref; } let switch_data = - { mac_cache = Hashtbl.create 2048;dpid = []; - of_ctrl = []; req_count=(ref 0);} + { mac_cache = Hashtbl.create 2048; (* dpid = []; + of_ctrl = []; *) req_count=(ref 0);} let datapath_join_cb controller dpid evt = @@ -57,7 +57,7 @@ let datapath_join_cb controller dpid evt = | OE.Datapath_join (c, _) -> c | _ -> invalid_arg "bogus datapath_join event match!" in - switch_data.dpid <- switch_data.dpid @ [dp]; +(* switch_data.dpid <- switch_data.dpid @ [dp]; *) return (pp "+ datapath:0x%012Lx\n" dp) let req_count = (ref 0) @@ -120,8 +120,8 @@ let packet_in_cb controller dpid evt = ) let init controller = - if (not (List.mem controller switch_data.of_ctrl)) then - switch_data.of_ctrl <- (([controller] @ switch_data.of_ctrl)); +(* if (not (List.mem controller switch_data.of_ctrl)) then + switch_data.of_ctrl <- (([controller] @ switch_data.of_ctrl));*) pp "test controller register datapath cb\n"; OC.register_cb controller OE.DATAPATH_JOIN datapath_join_cb; pp "test controller register packet_in cb\n"; @@ -133,8 +133,8 @@ let run () = Net.Manager.create (fun mgr interface id -> try_lwt let ip = -(* (ipv4_addr_of_tuple (10l,0l,0l,253l), *) - ( ipv4_addr_of_tuple (128l, 232l, 32l, 229l), +(* (ipv4_addr_of_tuple (10l,0l,0l,253l), *) + ( ipv4_addr_of_tuple (128l, 232l, 32l, 230l), ipv4_addr_of_tuple (255l,255l,255l,0l), []) in lwt _ = Manager.configure interface (`IPv4 ip) in OC.listen mgr (None, port) init diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index d6734a1..c2e4cd9 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -152,12 +152,12 @@ let process_of_packet state conn ofp = match ofp with | Hello (h) -> begin (* Reply to HELLO with a HELLO and a feature request *) let _ = cp "HELLO" in - lwt _ = send_packet conn (OP.Hello (h)) in + lwt _ = send_packet conn (OP.Hello (h)) in let h = OP.Header.create OP.Header.FEATURES_REQ OP.Header.get_len in - send_packet conn (OP.Features_req (h) ) + send_packet conn (OP.Features_req (h) ) end | Echo_req h -> begin (* Reply to ECHO requests *) -(* cp "ECHO_REQ"; *) + let _ = cp "ECHO_REQ" in let h = OP.Header.(create ~xid:h.xid ECHO_RESP get_len) in send_packet conn (OP.Echo_resp h) end @@ -165,6 +165,7 @@ let process_of_packet state conn ofp = cp "FEATURES_RESP"; let dpid = sfs.Switch.datapath_id in let _ = conn.dpid <- dpid in + let evt = Event.Datapath_join (dpid, sfs.Switch.ports) in let _ = if (Hashtbl.mem state.dp_db dpid) then @@ -172,17 +173,22 @@ let process_of_packet state conn ofp = in let _ = Hashtbl.replace state.dp_db dpid conn in Lwt_list.iter_p (fun cb -> cb state dpid evt) state.datapath_join_cb + +(* return () *) end | Packet_in (h, p) -> begin (* Generate a packet_in event *) (* cp (sp "+ %s|%s" (OP.Header.header_to_string h) (OP.Packet_in.packet_in_to_string p)); *) - let evt = Event.Packet_in ( +(* + let evt = Event.Packet_in ( p.Packet_in.in_port, p.Packet_in.buffer_id, p.Packet_in.data, conn.dpid) - in + in iter_p (fun cb -> cb state conn.dpid evt) state.packet_in_cb + *) + return () end | Flow_removed (h, p) -> (cp (sp "+ %s|%s" @@ -247,7 +253,7 @@ let process_of_packet state conn ofp = in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_status_cb end - | _ -> + | ofp -> let _ = OS.Console.log (sp "Packet type not supported %s" (OP.to_string ofp)) in return () @@ -263,7 +269,7 @@ let send_data controller dpid ofp = let mem_dbg name = -(* Gc.compact (); *) + Gc.compact (); let s = Gc.stat () in Printf.printf "blocks %s: l=%d f=%d \n %!" name s.Gc.live_blocks s.Gc.free_blocks @@ -272,28 +278,46 @@ let terminate st = (fun _ c -> Ofsocket.close c ) st.dp_db in Printf.printf "Terminating controller...\n%!" + +let main_loop st conn = + while_lwt true do + lwt ofp = read_packet conn in + lwt _ = + process_of_packet st conn ofp + in + return () + done + let controller_run st conn = - let continue = ref true in + lwt ofp = read_packet conn in + lwt _ = + process_of_packet st conn ofp + in + lwt ofp = read_packet conn in + lwt _ = + process_of_packet st conn ofp + in lwt _ = - while_lwt !continue do - try_lwt - lwt pkt = read_packet conn in - process_of_packet st conn pkt - with +(* try_lwt *) + main_loop st conn + +(* + with | Nettypes.Closed -> begin - let _ = printf "XXXXX switch disconnected\n%!" in - return (continue := false) + let _ = printf "XXXXX switch disconnected\n%!" in + return () end | OP.Unparsed(m, bs) | OP.Unparsable(m, bs) -> - let _ = cp (sp "# unparsed! m=%s" m) in - return (Cstruct.hexdump bs) - | Not_found -> - return (Printf.printf "Error:Not found\n%!") - | exn -> - pp "{OpenFlow-controller} ERROR:%s\n%!" (Printexc.to_string exn); - return (continue := false) - done + let _ = cp (sp "# unparsed! m=%s" m) in + let _ = Cstruct.hexdump bs in + return () +(* main_loop st conn *) + | exn -> + pp "{OpenFlow-controller} ERROR:%s\n%!" (Printexc.to_string exn); + return () + *) +(* main_loop st conn *) in if (conn.dpid > 0L) then let evt = Event.Datapath_leave (conn.dpid) in diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 9656749..8ed103a 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -2690,4 +2690,4 @@ let marshal msg = | Queue_get_config_req of Header.h * Port.t | Queue_get_config_resp of Header.h * Port.t * Queue.t array *) - marshal_and_sub marshal (Cstruct.of_bigarray (OS.Io_page.get ())) + marshal_and_sub marshal (OS.Io_page.to_cstruct (OS.Io_page.get ())) diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index 39b2aa8..988dbdd 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -34,79 +34,45 @@ let get_new_buffer len = module Socket = struct type t = { sock: Channel.t; - mutable data_cache: Cstruct.t list; + data_cache: Cstruct.t ref; } let create_socket sock = - { sock; data_cache=[];} + { sock; data_cache=ref (get_new_buffer 0);} let write_buffer t bits = -(* - match (Cstruct.len bits) with - | l when l <= 1400 -> - *) - let _ = Channel.write_buffer t.sock bits in - Channel.flush t.sock -(* - | _ -> - let buf = Cstruct.sub bits 0 1400 in - let _ = Channel.write_buffer t.sock buf in - let buf = Cstruct.sub bits 1400 ((Cstruct.len bits) - 1400) in - let _ = Channel.write_buffer t.sock buf in - lwt _ = Channel.flush t.sock in - return () - *) - + let _ = Channel.write_buffer t.sock bits in + Channel.flush t.sock + let close t = Channel.close t.sock - let cache_size t = +(* let cache_size t = List.fold_right ( fun a r -> - r + (Cstruct.len a) ) t.data_cache 0 + r + (Cstruct.len a) ) t.data_cache 0*) -let rec read_data t len = +let read_data t len = (* Printf.printf "let rec read_data t data_cache %d = \n%!" len; *) - match (len, t.data_cache) with - | (0, _) -> -(* pp "| (0, _) ->\n%!"; *) - return (get_new_buffer 0) - | (_, head::tail) when ((cache_size t) >=len) -> ( -(* pp "| (_, head::tail) when ((List.fold_right (f a b - * ->b+(Cstruct.len b)) tail (Cstruct.len head)) >= len) ->\n%!"; *) - let ret = Cstruct.create len in - let rec read_data_inner off = function - | head::tail when ((off + (Cstruct.len head)) < len) -> - let sz = Cstruct.len head in - let _ = Cstruct.blit head 0 ret off sz in - read_data_inner (off + sz) tail - | head::tail when ((off + (Cstruct.len head)) = len) -> - let sz = Cstruct.len head in - let _ = Cstruct.blit head 0 ret off sz in - t.data_cache <- tail - | head::tail when ((off + (Cstruct.len head)) > len) -> - let len_rest = len - off in - let _ = Cstruct.blit head 0 ret off len_rest in - let head = Cstruct.shift head len_rest in - t.data_cache <- head::tail - | rest -> - pp "read_data:Invalid state(req_len:%d,read_len:%d,avail_data:%d)\n%!" - len off (List.fold_right (fun a b -> b + (Cstruct.len a)) rest 0); - raise ReadError - in - let _ = read_data_inner 0 t.data_cache in - let ret = Cstruct.sub ret 0 len in - return (ret) - ) - | (_, _) -> begin -(* pp "| (_, head::tail) when ((List.fold_right (f a b ->b+(Cstruct.len - * b)) tail (Cstruct.len head)) < len) ->\n%!"; *) + match (len, (Cstruct.len !(t.data_cache) ) ) with + | (0, _) -> return (get_new_buffer 0) + | (_, 0) -> lwt data = Channel.read_some t.sock in - let _ = t.data_cache <- data::t.data_cache in - read_data t len - - end + let ret = Cstruct.sub data 0 len in + let _ = t.data_cache := (Cstruct.shift data len) in + return ret + | (_, l) when (l >= len) -> + let ret = !(t.data_cache) in + let ret = Cstruct.sub !(t.data_cache) 0 len in + let _ = t.data_cache := (Cstruct.shift !(t.data_cache) len) in + return ret + | (_, l) when (l < len) -> + let len_rest = len - l in + let ret = Cstruct.set_len !(t.data_cache) len in + lwt data = Channel.read_some t.sock in + let _ = Cstruct.blit data 0 ret l len_rest in + let _ = t.data_cache := (Cstruct.shift data len_rest) in + return (ret) end - (* module Unix_socket = struct type t = { @@ -215,18 +181,15 @@ let init_local_conn_state input output = let read_packet conn = match conn.t with | Socket t -> - lwt hbuf = Socket.read_data t OP.Header.sizeof_ofp_header in -(* lwt hbuf = Channel.read_some ~len:OP.Header.sizeof_ofp_header - * t.Socket.sock in *) + lwt hbuf = Channel.read_exactly t.Socket.sock OP.Header.sizeof_ofp_header in let ofh = OP.Header.parse_header hbuf in let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in - lwt dbuf = Socket.read_data t dlen in -(* lwt dbuf = + lwt dbuf = if (dlen = 0) then return (Cstruct.create 0) else - Channel.read_some ~len:dlen t.Socket.sock - in*) + Channel.read_exactly t.Socket.sock dlen + in let ofp = OP.parse ofh dbuf in return ofp (* | Unix t -> @@ -243,7 +206,9 @@ let read_packet conn = let send_packet conn ofp = match conn.t with - | Socket t -> Socket.write_buffer t (OP.marshal ofp) + | Socket t -> + let buf = OP.marshal ofp in + Socket.write_buffer t buf (* | Unix t -> Unix_socket.write_buffer t (OP.marshal ofp) *) | Local (_, output) -> return (output (Some ofp )) diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 8cf86aa..79d176d 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 37a5173c93faee9d5357566cf874a3b7) *) +(* DO NOT EDIT (digest: 61f654469bb09f01f7251ebcd6388c82) *) module OASISGettext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -335,7 +335,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -351,7 +351,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index 5323dfb..2393200 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 4cd0a948b0709058a2f443a0f166b18f) *) +(* DO NOT EDIT (digest: f9a1927fbe7dce2b8a0a21360f32decf) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISContext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISString.ml" *) +(* # 1 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISUtils.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) +(* # 71 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISMessage.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISVersion.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISLicense.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) @@ -1020,7 +1020,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 104 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) +(* # 104 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1186,7 +1186,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1270,7 +1270,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISHostPath.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISHostPath.ml" *) open Filename @@ -1303,7 +1303,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISSection.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1386,12 +1386,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISExecutable.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1424,7 +1424,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISLibrary.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1604,7 +1604,7 @@ module OASISLibrary = struct end module OASISObject = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISObject.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext @@ -1669,7 +1669,7 @@ module OASISObject = struct end module OASISFindlib = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISFindlib.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISFindlib.ml" *) open OASISTypes @@ -1956,32 +1956,32 @@ module OASISFindlib = struct end module OASISFlag = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISFlag.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISPackage.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISTest.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISDocument.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISExec.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -2059,7 +2059,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2256,7 +2256,7 @@ end # 2257 "setup.ml" module BaseEnvLight = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2354,7 +2354,7 @@ end # 2355 "setup.ml" module BaseContext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseContext.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseContext.ml" *) open OASISContext @@ -2365,7 +2365,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseMessage.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2384,7 +2384,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseEnv.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2844,7 +2844,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseArgExt.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2872,7 +2872,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseCheck.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2998,7 +2998,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -3114,7 +3114,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseStandardVar.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3478,7 +3478,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseFileAB.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3526,7 +3526,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseLog.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseLog.ml" *) open OASISUtils @@ -3645,7 +3645,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseBuilt.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3813,7 +3813,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseCustom.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3863,7 +3863,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseDynVar.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3910,7 +3910,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseTest.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -4000,7 +4000,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseDoc.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -4035,7 +4035,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/base/BaseSetup.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4616,7 +4616,7 @@ end # 4617 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4872,7 +4872,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5457,7 +5457,7 @@ end # 5458 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5559,7 +5559,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5766,7 +5766,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall From 365151f47ecf7da27cfbf820a41310a7a432deff Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 17 Jan 2013 18:19:21 +0000 Subject: [PATCH 34/75] small fix --- lib/ofcontroller.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index c2e4cd9..8042bb6 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -180,14 +180,13 @@ let process_of_packet state conn ofp = (* cp (sp "+ %s|%s" (OP.Header.header_to_string h) (OP.Packet_in.packet_in_to_string p)); *) -(* + let evt = Event.Packet_in ( p.Packet_in.in_port, p.Packet_in.buffer_id, p.Packet_in.data, conn.dpid) in - iter_p (fun cb -> cb state conn.dpid evt) - state.packet_in_cb - *) + lwt _ = iter_p (fun cb -> cb state conn.dpid evt) + state.packet_in_cb in return () end | Flow_removed (h, p) From 4ff3547dae5fa902c986e8a6e038416452eb623f Mon Sep 17 00:00:00 2001 From: crotsos Date: Wed, 23 Jan 2013 01:51:27 +0000 Subject: [PATCH 35/75] fixing flowvisor functionality --- Makefile | 2 - _oasis | 4 +- _tags | 12 +- controller/learning_switch.ml | 2 +- lib/META | 4 +- lib/flowvisor.ml | 628 ++++++++++++++++++++++++++++++++++ lib/flowvisor.mli | 27 ++ lib/flowvisor_topology.ml | 214 ++++++++++++ lib/flowvisor_topology.mli | 30 ++ lib/lldp.ml | 360 +++++++++++++++++++ lib/lldp.mli | 55 +++ lib/ofcontroller.ml | 127 +++---- lib/ofcontroller.mli | 5 +- lib/ofpacket.ml | 71 ++-- lib/ofpacket.mli | 5 +- lib/ofsocket.ml | 2 +- lib/ofswitch.ml | 39 ++- lib/ofswitch.mli | 2 +- lib/ofswitch_standalone.ml | 2 +- lib/openflow.mlpack | 5 +- myocamlbuild.ml | 14 +- setup.ml | 111 +++--- 22 files changed, 1511 insertions(+), 210 deletions(-) create mode 100644 lib/flowvisor.ml create mode 100644 lib/flowvisor.mli create mode 100644 lib/flowvisor_topology.ml create mode 100644 lib/flowvisor_topology.mli create mode 100644 lib/lldp.ml create mode 100644 lib/lldp.mli diff --git a/Makefile b/Makefile index cbb1265..263f96f 100644 --- a/Makefile +++ b/Makefile @@ -25,8 +25,6 @@ distclean: setup.ml setup.data setup: setup.data build: setup.data $(wildcard lib/*.ml) - oasis setup - ocaml setup.ml -configure $(LWT) $(MIRAGE) ocaml setup.ml -build -j $(J) $(OFLAGS) doc: setup.data setup.ml diff --git a/_oasis b/_oasis index f9294c1..5f0600c 100644 --- a/_oasis +++ b/_oasis @@ -29,9 +29,9 @@ Library openflow Path: lib Findlibname: openflow CompiledObject: native - Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch, Ofsocket, Ofswitch_standalone + Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch, Ofsocket, Ofswitch_standalone, Flowvisor, Flowvisor_topology, Lldp Pack: True - BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0), re.str + BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0), re.str, ocamlgraph Document openflow Title: OpenFlow docs diff --git a/_tags b/_tags index 89057d9..20e053a 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 78cbcfbdbaa70295a1850d67f7c11f8a) +# DO NOT EDIT (digest: 996f5338455e46bfc535ca456e9c0b45) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -21,6 +21,9 @@ "lib/ofswitch.cmx": for-pack(Openflow) "lib/ofsocket.cmx": for-pack(Openflow) "lib/ofswitch_standalone.cmx": for-pack(Openflow) +"lib/flowvisor.cmx": for-pack(Openflow) +"lib/flowvisor_topology.cmx": for-pack(Openflow) +"lib/lldp.cmx": for-pack(Openflow) # Executable ovs-vsctl "lib/ofswitch_ctrl.native": use_openflow "lib/ofswitch_ctrl.native": pkg_cstruct @@ -30,6 +33,7 @@ "lib/ofswitch_ctrl.native": pkg_rpclib.json "lib/ofswitch_ctrl.native": pkg_mirage "lib/ofswitch_ctrl.native": pkg_mirage-net +"lib/ofswitch_ctrl.native": pkg_ocamlgraph : use_openflow : pkg_cstruct : pkg_cstruct.syntax @@ -38,6 +42,7 @@ : pkg_rpclib.json : pkg_mirage : pkg_mirage-net +: pkg_ocamlgraph "lib/ofswitch_ctrl.native": custom # Executable learning_switch_lwt "controller/learning_switch.native": use_openflow @@ -48,6 +53,7 @@ "controller/learning_switch.native": pkg_rpclib.json "controller/learning_switch.native": pkg_mirage "controller/learning_switch.native": pkg_mirage-net +"controller/learning_switch.native": pkg_ocamlgraph "controller/learning_switch.native": custom # Executable basic_switch_lwt "switch/basic_switch.native": use_openflow @@ -58,6 +64,7 @@ "switch/basic_switch.native": pkg_rpclib.json "switch/basic_switch.native": pkg_mirage "switch/basic_switch.native": pkg_mirage-net +"switch/basic_switch.native": pkg_ocamlgraph : use_openflow : pkg_cstruct : pkg_cstruct.syntax @@ -66,6 +73,7 @@ : pkg_rpclib.json : pkg_mirage : pkg_mirage-net +: pkg_ocamlgraph "switch/basic_switch.native": custom # Executable learning_switch_mirage.o "controller/learning_switch.nobj.o": use_openflow @@ -76,6 +84,7 @@ "controller/learning_switch.nobj.o": pkg_rpclib.json "controller/learning_switch.nobj.o": pkg_mirage "controller/learning_switch.nobj.o": pkg_mirage-net +"controller/learning_switch.nobj.o": pkg_ocamlgraph : use_openflow : pkg_cstruct : pkg_cstruct.syntax @@ -84,6 +93,7 @@ : pkg_rpclib.json : pkg_mirage : pkg_mirage-net +: pkg_ocamlgraph "controller/learning_switch.nobj.o": custom # OASIS_STOP true: annot diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index ac77a61..c98849b 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -66,7 +66,7 @@ let packet_in_cb controller dpid evt = incr switch_data.req_count; let (in_port, buffer_id, data, dp) = match evt with - | OE.Packet_in (inp, buf, dat, dp) -> (inp, buf, dat, dp) + | OE.Packet_in (inp, _, buf, dat, dp) -> (inp, buf, dat, dp) | _ -> invalid_arg "bogus datapath_join event match!" in (* Parse Ethernet header *) diff --git a/lib/META b/lib/META index 1a8e298..3500586 100644 --- a/lib/META +++ b/lib/META @@ -1,9 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: cf826b73e7b89f065bfc4c5b9aa7ab3f) +# DO NOT EDIT (digest: af22db32fa2321ef21a267936ae9c0ff) version = "0.3.0" description = "OpenFlow protocol and switch implementations in pure OCaml" requires = -"cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net re.str" +"cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net re.str ocamlgraph" archive(byte) = "openflow.cma" archive(byte, plugin) = "openflow.cma" archive(native) = "openflow.cmxa" diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml new file mode 100644 index 0000000..ee479ab --- /dev/null +++ b/lib/flowvisor.ml @@ -0,0 +1,628 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt +open Net +open Net.Nettypes + +module OP = Ofpacket +module OC = Ofcontroller +module OE = Ofcontroller.Event +open OP +open OP.Flow +open OP.Flow_mod +open OP.Match + +let sp = Printf.sprintf +let pr = Printf.printf +let pp = Printf.printf +let ep = Printf.eprintf +let cp = OS.Console.log + +exception Ofcontroller_error of int32 * OP.error_code * OP.t +exception Ofswitch_error of int64 * int32 * OP.error_code * OP.t + +(* fake switch state to be exposed to controllers *) +type port = { + port_id: int; + port_name: string; + phy: OP.Port.phy; + origin_dpid: int64; + origin_port_id: int; +} + +type t = { + (* counters *) + mutable errornum : int32; + mutable portnum : int; + mutable xid_count : int32; + mutable buffer_id_count: int32; + + (* controller and switch storage *) + mutable controllers : (int64 * OP.Match.t *Ofsocket.conn_state ) list; + switches : (int64, Ofcontroller.t) Hashtbl.t; + + (* Mapping transients id values *) + xid_map : (int32, (int64 * int64 list * float)) Hashtbl.t; + port_map : (int, (int64 * int * OP.Port.phy)) Hashtbl.t; + buffer_id_map : (int32, (OP.Packet_in.t * int64)) Hashtbl.t; + + (* topology managment module *) + flv_topo: Flowvisor_topology.t; +} + +let supported_actions () = + OP.Switch.( + {output=true;set_vlan_id=true;set_vlan_pcp=true;strip_vlan=true; + set_dl_src=true; set_dl_dst=true; set_nw_src=true; set_nw_dst=true; + set_nw_tos=true; set_tp_src=true; set_tp_dst=true; enqueue=false; + vendor=false; }) + +let supported_capabilities () = + OP.Switch.({flow_stats=true;table_stats=true;port_stats=true;stp=false; + ip_reasm=false;queue_stats=false;arp_match_ip=true;}) + +let switch_features datapath_id ports = + OP.Switch.({datapath_id; n_buffers=0l; n_tables=(char_of_int 1); + capabilities=(supported_capabilities ()); + actions=(supported_actions ()); ports;}) + +let init_flowvisor flv_topo = + {errornum=0l; portnum=10; xid_count=0l; + port_map=(Hashtbl.create 64); + controllers=[]; buffer_id_map=(Hashtbl.create 64); + buffer_id_count=0l; xid_map=(Hashtbl.create 64); + switches=(Hashtbl.create 64); flv_topo;} + +let supported_actions () = + OP.Switch.({ + output=true; set_vlan_id=true; set_vlan_pcp=true; strip_vlan=true; + set_dl_src=true; set_dl_dst=true; set_nw_src=true; set_nw_dst=true; + set_nw_tos=true; set_tp_src=true; set_tp_dst=true; enqueue=false; + vendor=true; }) + +(* xid buffer controller functions *) +let match_dpid_buffer_id st dpid buffer_id = + try + let (_, dst_dpid) = Hashtbl.find st.buffer_id_map buffer_id in + (dpid = dst_dpid) + with Not_found -> false +let get_new_xid st dpid dst_dpid = + let xid = st.xid_count in + let _ = st.xid_count <- Int32.add st.xid_count 1l in + let now = OS.Clock.time () in + let _ = Hashtbl.replace st.xid_map xid (dpid, dst_dpid, now) in + xid + +(* communication primitives *) +let get_all_switch_dpid flv = Hashtbl.fold (fun dpid _ r -> r@[dpid]) flv.switches [] +let send_all_switches st msg = + Lwt_list.iter_p ( + fun (dpid, ch) -> Ofcontroller.send_data ch dpid msg) + (Hashtbl.fold (fun dpid ch c -> c @[(dpid, ch)]) st.switches []) +let send_switch st dpid msg = + try_lwt + let ch = Hashtbl.find st.switches dpid in + Ofcontroller.send_data ch dpid msg + with Not_found -> return (ep "[flowvisor] unregister dpid %Ld\n%!" dpid) + +let send_controller t msg = Ofsocket.send_packet t msg +let inform_controllers flv m msg = + (* find the controller that should handle the packet in *) + Lwt_list.iter_p + (fun (_, rule, t) -> + if (OP.Match.flow_match_compare m rule rule.OP.Match.wildcards) then + Ofsocket.send_packet t msg + else return ()) flv.controllers + +(************************************************* +* Switch OpenFlow control channel + *************************************************) +let packet_out_create st msg xid in_port bid data actions = + let data = + match (bid) with + | -1l -> data + (* if no buffer id included, send the data section of the + * packet_out*) + | bid when (Hashtbl.mem st.buffer_id_map bid) -> + (* if we have a buffer id in cache, use those data *) + let (pkt, _ ) = Hashtbl.find st.buffer_id_map bid in + pkt.OP.Packet_in.data + | _ -> raise (Ofcontroller_error(xid, OP.REQUEST_BUFFER_UNKNOWN, msg) ) + in + let m = OP.Packet_out.create ~buffer_id:(-1l) + ~actions ~in_port ~data () in + let h = OP.Header.create ~xid OP.Header.PACKET_OUT 0 in + OP.Packet_out (h,m) + + let rec pkt_out_process st xid inp bid data msg acts = function + | (OP.Flow.Output(OP.Port.All, len))::tail + | (OP.Flow.Output(OP.Port.Flood, len))::tail -> begin + let actions = acts @ [OP.Flow.Output(OP.Port.All, len)] in + (* OP.Port.None is not the appropriate way to handle this. Need to find the + * port that connects the two switches probably. *) + let msg = packet_out_create st msg xid OP.Port.No_port bid data actions in + lwt _ = send_all_switches st msg in + pkt_out_process st xid inp bid data msg acts tail + end + | (OP.Flow.Output(OP.Port.In_port, len))::tail -> begin + (* output packet to the last hop of the path *) + let (dpid, out_p, _) = Hashtbl.find st.port_map (OP.Port.int_of_port inp) in + let actions = acts @ [OP.Flow.Output(OP.Port.In_port, len)] in + let msg = packet_out_create st msg xid (OP.Port.Port(out_p)) bid data actions in + lwt _ = send_switch st dpid msg in + pkt_out_process st xid inp bid data msg acts tail + end + | (OP.Flow.Output(OP.Port.Port(p), len))::tail -> begin + (* output packet to the last hop of the path *) + let (dpid, out_p, _) = Hashtbl.find st.port_map p in + let actions = acts @ [OP.Flow.Output((OP.Port.port_of_int out_p), len)] in + let msg = packet_out_create st msg xid OP.Port.No_port bid data actions in + lwt _ = send_switch st dpid msg in + pkt_out_process st xid inp bid data msg acts tail + end + | (OP.Flow.Output(OP.Port.Table, len))::tail + | (OP.Flow.Output(OP.Port.Controller, len))::tail + | (OP.Flow.Output(OP.Port.Local, len))::tail + | (OP.Flow.Output(OP.Port.No_port, len))::tail + | (OP.Flow.Output(OP.Port.Normal, len))::tail -> + raise (Ofcontroller_error (xid, OP.REQUEST_BAD_STAT, msg) ) + | a :: tail -> + (* for the non-output action, populate the new action list *) + pkt_out_process st xid inp bid data msg (acts @ [a]) tail + | [] -> return () + +let map_path flv in_dpid in_port out_dpid out_port = +(* let _ = pp "[flowvisor-switch] mapping a path between %Ld:%s - %Ld:%s\n%!" + in_dpid (OP.Port.string_of_port in_port) + out_dpid (OP.Port.string_of_port out_port) in *) + if (in_dpid = out_dpid) then + [(out_dpid, in_port, out_port)] + else + let path = Flowvisor_topology.find_dpid_path flv.flv_topo + in_dpid in_port out_dpid out_port in +(* let _ = + List.iter ( + fun (dp, in_p, out_p) -> + pp "%s:%Ld:%s -> " + (OP.Port.string_of_port in_p) + dp (OP.Port.string_of_port out_p) + ) path in + let _ = pp "\n%!" in *) + path + +let map_spanning_tree flv in_dpid in_port = [] + +let rec send_flow_mod_to_path st xid msg pkt len actions path = + let h = OP.Header.create ~xid OP.Header.FLOW_MOD 0 in + match path with + | [] -> return () + | [(dpid, in_port, out_port)] -> begin + let actions = actions @ [OP.Flow.Output(out_port, len)] in + let _ = pkt.of_match.in_port <- in_port in + let fm = OP.Flow_mod.( + {pkt with buffer_id=(-1l);out_port=(OP.Port.No_port);actions;}) in + lwt _ = send_switch st dpid (OP.Flow_mod(h, fm)) in + match (pkt.buffer_id) with + | -1l -> return () + | bid when (Hashtbl.mem st.buffer_id_map bid) -> + (* if we have a buffer id in cache, use those data *) + let (pkt, _ ) = Hashtbl.find st.buffer_id_map bid in + let msg = packet_out_create st msg xid (OP.Port.No_port) + (-1l) (pkt.OP.Packet_in.data) actions in + lwt _ = send_switch st dpid msg in + return () + | _ -> + (* if buffer id is unknown, send error *) + raise (Ofcontroller_error(xid, OP.REQUEST_BUFFER_UNKNOWN, msg)) + end + | ((dpid, in_port, out_port)::rest) -> begin + let _ = pkt.of_match.in_port <- in_port in + let fm = OP.Flow_mod.( + {pkt with buffer_id=(-1l);out_port=(OP.Port.No_port); + actions=( [OP.Flow.Output(out_port, len)] );}) in + lwt _ = send_switch st dpid (OP.Flow_mod(h, fm)) in + send_flow_mod_to_path st xid msg pkt len actions rest + end + +let rec flow_mod_translate_inner st msg xid pkt in_dpid in_port acts = function + | (OP.Flow.Output(OP.Port.All, len))::tail + | (OP.Flow.Output(OP.Port.Flood, len))::tail -> + (* Need a spanning tree maybe for this? *) + lwt _ = send_flow_mod_to_path st xid msg pkt len acts + (map_spanning_tree st in_dpid in_port) in + flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail + | (OP.Flow.Output(OP.Port.In_port, len))::tail -> + lwt _ = send_flow_mod_to_path st xid msg pkt len acts + [(in_dpid, OP.Port.Port(in_port), OP.Port.In_port)] in + flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail + | (OP.Flow.Output(OP.Port.Controller, len))::tail -> + lwt _ = send_flow_mod_to_path st xid msg pkt len acts + [(in_dpid, OP.Port.Port(in_port), OP.Port.Controller)] in + flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail + | (OP.Flow.Output(OP.Port.Port(p), len))::tail -> + let (out_dpid, out_port, _) = Hashtbl.find st.port_map p in + lwt _ = send_flow_mod_to_path st xid msg pkt len acts + (map_path st in_dpid (OP.Port.Port(in_port) ) + out_dpid (OP.Port.Port(out_port))) in + flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail + | (OP.Flow.Output(OP.Port.Table, _))::_ + | (OP.Flow.Output(OP.Port.Local, _))::_ + | (OP.Flow.Output(OP.Port.No_port, _))::_ + | (OP.Flow.Output(OP.Port.Normal, _))::_ -> + raise (Ofcontroller_error (xid, OP.REQUEST_BAD_STAT, msg) ) + | a :: tail -> flow_mod_translate_inner st msg xid pkt in_dpid in_port (acts@[a]) tail + | [] -> return () + +let flow_mod_add_translate st msg xid pkt = + let (in_dpid, in_port, _) = Hashtbl.find st.port_map + (OP.Port.int_of_port pkt.of_match.in_port) in + flow_mod_translate_inner st msg xid pkt in_dpid in_port [] pkt.actions + +let flow_mod_del_translate st msg xid pkt = + match (pkt.of_match.OP.Match.wildcards.OP.Wildcards.in_port, + pkt.of_match.OP.Match.in_port, pkt.OP.Flow_mod.out_port) with + | (false, OP.Port.Local, OP.Port.No_port) + | (true, _, OP.Port.No_port) -> + let h = OP.Header.(create ~xid FLOW_MOD 0) in + send_all_switches st (OP.Flow_mod(h, pkt)) + | (false, OP.Port.Port(p), OP.Port.No_port) -> + let (dpid, port, _) = Hashtbl.find st.port_map p in + let _ = pkt.of_match.in_port <- OP.Port.Port(port) in + let h = OP.Header.(create ~xid FLOW_MOD 0) in + send_switch st dpid (OP.Flow_mod(h, pkt)) + | (false, OP.Port.Port(in_p), OP.Port.Port(out_p)) -> + let (in_dpid, in_port, _) = Hashtbl.find st.port_map in_p in + let (out_dpid, out_port, _) = Hashtbl.find st.port_map out_p in + lwt _ = send_flow_mod_to_path st xid msg pkt 0 [] + (map_path st in_dpid (OP.Port.Port(in_port) ) + out_dpid (OP.Port.Port(out_port))) in + return () + | _ -> raise (Ofcontroller_error (xid, OP.REQUEST_BAD_STAT, msg) ) + +let process_openflow st dpid t msg = + match msg with + | OP.Hello (h) -> + let _ = cp "[flowvisor-switch] HELLO\n%!" in + return () + | OP.Echo_req (h) -> (* Reply to ECHO requests *) + let _ = cp "[flowvisor-switch] ECHO_REQ\n%!" in + let h = OP.Header.(create ECHO_RESP ~xid:h.xid sizeof_ofp_header) in + send_controller t (OP.Echo_resp h) + | OP.Features_req (h) -> + let _ = cp "[flowvisor-switch] FEATURES_REQ\n%!" in + let h = OP.Header.(create FEATURES_RESP + ~xid:h.OP.Header.xid sizeof_ofp_header) in + let feat = switch_features dpid + (Hashtbl.fold (fun _ (_, _, p) r -> p::r) + st.port_map []) in + send_controller t (OP.Features_resp(h, feat)) + | OP.Stats_req(h, req) -> begin + (* TODO Need to translate the xid here *) + let _ = cp "[flowvisor-switch] STATS_REQ\n%!" in + match req with + | OP.Stats.Desc_req(req) -> + let desc = + OP.Stats.({ imfr_desc="Mirage"; hw_desc="Mirage"; + sw_desc="Mirage_flowvisor"; serial_num="0.1"; + dp_desc="Mirage";}) in + let resp_h = OP.Stats.({st_ty=DESC;more_to_follow=false;}) in + send_controller t + (OP.Stats_resp(h, (OP.Stats.Desc_resp(resp_h,desc)))) + | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> begin + (*TODO Need to consider the table_id and the out_port and + * split reply over multiple openflow packets if they don't + * fit a single packet. *) + match (of_match.OP.Match.wildcards.OP.Wildcards.in_port, + (of_match.OP.Match.in_port)) with + | (false, OP.Port.Port(p)) -> + let (dst_dpid, out_port, _) = + Hashtbl.find st.port_map p in + let xid = get_new_xid st dst_dpid [dpid] in + let h = OP.Header.(create STATS_RESP + ~xid sizeof_ofp_header) in + let out_port = OP.Port.Port(out_port) in + let of_match = OP.Match.translate_port of_match out_port in + (* TODO out_port needs processing. if dpid are between + * different switches need to define the outport + * as the port of the interconnection link *) + let table_id = OP.Stats.int_of_table_id table_id in + let req = OP.Stats.(Flow_req(req_h, of_match, + (OP.Stats.table_id_of_int table_id), + out_port)) in + send_switch st dst_dpid (OP.Stats_req(h, req)) + | (_, _) -> + let req = OP.Stats.(Flow_req(req_h, of_match, + table_id, out_port)) in + let xid = get_new_xid st dpid (get_all_switch_dpid st) in + let h = OP.Header.(create STATS_RESP + ~xid sizeof_ofp_header) in + send_all_switches st (OP.Stats_req(h, req)) + end + | OP.Stats.Aggregate_req (req_h, of_match, table_id, out_port) -> + begin + match (of_match.OP.Match.wildcards.OP.Wildcards.in_port, + (of_match.OP.Match.in_port)) with + | (false, OP.Port.Port(p)) -> + let (dst_dpid, port, _) = Hashtbl.find st.port_map p in + let xid = get_new_xid st dpid [dst_dpid] in + let h = OP.Header.({ h with xid;}) in + let _ = of_match.in_port <-OP.Port.Port(port) in + (* TODO out_port needs processing. if dpid are between + * different switches need to define the outport as the + * port of the interconnection link *) + let m = OP.Stats.(Aggregate_req(req_h, of_match, + table_id, out_port)) in + send_switch st dst_dpid (OP.Stats_req(h, m)) + | (_, _) -> + let h = OP.Header.({h with xid=(get_new_xid st dpid + (get_all_switch_dpid st));}) in + send_all_switches st (OP.Stats_req(h, req)) + end + | OP.Stats.Table_req(req_h) -> + let xid = get_new_xid st dpid (get_all_switch_dpid st) in + let h = OP.Header.({h with xid;}) in + send_all_switches st (OP.Stats_req(h, req)) + | OP.Stats.Port_req(req_h, port) -> begin + match port with + | OP.Port.No_port -> + let xid = get_new_xid st dpid (get_all_switch_dpid st) in + let h = OP.Header.({h with xid;}) in + send_all_switches st (OP.Stats_req(h, req)) + | OP.Port.Port(port) when (Hashtbl.mem st.port_map port) -> + let (dst_dpid, port, _) = Hashtbl.find st.port_map port in + let xid = get_new_xid st dpid [dst_dpid] in + let h = OP.Header.({h with xid;}) in + let m = OP.Stats.(Port_req(req_h, OP.Port.Port(port))) in + send_all_switches st (OP.Stats_req(h, m)) + | _ -> + raise (Ofcontroller_error (h.OP.Header.xid, OP.QUEUE_OP_BAD_PORT, msg)) + end + | _ -> + raise (Ofcontroller_error (h.OP.Header.xid, OP.REQUEST_BAD_STAT, msg)) + end + | OP.Get_config_req(h) -> + (* TODO make a custom reply tothe query *) + let h = OP.Header.({h with ty=FEATURES_RESP}) in + send_controller t (OP.Get_config_resp(h, OP.Switch.init_switch_config)) + | OP.Barrier_req(h) -> + (* TODO just reply for now. need to check this with all switches *) +(* let xid = get_new_xid dpid in *) + let _ = pr "BARRIER_REQ: %s\n%!" (OP.Header.header_to_string h) in + send_controller t (OP.Barrier_resp (OP.Header.({h with ty=BARRIER_RESP;})) ) + | OP.Packet_out(h, pkt) -> begin + let _ = pr "[flowvisor-switch] PACKET_OUT: %s\n%!" + (OP.Packet_out.packet_out_to_string pkt) in + (* Check if controller has the right to send traffic on the specific subnet *) + try_lwt + OP.Packet_out.(pkt_out_process st h.OP.Header.xid pkt.in_port + pkt.buffer_id pkt.data msg [] pkt.actions ) + with exn -> + return (pp "[flowvisor-switch] packet_out message error %s\n%!" + (Printexc.to_string exn)) + end + | OP.Flow_mod(h,fm) -> begin + let _ = pr "[flowvisor-switch] FLOW_MOD: %s\n%!" + (OP.Flow_mod.flow_mod_to_string fm) in + let xid = get_new_xid st dpid (get_all_switch_dpid st) in + match (fm.OP.Flow_mod.command) with + | OP.Flow_mod.ADD + | OP.Flow_mod.MODIFY + | OP.Flow_mod.MODIFY_STRICT -> + flow_mod_add_translate st msg xid fm + | OP.Flow_mod.DELETE + | OP.Flow_mod.DELETE_STRICT -> + flow_mod_del_translate st msg xid fm + end + (*Unsupported switch actions *) + | OP.Port_mod (h, _) + | OP.Queue_get_config_resp (h, _, _) + | OP.Queue_get_config_req (h, _) + | OP.Set_config (h, _) (* -> + send_controller t + (OP.marshal_error OP.REQUEST_BAD_TYPE bits h.OP.Header.xid) *) + (* Message that should not be received by a switch *) + | OP.Port_status (h, _) + | OP.Flow_removed (h, _) + | OP.Packet_in (h, _) + | OP.Get_config_resp (h, _) + | OP.Barrier_resp h + | OP.Stats_resp (h, _) + | OP.Features_resp (h, _) + | OP.Vendor (h, _, _) + | OP.Echo_resp (h) + | OP.Error (h, _, _) -> + let h = OP.Header.(create ~xid:h.xid OP.Header.ERROR 0) in + let bits = OP.marshal msg in + send_controller t (OP.Error(h, OP.REQUEST_BAD_TYPE, bits) ) + +let switch_channel st dpid of_m (remote_addr, remote_port) t = + let rs = Nettypes.ipv4_addr_to_string remote_addr in + let _ = pp "[flowvisor-switch]+ controller %s:%d\n%!" rs remote_port in + (* Trigger the dance between the 2 nodes *) + let sock = Ofsocket.init_socket_conn_state t in + let h = OP.Header.(create ~xid:1l HELLO sizeof_ofp_header) in + lwt _ = Ofsocket.send_packet sock (OP.Hello h) in + let _ = st.controllers <- (dpid, of_m, sock)::st.controllers in + let continue = ref true in + while_lwt !continue do + try_lwt + lwt ofp = Ofsocket.read_packet sock in + process_openflow st dpid sock ofp + with + | Nettypes.Closed -> + let _ = continue := false in + return (pr "[flowvisor-switch] Ofcontroller channel closed....\n%!") + | OP.Unparsed (m, bs) -> return ((pr "[flowvisor-switch] # unparsed! m=%s\n %!" m)) + | Ofcontroller_error (xid, error, msg)-> + let h = OP.Header.create ~xid OP.Header.ERROR 0 in + send_switch st dpid (OP.Error(h, error, (OP.marshal msg))) + | exn -> return (pr "[flowvisor-switch] ERROR:%s\n" (Printexc.to_string exn)) + done + +(* + * openflow controller threads + * *) +let add_flowvisor_port flv dpid port = + let port_id = flv.portnum in + let _ = flv.portnum <- flv.portnum + 1 in + lwt _ = Flowvisor_topology.add_port flv.flv_topo dpid port.OP.Port.port_no + (Net.Nettypes.ethernet_mac_of_bytes port.OP.Port.hw_addr) in + let phy = OP.Port.translate_port_phy port port_id in + let _ = Hashtbl.add flv.port_map port_id + (dpid, port.OP.Port.port_no, phy) in + let h = OP.Header.(create PORT_STATUS 0 ) in + let status = OP.Port_status(h, (OP.Port.({reason=OP.Port.ADD; desc=phy;}))) in + Lwt_list.iter_p + (fun (dpid, _, conn) -> + Ofsocket.send_packet conn status ) flv.controllers + +(* + * openflow controller threads + **) +let del_flowvisor_port flv desc = + let h = OP.Header.(create PORT_STATUS 0 ) in + let status = OP.Port_status(h, (OP.Port.({reason=OP.Port.ADD;desc;}))) in + Lwt_list.iter_p + (fun (dpid, _, conn) -> + Ofsocket.send_packet conn status ) flv.controllers + +let map_flv_port flv dpid port = + (* map the new port *) + OP.Port.Port ( + Hashtbl.fold ( + fun flv_port (sw_dpid, sw_port, _) r -> + if ((dpid = sw_dpid) && + (sw_port = port)) then flv_port + else r ) flv.port_map 0 ) + +let process_switch_channel flv st dpid e = + match e with + | OE.Datapath_join(dpid, ports) -> + let _ = pr "[flowvisor-ctrl]+ switch dpid:%Ld\n%!" dpid in + let _ = Flowvisor_topology.add_channel flv.flv_topo dpid st in + (* Update local state *) + let _ = Hashtbl.add flv.switches dpid st in + Lwt_list.iter_s (add_flowvisor_port flv dpid) ports + | OE.Datapath_leave(dpid) -> + let _ = pr "[flowvisor-ctrl]- switch dpid:%Ld\n%!" dpid in + let _ = Flowvisor_topology.remove_dpid flv.flv_topo dpid in + (* Need to remove ports and port mapping and disard any state + * pending for replies. *) + let removed = + Hashtbl.fold + (fun vp (dp, rp, phy) r -> + if (dp = dpid) then + let _ = Hashtbl.remove flv.port_map vp in + phy::r else r) flv.port_map [] in + lwt _ = + Lwt_list.iter_p (del_flowvisor_port flv) removed in + return () + | OE.Packet_in(p, reason, buffer_id, data, dpid) -> begin + let m = OP.Match.raw_packet_to_match p data in + match (p, m.OP.Match.dl_type) with + | (OP.Port.Port(p), 0x88cc) -> + let _ = Flowvisor_topology.process_lldp_packet + flv.flv_topo dpid p data in + return () + | (OP.Port.Port(p), _) when + not (Flowvisor_topology.is_transit_port flv.flv_topo dpid p) -> + (* translate the buffer id information *) + let buffer_id = flv.buffer_id_count in + let _ = flv.buffer_id_count <- Int32.add flv.buffer_id_count 1l in + (* generate packet bits *) + let in_port = map_flv_port flv dpid p in + let h = OP.Header.(create PACKET_IN 0) in + let pkt = OP.Packet_in.({buffer_id;in_port;reason;data;}) in + let _ = Hashtbl.add flv.buffer_id_map buffer_id (pkt, dpid) in + lwt _ = inform_controllers flv m (OP.Packet_in(h, pkt)) in + return () + | (OP.Port.Port(p), _) -> + return ((*pp "XXXXX supress disable transit port"*)) + | _ -> + let _ = pp "[flowvisor-ctrl] Invalid port on Packet_in\n%!" in + let h = OP.Header.(create ERROR 0) in + inform_controllers flv m + (OP.Error(h, OP.REQUEST_BAD_STAT, (Cstruct.create 0))) + end + | OE.Flow_removed(of_match, r, dur_s, dur_ns, pkts, bytes, dpid) -> + (* translate packet *) + let new_in_port = map_flv_port flv dpid + (OP.Port.int_of_port of_match.OP.Match.in_port) in + (* TODO need to pass cookie id, idle, and priority *) + let _ = of_match.OP.Match.in_port <- new_in_port in + let pkt = + OP.Flow_removed.( + {of_match; cookie=0L;reason=r; priority=0;idle_timeout=0; + duration_sec=dur_s; duration_nsec=dur_ns; packet_count=pkts; + byte_count=bytes;}) in + let h = OP.Header.(create FLOW_REMOVED 0) in + inform_controllers flv of_match (OP.Flow_removed(h, pkt)) + (* TODO: Need to write code to handle stats replies *) + | OE.Flow_stats_reply(xid, more, flows, dpid) -> + (* Group reply separation *) + return () + | OE.Aggr_flow_stats_reply(xid, pkts, bytes, flows, dpid) -> + return () + | OE.Port_stats_reply(xid, ports, dpid) -> + return () + | OE.Table_stats_reply(xid, tables, dpid) -> + return () + | OE.Port_status(reason, port, dpid) -> + (* TODO: send a port withdrawal to all controllers *) + return () + | _ -> + return (pp "[flowvisor-ctrl] Unsupported event\n%!") + + let init flv st = + (* register all the required handlers *) + let fn = process_switch_channel flv in + let _ = OC.register_cb st OE.DATAPATH_JOIN fn in + let _ = OC.register_cb st OE.DATAPATH_LEAVE fn in + let _ = OC.register_cb st OE.PACKET_IN fn in + let _ = OC.register_cb st OE.FLOW_REMOVED fn in + let _ = OC.register_cb st OE.FLOW_STATS_REPLY fn in + let _ = OC.register_cb st OE.AGGR_FLOW_STATS_REPLY fn in + let _ = OC.register_cb st OE.PORT_STATUS_CHANGE fn in + let _ = OC.register_cb st OE.TABLE_STATS_REPLY fn in + let _ = OC.register_cb st OE.PORT_STATUS_CHANGE fn in + () + +let create_flowvisor dpid = + let ret = init_flowvisor (Flowvisor_topology.init_topology ()) in + let _ = ignore_result (Flowvisor_topology.discover ret.flv_topo) in + ret + +let listen st mgr loc = Ofcontroller.listen mgr loc (init st) + +let remove_slice _ _ = return () +let add_slice mgr flv of_m dst dpid = + let _ = + (* TODO Need to store thread for termination on remove_slice *) + ignore_result ( + while_lwt true do + try_lwt + Net.Channel.connect mgr + ( `TCPv4 (None, dst, (switch_channel flv dpid of_m dst) ) ) + with exn -> + let _ = pp "[flowvisor-ctrl] controller error %s\n%!" + (Printexc.to_string exn) in + return () + done + + ) in + return () + diff --git a/lib/flowvisor.mli b/lib/flowvisor.mli new file mode 100644 index 0000000..0b2e7a3 --- /dev/null +++ b/lib/flowvisor.mli @@ -0,0 +1,27 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt +open Net +open Net.Nettypes + +type t + +val listen: t -> Manager.t -> ipv4_src -> unit Lwt.t +val create_flowvisor: unit -> t +val remove_slice : t -> Ofpacket.Match.t -> unit Lwt.t +val add_slice : Net.Manager.t -> t -> Ofpacket.Match.t -> + ipv4_dst -> int64 -> unit Lwt.t diff --git a/lib/flowvisor_topology.ml b/lib/flowvisor_topology.ml new file mode 100644 index 0000000..e582732 --- /dev/null +++ b/lib/flowvisor_topology.ml @@ -0,0 +1,214 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt +open Printf +open Net +open Net.Nettypes +open Lldp +open Graph + +module OP = Ofpacket +open OP + +let sp = Printf.sprintf +let pr = Printf.printf +let pp = Printf.printf +let ep = Printf.eprintf +let cp = OS.Console.log + +module V = struct + type t = int64 + let compare = Int64.compare + let hash = Hashtbl.hash + let equal = (=) +end +module E = struct + type t = (int64 * int * int64 * int * int) + let compare v1 v2 = + let (src1_dpid, src1_port, dst1_dpid, dst1_port, _) = v1 in + let (src2_dpid, src2_port, dst2_dpid, dst2_port, _) = v2 in + if ((src1_dpid = src2_dpid) && (src1_port = src2_port) && + (dst1_dpid = dst2_dpid) && (dst1_port = dst2_port)) || + ((src1_dpid = dst2_dpid) && (src1_port = dst2_port) && + (dst1_dpid = src2_dpid) && (dst1_port = src2_port)) then + 0 + else + Pervasives.compare v1 v2 + + let default = (0L, 0, 0L, 0, 1) +end + +(*module PortSet = Set.Make ( + struct + type t = (int64 * int) + let compare = Pervasives.compare +end) *) + +module Graph = Imperative.Graph.ConcreteLabeled(V)(E) + +module W = struct + type t = float + type label = (int64 * int * int64 * int * int) + let weight (_, _, _, _, rate) = 1.0 /. (float_of_int rate) + let compare = Pervasives.compare + let add = (+.) + let zero = 0.0 +end + +module Dijkstra = Path.Dijkstra(Graph)(W) + +type t = { + ports : (int64 * int, ethernet_mac * bool) Hashtbl.t; + channels : (int64, Ofcontroller.t) Hashtbl.t; + topo : Graph.t; +} + +let init_topology () = + let topo = Graph.create () in + {ports=(Hashtbl.create 64); channels=(Hashtbl.create 64); + topo;} + +let add_channel t dpid ch = + Hashtbl.replace t.channels dpid ch + +let generate_lldp_discovery dpid src_mac port = + let bits = OS.Io_page.to_cstruct (OS.Io_page.get ()) in + let _ = Cstruct.BE.set_uint64 bits 0 dpid in + let dpid = Cstruct.to_string (Cstruct.sub bits 0 8) in + let bits = OS.Io_page.to_cstruct (OS.Io_page.get ()) in + let _ = Cstruct.BE.set_uint16 bits 0 port in + let port = Cstruct.(to_string (sub bits 0 2)) in + marshal_and_sub (marsal_lldp_tlvs src_mac + [Tlv_chassis_id_mac(src_mac); + Tlv_port_id_port_comp(port); + Tlv_ttl(120); + Tlv(LLDP_TYPE_SYSTEM_DESCR, dpid); + Tlv_end;]) + (OS.Io_page.to_cstruct (OS.Io_page.get ())) + +let send_port_lldp t dpid port mac = + let data = generate_lldp_discovery dpid mac port in + let h = OP.Header.(create PACKET_OUT 0) in + let m = OP.Packet_out.create ~actions:[(OP.Flow.Output(OP.Port.Port(port), 2000))] + ~data ~in_port:(OP.Port.No_port) () in + let ch = Hashtbl.find t.channels dpid in + Ofcontroller.send_data ch dpid (OP.Packet_out(h, m)) + +let add_port t dpid port mac = + let _ = Hashtbl.replace t.ports (dpid, port) (mac, false) in + send_port_lldp t dpid port mac + +let mark_port_down t dpid port down = + let fmac = Net.Nettypes.ethernet_mac_of_bytes "\xff\xff\xff\xff\xff\xff" in + try + let (mac, _) = Hashtbl.find t.ports (dpid, port) in + Hashtbl.replace t.ports (dpid, port) (mac, down) + with Not_found -> Hashtbl.add t.ports (dpid, port) (fmac, down) + +let discover t = + while_lwt true do + let ports = + Hashtbl.fold + (fun (dpid, port) (mac, _) r -> (dpid, port, mac)::r) + t.ports [] in + + lwt _ = Lwt_list.iter_p ( + fun (dpid, port, mac) -> send_port_lldp t dpid port mac) ports in + lwt _ = OS.Time.sleep 120.0 in + return () + done + +let print_graph t = + Graph.iter_edges_e ( + fun (_, (sdpid, sport, ddpid, dport, len), _) -> + printf "%06Lx:%d - %06Lx:%d = %d\n%!" sdpid sport ddpid dport len + ) t.topo + +let process_lldp_packet t src_dpid src_port pkt = + let tlvs = parse_lldp_tlvs pkt in + let (dst_dpid, dst_port, mac) = + List.fold_right ( + fun tlv (dpid, port, mac) -> + match tlv with + | Tlv_chassis_id_mac (mac) -> + (dpid, port, mac) + | Tlv_port_id_port_comp(bits) -> + let port_id = ref 0 in + let _ = String.iter ( + fun c -> + port_id := (!port_id lsl 8) + (int_of_char c) + ) bits in + (dpid, !port_id, mac) + | Tlv(LLDP_TYPE_SYSTEM_DESCR, bits) -> + let dpid = ref 0L in + let _ = String.iter ( + fun c -> + dpid := Int64.add (Int64.shift_left !dpid 8) + (Int64.of_int (int_of_char c)) + ) bits in + (!dpid, port, mac) + | _ -> (dpid, port, mac) + ) tlvs (0L, 0, Net.Nettypes.ethernet_mac_broadcast) in + let v = (src_dpid, (src_dpid, src_port, dst_dpid, dst_port, 1), dst_dpid) in + let _ = printf "[flowvisor-topo] adding link %Ld:%d-%Ld:%d\n%!" + src_dpid src_port dst_dpid dst_port in + let _ = Graph.add_edge_e t.topo v in + let _ = mark_port_down t src_dpid src_port true in + let _ = mark_port_down t dst_dpid dst_port true in + () + +let remove_dpid t dpid = + let _ = Graph.remove_vertex t.topo dpid in + let _ = + Hashtbl.iter ( + fun (dp, p) _ -> + if (dpid = dp) then + Hashtbl.remove t.ports (dp, p)) t.ports in + let _ = Hashtbl.remove t.channels dpid in + () + +let is_transit_port t dpid port = + try + let (_, down) = Hashtbl.find t.ports (dpid, port) in down + with Not_found -> false + + +let find_dpid_path t src_dpid src_port dst_dpid dst_port = +(* let _ = printf "[flowvisor-topo] looking for path %Ld:%s - %Ld:%s\n%!" + src_dpid (OP.Port.string_of_port src_port) + dst_dpid (OP.Port.string_of_port dst_port) in *) + let (path, w) = Dijkstra.shortest_path t.topo src_dpid dst_dpid in + let (path, dpid, port) = List.fold_right ( + fun (sdp, (dp_1, port_1, dp_2, port_2, _), ddp) (p, curr_dp, curr_p) -> +(* let _ = printf "[flowvisor-topo] found link %Ld:%d-%Ld:%d\n%!" + dp_1 port_1 dp_2 port_2 in *) + let (hop, curr_dp, curr_p) = + match (curr_dp) with + | dp when dp = dp_1 -> + let hop = (curr_dp, OP.Port.Port(port_1), + curr_p) in + (hop, dp_2, port_2) + | dp when dp = dp_2 -> + let hop = (curr_dp, + OP.Port.Port(port_2), curr_p) in + (hop, dp_1, port_1) + | _ -> + failwith (sp "Unknwk dpid %Ld" curr_dp) + in + ((hop :: p), curr_dp, OP.Port.Port(curr_p)) + ) path ([], dst_dpid, dst_port) in + (src_dpid, src_port, port) :: path diff --git a/lib/flowvisor_topology.mli b/lib/flowvisor_topology.mli new file mode 100644 index 0000000..8d9cf95 --- /dev/null +++ b/lib/flowvisor_topology.mli @@ -0,0 +1,30 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Net.Nettypes + +type t + +val init_topology: unit -> t +val add_port: t -> int64 -> int -> ethernet_mac -> unit Lwt.t +val add_channel: t -> int64 -> Ofcontroller.t -> unit +val discover: t-> unit Lwt.t +val process_lldp_packet: t -> int64 -> int -> Cstruct.t -> unit +val find_dpid_path: t -> int64 -> Ofpacket.Port.t -> int64 -> + Ofpacket.Port.t -> (int64 * Ofpacket.Port.t * Ofpacket.Port.t) list +val remove_dpid: t -> int64 -> unit +val is_transit_port : t -> int64 -> int -> bool + diff --git a/lib/lldp.ml b/lib/lldp.ml new file mode 100644 index 0000000..736a596 --- /dev/null +++ b/lib/lldp.ml @@ -0,0 +1,360 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Cstruct +open Printf +open Net +open Net.Nettypes + +exception Unparsable of Cstruct.t + +(*cenum lldp_tlv_types { + LLDP_TYPE_END = 0; + LLDP_TYPE_CHASSIS_ID = 1; + LLDP_TYPE_PORT_ID = 2; + LLDP_TYPE_TTL = 3; + LLDP_TYPE_PORT_DESCR = 4; + LLDP_TYPE_SYSTEM_NAME = 5; + LLDP_TYPE_SYSTEM_DESCR = 6; + LLDP_TYPE_SYSTEM_CAP = 7; + LLDP_TYPE_MGMT_ADDR = 8 +} as uint8_t + +cenum lldp_chassis_id_subtype { + LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE = 1; + LLDP_CHASSIS_INTF_ALIAS_SUBTYPE = 2; + LLDP_CHASSIS_PORT_COMP_SUBTYPE = 3; + LLDP_CHASSIS_MAC_ADDR_SUBTYPE = 4; + LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE = 5; + LLDP_CHASSIS_INTF_NAME_SUBTYPE = 6; + LLDP_CHASSIS_LOCAL_SUBTYPE = 8 +} as uint8_t + +cenum lldp_port_id_subtype { + LLDP_PORT_INTF_ALIAS_SUBTYPE = 1; + LLDP_PORT_PORT_COMP_SUBTYPE = 2; + LLDP_PORT_MAC_ADDR_SUBTYPE = 3; + LLDP_PORT_NETWORK_ADDR_SUBTYPE = 4; + LLDP_PORT_INTF_NAME_SUBTYPE = 5; + LLDP_PORT_AGENT_CIRC_ID_SUBTYPE = 6; + LLDP_PORT_LOCAL_SUBTYPE = 7 +} as uint8_t*) + +type lldp_tlv_types = + LLDP_TYPE_END + | LLDP_TYPE_CHASSIS_ID + | LLDP_TYPE_PORT_ID + | LLDP_TYPE_TTL + | LLDP_TYPE_PORT_DESCR + | LLDP_TYPE_SYSTEM_NAME + | LLDP_TYPE_SYSTEM_DESCR + | LLDP_TYPE_SYSTEM_CAP + | LLDP_TYPE_MGMT_ADDR + +let lldp_tlv_types_of_int = + function + | 0 -> Some LLDP_TYPE_END + | 1 -> Some LLDP_TYPE_CHASSIS_ID + | 2 -> Some LLDP_TYPE_PORT_ID + | 3 -> Some LLDP_TYPE_TTL + | 4 -> Some LLDP_TYPE_PORT_DESCR + | 5 -> Some LLDP_TYPE_SYSTEM_NAME + | 6 -> Some LLDP_TYPE_SYSTEM_DESCR + | 7 -> Some LLDP_TYPE_SYSTEM_CAP + | 8 -> Some LLDP_TYPE_MGMT_ADDR + | _ -> None + +let lldp_tlv_types_to_int = + function + | LLDP_TYPE_END -> 0 + | LLDP_TYPE_CHASSIS_ID -> 1 + | LLDP_TYPE_PORT_ID -> 2 + | LLDP_TYPE_TTL -> 3 + | LLDP_TYPE_PORT_DESCR -> 4 + | LLDP_TYPE_SYSTEM_NAME -> 5 + | LLDP_TYPE_SYSTEM_DESCR -> 6 + | LLDP_TYPE_SYSTEM_CAP -> 7 + | LLDP_TYPE_MGMT_ADDR -> 8 + +let lldp_tlv_types_to_string = + function + | LLDP_TYPE_END -> "LLDP_TYPE_END" + | LLDP_TYPE_CHASSIS_ID -> "LLDP_TYPE_CHASSIS_ID" + | LLDP_TYPE_PORT_ID -> "LLDP_TYPE_PORT_ID" + | LLDP_TYPE_TTL -> "LLDP_TYPE_TTL" + | LLDP_TYPE_PORT_DESCR -> "LLDP_TYPE_PORT_DESCR" + | LLDP_TYPE_SYSTEM_NAME -> "LLDP_TYPE_SYSTEM_NAME" + | LLDP_TYPE_SYSTEM_DESCR -> "LLDP_TYPE_SYSTEM_DESCR" + | LLDP_TYPE_SYSTEM_CAP -> "LLDP_TYPE_SYSTEM_CAP" + | LLDP_TYPE_MGMT_ADDR -> "LLDP_TYPE_MGMT_ADDR" + +type lldp_chassis_id_subtype = + LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE + | LLDP_CHASSIS_INTF_ALIAS_SUBTYPE + | LLDP_CHASSIS_PORT_COMP_SUBTYPE + | LLDP_CHASSIS_MAC_ADDR_SUBTYPE + | LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE + | LLDP_CHASSIS_INTF_NAME_SUBTYPE + | LLDP_CHASSIS_LOCAL_SUBTYPE + +let lldp_chassis_id_subtype_of_int = + function + | 1 -> Some LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE + | 2 -> Some LLDP_CHASSIS_INTF_ALIAS_SUBTYPE + | 3 -> Some LLDP_CHASSIS_PORT_COMP_SUBTYPE + | 4 -> Some LLDP_CHASSIS_MAC_ADDR_SUBTYPE + | 5 -> Some LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE + | 6 -> Some LLDP_CHASSIS_INTF_NAME_SUBTYPE + | 8 -> Some LLDP_CHASSIS_LOCAL_SUBTYPE + | _ -> None + +let lldp_chassis_id_subtype_to_int = + function + | LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE -> 1 + | LLDP_CHASSIS_INTF_ALIAS_SUBTYPE -> 2 + | LLDP_CHASSIS_PORT_COMP_SUBTYPE -> 3 + | LLDP_CHASSIS_MAC_ADDR_SUBTYPE -> 4 + | LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE -> 5 + | LLDP_CHASSIS_INTF_NAME_SUBTYPE -> 6 + | LLDP_CHASSIS_LOCAL_SUBTYPE -> 8 + +let lldp_chassis_id_subtype_to_string = + function + | LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE -> "LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE" + | LLDP_CHASSIS_INTF_ALIAS_SUBTYPE -> "LLDP_CHASSIS_INTF_ALIAS_SUBTYPE" + | LLDP_CHASSIS_PORT_COMP_SUBTYPE -> "LLDP_CHASSIS_PORT_COMP_SUBTYPE" + | LLDP_CHASSIS_MAC_ADDR_SUBTYPE -> "LLDP_CHASSIS_MAC_ADDR_SUBTYPE" + | LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE -> "LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE" + | LLDP_CHASSIS_INTF_NAME_SUBTYPE -> "LLDP_CHASSIS_INTF_NAME_SUBTYPE" + | LLDP_CHASSIS_LOCAL_SUBTYPE -> "LLDP_CHASSIS_LOCAL_SUBTYPE" + +type lldp_port_id_subtype = + LLDP_PORT_INTF_ALIAS_SUBTYPE + | LLDP_PORT_PORT_COMP_SUBTYPE + | LLDP_PORT_MAC_ADDR_SUBTYPE + | LLDP_PORT_NETWORK_ADDR_SUBTYPE + | LLDP_PORT_INTF_NAME_SUBTYPE + | LLDP_PORT_AGENT_CIRC_ID_SUBTYPE + | LLDP_PORT_LOCAL_SUBTYPE + +let lldp_port_id_subtype_of_int = + function + | 1 -> Some LLDP_PORT_INTF_ALIAS_SUBTYPE + | 2 -> Some LLDP_PORT_PORT_COMP_SUBTYPE + | 3 -> Some LLDP_PORT_MAC_ADDR_SUBTYPE + | 4 -> Some LLDP_PORT_NETWORK_ADDR_SUBTYPE + | 5 -> Some LLDP_PORT_INTF_NAME_SUBTYPE + | 6 -> Some LLDP_PORT_AGENT_CIRC_ID_SUBTYPE + | 7 -> Some LLDP_PORT_LOCAL_SUBTYPE + | _ -> None + +let lldp_port_id_subtype_to_int = + function + | LLDP_PORT_INTF_ALIAS_SUBTYPE -> 1 + | LLDP_PORT_PORT_COMP_SUBTYPE -> 2 + | LLDP_PORT_MAC_ADDR_SUBTYPE -> 3 + | LLDP_PORT_NETWORK_ADDR_SUBTYPE -> 4 + | LLDP_PORT_INTF_NAME_SUBTYPE -> 5 + | LLDP_PORT_AGENT_CIRC_ID_SUBTYPE -> 6 + | LLDP_PORT_LOCAL_SUBTYPE -> 7 + +let lldp_port_id_subtype_to_string = + function + | LLDP_PORT_INTF_ALIAS_SUBTYPE -> "LLDP_PORT_INTF_ALIAS_SUBTYPE" + | LLDP_PORT_PORT_COMP_SUBTYPE -> "LLDP_PORT_PORT_COMP_SUBTYPE" + | LLDP_PORT_MAC_ADDR_SUBTYPE -> "LLDP_PORT_MAC_ADDR_SUBTYPE" + | LLDP_PORT_NETWORK_ADDR_SUBTYPE -> "LLDP_PORT_NETWORK_ADDR_SUBTYPE" + | LLDP_PORT_INTF_NAME_SUBTYPE -> "LLDP_PORT_INTF_NAME_SUBTYPE" + | LLDP_PORT_AGENT_CIRC_ID_SUBTYPE -> "LLDP_PORT_AGENT_CIRC_ID_SUBTYPE" + | LLDP_PORT_LOCAL_SUBTYPE -> "LLDP_PORT_LOCAL_SUBTYPE" + + +type lldp_tvl = + | Tlv_chassis_id_chassis_comp of string + | Tlv_chassis_id_intf_alias of string + | Tlv_chassis_id_port_comp of string + | Tlv_chassis_id_mac of ethernet_mac + | Tlv_chassis_id_net of ipv4_addr + | Tlv_chassis_id_intf_name of string + | Tlv_chassis_id_local of string + | Tlv_port_id_intf_alias of string + | Tlv_port_id_port_comp of string + | Tlv_port_id_mac of ethernet_mac + | Tlv_port_id_net of ipv4_addr + | Tlv_port_id_intf_name of string + | Tlv_port_id_circ_id of string + | Tlv_port_id_local of string + | Tlv_ttl of int + | Tlv_end + | Tlv of lldp_tlv_types * string + | Tlv_unk of int * string + +let parse_lldp_tlv bits = + let tlv_type_len = Cstruct.BE.get_uint16 bits 0 in + let tlv_type = tlv_type_len lsr 9 in + let tlv_len = tlv_type_len land 0x01FF in + let tlv = + match (lldp_tlv_types_of_int tlv_type) with + | Some(LLDP_TYPE_END) -> Tlv_end + | Some(LLDP_TYPE_CHASSIS_ID) -> begin + let data = Cstruct.to_string (Cstruct.sub bits 3 (tlv_len - 1)) in + let chassis_id_subtype = Cstruct.get_uint8 bits 2 in + match (lldp_chassis_id_subtype_of_int chassis_id_subtype) with + | Some(LLDP_CHASSIS_CHASSIS_COMP_SUBTYPE)-> + Tlv_chassis_id_chassis_comp(data) + | Some(LLDP_CHASSIS_INTF_ALIAS_SUBTYPE) -> + Tlv_chassis_id_intf_alias(data) + | Some(LLDP_CHASSIS_PORT_COMP_SUBTYPE) -> + Tlv_chassis_id_port_comp(data) + | Some(LLDP_CHASSIS_MAC_ADDR_SUBTYPE) -> + Tlv_chassis_id_mac(Net.Nettypes.ethernet_mac_of_bytes data) + | Some(LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE)-> + let ip = ipv4_addr_of_uint32 + (Cstruct.BE.get_uint32 bits 3) in + Tlv_chassis_id_net(ip) + | Some(LLDP_CHASSIS_INTF_NAME_SUBTYPE) -> + Tlv_chassis_id_intf_name(data) + | Some(LLDP_CHASSIS_LOCAL_SUBTYPE) -> + Tlv_chassis_id_local(data) + | None -> + raise (Unparsable(bits)) + end + | Some(LLDP_TYPE_PORT_ID) -> begin + let data = Cstruct.to_string (Cstruct.sub bits 3 (tlv_len - 1)) in + let port_id_subtype = Cstruct.get_uint8 bits 2 in + match (lldp_port_id_subtype_of_int port_id_subtype) with + | Some(LLDP_PORT_INTF_ALIAS_SUBTYPE) -> + Tlv_port_id_intf_alias(data) + | Some(LLDP_PORT_PORT_COMP_SUBTYPE) -> + Tlv_port_id_port_comp(data) + | Some(LLDP_PORT_MAC_ADDR_SUBTYPE) -> + Tlv_port_id_mac(Net.Nettypes.ethernet_mac_of_bytes data) + | Some(LLDP_PORT_NETWORK_ADDR_SUBTYPE) -> + let ip = ipv4_addr_of_uint32 + (Cstruct.BE.get_uint32 bits 3) in + Tlv_port_id_net(ip) + | Some(LLDP_PORT_INTF_NAME_SUBTYPE) -> + Tlv_port_id_intf_name(data) + | Some(LLDP_PORT_AGENT_CIRC_ID_SUBTYPE)-> + Tlv_port_id_circ_id(data) + | Some(LLDP_PORT_LOCAL_SUBTYPE) -> + Tlv_port_id_local(data) + | None -> raise (Unparsable(bits)) + end + | Some(LLDP_TYPE_TTL) -> + let ttl = Cstruct.BE.get_uint16 bits 3 in + Tlv_ttl(ttl) + | Some(typ) -> + let data = Cstruct.to_string (Cstruct.sub bits 3 (tlv_len - 1)) in + Tlv(typ, data) + | None -> + let data = Cstruct.to_string (Cstruct.sub bits 2 tlv_len) in + Tlv_unk(tlv_type, data) + in + (tlv_len + 2, tlv) + +let parse_lldp_tlvs bits = + (* Ignore ethernet headers for now *) + let bits = Cstruct.shift bits Ethif.sizeof_ethernet in + let rec parse_lldp_tlvs_inner bits = + match (Cstruct.len bits) with + | 0 -> [] + | _ -> + let (len, tlv) = parse_lldp_tlv bits in + if(tlv = Tlv_end) then + [tlv] + else + let bits = Cstruct.shift bits len in + [tlv] @ (parse_lldp_tlvs_inner bits) + in + parse_lldp_tlvs_inner bits + +let set_lldp_tlv_typ_subtyp_data bits typ subtyp data = + let typ = typ lsl 9 in + let len = ((String.length data) + 1) land 0x1ff in + let typ_len = typ + len in + let _ = Cstruct.BE.set_uint16 bits 0 typ_len in + let _ = Cstruct.set_uint8 bits 2 subtyp in + let _ = Cstruct.blit_from_string data 0 bits 3 (String.length data) in + len + 2 + +let set_lldp_tlv_typ_data bits typ data = + let typ = typ lsl 9 in + let len = (String.length data) land 0x1ff in + let typ_len = typ + len in + let _ = Cstruct.BE.set_uint16 bits 0 typ_len in + let _ = Cstruct.blit_from_string data 0 bits 2 (String.length data) in + len + 2 + +let marsal_lldp_tlv tlv bits = + match tlv with + (* chassis id *) + | Tlv_chassis_id_chassis_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 1 1 data + | Tlv_chassis_id_intf_alias(data) -> set_lldp_tlv_typ_subtyp_data bits 1 2 data + | Tlv_chassis_id_port_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 1 3 data + | Tlv_chassis_id_mac(mac) -> set_lldp_tlv_typ_subtyp_data bits 1 4 + (Net.Nettypes.ethernet_mac_to_bytes mac) + | Tlv_chassis_id_net(ip) -> + let _ = Cstruct.BE.set_uint16 bits 0 0x205 in + let _ = Cstruct.set_uint8 bits 2 5 in + let _ = Cstruct.BE.set_uint32 bits 3 (Net.Nettypes.ipv4_addr_to_uint32 + ip) in + 7 + | Tlv_chassis_id_intf_name(data) -> set_lldp_tlv_typ_subtyp_data bits 1 6 data + | Tlv_chassis_id_local(data) -> set_lldp_tlv_typ_subtyp_data bits 1 8 data + (* Port id *) + | Tlv_port_id_intf_alias(data) -> set_lldp_tlv_typ_subtyp_data bits 2 1 data + | Tlv_port_id_port_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 2 2 data + | Tlv_port_id_mac(mac) -> set_lldp_tlv_typ_subtyp_data bits 2 3 + (Net.Nettypes.ethernet_mac_to_bytes mac) + | Tlv_port_id_net(ip) -> + let _ = Cstruct.BE.set_uint16 bits 0 0x405 in + let _ = Cstruct.set_uint8 bits 2 4 in + let _ = Cstruct.BE.set_uint32 bits 3 (Net.Nettypes.ipv4_addr_to_uint32 + ip) in + 7 + | Tlv_port_id_intf_name(data) -> set_lldp_tlv_typ_subtyp_data bits 2 5 data + | Tlv_port_id_circ_id(data) -> set_lldp_tlv_typ_subtyp_data bits 2 6 data + | Tlv_port_id_local(data) -> set_lldp_tlv_typ_subtyp_data bits 2 7 data + | Tlv_ttl(ttl) -> + let _ = Cstruct.BE.set_uint16 bits 0 0x602 in + let _ = Cstruct.BE.set_uint16 bits 2 ttl in + 4 + | Tlv_end -> + let _ = Cstruct.BE.set_uint16 bits 0 0x000 in + 2 + | Tlv(typ, data) -> + set_lldp_tlv_typ_data bits (lldp_tlv_types_to_int typ) data + | Tlv_unk (typ, data) -> set_lldp_tlv_typ_data bits typ data + +let marsal_lldp_tlvs mac tlvs bits = + let _ = Net.Ethif.set_ethernet_dst "\x01\x80\xc2\x00\x00\x0e" 0 bits in + let _ = Net.Ethif.set_ethernet_src (Net.Nettypes.ethernet_mac_to_bytes mac) + 0 bits in + let _ = Net.Ethif.set_ethernet_ethertype bits 0x88cc in + let bits = Cstruct.shift bits Ethif.sizeof_ethernet in + let rec marsal_lldp_tlvs_inner tlvs bits = + match tlvs with + | [] -> 0 + | h::t -> + let len = marsal_lldp_tlv h bits in + let bits = Cstruct.shift bits len in + let rest = marsal_lldp_tlvs_inner t bits in + len + rest + in + Ethif.sizeof_ethernet + marsal_lldp_tlvs_inner tlvs bits + + diff --git a/lib/lldp.mli b/lib/lldp.mli new file mode 100644 index 0000000..352755e --- /dev/null +++ b/lib/lldp.mli @@ -0,0 +1,55 @@ +(* + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Net +open Net.Nettypes +open Cstruct + +exception Unparsable of Cstruct.t + +type lldp_tlv_types = + | LLDP_TYPE_END + | LLDP_TYPE_CHASSIS_ID + | LLDP_TYPE_PORT_ID + | LLDP_TYPE_TTL + | LLDP_TYPE_PORT_DESCR + | LLDP_TYPE_SYSTEM_NAME + | LLDP_TYPE_SYSTEM_DESCR + | LLDP_TYPE_SYSTEM_CAP + | LLDP_TYPE_MGMT_ADDR + +type lldp_tvl = + | Tlv_chassis_id_chassis_comp of string + | Tlv_chassis_id_intf_alias of string + | Tlv_chassis_id_port_comp of string + | Tlv_chassis_id_mac of ethernet_mac + | Tlv_chassis_id_net of ipv4_addr + | Tlv_chassis_id_intf_name of string + | Tlv_chassis_id_local of string + | Tlv_port_id_intf_alias of string + | Tlv_port_id_port_comp of string + | Tlv_port_id_mac of ethernet_mac + | Tlv_port_id_net of ipv4_addr + | Tlv_port_id_intf_name of string + | Tlv_port_id_circ_id of string + | Tlv_port_id_local of string + | Tlv_ttl of int + | Tlv_end + | Tlv of lldp_tlv_types * string + | Tlv_unk of int * string + +val parse_lldp_tlvs: t -> lldp_tvl list +val marsal_lldp_tlvs: ethernet_mac -> lldp_tvl list -> t -> int diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index c2e4cd9..ee0c856 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -40,7 +40,8 @@ module Event = struct type e = | Datapath_join of OP.datapath_id * OP.Port.phy list | Datapath_leave of OP.datapath_id - | Packet_in of OP.Port.t * int32 * Cstruct.t * OP.datapath_id + | Packet_in of OP.Port.t * OP.Packet_in.reason * + int32 * Cstruct.t * OP.datapath_id | Flow_removed of OP.Match.t * OP.Flow_removed.reason * int32 * int32 * int64 * int64 * OP.datapath_id @@ -56,9 +57,11 @@ module Event = struct let string_of_event = function | Datapath_join (dpid, _) -> sp "Datapath_join: dpid:0x%012Lx" dpid | Datapath_leave dpid -> sp "Datapath_leave: dpid:0x%012Lx" dpid - | Packet_in (port, buffer_id, bs, dpid) - -> (sp "Packet_in: port:%s ... dpid:0x%012Lx buffer_id:%ld" - (OP.Port.string_of_port port) dpid buffer_id ) + | Packet_in (port, r, buffer_id, bs, dpid) -> + (sp "Packet_in: port:%s reason:%s dpid:0x%012Lx buffer_id:%ld" + (OP.Port.string_of_port port) + (OP.Packet_in.string_of_reason r) + dpid buffer_id ) | Flow_removed (flow, reason, duration_sec, duration_usec, packet_count, byte_count, dpid) -> (sp "Flow_removed: flow: %s reason:%s duration:%ld.%ld packets:%s \ @@ -151,61 +154,51 @@ let process_of_packet state conn ofp = OP.( match ofp with | Hello (h) -> begin (* Reply to HELLO with a HELLO and a feature request *) - let _ = cp "HELLO" in - lwt _ = send_packet conn (OP.Hello (h)) in + let _ = pp "[controller] HELLO\n%!" in + lwt _ = send_packet conn (OP.Hello (h)) in let h = OP.Header.create OP.Header.FEATURES_REQ OP.Header.get_len in send_packet conn (OP.Features_req (h) ) end | Echo_req h -> begin (* Reply to ECHO requests *) - let _ = cp "ECHO_REQ" in - let h = OP.Header.(create ~xid:h.xid ECHO_RESP get_len) in - send_packet conn (OP.Echo_resp h) + let _ = pp "[controller] ECHO_REQ\n%!" in + let h = OP.Header.(create ~xid:h.xid ECHO_RESP get_len) in + send_packet conn (OP.Echo_resp h) end | Features_resp (h, sfs) -> begin (* Generate a datapath join event *) - cp "FEATURES_RESP"; - let dpid = sfs.Switch.datapath_id in - let _ = conn.dpid <- dpid in - - let evt = Event.Datapath_join (dpid, sfs.Switch.ports) in + let _ = pp "[controller] FEATURES_RESP\n%!" in + let _ = conn.dpid <- sfs.Switch.datapath_id in + let evt = Event.Datapath_join (sfs.Switch.datapath_id, sfs.Switch.ports) in let _ = - if (Hashtbl.mem state.dp_db dpid) then - Printf.printf "Deleting old state \n%!" + if (Hashtbl.mem state.dp_db sfs.Switch.datapath_id) then + Printf.printf "[controller] Deleting old state \n%!" in - let _ = Hashtbl.replace state.dp_db dpid conn in - Lwt_list.iter_p (fun cb -> cb state dpid evt) state.datapath_join_cb - -(* return () *) + let _ = Hashtbl.replace state.dp_db sfs.Switch.datapath_id conn in + Lwt_list.iter_p (fun cb -> cb state sfs.Switch.datapath_id evt) + state.datapath_join_cb end | Packet_in (h, p) -> begin (* Generate a packet_in event *) -(* cp (sp "+ %s|%s" + let _ = pp "[controller]+ %s|%s\n%!" (OP.Header.header_to_string h) - (OP.Packet_in.packet_in_to_string p)); *) -(* - let evt = Event.Packet_in ( - p.Packet_in.in_port, p.Packet_in.buffer_id, - p.Packet_in.data, conn.dpid) - in - iter_p (fun cb -> cb state conn.dpid evt) - state.packet_in_cb - *) - return () + (OP.Packet_in.packet_in_to_string p) in + let evt = + Event.Packet_in (p.Packet_in.in_port, p.Packet_in.reason, + p.Packet_in.buffer_id, p.Packet_in.data, conn.dpid) in + iter_p (fun cb -> cb state conn.dpid evt) state.packet_in_cb end - | Flow_removed (h, p) - -> (cp (sp "+ %s|%s" + | Flow_removed (h, p) -> + let _ = pp "+ %s|%s\n%!" (OP.Header.header_to_string h) - (OP.Flow_removed.string_of_flow_removed p)); - let evt = Event.Flow_removed ( - p.Flow_removed.of_match, p.Flow_removed.reason, + (OP.Flow_removed.string_of_flow_removed p) in + let evt = Event.Flow_removed ( + p.Flow_removed.of_match, p.Flow_removed.reason, p.Flow_removed.duration_sec, p.Flow_removed.duration_nsec, p.Flow_removed.packet_count, p.Flow_removed.byte_count, conn.dpid) - in - Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_removed_cb - ) - + in + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_removed_cb | Stats_resp(h, resp) -> begin - cp (sp "+ %s|%s" (OP.Header.header_to_string h) - (OP.Stats.string_of_stats resp)); - match resp with + let _ = pp "[controller] + %s|%s\n%!" (OP.Header.header_to_string h) + (OP.Stats.string_of_stats resp) in + match resp with | OP.Stats.Flow_resp(resp_h, flows) -> begin let evt = Event.Flow_stats_reply( h.Header.xid, resp_h.Stats.more_to_follow, flows, conn.dpid) @@ -247,15 +240,13 @@ let process_of_packet state conn ofp = end | Port_status(h, st) -> begin - cp (sp "+ %s|%s" (OP.Header.header_to_string h) - (OP.Port.string_of_status st)); - let evt = Event.Port_status (st.Port.reason, st.Port.desc, conn.dpid) - in + let _ = pp "[controller] + %s|%s" (OP.Header.header_to_string h) + (OP.Port.string_of_status st) in + let evt = Event.Port_status (st.Port.reason, st.Port.desc, conn.dpid) in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_status_cb end | ofp -> - let _ = OS.Console.log (sp "Packet type not supported %s" - (OP.to_string ofp)) in + let _ = pp "[controller] Unsupported %s" (OP.to_string ofp) in return () ) @@ -267,57 +258,33 @@ let send_data controller dpid ofp = let conn = Hashtbl.find controller.dp_db dpid in Ofsocket.send_packet conn ofp - let mem_dbg name = Gc.compact (); let s = Gc.stat () in Printf.printf "blocks %s: l=%d f=%d \n %!" name s.Gc.live_blocks s.Gc.free_blocks -let terminate st = - let _ = Hashtbl.iter - (fun _ c -> Ofsocket.close c ) st.dp_db in - Printf.printf "Terminating controller...\n%!" - - let main_loop st conn = while_lwt true do lwt ofp = read_packet conn in - lwt _ = process_of_packet st conn ofp - in - return () done let controller_run st conn = - lwt ofp = read_packet conn in - lwt _ = - process_of_packet st conn ofp - in - lwt ofp = read_packet conn in - lwt _ = - process_of_packet st conn ofp - in lwt _ = -(* try_lwt *) + try_lwt main_loop st conn - -(* with | Nettypes.Closed -> begin - let _ = printf "XXXXX switch disconnected\n%!" in - return () + return (printf "[controller] switch disconnected\n%!") end | OP.Unparsed(m, bs) | OP.Unparsable(m, bs) -> - let _ = cp (sp "# unparsed! m=%s" m) in + let _ = pp "[controller] # unparsed! m=%s" m in let _ = Cstruct.hexdump bs in return () -(* main_loop st conn *) | exn -> - pp "{OpenFlow-controller} ERROR:%s\n%!" (Printexc.to_string exn); + pp "[controller] ERROR:%s\n%!" (Printexc.to_string exn); return () - *) -(* main_loop st conn *) in if (conn.dpid > 0L) then let evt = Event.Datapath_leave (conn.dpid) in @@ -325,12 +292,12 @@ let controller_run st conn = st.datapath_leave_cb in let _ = Hashtbl.remove st.dp_db conn.dpid in return () - else - return () + else + return () let socket_controller st (remote_addr, remote_port) t = let rs = Nettypes.ipv4_addr_to_string remote_addr in - let _ = pp "OpenFlow Controller+ %s:%d\n%!" rs remote_port in + let _ = pp "[controller]+ Controller %s:%d\n%!" rs remote_port in let conn = init_socket_conn_state t in controller_run st conn diff --git a/lib/ofcontroller.mli b/lib/ofcontroller.mli index abc7ba2..565db88 100644 --- a/lib/ofcontroller.mli +++ b/lib/ofcontroller.mli @@ -35,7 +35,8 @@ module Event : sig type e = Datapath_join of datapath_id * Ofpacket.Port.phy list | Datapath_leave of datapath_id - | Packet_in of Port.t * int32 * Cstruct.t * datapath_id + | Packet_in of Port.t * Packet_in.reason * int32 * + Cstruct.t * datapath_id | Flow_removed of Match.t * Flow_removed.reason * int32 * int32 * int64 * int64 * datapath_id | Flow_stats_reply of int32 * bool * Flow.stats list * datapath_id @@ -51,8 +52,6 @@ type t val register_cb : t -> Event.t -> (t -> Ofpacket.datapath_id -> Event.e -> unit Lwt.t) -> unit val send_of_data : t -> Ofpacket.datapath_id -> Cstruct.t -> unit Lwt.t val send_data : t -> Ofpacket.datapath_id -> Ofpacket.t -> unit Lwt.t -val terminate : t -> unit -val mem_dbg : string -> unit val listen : Manager.t -> Nettypes.ipv4_src -> (t -> 'a) -> unit Lwt.t val connect : Manager.t -> Nettypes.ipv4_dst -> diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 8ed103a..7c2c8ea 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -536,6 +536,14 @@ module Port = struct advertised=init_port_features; supported=init_port_features; peer=init_port_features;} + let translate_port_phy port new_port_id = + {port_no=new_port_id; hw_addr=port.hw_addr; + name=port.name; config=port.config; + state=port.state; curr=port.curr; + advertised=port.advertised; supported=port.supported; + peer=port.peer;} + + let marshal_phy phy bits = let _ = set_ofp_phy_port_port_no bits phy.port_no in let _ = set_ofp_phy_port_hw_addr phy.hw_addr 0 bits in @@ -1759,7 +1767,7 @@ module Flow_mod = struct flags: flags; mutable actions: Flow.action list; } - + (* {of_m with of_match=x; } *) cstruct ofp_flow_mod { uint64_t cookie; uint16_t command; @@ -2145,7 +2153,7 @@ module Stats = struct create_port_stat_req ~xid ~port bits | Queue_req (_, port, queue_id) -> create_queue_stat_req ~xid ~queue_id ~port bits -(* | Vendor_req _ -> failwith "Vendor queue req not supported" *) + | Vendor_req _ -> failwith "Vendor queue req not supported" let parse_stats_req bits = @@ -2219,22 +2227,19 @@ module Stats = struct } as big_endian let rec parse_table_stats_reply bits = - match (Cstruct.len bits ) with - | l -> - let table_id = table_id_of_int (get_ofp_table_stats_table_id bits) in - let name = get_ofp_table_stats_name bits in - let name = Cstruct.copy name 0 (Cstruct.len name) in - let wildcards = Wildcards.parse_wildcards (get_ofp_table_stats_wildcards - bits) in - let max_entries = get_ofp_table_stats_max_entries bits in - let active_count = get_ofp_table_stats_active_count bits in - let lookup_count = get_ofp_table_stats_lookup_count bits in - let matched_count = get_ofp_table_stats_matched_count bits in - let ret = {table_id; name; wildcards; max_entries; active_count; lookup_count; - matched_count;} in - let _ = Cstruct.shift bits sizeof_ofp_table_stats in - [ret] @ (parse_table_stats_reply bits) - | 0 -> [] + let table_id = table_id_of_int (get_ofp_table_stats_table_id bits) in + let name = get_ofp_table_stats_name bits in + let name = Cstruct.copy name 0 (Cstruct.len name) in + let wildcards = Wildcards.parse_wildcards + (get_ofp_table_stats_wildcards bits) in + let max_entries = get_ofp_table_stats_max_entries bits in + let active_count = get_ofp_table_stats_active_count bits in + let lookup_count = get_ofp_table_stats_lookup_count bits in + let matched_count = get_ofp_table_stats_matched_count bits in + let ret = {table_id; name; wildcards; max_entries; active_count; + lookup_count; matched_count;} in + let _ = Cstruct.shift bits sizeof_ofp_table_stats in + [ret] @ (parse_table_stats_reply bits) let rec string_of_table_stats_reply tables = match tables with @@ -2629,13 +2634,13 @@ let parse h bits = ) let to_string = function - | Features_req h - | Get_config_req h - | Barrier_req h - | Barrier_resp h - | Echo_req h - | Echo_resp h - | Get_config_req h + | Features_req (h) + | Get_config_req (h) + | Barrier_req (h) + | Barrier_resp (h) + | Echo_req (h) + | Echo_resp (h) + | Get_config_req (h) | Get_config_resp (h, _) | Set_config (h, _) | Flow_removed (h, _) @@ -2653,14 +2658,14 @@ let to_string = function let marshal msg = let marshal = match msg with - | Features_req h - | Get_config_req h - | Barrier_req h - | Barrier_resp h - | Echo_req h - | Echo_resp h - | Get_config_req h - | Hello h -> Header.marshal_header h + | Features_req (h) + | Get_config_req (h) + | Barrier_req (h) + | Barrier_resp (h) + | Echo_req (h) + | Echo_resp (h) + | Get_config_req (h) + | Hello (h) -> Header.marshal_header h | Flow_removed (h, frm) -> Flow_removed.marshal_flow_removed ~xid:(h.Header.xid) frm | Packet_in (h, pkt_in) -> diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index d0002a9..c3d1b90 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -56,7 +56,7 @@ module Header : | BARRIER_RESP | QUEUE_GET_CONFIG_REQ | QUEUE_GET_CONFIG_RESP - type h = { ver : uint8; ty : msg_code; len : uint16; xid : uint32; } + type h = {ver:uint8;ty:msg_code;len:uint16;xid:uint32;} val get_len : int val parse_header : Cstruct.t -> h val header_to_string : h -> string @@ -128,7 +128,8 @@ module Port : peer : features; } val init_port_phy: ?port_no:int -> ?hw_addr:eaddr -> - ?name:string -> unit -> phy + ?name:string -> unit -> phy + val translate_port_phy : phy -> int -> phy val string_of_phy : phy -> string type stats = { mutable port_id : uint16; diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index 988dbdd..c754a08 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -61,7 +61,6 @@ let read_data t len = let _ = t.data_cache := (Cstruct.shift data len) in return ret | (_, l) when (l >= len) -> - let ret = !(t.data_cache) in let ret = Cstruct.sub !(t.data_cache) 0 len in let _ = t.data_cache := (Cstruct.shift !(t.data_cache) len) in return ret @@ -72,6 +71,7 @@ let read_data t len = let _ = Cstruct.blit data 0 ret l len_rest in let _ = t.data_cache := (Cstruct.shift data len_rest) in return (ret) + | _ -> failwith "invalid read data operation" end (* module Unix_socket = struct diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 51e6e42..d8801a2 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -337,8 +337,8 @@ module Switch = struct let supported_capabilities () = OP.Switch.({flow_stats=true;table_stats=true;port_stats=true;stp=true; ip_reasm=false;queue_stats=false;arp_match_ip=true;}) - let switch_features () = - OP.Switch.({datapath_id=1L; n_buffers=0l; n_tables=(char_of_int 1); + let switch_features datapath_id = + OP.Switch.({datapath_id; n_buffers=0l; n_tables=(char_of_int 1); capabilities=(supported_capabilities ()); actions=(supported_actions ()); ports=[];}) @@ -464,9 +464,7 @@ module Switch = struct update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; Net.Manager.inject_packet port.mgr port.ethif bits (* Net.Ethif.write (Net.Manager.get_netif port.mgr port.ethif) bits*) - ) else - return () - ) st.ports + ) else return ()) st.ports | OP.Port.In_port -> let port = (OP.Port.int_of_port in_port) in if Hashtbl.mem st.int_to_port port then @@ -617,13 +615,12 @@ type t = Switch.t (* * let process_frame_depr intf_name frame = *) let process_frame_inner st p intf frame = - match frame with - | Net.Ethif.Output _ -> return () + match frame with + | Net.Ethif.Output (frame::_) -> return () | Net.Ethif.Input frame -> begin try_lwt - let in_port = (OP.Port.port_of_int p.Switch.port_id) in - let tupple = (OP.Match.raw_packet_to_match in_port frame ) in - + let in_port = (OP.Port.port_of_int p.Switch.port_id) in + let tupple = (OP.Match.raw_packet_to_match in_port frame ) in (* Update port rx statistics *) let _ = Switch.update_port_rx_stats (Int64.of_int (Cstruct.len frame)) p in @@ -635,10 +632,12 @@ let process_frame_inner st p intf frame = let buffer_id = st.Switch.packet_buffer_id in (*TODO Move this code in the Switch module *) st.Switch.packet_buffer_id <- Int32.add st.Switch.packet_buffer_id 1l; - let (_, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id ~in_port + let (h, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id ~in_port ~reason:OP.Packet_in.NO_MATCH ~data:frame in let _ = st.Switch.packet_buffer <- st.Switch.packet_buffer @ [pkt_in] in - let size = + + (* Disable for now packet trimming for buffered packets *) +(* let size = if (Cstruct.len frame > 92) then 92 else @@ -646,10 +645,12 @@ let process_frame_inner st p intf frame = in let (h, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id ~in_port ~reason:OP.Packet_in.NO_MATCH - ~data:(Cstruct.sub frame 0 size) in - match st.Switch.controller with - | None -> return () - | Some conn -> Ofsocket.send_packet conn (OP.Packet_in (h, pkt_in)) + ~data:(Cstruct.sub frame 0 size) in*) + return (ignore_result ( + match st.Switch.controller with + | None -> return () + | Some conn -> Ofsocket.send_packet conn (OP.Packet_in (h, pkt_in)) + )) end (* generate a packet in event *) | Switch.Found(entry) -> @@ -826,7 +827,7 @@ let process_openflow st t msg = Ofsocket.send_packet t (OP.Barrier_resp(resp_h)) | OP.Packet_out(h, pkt) -> - cp (sp "PACKET_OUT: %s" (OP.Packet_out.packet_out_to_string pkt)); +(* cp (sp "PACKET_OUT: %s" (OP.Packet_out.packet_out_to_string pkt)); *) if (pkt.OP.Packet_out.buffer_id = -1l) then Switch.apply_of_actions st pkt.OP.Packet_out.in_port pkt.OP.Packet_out.data pkt.OP.Packet_out.actions @@ -1063,13 +1064,13 @@ let add_flow st fm = Table.add_flow st st.Switch.table fm let del_flow st m = Table.del_flow st.Switch.table m OP.Port.No_port st.Switch.controller -let create_switch () = +let create_switch dpid = let (packet_queue, push_packet) = Lwt_stream.create () in Switch.( { ports = []; int_to_port = (Hashtbl.create 64); dev_to_port=(Hashtbl.create 64); p_sflow = 0_l; controller=None; errornum = 0l; portnum=0; packet_queue; push_packet; queue_len = 0; stats={n_frags=0L; n_hits=0L;n_missed=0L;n_lost=0L;}; - table = (Table.init_table ()); features=(Switch.switch_features ()); + table = (Table.init_table ()); features=(Switch.switch_features dpid); packet_buffer=[]; packet_buffer_id=0l;}) let listen st mgr loc = diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index 80fe03d..857002d 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -23,7 +23,7 @@ val add_port_local : Net.Manager.t -> t -> Net.Manager.id -> unit Lwt.t val add_flow : t -> Ofpacket.Flow_mod.t -> unit Lwt.t val del_flow : t -> Ofpacket.Match.t -> unit Lwt.t val get_flow_stats : t -> Ofpacket.Match.t -> Ofpacket.Flow.stats list -val create_switch : unit -> t +val create_switch : int64 -> t val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> unit Lwt.t val connect : t -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> diff --git a/lib/ofswitch_standalone.ml b/lib/ofswitch_standalone.ml index cc0c082..91b6664 100644 --- a/lib/ofswitch_standalone.ml +++ b/lib/ofswitch_standalone.ml @@ -86,7 +86,7 @@ let packet_in_cb controller dpid evt = incr switch_data.req_count; let (in_port, buffer_id, data, dp) = match evt with - | OE.Packet_in (inp, buf, dat, dp) -> (inp, buf, dat, dp) + | OE.Packet_in (inp, _, buf, dat, dp) -> (inp, buf, dat, dp) | _ -> invalid_arg "bogus datapath_join event match!" in (* Parse Ethernet header *) diff --git a/lib/openflow.mlpack b/lib/openflow.mlpack index 57ffe79..2ca8d91 100644 --- a/lib/openflow.mlpack +++ b/lib/openflow.mlpack @@ -1,9 +1,12 @@ # OASIS_START -# DO NOT EDIT (digest: 58fcea190f28357e050fe23bbcbd01b3) +# DO NOT EDIT (digest: f8655b265a303b0b1fd5a6766c3a4bec) Ofpacket Ofcontroller Ofswitch_config Ofswitch Ofsocket Ofswitch_standalone +Flowvisor +Flowvisor_topology +Lldp # OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 79d176d..83cf5a7 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 61f654469bb09f01f7251ebcd6388c82) *) +(* DO NOT EDIT (digest: b6e8b4245b50e2cce10c824f28c99f46) *) module OASISGettext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -335,7 +335,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -351,7 +351,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index 2393200..4e52110 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: f9a1927fbe7dce2b8a0a21360f32decf) *) +(* DO NOT EDIT (digest: 152779c70a75a31419a30a533e9cc554) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISContext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISString.ml" *) +(* # 1 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISUtils.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) +(* # 71 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISMessage.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISVersion.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISLicense.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) @@ -1020,7 +1020,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 104 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) +(* # 104 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1186,7 +1186,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1270,7 +1270,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISHostPath.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISHostPath.ml" *) open Filename @@ -1303,7 +1303,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISSection.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1386,12 +1386,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISExecutable.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1424,7 +1424,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISLibrary.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1604,7 +1604,7 @@ module OASISLibrary = struct end module OASISObject = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISObject.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext @@ -1669,7 +1669,7 @@ module OASISObject = struct end module OASISFindlib = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISFindlib.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFindlib.ml" *) open OASISTypes @@ -1956,32 +1956,32 @@ module OASISFindlib = struct end module OASISFlag = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISFlag.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISPackage.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISTest.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISDocument.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISExec.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -2059,7 +2059,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2256,7 +2256,7 @@ end # 2257 "setup.ml" module BaseEnvLight = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2354,7 +2354,7 @@ end # 2355 "setup.ml" module BaseContext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseContext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseContext.ml" *) open OASISContext @@ -2365,7 +2365,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseMessage.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2384,7 +2384,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseEnv.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2844,7 +2844,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseArgExt.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2872,7 +2872,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseCheck.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2998,7 +2998,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -3114,7 +3114,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseStandardVar.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3478,7 +3478,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseFileAB.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3526,7 +3526,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseLog.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseLog.ml" *) open OASISUtils @@ -3645,7 +3645,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseBuilt.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3813,7 +3813,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseCustom.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3863,7 +3863,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseDynVar.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3910,7 +3910,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseTest.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -4000,7 +4000,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseDoc.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -4035,7 +4035,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/base/BaseSetup.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4616,7 +4616,7 @@ end # 4617 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4872,7 +4872,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5457,7 +5457,7 @@ end # 5458 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5559,7 +5559,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5766,7 +5766,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-xen/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5958,7 +5958,8 @@ let setup_t = FindlibPackage ("mirage-net", Some (OASISVersion.VGreaterEqual "0.3.0")); - FindlibPackage ("re.str", None) + FindlibPackage ("re.str", None); + FindlibPackage ("ocamlgraph", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -5978,7 +5979,10 @@ let setup_t = "Ofswitch_config"; "Ofswitch"; "Ofsocket"; - "Ofswitch_standalone" + "Ofswitch_standalone"; + "Flowvisor"; + "Flowvisor_topology"; + "Lldp" ]; lib_pack = true; lib_internal_modules = []; @@ -6145,8 +6149,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = - Some "K\197R\003\255\007\214\027\159\246\230\175,\236m\247"; + oasis_digest = Some "¢¾@\bò\130\027­°\011)«ò\131H\031"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6154,6 +6157,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6158 "setup.ml" +# 6161 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 1d21b716c9d2e8b9e46ef1d0c4c570f90948ffa7 Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 24 Jan 2013 11:46:24 +0000 Subject: [PATCH 36/75] Adding some logging code for ofswitch --- lib/ofswitch.ml | 34 +++++++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index d8801a2..dee6aad 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -22,6 +22,8 @@ open Net open Nettypes open Ofswitch_config open Printf +open Jsonrpc + module OP = Ofpacket @@ -145,9 +147,22 @@ module Table = struct let _ = Console.log (sprintf "Adding flow %s" (OP.Match.match_to_string t.OP.Flow_mod.of_match)) in - let entry = Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); + let entry = Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); cache_entries=[];}) in - let _ = Hashtbl.replace table.entries t.OP.Flow_mod.of_match entry in + + (* log data to the visualisation server *) + let Some(node_name) = Lwt.get OS.Topology.node_name in + let flow_str = OP.Match.match_to_string t.OP.Flow_mod.of_match in + let action_str = OP.Flow.string_of_actions t.OP.Flow_mod.actions in + let msg = Rpc.Dict [ + ("name", (Rpc.String node_name)); + ("type", (Rpc.String "add")); + ("flow", (Rpc.String flow_str)); + ("action", (Rpc.String action_str)); + ] in + + let _ = OS.Console.broadcast "flow" (Jsonrpc.to_string msg) in + let _ = Hashtbl.replace table.entries t.OP.Flow_mod.of_match entry in (* In the fast path table, I need to delete any conflicting entries *) let _ = Hashtbl.iter ( @@ -181,7 +196,20 @@ module Table = struct ((out_port = OP.Port.No_port) || (is_output_port out_port flow.Entry.actions))) then ( let _ = Hashtbl.remove table.entries of_match in - ret @ [(of_match, flow)] + + (* log removal of flow *) + let Some(node_name) = Lwt.get OS.Topology.node_name in + let flow_str = OP.Match.match_to_string of_match in + let action_str = OP.Flow.string_of_actions flow.Entry.actions in + let msg = Rpc.Dict [ + ("name", (Rpc.String node_name)); + ("type", (Rpc.String "del")); + ("flow", (Rpc.String flow_str)); + ("action", (Rpc.String action_str)); + ] in + + let _ = OS.Console.broadcast "flow" (Jsonrpc.to_string msg) in + ret @ [(of_match, flow)] ) else ret ) table.entries [] in From 3e1e1bc721e1e29a07a73a7248b0451dbe2b9070 Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 24 Jan 2013 19:45:58 +0000 Subject: [PATCH 37/75] fixing state caching on flowvisor module --- lib/flowvisor.ml | 164 +++++++++++++++++++++++++++++++++++-------- lib/ofcontroller.ml | 18 +++-- lib/ofcontroller.mli | 4 +- lib/ofpacket.ml | 22 +++--- lib/ofpacket.mli | 9 +-- lib/ofswitch.ml | 81 ++++++++++++--------- 6 files changed, 211 insertions(+), 87 deletions(-) diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index ee479ab..6f098d1 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -44,6 +44,21 @@ type port = { origin_port_id: int; } +type cached_reply = + | Flows of OP.Flow.stats list + | Aggr of OP.Stats.aggregate + | Table of OP.Stats.table + | Port of OP.Port.stats list + | No_reply + +type xid_state = { + xid : int32; + src : int64; + mutable dst : int64 list; + ts : float; + mutable cache : cached_reply; +} + type t = { (* counters *) mutable errornum : int32; @@ -56,7 +71,7 @@ type t = { switches : (int64, Ofcontroller.t) Hashtbl.t; (* Mapping transients id values *) - xid_map : (int32, (int64 * int64 list * float)) Hashtbl.t; + xid_map : (int32, xid_state) Hashtbl.t; port_map : (int, (int64 * int * OP.Port.phy)) Hashtbl.t; buffer_id_map : (int32, (OP.Packet_in.t * int64)) Hashtbl.t; @@ -64,6 +79,9 @@ type t = { flv_topo: Flowvisor_topology.t; } +(* timeout pending queries after 3 minutes *) +let timeout = 180. + let supported_actions () = OP.Switch.( {output=true;set_vlan_id=true;set_vlan_pcp=true;strip_vlan=true; @@ -100,15 +118,33 @@ let match_dpid_buffer_id st dpid buffer_id = let (_, dst_dpid) = Hashtbl.find st.buffer_id_map buffer_id in (dpid = dst_dpid) with Not_found -> false -let get_new_xid st dpid dst_dpid = +let get_new_xid old_xid st src dst cache = let xid = st.xid_count in let _ = st.xid_count <- Int32.add st.xid_count 1l in - let now = OS.Clock.time () in - let _ = Hashtbl.replace st.xid_map xid (dpid, dst_dpid, now) in + let r = {xid; src; dst; ts=(OS.Clock.time ()); cache;} in + let _ = Hashtbl.replace st.xid_map xid r in xid +let handle_xid st xid = return () + +let timeout_xid st = + while_lwt true do + lwt _ = OS.Time.sleep 120.0 in + let time = OS.Clock.time () in + let xid = + Hashtbl.fold ( + fun xid r ret -> + if (r.ts+.timeout>time) then + let _ = Hashtbl.remove st.xid_map xid in + r :: ret + else ret + ) st.xid_map [] in + lwt _ = Lwt_list.iter_p (handle_xid st) xid in + OS.Time.sleep 600. + done + (* communication primitives *) -let get_all_switch_dpid flv = Hashtbl.fold (fun dpid _ r -> r@[dpid]) flv.switches [] +let switch_dpid flv = Hashtbl.fold (fun dpid _ r -> r@[dpid]) flv.switches [] let send_all_switches st msg = Lwt_list.iter_p ( fun (dpid, ch) -> Ofcontroller.send_data ch dpid msg) @@ -319,7 +355,7 @@ let process_openflow st dpid t msg = OP.Stats.({ imfr_desc="Mirage"; hw_desc="Mirage"; sw_desc="Mirage_flowvisor"; serial_num="0.1"; dp_desc="Mirage";}) in - let resp_h = OP.Stats.({st_ty=DESC;more_to_follow=false;}) in + let resp_h = OP.Stats.({st_ty=DESC;more=false;}) in send_controller t (OP.Stats_resp(h, (OP.Stats.Desc_resp(resp_h,desc)))) | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> begin @@ -331,7 +367,7 @@ let process_openflow st dpid t msg = | (false, OP.Port.Port(p)) -> let (dst_dpid, out_port, _) = Hashtbl.find st.port_map p in - let xid = get_new_xid st dst_dpid [dpid] in + let xid = get_new_xid h.OP.Header.xid st dst_dpid [dpid] (Flows [])in let h = OP.Header.(create STATS_RESP ~xid sizeof_ofp_header) in let out_port = OP.Port.Port(out_port) in @@ -347,18 +383,20 @@ let process_openflow st dpid t msg = | (_, _) -> let req = OP.Stats.(Flow_req(req_h, of_match, table_id, out_port)) in - let xid = get_new_xid st dpid (get_all_switch_dpid st) in + let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) (Flows []) in let h = OP.Header.(create STATS_RESP ~xid sizeof_ofp_header) in - send_all_switches st (OP.Stats_req(h, req)) + send_all_switches st (OP.Stats_req(h, req)) end | OP.Stats.Aggregate_req (req_h, of_match, table_id, out_port) -> begin + let cache = (Aggr (OP.Stats.({packet_count=0L; byte_count=0L; + flow_count=0l;}))) in match (of_match.OP.Match.wildcards.OP.Wildcards.in_port, (of_match.OP.Match.in_port)) with | (false, OP.Port.Port(p)) -> let (dst_dpid, port, _) = Hashtbl.find st.port_map p in - let xid = get_new_xid st dpid [dst_dpid] in + let xid = get_new_xid h.OP.Header.xid st dpid [dst_dpid] cache in let h = OP.Header.({ h with xid;}) in let _ = of_match.in_port <-OP.Port.Port(port) in (* TODO out_port needs processing. if dpid are between @@ -368,23 +406,26 @@ let process_openflow st dpid t msg = table_id, out_port)) in send_switch st dst_dpid (OP.Stats_req(h, m)) | (_, _) -> - let h = OP.Header.({h with xid=(get_new_xid st dpid - (get_all_switch_dpid st));}) in + let h = OP.Header.({h with xid=(get_new_xid h.OP.Header.xid st dpid + (switch_dpid st) cache);}) in send_all_switches st (OP.Stats_req(h, req)) end | OP.Stats.Table_req(req_h) -> - let xid = get_new_xid st dpid (get_all_switch_dpid st) in + let cache = Table (OP.Stats.init_table_stats (OP.Stats.table_id_of_int 1) + "mirage" (OP.Wildcards.full_wildcard ()) ) in + let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) cache in let h = OP.Header.({h with xid;}) in send_all_switches st (OP.Stats_req(h, req)) | OP.Stats.Port_req(req_h, port) -> begin match port with | OP.Port.No_port -> - let xid = get_new_xid st dpid (get_all_switch_dpid st) in + let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) (Port + []) in let h = OP.Header.({h with xid;}) in send_all_switches st (OP.Stats_req(h, req)) | OP.Port.Port(port) when (Hashtbl.mem st.port_map port) -> let (dst_dpid, port, _) = Hashtbl.find st.port_map port in - let xid = get_new_xid st dpid [dst_dpid] in + let xid = get_new_xid h.OP.Header.xid st dpid [dst_dpid] (Port []) in let h = OP.Header.({h with xid;}) in let m = OP.Stats.(Port_req(req_h, OP.Port.Port(port))) in send_all_switches st (OP.Stats_req(h, m)) @@ -417,7 +458,7 @@ let process_openflow st dpid t msg = | OP.Flow_mod(h,fm) -> begin let _ = pr "[flowvisor-switch] FLOW_MOD: %s\n%!" (OP.Flow_mod.flow_mod_to_string fm) in - let xid = get_new_xid st dpid (get_all_switch_dpid st) in + let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) No_reply in match (fm.OP.Flow_mod.command) with | OP.Flow_mod.ADD | OP.Flow_mod.MODIFY @@ -502,12 +543,14 @@ let del_flowvisor_port flv desc = let map_flv_port flv dpid port = (* map the new port *) - OP.Port.Port ( - Hashtbl.fold ( - fun flv_port (sw_dpid, sw_port, _) r -> - if ((dpid = sw_dpid) && - (sw_port = port)) then flv_port - else r ) flv.port_map 0 ) + let port = + Hashtbl.fold ( + fun flv_port (sw_dpid, sw_port, _) r -> + if ((dpid = sw_dpid) && + (sw_port = port)) then flv_port + else r ) flv.port_map (-1) in + if (port < 0) then raise Not_found + else OP.Port.Port (port) let process_switch_channel flv st dpid e = match e with @@ -572,14 +615,75 @@ let process_switch_channel flv st dpid e = let h = OP.Header.(create FLOW_REMOVED 0) in inform_controllers flv of_match (OP.Flow_removed(h, pkt)) (* TODO: Need to write code to handle stats replies *) - | OE.Flow_stats_reply(xid, more, flows, dpid) -> - (* Group reply separation *) - return () - | OE.Aggr_flow_stats_reply(xid, pkts, bytes, flows, dpid) -> - return () - | OE.Port_stats_reply(xid, ports, dpid) -> - return () - | OE.Table_stats_reply(xid, tables, dpid) -> + | OE.Flow_stats_reply(xid, more, flows, dpid) -> begin + try_lwt + let xid_st = Hashtbl.find flv.xid_map xid in + match xid_st.cache with + | Flows fl -> + (* Group reply separation *) + let _ = xid_st.cache <- (Flows (fl @ flows)) in + let _ = + if not more then + xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst + in + if (List.length xid_st.dst = 0 ) then + let _ = Hashtbl.remove flv.xid_map xid in + handle_xid st xid_st + else + let _ = Hashtbl.replace flv.xid_map xid xid_st in + return () + | _ -> return () + with Not_found -> return () + end + | OE.Aggr_flow_stats_reply(xid, pkts, bytes, flows, dpid) -> begin + try_lwt + let xid_st = Hashtbl.find flv.xid_map xid in + match xid_st.cache with + | Aggr aggr -> + (* Group reply separation *) + let aggr = + OP.Stats.({packet_count=(Int64.add pkts aggr.packet_count); + byte_count=(Int64.add bytes aggr.byte_count); + flow_count=(Int32.add flows aggr.flow_count);}) in + let _ = xid_st.cache <- (Aggr aggr) in + let _ = + xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst + in + if (List.length xid_st.dst = 0 ) then + let _ = Hashtbl.remove flv.xid_map xid in + handle_xid st xid_st + else + let _ = Hashtbl.replace flv.xid_map xid xid_st in + return () + | _ -> return () + with Not_found -> return () + end + | OE.Port_stats_reply(xid, more, ports, dpid) -> begin + try_lwt + let xid_st = Hashtbl.find flv.xid_map xid in + match xid_st.cache with + | Port p -> + (* Group reply separation *) + let ports = + List.map ( + fun port -> + let port_id = map_flv_port flv dpid port.OP.Port.port_id in + OP.Port.({port with port_id=(OP.Port.int_of_port port_id);})) ports in + let _ = xid_st.cache <- (Port (p @ ports)) in + let _ = + if not more then + xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst + in + if (List.length xid_st.dst = 0 ) then + let _ = Hashtbl.remove flv.xid_map xid in + handle_xid st xid_st + else + let _ = Hashtbl.replace flv.xid_map xid xid_st in + return () + | _ -> return () + with Not_found -> return () + end + | OE.Table_stats_reply(xid, more, tables, dpid) -> return () | OE.Port_status(reason, port, dpid) -> (* TODO: send a port withdrawal to all controllers *) diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 7fdb141..622ee9f 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -47,8 +47,8 @@ module Event = struct * OP.datapath_id | Flow_stats_reply of int32 * bool * OP.Flow.stats list * OP.datapath_id | Aggr_flow_stats_reply of int32 * int64 * int64 * int32 * OP.datapath_id - | Port_stats_reply of int32 * OP.Port.stats list * OP.datapath_id - | Table_stats_reply of int32 * OP.Stats.table list * OP.datapath_id + | Port_stats_reply of int32 * bool * OP.Port.stats list * OP.datapath_id + | Table_stats_reply of int32 * bool * OP.Stats.table list * OP.datapath_id | Desc_stats_reply of string * string * string * string * string * OP.datapath_id @@ -77,10 +77,10 @@ module Event = struct -> (sp "aggr flow stats reply: dpid:%012Lx packets:%Ld bytes:%Ld \ flows:%ld xid:%ld" dpid packet_count byte_count flow_count xid) - | Port_stats_reply (xid, ports, dpid) + | Port_stats_reply (xid, _, ports, dpid) -> (sp "port stats reply: dpid:%012Lx ports:%d xid%ld" dpid (List.length ports) xid) - | Table_stats_reply (xid, tables, dpid) + | Table_stats_reply (xid, _, tables, dpid) -> (sp "table stats reply: dpid:%012Lx tables:%d xid%ld" dpid (List.length tables) xid) | Desc_stats_reply (mfr_desc, hw_desc, sw_desc, serial_num, dp_desc, dpid) @@ -201,7 +201,7 @@ let process_of_packet state conn ofp = match resp with | OP.Stats.Flow_resp(resp_h, flows) -> begin let evt = Event.Flow_stats_reply( - h.Header.xid, resp_h.Stats.more_to_follow, flows, conn.dpid) + h.Header.xid, resp_h.Stats.more, flows, conn.dpid) in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_stats_reply_cb @@ -225,14 +225,18 @@ let process_of_packet state conn ofp = end | OP.Stats.Port_resp (resp_h, ports) -> begin - let evt = Event.Port_stats_reply(h.Header.xid, ports, conn.dpid) + let evt = + Event.Port_stats_reply(h.Header.xid, resp_h.OP.Stats.more, + ports, conn.dpid) in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_stats_reply_cb end | OP.Stats.Table_resp (resp_h, tables) -> begin - let evt = Event.Table_stats_reply(h.Header.xid, tables, conn.dpid) in + let evt = + Event.Table_stats_reply(h.Header.xid, resp_h.OP.Stats.more, + tables, conn.dpid) in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.table_stats_reply_cb end diff --git a/lib/ofcontroller.mli b/lib/ofcontroller.mli index 565db88..296c1dc 100644 --- a/lib/ofcontroller.mli +++ b/lib/ofcontroller.mli @@ -41,8 +41,8 @@ module Event : sig int32 * int32 * int64 * int64 * datapath_id | Flow_stats_reply of int32 * bool * Flow.stats list * datapath_id | Aggr_flow_stats_reply of int32 * int64 * int64 * int32 * datapath_id - | Port_stats_reply of int32 * Port.stats list * datapath_id - | Table_stats_reply of int32 * Stats.table list * datapath_id + | Port_stats_reply of int32 * bool * Port.stats list * datapath_id + | Table_stats_reply of int32 * bool * Stats.table list * datapath_id | Desc_stats_reply of string * string * string * string * string * datapath_id | Port_status of Port.reason * Port.phy * datapath_id val string_of_event : e -> string diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 7c2c8ea..1b94aaf 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -1945,9 +1945,9 @@ module Stats = struct type aggregate = { - packet_count: uint64; - byte_count: uint64; - flow_count: uint32; + mutable packet_count: uint64; + mutable byte_count: uint64; + mutable flow_count: uint32; } type table = { @@ -1960,6 +1960,10 @@ module Stats = struct mutable matched_count: uint64; } + let init_table_stats table_id name wildcards = + {table_id; name; wildcards; max_entries=0l;active_count=0l; + lookup_count=(0L); matched_count=(0L);} + type queue = { port_no: uint16; queue_id: uint32; @@ -2184,7 +2188,7 @@ module Stats = struct type resp_hdr = { st_ty: stats_type; - more_to_follow: bool; + more: bool; } let int_of_stats_type = function @@ -2290,8 +2294,8 @@ module Stats = struct let parse_stats_resp bits = let typ = stats_type_of_int (get_ofp_stats_reply_typ bits) in - let more_to_follow = ((get_ofp_stats_reply_flags bits) = 1) in - let resp = {st_ty=typ;more_to_follow;} in + let more = ((get_ofp_stats_reply_flags bits) = 1) in + let resp = {st_ty=typ;more;} in let _ = Cstruct.shift bits sizeof_ofp_stats_reply in match typ with @@ -2345,7 +2349,7 @@ module Stats = struct bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type DESC) in let _ = set_ofp_stats_reply_flags bits (int_of_bool - resp_hdr.more_to_follow) in + resp_hdr.more) in let bits = Cstruct.shift bits sizeof_ofp_stats_reply in let _ = set_ofp_desc_stats_mfr_desc desc.imfr_desc 0 bits in let _ = set_ofp_desc_stats_hw_desc desc.hw_desc 0 bits in @@ -2363,7 +2367,7 @@ module Stats = struct bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type FLOW) in let _ = set_ofp_stats_reply_flags bits (int_of_bool - resp_h.more_to_follow) in + resp_h.more) in let bits = Cstruct.shift bits sizeof_ofp_stats_reply in let (flows_len, bits) = marshal_and_shift (Flow.marshal_flow_stats flows) bits in @@ -2377,7 +2381,7 @@ module Stats = struct bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type AGGREGATE) in let _ = set_ofp_stats_reply_flags bits (int_of_bool - resp.more_to_follow) in + resp.more) in let bits = Cstruct.shift bits sizeof_ofp_stats_reply in let _ = set_ofp_aggregate_stats_reply_packet_count bits stats.packet_count in let _ = set_ofp_aggregate_stats_reply_byte_count bits stats.byte_count in diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index c3d1b90..1658253 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -403,9 +403,9 @@ module Stats : val string_of_table_id : table_id -> string type aggregate = { - packet_count : uint64; - byte_count : uint64; - flow_count : uint32; + mutable packet_count : uint64; + mutable byte_count : uint64; + mutable flow_count : uint32; } type table = { mutable table_id : table_id; @@ -416,6 +416,7 @@ module Stats : mutable lookup_count : uint64; mutable matched_count : uint64; } + val init_table_stats : table_id -> string -> Wildcards.t -> table type queue = { port_no : uint16; queue_id : uint32; @@ -459,7 +460,7 @@ module Stats : | Vendor_req of req_hdr val marshal_stats_req : ?xid:int32 -> req -> Cstruct.t -> int - type resp_hdr = { st_ty : stats_type; more_to_follow : bool; } + type resp_hdr = { st_ty : stats_type; more : bool; } val int_of_stats_type : stats_type -> int val stats_type_of_int : int -> stats_type type resp = diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index dee6aad..c7aeb52 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -151,18 +151,22 @@ module Table = struct cache_entries=[];}) in (* log data to the visualisation server *) - let Some(node_name) = Lwt.get OS.Topology.node_name in - let flow_str = OP.Match.match_to_string t.OP.Flow_mod.of_match in - let action_str = OP.Flow.string_of_actions t.OP.Flow_mod.actions in - let msg = Rpc.Dict [ - ("name", (Rpc.String node_name)); - ("type", (Rpc.String "add")); - ("flow", (Rpc.String flow_str)); - ("action", (Rpc.String action_str)); - ] in - - let _ = OS.Console.broadcast "flow" (Jsonrpc.to_string msg) in - let _ = Hashtbl.replace table.entries t.OP.Flow_mod.of_match entry in + let _ = + match (Lwt.get OS.Topology.node_name) with + | None -> () + | Some(node_name) -> + let flow_str = OP.Match.match_to_string t.OP.Flow_mod.of_match in + let action_str = OP.Flow.string_of_actions t.OP.Flow_mod.actions in + let msg = Rpc.Dict [ + ("name", (Rpc.String node_name)); + ("type", (Rpc.String "add")); + ("flow", (Rpc.String flow_str)); + ("action", (Rpc.String action_str)); + ] in + OS.Console.broadcast "flow" (Jsonrpc.to_string msg) + in + + let _ = Hashtbl.replace table.entries t.OP.Flow_mod.of_match entry in (* In the fast path table, I need to delete any conflicting entries *) let _ = Hashtbl.iter ( @@ -198,20 +202,21 @@ module Table = struct let _ = Hashtbl.remove table.entries of_match in (* log removal of flow *) - let Some(node_name) = Lwt.get OS.Topology.node_name in - let flow_str = OP.Match.match_to_string of_match in - let action_str = OP.Flow.string_of_actions flow.Entry.actions in - let msg = Rpc.Dict [ - ("name", (Rpc.String node_name)); - ("type", (Rpc.String "del")); - ("flow", (Rpc.String flow_str)); - ("action", (Rpc.String action_str)); - ] in - - let _ = OS.Console.broadcast "flow" (Jsonrpc.to_string msg) in - ret @ [(of_match, flow)] - ) else - ret + let _ = + match Lwt.get OS.Topology.node_name with + | None -> () + | Some(node_name) -> + let flow_str = OP.Match.match_to_string of_match in + let action_str = OP.Flow.string_of_actions flow.Entry.actions in + let msg = Rpc.Dict [ + ("name", (Rpc.String node_name)); + ("type", (Rpc.String "del")); + ("flow", (Rpc.String flow_str)); + ("action", (Rpc.String action_str));] in + OS.Console.broadcast "flow" (Jsonrpc.to_string msg) + in + (of_match, flow)::ret + ) else ret ) table.entries [] in (* Delete all entries from cache *) @@ -644,7 +649,7 @@ type t = Switch.t * let process_frame_depr intf_name frame = *) let process_frame_inner st p intf frame = match frame with - | Net.Ethif.Output (frame::_) -> return () + | Net.Ethif.Output _ -> return () | Net.Ethif.Input frame -> begin try_lwt let in_port = (OP.Port.port_of_int p.Switch.port_id) in @@ -770,7 +775,7 @@ let process_openflow st t msg = | OP.Stats.Desc_req(req) -> let p = OP.Stats.(Desc_resp ( - {st_ty=DESC; more_to_follow=false;}, + {st_ty=DESC; more=false;}, { imfr_desc="Mirage"; hw_desc="Mirage"; sw_desc="Mirage"; serial_num="0.1";dp_desc="Mirage";} )) in @@ -781,7 +786,7 @@ let process_openflow st t msg = * split reply over multiple openflow packets if they don't * fit a single packet. *) let flows = get_flow_stats st of_match in - let stats = OP.Stats.({st_ty=FLOW; more_to_follow=false;}) in + let stats = OP.Stats.({st_ty=FLOW; more=false;}) in let r = OP.Stats.Flow_resp(stats, flows) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in Ofsocket.send_packet t (OP.Stats_resp (h, r)) @@ -800,7 +805,7 @@ let process_openflow st t msg = ) in Hashtbl.iter (fun key value -> match_flows_aggr of_match key value) st.Switch.table.Table.entries; - let stats = OP.Stats.({st_ty=AGGREGATE; more_to_follow=false;}) in + let stats = OP.Stats.({st_ty=AGGREGATE; more=false;}) in let r = OP.Stats.Aggregate_resp(stats, OP.Stats.({byte_count=(!aggr_flow_bytes); packet_count=(!aggr_flow_pkts); @@ -809,7 +814,7 @@ let process_openflow st t msg = let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in Ofsocket.send_packet t (OP.Stats_resp (h, r)) | OP.Stats.Table_req(req) -> - let stats = OP.Stats.({st_ty=TABLE; more_to_follow=false;}) in + let stats = OP.Stats.({st_ty=TABLE; more=false;}) in let r = OP.Stats.Table_resp(stats, [st.Switch.table.Table.stats]) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in Ofsocket.send_packet t (OP.Stats_resp (h, r)) @@ -817,18 +822,18 @@ let process_openflow st t msg = match port with | OP.Port.No_port -> let port_stats = List.map (fun p -> p.Switch.counter) st.Switch.ports in - let stats = OP.Stats.({st_ty=PORT; more_to_follow=false;}) in + let stats = OP.Stats.({st_ty=PORT; more=false;}) in let r = OP.Stats.Port_resp(stats, port_stats) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in Ofsocket.send_packet t (OP.Stats_resp (h, r)) - | OP.Port.Port(port_id) -> + | OP.Port.Port(port_id) -> begin try_lwt let port = Hashtbl.find st.Switch.int_to_port port_id in - let stats = OP.Stats.({st_ty=PORT; more_to_follow=false;}) in + let stats = OP.Stats.({st_ty=PORT; more=false;}) in let r = OP.Stats.Port_resp(stats, [(!port).Switch.counter]) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in Ofsocket.send_packet t (OP.Stats_resp (h, r)) - with Not_found -> + with Not_found -> (* TODO reply with right error code *) pr "Invalid port_id in stats\n%!"; let h = OP.Header.create ~xid OP.Header.ERROR @@ -836,6 +841,12 @@ let process_openflow st t msg = Ofsocket.send_packet t (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) end + | _ -> + pr "Invalid port_id in stats\n%!"; + let h = OP.Header.create ~xid OP.Header.ERROR 0 in + Ofsocket.send_packet t + OP.(Error (h, ACTION_BAD_OUT_PORT, (marshal msg))) + end | _ -> begin let h = OP.Header.create ~xid OP.Header.ERROR (OP.Header.get_len + 4) in From 9829796283638b949c28ccf6f0372abe0bdb388e Mon Sep 17 00:00:00 2001 From: crotsos Date: Sat, 26 Jan 2013 19:33:31 +0000 Subject: [PATCH 38/75] fixing match compare function --- lib/ofpacket.ml | 78 +++++++++++++++++++++++++++++++++++++++--------- lib/ofpacket.mli | 11 ++++++- 2 files changed, 74 insertions(+), 15 deletions(-) diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 1b94aaf..50f2c39 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -977,6 +977,13 @@ module Match = struct dl_dst="\000\000\000\000\000\000"; dl_vlan=0; dl_vlan_pcp='\000'; dl_type=0; nw_src=0l; nw_dst=0l; nw_tos='\000';nw_proto='\000';tp_src=0; tp_dst=0;} + let arp () = + {wildcards=(Wildcards.full_wildcard ()); in_port=Port.No_port; + dl_src="\000\000\000\000\000\000"; + dl_dst="\000\000\000\000\000\000"; + dl_vlan=0; dl_vlan_pcp='\000'; dl_type=0; nw_src=0l; nw_dst=0l; + nw_tos='\000';nw_proto='\000';tp_src=0; tp_dst=0;} + cstruct ofp_match { uint32_t wildcards; @@ -1047,6 +1054,43 @@ module Match = struct nw_src; nw_dst; nw_tos; nw_proto; tp_src; tp_dst; } + let create_match ?(in_port=None) ?(dl_vlan=None) ?(dl_src=None) ?(dl_dst=None) + ?(dl_type=None) ?(nw_proto=None) ?(tp_dst=None) ?(tp_src=None) + ?(nw_dst=None) ?(nw_dst_len=32) ?(nw_src=None) ?(nw_src_len=32) + ?(dl_vlan_pcp=None) ?(nw_tos=None) () = + + let is_none = function + | None -> true + | Some _ -> false + in + let option_default v d = + match v with + | None -> d + | Some v -> v + in + let zero_mac = (* Net.Nettypes.ethernet_mac_of_bytes *) + "\x00\x00\x00\x00\x00\x00" in + let flow_wild = Wildcards.({ + in_port=(is_none in_port); dl_vlan=(is_none dl_vlan); + dl_src=(is_none dl_src); dl_dst=(is_none dl_dst); + dl_type=(is_none dl_type); nw_proto=(is_none nw_proto); + tp_dst=(is_none tp_dst); tp_src=(is_none tp_src); + nw_dst=(char_of_int nw_dst_len); nw_src=(char_of_int nw_src_len); + dl_vlan_pcp=(is_none dl_vlan_pcp); nw_tos=(is_none nw_tos);}) in + create_flow_match flow_wild + ~in_port:(option_default in_port 0) + ~dl_src:(option_default dl_src zero_mac) + ~dl_dst:(option_default dl_dst zero_mac) + ~dl_vlan:(option_default dl_vlan 0xffff) + ~dl_vlan_pcp:(option_default dl_vlan_pcp (char_of_int 0)) + ~dl_type:(option_default dl_type 0) + ~nw_tos:(option_default nw_tos (char_of_int 0)) + ~nw_proto:(option_default nw_proto (char_of_int 0)) + ~nw_src:(option_default nw_src 0l) + ~nw_dst:(option_default nw_dst 0l) + ~tp_src:(option_default tp_src 0) + ~tp_dst:(option_default tp_dst 0) () + let translate_port m p = {wildcards=m.wildcards; in_port=p; dl_src=m.dl_src; dl_dst=m.dl_dst; dl_vlan=m.dl_vlan; dl_vlan_pcp=m.dl_vlan_pcp; dl_type=m.dl_type; @@ -1197,24 +1241,30 @@ module Match = struct (string_of_bool ((wildcard.Wildcards.nw_tos) || (flow.nw_tos == flow_def.nw_tos)) ) (string_of_bool ((wildcard.Wildcards.dl_vlan_pcp) || flow.dl_vlan_pcp == flow_def.dl_vlan_pcp));*) - - (((wildcard.Wildcards.in_port)|| ((Port.int_of_port flow.in_port) == (Port.int_of_port flow_def.in_port))) && + let nw_src_mask = 0x20 - (int_of_char wildcard.Wildcards.nw_src) in + let nw_dst_mask = 0x20 - (int_of_char wildcard.Wildcards.nw_dst) in + let _ = printf + "%lx/%d - %lx:%d , %lx = %lx\n%!" + flow.nw_src nw_src_mask flow_def.nw_src nw_src_mask + (Int32.shift_right_logical flow.nw_src nw_src_mask) + (Int32.shift_right_logical flow_def.nw_src nw_src_mask) in + (((wildcard.Wildcards.in_port)|| ((Port.int_of_port flow.in_port) = (Port.int_of_port flow_def.in_port))) && (* ((wildcard.Wildcards.dl_vlan) || (flow.dl_vlan == flow_def.dl_vlan)) * &&*) ((wildcard.Wildcards.dl_src) || (flow.dl_src = flow_def.dl_src)) && ((wildcard.Wildcards.dl_dst) || (flow.dl_dst = flow_def.dl_dst)) && - ((wildcard.Wildcards.dl_type) || (flow.dl_type== flow_def.dl_type)) && - ((wildcard.Wildcards.nw_proto)|| (flow.nw_proto==flow_def.nw_proto)) && - ((wildcard.Wildcards.tp_src) || (flow.tp_src == flow_def.tp_src)) && - ((wildcard.Wildcards.tp_dst) || (flow.tp_dst == flow_def.tp_dst)) && - ((wildcard.Wildcards.nw_src >= '\x20') || - (Int32.shift_right_logical flow.nw_src (int_of_char wildcard.Wildcards.nw_src)) = - (Int32.shift_right_logical flow_def.nw_src (int_of_char wildcard.Wildcards.nw_src))) && - ((wildcard.Wildcards.nw_dst >= '\x20') || - (Int32.shift_right_logical flow.nw_dst (int_of_char wildcard.Wildcards.nw_dst)) = - (Int32.shift_right_logical flow_def.nw_dst (int_of_char wildcard.Wildcards.nw_dst))) && - ((wildcard.Wildcards.nw_tos) || (flow.nw_tos == flow_def.nw_tos)) && - ((wildcard.Wildcards.dl_vlan_pcp) || flow.dl_vlan_pcp == + ((wildcard.Wildcards.dl_type) || (flow.dl_type= flow_def.dl_type)) && + ((wildcard.Wildcards.nw_proto)|| (flow.nw_proto = flow_def.nw_proto)) && + ((wildcard.Wildcards.tp_src) || (flow.tp_src = flow_def.tp_src)) && + ((wildcard.Wildcards.tp_dst) || (flow.tp_dst = flow_def.tp_dst)) && + ((nw_src_mask <= 0) || + (Int32.shift_right_logical flow.nw_src nw_src_mask) = + (Int32.shift_right_logical flow_def.nw_src nw_src_mask)) && + ((nw_dst_mask <= 0) || + (Int32.shift_right_logical flow.nw_dst nw_dst_mask) = + (Int32.shift_right_logical flow_def.nw_dst nw_dst_mask)) && + ((wildcard.Wildcards.nw_tos) || (flow.nw_tos = flow_def.nw_tos)) && + ((wildcard.Wildcards.dl_vlan_pcp) || flow.dl_vlan_pcp = flow_def.dl_vlan_pcp)) end diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index 1658253..1d91791 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -238,7 +238,16 @@ module Match : } val wildcard: unit -> t - val flow_match_compare : t -> t -> Wildcards.t -> bool + val create_match : ?in_port:int option -> ?dl_vlan:int option -> + ?dl_src:(* Net.Nettypes.ethernet_mac *) eaddr option -> + ?dl_dst:(* Net.Nettypes.ethernet_mac *) eaddr option -> + ?dl_type:int option -> ?nw_proto:char option -> + ?tp_dst:int option -> ?tp_src:int option -> + ?nw_dst:int32 option -> ?nw_dst_len:int -> + ?nw_src:int32 option -> ?nw_src_len:int -> + ?dl_vlan_pcp:char option -> ?nw_tos:char option -> unit -> t + + val flow_match_compare : t -> t -> Wildcards.t -> bool val create_flow_match : Wildcards.t -> ?in_port:int16 -> From 6f3fdfa44860677acce43c57fa6ecad6b3affce3 Mon Sep 17 00:00:00 2001 From: crotsos Date: Sat, 26 Jan 2013 19:33:59 +0000 Subject: [PATCH 39/75] fixing the source code --- lib/flowvisor.ml | 102 ++++++++++++++++++++++++++++++---------------- lib/flowvisor.mli | 8 +++- 2 files changed, 74 insertions(+), 36 deletions(-) diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index 6f098d1..886691c 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -159,8 +159,11 @@ let send_controller t msg = Ofsocket.send_packet t msg let inform_controllers flv m msg = (* find the controller that should handle the packet in *) Lwt_list.iter_p - (fun (_, rule, t) -> - if (OP.Match.flow_match_compare m rule rule.OP.Match.wildcards) then + (fun (_, rule, t) -> + let _ = pp "\nrule:%s\nin:%s\n\n%!" (OP.Match.match_to_string rule) + (OP.Match.match_to_string m) in + if (OP.Match.flow_match_compare rule m rule.OP.Match.wildcards) then + let _ = pp "matched flow\n%!" in Ofsocket.send_packet t msg else return ()) flv.controllers @@ -170,15 +173,23 @@ let inform_controllers flv m msg = let packet_out_create st msg xid in_port bid data actions = let data = match (bid) with - | -1l -> data + | -1l -> data (* if no buffer id included, send the data section of the * packet_out*) | bid when (Hashtbl.mem st.buffer_id_map bid) -> (* if we have a buffer id in cache, use those data *) let (pkt, _ ) = Hashtbl.find st.buffer_id_map bid in - pkt.OP.Packet_in.data + let _ = Hashtbl.remove st.buffer_id_map bid in + pkt.OP.Packet_in.data | _ -> raise (Ofcontroller_error(xid, OP.REQUEST_BUFFER_UNKNOWN, msg) ) in + let in_port = + try + let (_, in_port, _) = Hashtbl.find st.port_map (OP.Port.int_of_port + in_port) in + OP.Port.Port(in_port) + with Not_found -> OP.Port.No_port + in let m = OP.Packet_out.create ~buffer_id:(-1l) ~actions ~in_port ~data () in let h = OP.Header.create ~xid OP.Header.PACKET_OUT 0 in @@ -190,7 +201,7 @@ let packet_out_create st msg xid in_port bid data actions = let actions = acts @ [OP.Flow.Output(OP.Port.All, len)] in (* OP.Port.None is not the appropriate way to handle this. Need to find the * port that connects the two switches probably. *) - let msg = packet_out_create st msg xid OP.Port.No_port bid data actions in + let msg = packet_out_create st msg xid inp bid data actions in lwt _ = send_all_switches st msg in pkt_out_process st xid inp bid data msg acts tail end @@ -206,7 +217,7 @@ let packet_out_create st msg xid in_port bid data actions = (* output packet to the last hop of the path *) let (dpid, out_p, _) = Hashtbl.find st.port_map p in let actions = acts @ [OP.Flow.Output((OP.Port.port_of_int out_p), len)] in - let msg = packet_out_create st msg xid OP.Port.No_port bid data actions in + let msg = packet_out_create st msg xid inp bid data actions in lwt _ = send_switch st dpid msg in pkt_out_process st xid inp bid data msg acts tail end @@ -490,11 +501,7 @@ let process_openflow st dpid t msg = let bits = OP.marshal msg in send_controller t (OP.Error(h, OP.REQUEST_BAD_TYPE, bits) ) -let switch_channel st dpid of_m (remote_addr, remote_port) t = - let rs = Nettypes.ipv4_addr_to_string remote_addr in - let _ = pp "[flowvisor-switch]+ controller %s:%d\n%!" rs remote_port in - (* Trigger the dance between the 2 nodes *) - let sock = Ofsocket.init_socket_conn_state t in +let switch_channel st dpid of_m sock = let h = OP.Header.(create ~xid:1l HELLO sizeof_ofp_header) in lwt _ = Ofsocket.send_packet sock (OP.Hello h) in let _ = st.controllers <- (dpid, of_m, sock)::st.controllers in @@ -520,11 +527,11 @@ let switch_channel st dpid of_m (remote_addr, remote_port) t = let add_flowvisor_port flv dpid port = let port_id = flv.portnum in let _ = flv.portnum <- flv.portnum + 1 in - lwt _ = Flowvisor_topology.add_port flv.flv_topo dpid port.OP.Port.port_no - (Net.Nettypes.ethernet_mac_of_bytes port.OP.Port.hw_addr) in - let phy = OP.Port.translate_port_phy port port_id in + let phy = OP.Port.translate_port_phy port port_id in let _ = Hashtbl.add flv.port_map port_id (dpid, port.OP.Port.port_no, phy) in + lwt _ = Flowvisor_topology.add_port flv.flv_topo dpid port.OP.Port.port_no + (Net.Nettypes.ethernet_mac_of_bytes port.OP.Port.hw_addr) in let h = OP.Header.(create PORT_STATUS 0 ) in let status = OP.Port_status(h, (OP.Port.({reason=OP.Port.ADD; desc=phy;}))) in Lwt_list.iter_p @@ -552,14 +559,15 @@ let map_flv_port flv dpid port = if (port < 0) then raise Not_found else OP.Port.Port (port) -let process_switch_channel flv st dpid e = +let process_switch_channel flv st dpid e = + try_lwt match e with | OE.Datapath_join(dpid, ports) -> let _ = pr "[flowvisor-ctrl]+ switch dpid:%Ld\n%!" dpid in let _ = Flowvisor_topology.add_channel flv.flv_topo dpid st in (* Update local state *) let _ = Hashtbl.add flv.switches dpid st in - Lwt_list.iter_s (add_flowvisor_port flv dpid) ports + Lwt_list.iter_p (add_flowvisor_port flv dpid) ports | OE.Datapath_leave(dpid) -> let _ = pr "[flowvisor-ctrl]- switch dpid:%Ld\n%!" dpid in let _ = Flowvisor_topology.remove_dpid flv.flv_topo dpid in @@ -574,18 +582,25 @@ let process_switch_channel flv st dpid e = lwt _ = Lwt_list.iter_p (del_flowvisor_port flv) removed in return () - | OE.Packet_in(p, reason, buffer_id, data, dpid) -> begin - let m = OP.Match.raw_packet_to_match p data in - match (p, m.OP.Match.dl_type) with - | (OP.Port.Port(p), 0x88cc) -> - let _ = Flowvisor_topology.process_lldp_packet - flv.flv_topo dpid p data in - return () + | OE.Packet_in(in_port, reason, buffer_id, data, dpid) -> begin + let m = OP.Match.raw_packet_to_match in_port data in + match (in_port, m.OP.Match.dl_type) with + | (OP.Port.Port(p), 0x88cc) -> begin + match (Flowvisor_topology.process_lldp_packet + flv.flv_topo dpid p data) with + | true -> return () + | false -> + let in_port = map_flv_port flv dpid p in + let h = OP.Header.(create PACKET_IN 0) in + let pkt = OP.Packet_in.({buffer_id=(-1l);in_port;reason;data;}) in + inform_controllers flv m (OP.Packet_in(h, pkt)) + end | (OP.Port.Port(p), _) when - not (Flowvisor_topology.is_transit_port flv.flv_topo dpid p) -> + not (Flowvisor_topology.is_transit_port flv.flv_topo dpid p) -> begin (* translate the buffer id information *) let buffer_id = flv.buffer_id_count in let _ = flv.buffer_id_count <- Int32.add flv.buffer_id_count 1l in + (* generate packet bits *) let in_port = map_flv_port flv dpid p in let h = OP.Header.(create PACKET_IN 0) in @@ -593,6 +608,7 @@ let process_switch_channel flv st dpid e = let _ = Hashtbl.add flv.buffer_id_map buffer_id (pkt, dpid) in lwt _ = inform_controllers flv m (OP.Packet_in(h, pkt)) in return () + end | (OP.Port.Port(p), _) -> return ((*pp "XXXXX supress disable transit port"*)) | _ -> @@ -687,9 +703,10 @@ let process_switch_channel flv st dpid e = return () | OE.Port_status(reason, port, dpid) -> (* TODO: send a port withdrawal to all controllers *) - return () + add_flowvisor_port flv dpid port | _ -> return (pp "[flowvisor-ctrl] Unsupported event\n%!") + with Not_found -> return (pr "[flowvisor-ctrl] ignore pkt of non existing state\n%!") let init flv st = (* register all the required handlers *) @@ -710,23 +727,38 @@ let create_flowvisor dpid = let _ = ignore_result (Flowvisor_topology.discover ret.flv_topo) in ret -let listen st mgr loc = Ofcontroller.listen mgr loc (init st) - -let remove_slice _ _ = return () -let add_slice mgr flv of_m dst dpid = - let _ = - (* TODO Need to store thread for termination on remove_slice *) +let add_slice mgr flv of_m dst dpid = + let _ = ignore_result ( while_lwt true do try_lwt - Net.Channel.connect mgr - ( `TCPv4 (None, dst, (switch_channel flv dpid of_m dst) ) ) + let switch_connect (addr, port) t = + let rs = Nettypes.ipv4_addr_to_string addr in + let _ = pp "[flowvisor-switch]+ controller %s:%d\n%!" rs port in + (* Trigger the dance between the 2 nodes *) + let sock = Ofsocket.init_socket_conn_state t in + switch_channel flv dpid of_m sock + in + Net.Channel.connect mgr + ( `TCPv4 (None, dst, (switch_connect dst) ) ) with exn -> let _ = pp "[flowvisor-ctrl] controller error %s\n%!" (Printexc.to_string exn) in return () - done - + done ) in return () +let listen st mgr loc = Ofcontroller.listen mgr loc (init st) +let local_listen st conn = + let t = Ofcontroller.init_controller () in + Ofcontroller.local_connect t conn (init st) + +let remove_slice _ _ = return () +let add_local_slice flv of_m conn dpid = + let _ = + (* TODO Need to store thread for termination on remove_slice *) + ignore_result ( switch_channel flv dpid of_m conn) in + return () + + diff --git a/lib/flowvisor.mli b/lib/flowvisor.mli index 0b2e7a3..c8b92b1 100644 --- a/lib/flowvisor.mli +++ b/lib/flowvisor.mli @@ -21,7 +21,13 @@ open Net.Nettypes type t val listen: t -> Manager.t -> ipv4_src -> unit Lwt.t +val local_listen: t -> Ofsocket.conn_state -> unit Lwt.t val create_flowvisor: unit -> t val remove_slice : t -> Ofpacket.Match.t -> unit Lwt.t +val add_local_slice : Net.Manager.t -> t -> Ofpacket.Match.t -> + Ofsocket.conn_state -> int64 -> unit Lwt.t val add_slice : Net.Manager.t -> t -> Ofpacket.Match.t -> - ipv4_dst -> int64 -> unit Lwt.t + ipv4_dst -> int64 -> unit Lwt.t +val add_local_slice : t -> Ofpacket.Match.t -> + Ofsocket.conn_state -> int64 -> unit Lwt.t + From 51b85d1bcd6d6530c661abe83f6367fbe0ce4ece Mon Sep 17 00:00:00 2001 From: crotsos Date: Sat, 26 Jan 2013 19:35:01 +0000 Subject: [PATCH 40/75] fixinfg the local connect idea on ofsocket and revert to new API --- lib/flowvisor_topology.ml | 22 ++++--- lib/flowvisor_topology.mli | 2 +- lib/ofcontroller.ml | 11 ++-- lib/ofcontroller.mli | 6 +- lib/ofsocket.ml | 120 +++--------------------------------- lib/ofsocket.mli | 3 +- lib/ofswitch.ml | 5 +- lib/ofswitch.mli | 5 +- lib/ofswitch_standalone.ml | 10 ++- lib/ofswitch_standalone.mli | 3 +- 10 files changed, 39 insertions(+), 148 deletions(-) diff --git a/lib/flowvisor_topology.ml b/lib/flowvisor_topology.ml index e582732..285bcb5 100644 --- a/lib/flowvisor_topology.ml +++ b/lib/flowvisor_topology.ml @@ -108,7 +108,8 @@ let send_port_lldp t dpid port mac = let ch = Hashtbl.find t.channels dpid in Ofcontroller.send_data ch dpid (OP.Packet_out(h, m)) -let add_port t dpid port mac = +let add_port t dpid port mac = + let _ = printf "[flowvisor-topo] adding port %Ld:%d\n%!" dpid port in let _ = Hashtbl.replace t.ports (dpid, port) (mac, false) in send_port_lldp t dpid port mac @@ -162,14 +163,17 @@ let process_lldp_packet t src_dpid src_port pkt = ) bits in (!dpid, port, mac) | _ -> (dpid, port, mac) - ) tlvs (0L, 0, Net.Nettypes.ethernet_mac_broadcast) in - let v = (src_dpid, (src_dpid, src_port, dst_dpid, dst_port, 1), dst_dpid) in - let _ = printf "[flowvisor-topo] adding link %Ld:%d-%Ld:%d\n%!" - src_dpid src_port dst_dpid dst_port in - let _ = Graph.add_edge_e t.topo v in - let _ = mark_port_down t src_dpid src_port true in - let _ = mark_port_down t dst_dpid dst_port true in - () + ) tlvs (0L, 0, Net.Nettypes.ethernet_mac_broadcast) in + match (Hashtbl.mem t.channels dst_dpid) with + | false -> false + | true -> + let v = (src_dpid, (src_dpid, src_port, dst_dpid, dst_port, 1), dst_dpid) in + let _ = printf "[flowvisor-topo] adding link %Ld:%d-%Ld:%d\n%!" + src_dpid src_port dst_dpid dst_port in + let _ = Graph.add_edge_e t.topo v in + let _ = mark_port_down t src_dpid src_port true in + let _ = mark_port_down t dst_dpid dst_port true in + true let remove_dpid t dpid = let _ = Graph.remove_vertex t.topo dpid in diff --git a/lib/flowvisor_topology.mli b/lib/flowvisor_topology.mli index 8d9cf95..ba17728 100644 --- a/lib/flowvisor_topology.mli +++ b/lib/flowvisor_topology.mli @@ -22,7 +22,7 @@ val init_topology: unit -> t val add_port: t -> int64 -> int -> ethernet_mac -> unit Lwt.t val add_channel: t -> int64 -> Ofcontroller.t -> unit val discover: t-> unit Lwt.t -val process_lldp_packet: t -> int64 -> int -> Cstruct.t -> unit +val process_lldp_packet: t -> int64 -> int -> Cstruct.t -> bool val find_dpid_path: t -> int64 -> Ofpacket.Port.t -> int64 -> Ofpacket.Port.t -> (int64 * Ofpacket.Port.t * Ofpacket.Port.t) list val remove_dpid: t -> int64 -> unit diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 622ee9f..8a1b48b 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -329,11 +329,8 @@ let connect mgr loc init = Net.Channel.connect mgr (`TCPv4 (None, loc, (socket_controller st loc) )) -let init_controller init = - let st = init_controller () in - let _ = init st in - st +let init_controller () = init_controller () -let local_connect mgr st (input, output) init = - let conn = init_local_conn_state input output in - controller_run st conn +let local_connect st conn init = + let _ = init st in + controller_run st conn diff --git a/lib/ofcontroller.mli b/lib/ofcontroller.mli index 296c1dc..f0e54ca 100644 --- a/lib/ofcontroller.mli +++ b/lib/ofcontroller.mli @@ -56,7 +56,5 @@ val listen : Manager.t -> Nettypes.ipv4_src -> (t -> 'a) -> unit Lwt.t val connect : Manager.t -> Nettypes.ipv4_dst -> (t -> 'a) -> unit Lwt.t -val init_controller : (t -> 'a) -> t -val local_connect : Manager.t -> t -> - (Ofpacket.t Lwt_stream.t * (Ofpacket.t option -> unit )) -> - (t -> 'a) -> unit Lwt.t +val init_controller : unit -> t +val local_connect : t -> Ofsocket.conn_state -> (t -> 'a) -> unit Lwt.t diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index c754a08..58a5db1 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -73,98 +73,10 @@ let read_data t len = return (ret) | _ -> failwith "invalid read data operation" end -(* -module Unix_socket = struct - type t = { - sock: Lwt_unix.file_descr; - data_cache: Cstruct.t list ref; - } - - let create_socket sock = - { sock; data_cache=(ref []);} - - let rec write_buffer t bits = - let rec write_buffer_inner t bits = function - | len when len >= (Cstruct.len bits) -> return () - | len -> - lwt l = Lwt_bytes.write t.sock bits.Cstruct.buffer - (bits.Cstruct.off + len) ((Cstruct.len bits) - len) in - let _ = - if (l = 0) then - raise Net.Nettypes.Closed - in - write_buffer_inner t bits (len + l) - in - try_lwt - write_buffer_inner t bits 0 - with exn -> - let _ = printf "[socket] write error: %s\n%!" (Printexc.to_string exn) in - raise Net.Nettypes.Closed - - let close t = return (Lwt_unix.shutdown t.sock Lwt_unix.SHUTDOWN_ALL) - - let buf_size ar = - List.fold_right (fun a b -> (Cstruct.len a) + b) ar 0 - - let rec read_data t len = - try_lwt - match (len, !(t.data_cache)) with - | (0, _) -> return (Cstruct.create 0 ) - | (_, []) -> - let p = Cstruct.of_bigarray (OS.Io_page.get ()) in - lwt l = Lwt_bytes.read t.sock p.Cstruct.buffer 0 (Cstruct.len p) in - let _ = if (l = 0) then raise Net.Nettypes.Closed in - let _ = t.data_cache := [(Cstruct.sub p 0 l)] in - read_data t len - | (_, head::tail) when (buf_size !(t.data_cache)) >= len -> begin - let ret = Cstruct.of_bigarray (OS.Io_page.get ()) in - let ret_len = ref 0 in - let rec read_data_inner = function - | head::tail when ((!ret_len + (Cstruct.len head)) < len) -> - let _ = Cstruct.blit head 0 ret !ret_len (Cstruct.len head) in - ret_len := !ret_len + (Cstruct.len head); - read_data_inner tail - | head::tail when ((!ret_len + (Cstruct.len head)) = len) -> - let _ = Cstruct.blit head 0 ret !ret_len (Cstruct.len head) in - ret_len := !ret_len + (Cstruct.len head); - t.data_cache := tail; - return () - | head::tail when ((!ret_len + (Cstruct.len head)) > len) -> - let len_rest = len - !ret_len in - let _ = Cstruct.blit head 0 ret !ret_len len_rest in - let head = Cstruct.shift head len_rest in - ret_len := !ret_len + len_rest; - t.data_cache := [head] @ tail; - return () - | rest -> - pp "read_data:Invalid state(req_len:%d,read_len:%d,avail_data:%d)\n%!" - len !ret_len (List.fold_right (fun a b -> b + (Cstruct.len a)) rest 0); - raise ReadError - in - lwt _ = read_data_inner !(t.data_cache) in - let ret = Cstruct.sub ret 0 len in - return (ret) - end - | (_, head::tail) when (buf_size !(t.data_cache)) < len -> - let p = Cstruct.of_bigarray (OS.Io_page.get ()) in - lwt l = Lwt_bytes.read t.sock p.Cstruct.buffer 0 (Cstruct.len p) in - let _ = if (l = 0) then raise Net.Nettypes.Closed in - let _ = t.data_cache := !(t.data_cache) @ [(Cstruct.sub p 0 l)] in - read_data t len - | (_, _) -> - let _ = Printf.printf "read_data and not match found\n%!" in - return (Cstruct.create 0 ) - with exn -> - let _ = printf "[socket] read error: %s\n%!" (Printexc.to_string exn) in - raise Net.Nettypes.Closed - -end - *) type conn_type = | Socket of Socket.t | Local of OP.t Lwt_stream.t * (OP.t option -> unit) -(* | Unix of Unix_socket.t *) type conn_state = { mutable dpid : OP.datapath_id; @@ -173,10 +85,12 @@ type conn_state = { let init_socket_conn_state t = {dpid=0L;t=(Socket (Socket.create_socket t));} -let init_local_conn_state input output = - {dpid=0L;t=(Local (input, output));} -(*let init_unix_conn_state fd = - {dpid=0L;t=(Unix (Unix_socket.create_socket fd));}*) +let init_local_conn_state () = + let (controller_input, switch_output) = Lwt_stream.create () in + let (switch_input, controller_output) = Lwt_stream.create () in + let ch1 = {dpid=0L;t=(Local (controller_input, controller_output));} in + let ch2 = {dpid=0L;t=(Local (switch_input, switch_output));} in + (ch1, ch2) let read_packet conn = match conn.t with @@ -192,14 +106,7 @@ let read_packet conn = in let ofp = OP.parse ofh dbuf in return ofp -(* | Unix t -> - lwt hbuf = Unix_socket.read_data t OP.Header.sizeof_ofp_header in - let ofh = OP.Header.parse_header hbuf in - let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in - lwt dbuf = Unix_socket.read_data t dlen in - let ofp = OP.parse ofh dbuf in - return ofp *) - | Local (input, _) -> + | Local (input, _) -> match_lwt (Lwt_stream.get input) with | None -> raise Nettypes.Closed | Some ofp -> return ofp @@ -209,13 +116,11 @@ let send_packet conn ofp = | Socket t -> let buf = OP.marshal ofp in Socket.write_buffer t buf -(* | Unix t -> Unix_socket.write_buffer t (OP.marshal ofp) *) - | Local (_, output) -> return (output (Some ofp )) + | Local (_, output) -> return (output (Some ofp )) let send_data_raw t bits = match t.t with | Local _ -> failwith "send_of_data is not supported in Local mode" -(* | Unix t -> Unix_socket.write_buffer t bits *) | Socket t -> Socket.write_buffer t bits let close conn = @@ -227,12 +132,5 @@ let close conn = with exn -> return (printf "[socket] close error: %s\n%!" (Printexc.to_string exn)) ) -(* | Unix t -> - resolve ( - try_lwt - Unix_socket.close t - with exn -> - return (printf "[socket] close error: %s\n%!" (Printexc.to_string exn)) - ) *) - | Local (_, output) -> output None + | Local (_, output) -> output None diff --git a/lib/ofsocket.mli b/lib/ofsocket.mli index e349003..2bbec52 100644 --- a/lib/ofsocket.mli +++ b/lib/ofsocket.mli @@ -26,8 +26,7 @@ type conn_state = { val init_socket_conn_state : Channel.t -> conn_state (* val init_unix_conn_state : Lwt_unix.file_descr -> conn_state *) -val init_local_conn_state: Ofpacket.t Lwt_stream.t -> - (Ofpacket.t option -> unit) -> conn_state +val init_local_conn_state: unit -> (conn_state * conn_state) val read_packet : conn_state -> Ofpacket.t Lwt.t val send_packet : conn_state -> Ofpacket.t -> unit Lwt.t val send_data_raw : conn_state -> Cstruct.t -> unit Lwt.t diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index c7aeb52..ccd3711 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -494,7 +494,7 @@ module Switch = struct Lwt_list.iter_p (fun port -> if(port.port_id != (OP.Port.int_of_port in_port)) then ( - update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; + update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; Net.Manager.inject_packet port.mgr port.ethif bits (* Net.Ethif.write (Net.Manager.get_netif port.mgr port.ethif) bits*) ) else return ()) st.ports @@ -1122,8 +1122,7 @@ let connect st mgr loc = (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) -let local_connect st mgr input output = - let conn = Ofsocket.init_local_conn_state input output in +let local_connect st mgr conn = let _ = st.Switch.controller <- (Some conn) in let t, _ = Lwt.task () in (control_channel_run st conn t) <&> diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index 857002d..25c39ca 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -28,10 +28,9 @@ val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> unit Lwt.t val connect : t -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> unit Lwt.t +val local_connect : t -> Net.Manager.t -> Ofsocket.conn_state -> unit Lwt.t (* val lwt_connect : t -> ?standalone:bool -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> unit Lwt.t *) -val local_connect : t -> Net.Manager.t -> - Ofpacket.t Lwt_stream.t -> (Ofpacket.t option -> unit ) -> - unit Lwt.t +val local_connect : t -> Net.Manager.t -> Ofsocket.conn_state -> unit Lwt.t diff --git a/lib/ofswitch_standalone.ml b/lib/ofswitch_standalone.ml index 91b6664..758676f 100644 --- a/lib/ofswitch_standalone.ml +++ b/lib/ofswitch_standalone.ml @@ -144,17 +144,15 @@ let init controller = OC.register_cb controller OE.PORT_STATUS_CHANGE port_status_cb -let init_controller () = - OC.init_controller init +let init_controller () = OC.init_controller () let run_controller mgr st = - let (controller_input, switch_output) = Lwt_stream.create () in - let (switch_input, controller_output) = Lwt_stream.create () in + let (controller, switch) = Ofsocket.init_local_conn_state () in let _ = Lwt.ignore_result ( try_lwt - OC.local_connect mgr st (controller_input, controller_output) init + OC.local_connect st controller init with exn -> return (printf "[switch] standalone controller dailed %s\n%!" (Printexc.to_string exn)) ) in - return (switch_input, switch_output) + return switch diff --git a/lib/ofswitch_standalone.mli b/lib/ofswitch_standalone.mli index 3d6e981..82c3bcf 100644 --- a/lib/ofswitch_standalone.mli +++ b/lib/ofswitch_standalone.mli @@ -15,5 +15,4 @@ *) val init_controller : unit -> Ofcontroller.t -val run_controller : Net.Manager.t -> Ofcontroller.t -> - (Ofpacket.t Lwt_stream.t * (Ofpacket.t option -> unit)) Lwt.t +val run_controller : Net.Manager.t -> Ofcontroller.t -> Ofsocket.conn_state Lwt.t From f121d0e3be50b04dc509edcfef3c7bd4cdf18fa7 Mon Sep 17 00:00:00 2001 From: crotsos Date: Tue, 29 Jan 2013 10:57:43 +0000 Subject: [PATCH 41/75] fixing compilation --- _oasis | 4 +- _tags | 20 +---- lib/ofcontroller.ml | 2 +- lib/ofsocket.ml | 195 ++++---------------------------------------- lib/ofsocket.mli | 1 - lib/ofswitch.ml | 4 +- lib/ofswitch.mli | 4 +- myocamlbuild.ml | 16 ++-- setup.ml | 127 ++++++++++++----------------- 9 files changed, 81 insertions(+), 292 deletions(-) diff --git a/_oasis b/_oasis index ed455c8..307e742 100644 --- a/_oasis +++ b/_oasis @@ -59,7 +59,7 @@ Executable learning_switch_lwt Install: true BuildDepends: cstruct, cstruct.syntax, openflow -Executable basic_switch_lwt +(* Executable basic_switch_lwt Path: switch MainIs: basic_switch.ml Build$: flag(lwt) @@ -68,7 +68,7 @@ Executable basic_switch_lwt Install: true BuildDepends: openflow -(*Executable learning_switch_mirage +Executable learning_switch_mirage Path: controller MainIs: learning_switch.ml Build$: flag(mirage) diff --git a/_tags b/_tags index 6069146..7eab034 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: c07db1f17ad31bd9de21d6ae41f3283a) +# DO NOT EDIT (digest: 75a0f2248e819616790024f00e8078e7) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -57,24 +57,6 @@ : pkg_mirage : pkg_mirage-net "controller/learning_switch.native": custom -# Executable basic_switch_lwt -"switch/basic_switch.native": use_openflow -"switch/basic_switch.native": pkg_cstruct -"switch/basic_switch.native": pkg_cstruct.syntax -"switch/basic_switch.native": pkg_re.str -"switch/basic_switch.native": pkg_rpclib -"switch/basic_switch.native": pkg_rpclib.json -"switch/basic_switch.native": pkg_mirage -"switch/basic_switch.native": pkg_mirage-net -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_re.str -: pkg_rpclib -: pkg_rpclib.json -: pkg_mirage -: pkg_mirage-net -"switch/basic_switch.native": custom # OASIS_STOP true: annot : syntax_camlp4o diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 57f3fb8..d6734a1 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -291,7 +291,7 @@ let controller_run st conn = | Not_found -> return (Printf.printf "Error:Not found\n%!") | exn -> - pp "{OpenFlow-controller} ERROR:%s\n%!" (Printexc.to_string ()); + pp "{OpenFlow-controller} ERROR:%s\n%!" (Printexc.to_string exn); return (continue := false) done in diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index 48f7a58..4689e2b 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -28,170 +28,29 @@ let cp = pp "%s\n%!" let resolve t = Lwt.on_success t (fun _ -> ()) module Socket = struct -type t = { - sock: Channel.t; - mutable data_cache: Cstruct.t list; -} + type t = { + sock: Channel.t; + mutable data_cache: Cstruct.t list; + } -let create_socket sock = - { sock; data_cache=[];} + let create_socket sock = + { sock; data_cache=[];} -let write_buffer t bits = -(* - match (Cstruct.len bits) with - | l when l <= 1400 -> - *) - let _ = Channel.write_buffer t.sock bits in - Channel.flush t.sock -(* - | _ -> - let buf = Cstruct.sub bits 0 1400 in - let _ = Channel.write_buffer t.sock buf in - let buf = Cstruct.sub bits 1400 ((Cstruct.len bits) - 1400) in - let _ = Channel.write_buffer t.sock buf in - lwt _ = Channel.flush t.sock in - return () - *) + let write_buffer t bits = + let _ = Channel.write_buffer t.sock bits in + Channel.flush t.sock -let close t = Channel.close t.sock + let close t = Channel.close t.sock let cache_size t = List.fold_right ( fun a r -> r + (Cstruct.len a) ) t.data_cache 0 - -let rec read_data t len = -(* Printf.printf "let rec read_data t data_cache %d = \n%!" len; *) - match (len, t.data_cache) with - | (0, _) -> -(* pp "| (0, _) ->\n%!"; *) - return (Cstruct.create 0) - | (_, head::tail) when ((cache_size t) >=len) -> ( -(* pp "| (_, head::tail) when ((List.fold_right (f a b - * ->b+(Cstruct.len b)) tail (Cstruct.len head)) >= len) ->\n%!"; *) - let ret = Cstruct.create len in - let rec read_data_inner off = function - | head::tail when ((off + (Cstruct.len head)) < len) -> - let sz = Cstruct.len head in - let _ = Cstruct.blit head 0 ret off sz in - read_data_inner (off + sz) tail - | head::tail when ((off + (Cstruct.len head)) = len) -> - let len = Cstruct.len head in - let _ = Cstruct.blit head 0 ret off sz in - t.data_cache <- tail - | head::tail when ((off + (Cstruct.len head)) > len) -> - let len_rest = len - !ret_len in - let _ = Cstruct.blit head 0 ret off len_rest in - let head = Cstruct.shift head len_rest in - t.data_cache <- head::tail - | rest -> - pp "read_data:Invalid state(req_len:%d,read_len:%d,avail_data:%d)\n%!" - len off (List.fold_right (fun a b -> b + (Cstruct.len a)) rest 0); - raise ReadError - in - let _ = read_data_inner 0 t.data_cache in - let ret = Cstruct.sub ret 0 len in - return (ret) - ) - | (_, _) -> begin -(* pp "| (_, head::tail) when ((List.fold_right (f a b ->b+(Cstruct.len - * b)) tail (Cstruct.len head)) < len) ->\n%!"; *) - lwt data = Channel.read_some t.sock in - t.data_cache := !(t.data_cache) @ [data]; - read_data t len - end end -module Unix_socket = struct - type t = { - sock: Lwt_unix.file_descr; - data_cache: Cstruct.t list ref; - } - - let create_socket sock = - { sock; data_cache=(ref []);} - - let rec write_buffer t bits = - let rec write_buffer_inner t bits = function - | len when len >= (Cstruct.len bits) -> return () - | len -> - lwt l = Lwt_bytes.write t.sock bits.Cstruct.buffer - (bits.Cstruct.off + len) ((Cstruct.len bits) - len) in - let _ = - if (l = 0) then - raise Net.Nettypes.Closed - in - write_buffer_inner t bits (len + l) - in - try_lwt - write_buffer_inner t bits 0 - with exn -> - let _ = printf "[socket] write error: %s\n%!" (Printexc.to_string exn) in - raise Net.Nettypes.Closed - - let close t = return (Lwt_unix.shutdown t.sock Lwt_unix.SHUTDOWN_ALL) - - let buf_size ar = - List.fold_right (fun a b -> (Cstruct.len a) + b) ar 0 - - let rec read_data t len = - try_lwt - match (len, !(t.data_cache)) with - | (0, _) -> return (Cstruct.create 0 ) - | (_, []) -> - let p = Cstruct.of_bigarray (OS.Io_page.get ()) in - lwt l = Lwt_bytes.read t.sock p.Cstruct.buffer 0 (Cstruct.len p) in - let _ = if (l = 0) then raise Net.Nettypes.Closed in - let _ = t.data_cache := [(Cstruct.sub p 0 l)] in - read_data t len - | (_, head::tail) when (buf_size !(t.data_cache)) >= len -> begin - let ret = Cstruct.of_bigarray (OS.Io_page.get ()) in - let ret_len = ref 0 in - let rec read_data_inner = function - | head::tail when ((!ret_len + (Cstruct.len head)) < len) -> - let _ = Cstruct.blit head 0 ret !ret_len (Cstruct.len head) in - ret_len := !ret_len + (Cstruct.len head); - read_data_inner tail - | head::tail when ((!ret_len + (Cstruct.len head)) = len) -> - let _ = Cstruct.blit head 0 ret !ret_len (Cstruct.len head) in - ret_len := !ret_len + (Cstruct.len head); - t.data_cache := tail; - return () - | head::tail when ((!ret_len + (Cstruct.len head)) > len) -> - let len_rest = len - !ret_len in - let _ = Cstruct.blit head 0 ret !ret_len len_rest in - let head = Cstruct.shift head len_rest in - ret_len := !ret_len + len_rest; - t.data_cache := [head] @ tail; - return () - | rest -> - pp "read_data:Invalid state(req_len:%d,read_len:%d,avail_data:%d)\n%!" - len !ret_len (List.fold_right (fun a b -> b + (Cstruct.len a)) rest 0); - raise ReadError - in - lwt _ = read_data_inner !(t.data_cache) in - let ret = Cstruct.sub ret 0 len in - return (ret) - end - | (_, head::tail) when (buf_size !(t.data_cache)) < len -> - let p = Cstruct.of_bigarray (OS.Io_page.get ()) in - lwt l = Lwt_bytes.read t.sock p.Cstruct.buffer 0 (Cstruct.len p) in - let _ = if (l = 0) then raise Net.Nettypes.Closed in - let _ = t.data_cache := !(t.data_cache) @ [(Cstruct.sub p 0 l)] in - read_data t len - | (_, _) -> - let _ = Printf.printf "read_data and not match found\n%!" in - return (Cstruct.create 0 ) - with exn -> - let _ = printf "[socket] read error: %s\n%!" (Printexc.to_string exn) in - raise Net.Nettypes.Closed - -end - type conn_type = | Socket of Socket.t | Local of OP.t Lwt_stream.t * (OP.t option -> unit) - | Unix of Unix_socket.t type conn_state = { mutable dpid : OP.datapath_id; @@ -202,31 +61,19 @@ let init_socket_conn_state t = {dpid=0L;t=(Socket (Socket.create_socket t));} let init_local_conn_state input output = {dpid=0L;t=(Local (input, output));} -let init_unix_conn_state fd = - {dpid=0L;t=(Unix (Unix_socket.create_socket fd));} let read_packet conn = match conn.t with | Socket t -> - lwt hbuf = Socket.read_data t OP.Header.sizeof_ofp_header in -(* lwt hbuf = Channel.read_some ~len:OP.Header.sizeof_ofp_header - * t.Socket.sock in *) + lwt hbuf = Net.Channel.read_exactly t.Socket.sock OP.Header.sizeof_ofp_header in let ofh = OP.Header.parse_header hbuf in let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in - lwt dbuf = Socket.read_data t dlen in -(* lwt dbuf = + lwt dbuf = if (dlen = 0) then return (Cstruct.create 0) else - Channel.read_some ~len:dlen t.Socket.sock - in*) - let ofp = OP.parse ofh dbuf in - return ofp - | Unix t -> - lwt hbuf = Unix_socket.read_data t OP.Header.sizeof_ofp_header in - let ofh = OP.Header.parse_header hbuf in - let dlen = ofh.OP.Header.len - OP.Header.sizeof_ofp_header in - lwt dbuf = Unix_socket.read_data t dlen in + Net.Channel.read_exactly t.Socket.sock dlen + in let ofp = OP.parse ofh dbuf in return ofp | Local (input, _) -> @@ -236,17 +83,12 @@ let read_packet conn = let send_packet conn ofp = match conn.t with - | Socket t -> - (* Socket.write_buffer t (OP.marshal ofp) *) - let _ = Channel.write_buffer t.Socket.sock (OP.marshal ofp) in - Channel.flush t.Socket.sock - | Unix t -> Unix_socket.write_buffer t (OP.marshal ofp) + | Socket t -> Socket.write_buffer t (OP.marshal ofp) | Local (_, output) -> return (output (Some ofp )) let send_data_raw t bits = match t.t with | Local _ -> failwith "send_of_data is not supported in Local mode" - | Unix t -> Unix_socket.write_buffer t bits | Socket t -> (* Socket.write_buffer t bits *) let _ = Channel.write_buffer t.Socket.sock bits in @@ -261,12 +103,5 @@ let close conn = with exn -> return (printf "[socket] close error: %s\n%!" (Printexc.to_string exn)) ) - | Unix t -> - resolve ( - try_lwt - Unix_socket.close t - with exn -> - return (printf "[socket] close error: %s\n%!" (Printexc.to_string exn)) - ) | Local (_, output) -> output None diff --git a/lib/ofsocket.mli b/lib/ofsocket.mli index 3c05748..ee9cdf7 100644 --- a/lib/ofsocket.mli +++ b/lib/ofsocket.mli @@ -25,7 +25,6 @@ type conn_state = { } val init_socket_conn_state : Channel.t -> conn_state -val init_unix_conn_state : Lwt_unix.file_descr -> conn_state val init_local_conn_state: Ofpacket.t Lwt_stream.t -> (Ofpacket.t option -> unit) -> conn_state val read_packet : conn_state -> Ofpacket.t Lwt.t diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 184e0ec..6bcdd26 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -1066,7 +1066,7 @@ let local_connect st mgr input output = (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) -let lwt_connect st ?(standalone=true) mgr loc = +(* let lwt_connect st ?(standalone=true) mgr loc = let of_ctrl = Ofswitch_standalone.init_controller () in let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (del_port mgr st) @@ -1106,4 +1106,4 @@ let lwt_connect st ?(standalone=true) mgr loc = lwt _ = log ~level:Notice "Remote controller started..." in control_channel_run st conn t )) - done + done *) diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index aa03d3f..4a8f83b 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -28,8 +28,8 @@ val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> unit Lwt.t val connect : t -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> unit Lwt.t -val lwt_connect : t -> ?standalone:bool -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> - unit Lwt.t +(* val lwt_connect : t -> ?standalone:bool -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> + unit Lwt.t *) val local_connect : t -> Net.Manager.t -> Ofpacket.t Lwt_stream.t -> (Ofpacket.t option -> unit ) -> unit Lwt.t diff --git a/myocamlbuild.ml b/myocamlbuild.ml index d7f908b..e948bf6 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: eb256e7e5e2662771dedb4bce0bc0cc9) *) +(* DO NOT EDIT (digest: f6a1f82a2ed59ba087decebaf9e364af) *) module OASISGettext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { @@ -480,7 +480,7 @@ let package_default = MyOCamlbuildBase.lib_ocaml = [("openflow", ["lib"])]; lib_c = []; flags = []; - includes = [("switch", ["lib"]); ("controller", ["lib"])]; + includes = [("controller", ["lib"])]; } ;; diff --git a/setup.ml b/setup.ml index e492e50..d0eaafc 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: c13b37c4403b506e70e67de9eb00f5b7) *) +(* DO NOT EDIT (digest: 3bb463ce7026030517624fb3f6218f7e) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISString.ml" *) +(* # 1 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 71 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 102 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseContext.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseMessage.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseEnv.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseCheck.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseLog.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseLog.ml" *) open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseCustom.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseTest.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseDoc.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/base/BaseSetup.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/home/cr409/.opam/4.00.1+mirage-unix/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/Users/cr409/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5818,34 +5818,7 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])]; }, {exec_custom = true; exec_main_is = "learning_switch.ml"; - }); - Executable - ({ - cs_name = "basic_switch_lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "lwt", true) - ]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "switch"; - bs_compiled_object = Native; - bs_build_depends = [InternalLibrary "openflow"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = true; exec_main_is = "basic_switch.ml"; }) + }) ]; plugins = [(`Extra, "META", Some "0.2")]; schema_data = PropList.Data.create (); @@ -5853,7 +5826,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "\166\218\150\216\249+#\025\143\018f\022B\217\248?"; + oasis_digest = Some "\156X%ÒÏd{q\004\016ÊcâÇPá"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5861,6 +5834,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5865 "setup.ml" +# 5838 "setup.ml" (* OASIS_STOP *) let () = setup ();; From d4c9ea2c30737c735195b3002970e5b5d9cf6026 Mon Sep 17 00:00:00 2001 From: crotsos Date: Tue, 26 Feb 2013 17:44:53 +0000 Subject: [PATCH 42/75] removing some debugging info --- lib/flowvisor.ml | 8 +++----- lib/ofpacket.ml | 7 +------ 2 files changed, 4 insertions(+), 11 deletions(-) diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index 886691c..04205a8 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -160,10 +160,7 @@ let inform_controllers flv m msg = (* find the controller that should handle the packet in *) Lwt_list.iter_p (fun (_, rule, t) -> - let _ = pp "\nrule:%s\nin:%s\n\n%!" (OP.Match.match_to_string rule) - (OP.Match.match_to_string m) in if (OP.Match.flow_match_compare rule m rule.OP.Match.wildcards) then - let _ = pp "matched flow\n%!" in Ofsocket.send_packet t msg else return ()) flv.controllers @@ -241,14 +238,15 @@ let map_path flv in_dpid in_port out_dpid out_port = else let path = Flowvisor_topology.find_dpid_path flv.flv_topo in_dpid in_port out_dpid out_port in -(* let _ = +(* let path = List.rev path in *) + let _ = List.iter ( fun (dp, in_p, out_p) -> pp "%s:%Ld:%s -> " (OP.Port.string_of_port in_p) dp (OP.Port.string_of_port out_p) ) path in - let _ = pp "\n%!" in *) + let _ = pp "\n%!" in path let map_spanning_tree flv in_dpid in_port = [] diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 50f2c39..2eabc09 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -1243,12 +1243,7 @@ module Match = struct flow_def.dl_vlan_pcp));*) let nw_src_mask = 0x20 - (int_of_char wildcard.Wildcards.nw_src) in let nw_dst_mask = 0x20 - (int_of_char wildcard.Wildcards.nw_dst) in - let _ = printf - "%lx/%d - %lx:%d , %lx = %lx\n%!" - flow.nw_src nw_src_mask flow_def.nw_src nw_src_mask - (Int32.shift_right_logical flow.nw_src nw_src_mask) - (Int32.shift_right_logical flow_def.nw_src nw_src_mask) in - (((wildcard.Wildcards.in_port)|| ((Port.int_of_port flow.in_port) = (Port.int_of_port flow_def.in_port))) && + (((wildcard.Wildcards.in_port)|| ((Port.int_of_port flow.in_port) = (Port.int_of_port flow_def.in_port))) && (* ((wildcard.Wildcards.dl_vlan) || (flow.dl_vlan == flow_def.dl_vlan)) * &&*) ((wildcard.Wildcards.dl_src) || (flow.dl_src = flow_def.dl_src)) && From 78fed67c2e3720f8c96791d42c0b0285088877ca Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Thu, 28 Feb 2013 12:20:42 +0000 Subject: [PATCH 43/75] fixing queue scheduling in forwarding plane --- lib/ofswitch.ml | 46 ++++++++++++++++++++++++++++++++++------------ 1 file changed, 34 insertions(+), 12 deletions(-) diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index ccd3711..9426961 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -300,6 +300,7 @@ module Switch = struct port_name: string; counter: OP.Port.stats; phy: OP.Port.phy; + queue: Cstruct.t Queue.t; } let init_port mgr port_no ethif = let name = Manager.get_intf_name mgr ethif in @@ -328,7 +329,8 @@ module Switch = struct state= port_state; curr=features; advertised=features; supported=features; peer=features;}) in - {port_id=port_no; mgr; port_name=name; counter; ethif;phy;} + {port_id=port_no; mgr; port_name=name; counter; + ethif;phy;queue=(Queue.create ())} type stats = { mutable n_frags: uint64; @@ -361,7 +363,8 @@ module Switch = struct mutable queue_len : int; features : OP.Switch.features; mutable packet_buffer: OP.Packet_in.t list; - mutable packet_buffer_id: int32; + mutable packet_buffer_id: int32; + ready : unit Lwt_condition.t ; } let supported_actions () = OP.Switch.({ output=true; set_vlan_id=true; set_vlan_pcp=true; strip_vlan=true; @@ -647,10 +650,7 @@ type t = Switch.t (* * let process_frame_depr intf_name frame = *) -let process_frame_inner st p intf frame = - match frame with - | Net.Ethif.Output _ -> return () - | Net.Ethif.Input frame -> begin +let process_frame_inner st p frame = try_lwt let in_port = (OP.Port.port_of_int p.Switch.port_id) in let tupple = (OP.Match.raw_packet_to_match in_port frame ) in @@ -695,12 +695,31 @@ let process_frame_inner st p intf frame = pp "control channel error: %s\nbt: %s\n%!" (Printexc.to_string exn) (Printexc.get_backtrace ()); return () - end -let process_frame p st intf_name frame = +let forward_thread st = + while_lwt true do + lwt _ = Lwt_condition.wait st.Switch.ready in + Lwt_list.iter_s ( + fun p -> + if (Queue.is_empty p.Switch.queue) then + return () + else + let frame = Queue.take p.Switch.queue in + process_frame_inner st p frame + ) st.Switch.ports + done + +let process_frame st p _ frame = try_lwt (*let p = Hashtbl.find st.Switch.dev_to_port intf_name in *) - process_frame_inner st p intf_name frame + match frame with + | Net.Ethif.Output _ -> return () + | Net.Ethif.Input frame -> begin +(* process_frame_inner st p intf_name frame *) + let _ = Queue.push frame p.Switch.queue in + let _ = Lwt_condition.signal st.Switch.ready () in + return () + end (* if (st.Switch.queue_len < 256) then ( st.Switch.queue_len <- st.Switch.queue_len + 1; @@ -1017,7 +1036,7 @@ let add_port mgr ?(use_mac=false) sw ethif = Hashtbl.add sw.Switch.dev_to_port ethif (ref port); sw.Switch.features.OP.Switch.ports <- sw.Switch.features.OP.Switch.ports @ [port.Switch.phy]; - let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw port) in + let _ = Net.Manager.set_promiscuous mgr ethif (process_frame sw port) in let h,p = OP.Port.create_port_status OP.Port.ADD port.Switch.phy in lwt _ = match sw.Switch.controller with @@ -1096,7 +1115,7 @@ let add_port_local mgr sw ethif = *) let _ = Console.log (sprintf "Adding port %s (port_id=%d)" ethif local_port_id) in - let _ = Net.Manager.set_promiscuous mgr ethif (process_frame_inner sw port) in + let _ = Net.Manager.set_promiscuous mgr ethif (process_frame sw port) in return () let add_flow st fm = Table.add_flow st st.Switch.table fm @@ -1110,15 +1129,17 @@ let create_switch dpid = p_sflow = 0_l; controller=None; errornum = 0l; portnum=0; packet_queue; push_packet; queue_len = 0; stats={n_frags=0L; n_hits=0L;n_missed=0L;n_lost=0L;}; table = (Table.init_table ()); features=(Switch.switch_features dpid); - packet_buffer=[]; packet_buffer_id=0l;}) + packet_buffer=[]; packet_buffer_id=0l;ready=(Lwt_condition.create ());}) let listen st mgr loc = Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> + (forward_thread st) <&> (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) let connect st mgr loc = Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> + (forward_thread st) <&> (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) @@ -1126,6 +1147,7 @@ let local_connect st mgr conn = let _ = st.Switch.controller <- (Some conn) in let t, _ = Lwt.task () in (control_channel_run st conn t) <&> + (forward_thread st) <&> (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) (* From cfd544048ce6ef3431ec5b0d60d31cd6853a0738 Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Thu, 28 Feb 2013 17:43:14 +0000 Subject: [PATCH 44/75] add a verbose flag to reduce logging --- lib/flowvisor.ml | 25 ++++++----- lib/flowvisor.mli | 2 +- lib/ofcontroller.ml | 36 +++++++-------- lib/ofcontroller.mli | 6 +-- lib/ofswitch.ml | 83 +++++++++++++++++----------------- lib/ofswitch.mli | 2 +- myocamlbuild.ml | 14 +++--- setup.ml | 103 ++++++++++++++++++++++--------------------- 8 files changed, 137 insertions(+), 134 deletions(-) diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index 04205a8..7c4461b 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -60,6 +60,7 @@ type xid_state = { } type t = { + verbose : bool; (* counters *) mutable errornum : int32; mutable portnum : int; @@ -98,8 +99,8 @@ let switch_features datapath_id ports = capabilities=(supported_capabilities ()); actions=(supported_actions ()); ports;}) -let init_flowvisor flv_topo = - {errornum=0l; portnum=10; xid_count=0l; +let init_flowvisor verbose flv_topo = + {verbose; errornum=0l; portnum=10; xid_count=0l; port_map=(Hashtbl.create 64); controllers=[]; buffer_id_map=(Hashtbl.create 64); buffer_id_count=0l; xid_map=(Hashtbl.create 64); @@ -239,14 +240,14 @@ let map_path flv in_dpid in_port out_dpid out_port = let path = Flowvisor_topology.find_dpid_path flv.flv_topo in_dpid in_port out_dpid out_port in (* let path = List.rev path in *) - let _ = +(* let _ = List.iter ( fun (dp, in_p, out_p) -> pp "%s:%Ld:%s -> " (OP.Port.string_of_port in_p) dp (OP.Port.string_of_port out_p) ) path in - let _ = pp "\n%!" in + let _ = pp "\n%!" in *) path let map_spanning_tree flv in_dpid in_port = [] @@ -341,14 +342,14 @@ let flow_mod_del_translate st msg xid pkt = let process_openflow st dpid t msg = match msg with | OP.Hello (h) -> - let _ = cp "[flowvisor-switch] HELLO\n%!" in + let _ = if st.verbose then cp "[flowvisor-switch] HELLO\n%!" in return () | OP.Echo_req (h) -> (* Reply to ECHO requests *) - let _ = cp "[flowvisor-switch] ECHO_REQ\n%!" in + let _ = if st.verbose then cp "[flowvisor-switch] ECHO_REQ\n%!" in let h = OP.Header.(create ECHO_RESP ~xid:h.xid sizeof_ofp_header) in send_controller t (OP.Echo_resp h) | OP.Features_req (h) -> - let _ = cp "[flowvisor-switch] FEATURES_REQ\n%!" in + let _ = if st.verbose then cp "[flowvisor-switch] FEATURES_REQ\n%!" in let h = OP.Header.(create FEATURES_RESP ~xid:h.OP.Header.xid sizeof_ofp_header) in let feat = switch_features dpid @@ -357,7 +358,7 @@ let process_openflow st dpid t msg = send_controller t (OP.Features_resp(h, feat)) | OP.Stats_req(h, req) -> begin (* TODO Need to translate the xid here *) - let _ = cp "[flowvisor-switch] STATS_REQ\n%!" in + let _ = if st.verbose then cp "[flowvisor-switch] STATS_REQ\n%!" in match req with | OP.Stats.Desc_req(req) -> let desc = @@ -454,7 +455,7 @@ let process_openflow st dpid t msg = let _ = pr "BARRIER_REQ: %s\n%!" (OP.Header.header_to_string h) in send_controller t (OP.Barrier_resp (OP.Header.({h with ty=BARRIER_RESP;})) ) | OP.Packet_out(h, pkt) -> begin - let _ = pr "[flowvisor-switch] PACKET_OUT: %s\n%!" + let _ = if st.verbose then pr "[flowvisor-switch] PACKET_OUT: %s\n%!" (OP.Packet_out.packet_out_to_string pkt) in (* Check if controller has the right to send traffic on the specific subnet *) try_lwt @@ -465,7 +466,7 @@ let process_openflow st dpid t msg = (Printexc.to_string exn)) end | OP.Flow_mod(h,fm) -> begin - let _ = pr "[flowvisor-switch] FLOW_MOD: %s\n%!" + let _ = if st.verbose then pr "[flowvisor-switch] FLOW_MOD: %s\n%!" (OP.Flow_mod.flow_mod_to_string fm) in let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) No_reply in match (fm.OP.Flow_mod.command) with @@ -720,8 +721,8 @@ let process_switch_channel flv st dpid e = let _ = OC.register_cb st OE.PORT_STATUS_CHANGE fn in () -let create_flowvisor dpid = - let ret = init_flowvisor (Flowvisor_topology.init_topology ()) in +let create_flowvisor ?(verbose=false) () = + let ret = init_flowvisor verbose (Flowvisor_topology.init_topology ()) in let _ = ignore_result (Flowvisor_topology.discover ret.flv_topo) in ret diff --git a/lib/flowvisor.mli b/lib/flowvisor.mli index c8b92b1..7474653 100644 --- a/lib/flowvisor.mli +++ b/lib/flowvisor.mli @@ -22,7 +22,7 @@ type t val listen: t -> Manager.t -> ipv4_src -> unit Lwt.t val local_listen: t -> Ofsocket.conn_state -> unit Lwt.t -val create_flowvisor: unit -> t +val create_flowvisor: ?verbose:bool -> unit -> t val remove_slice : t -> Ofpacket.Match.t -> unit Lwt.t val add_local_slice : Net.Manager.t -> t -> Ofpacket.Match.t -> Ofsocket.conn_state -> int64 -> unit Lwt.t diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 8a1b48b..91a2d8e 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -114,6 +114,7 @@ type t = { (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; mutable port_status_cb: (t -> OP.datapath_id -> Event.e -> unit Lwt.t) list; + verbose : bool; } let register_cb controller e cb = @@ -154,18 +155,18 @@ let process_of_packet state conn ofp = OP.( match ofp with | Hello (h) -> begin (* Reply to HELLO with a HELLO and a feature request *) - let _ = pp "[controller] HELLO\n%!" in + let _ = if state.verbose then pp "[controller] HELLO\n%!" in lwt _ = send_packet conn (OP.Hello (h)) in let h = OP.Header.create OP.Header.FEATURES_REQ OP.Header.get_len in send_packet conn (OP.Features_req (h) ) end | Echo_req h -> begin (* Reply to ECHO requests *) - let _ = pp "[controller] ECHO_REQ\n%!" in + let _ = if state.verbose then pp "[controller] ECHO_REQ\n%!" in let h = OP.Header.(create ~xid:h.xid ECHO_RESP get_len) in send_packet conn (OP.Echo_resp h) end | Features_resp (h, sfs) -> begin (* Generate a datapath join event *) - let _ = pp "[controller] FEATURES_RESP\n%!" in + let _ = if state.verbose then pp "[controller] FEATURES_RESP\n%!" in let _ = conn.dpid <- sfs.Switch.datapath_id in let evt = Event.Datapath_join (sfs.Switch.datapath_id, sfs.Switch.ports) in let _ = @@ -177,7 +178,7 @@ let process_of_packet state conn ofp = state.datapath_join_cb end | Packet_in (h, p) -> begin (* Generate a packet_in event *) - let _ = pp "[controller]+ %s|%s\n%!" + let _ = if state.verbose then pp "[controller]+ %s|%s\n%!" (OP.Header.header_to_string h) (OP.Packet_in.packet_in_to_string p) in let evt = @@ -186,7 +187,7 @@ let process_of_packet state conn ofp = iter_p (fun cb -> cb state conn.dpid evt) state.packet_in_cb end | Flow_removed (h, p) -> - let _ = pp "+ %s|%s\n%!" + let _ = if state.verbose then pp "+ %s|%s\n%!" (OP.Header.header_to_string h) (OP.Flow_removed.string_of_flow_removed p) in let evt = Event.Flow_removed ( @@ -196,8 +197,9 @@ let process_of_packet state conn ofp = in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_removed_cb | Stats_resp(h, resp) -> begin - let _ = pp "[controller] + %s|%s\n%!" (OP.Header.header_to_string h) - (OP.Stats.string_of_stats resp) in + let _ = if state.verbose then + pp "[controller] + %s|%s\n%!" (OP.Header.header_to_string h) + (OP.Stats.string_of_stats resp) in match resp with | OP.Stats.Flow_resp(resp_h, flows) -> begin let evt = Event.Flow_stats_reply( @@ -244,7 +246,7 @@ let process_of_packet state conn ofp = end | Port_status(h, st) -> begin - let _ = pp "[controller] + %s|%s" (OP.Header.header_to_string h) + let _ = if state.verbose then pp "[controller] + %s|%s" (OP.Header.header_to_string h) (OP.Port.string_of_status st) in let evt = Event.Port_status (st.Port.reason, st.Port.desc, conn.dpid) in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_status_cb @@ -305,8 +307,9 @@ let socket_controller st (remote_addr, remote_port) t = let conn = init_socket_conn_state t in controller_run st conn -let init_controller () = - { dp_db = Hashtbl.create 0; +let init_controller ?(verbose=false) () = + { verbose; + dp_db = Hashtbl.create 0; datapath_join_cb = []; datapath_leave_cb = []; packet_in_cb = []; @@ -318,19 +321,16 @@ let init_controller () = table_stats_reply_cb = []; port_status_cb = []; } -let listen mgr loc init = - let st = init_controller () in +let listen mgr ?(verbose=false) loc init = + let st = init_controller ~verbose () in let _ = init st in (Channel.listen mgr (`TCPv4 (loc, (socket_controller st) ))) -let connect mgr loc init = - let st = init_controller () in +let connect mgr ?(verbose=false) loc init = + let st = init_controller ~verbose () in let _ = init st in Net.Channel.connect mgr (`TCPv4 (None, loc, (socket_controller st loc) )) -let init_controller () = init_controller () - let local_connect st conn init = - let _ = init st in - controller_run st conn + let _ = init st in controller_run st conn diff --git a/lib/ofcontroller.mli b/lib/ofcontroller.mli index f0e54ca..8717358 100644 --- a/lib/ofcontroller.mli +++ b/lib/ofcontroller.mli @@ -52,9 +52,9 @@ type t val register_cb : t -> Event.t -> (t -> Ofpacket.datapath_id -> Event.e -> unit Lwt.t) -> unit val send_of_data : t -> Ofpacket.datapath_id -> Cstruct.t -> unit Lwt.t val send_data : t -> Ofpacket.datapath_id -> Ofpacket.t -> unit Lwt.t -val listen : Manager.t -> Nettypes.ipv4_src -> +val listen : Manager.t -> ?verbose:bool -> Nettypes.ipv4_src -> (t -> 'a) -> unit Lwt.t -val connect : Manager.t -> Nettypes.ipv4_dst -> +val connect : Manager.t -> ?verbose:bool -> Nettypes.ipv4_dst -> (t -> 'a) -> unit Lwt.t -val init_controller : unit -> t +val init_controller : ?verbose:bool -> unit -> t val local_connect : t -> Ofsocket.conn_state -> (t -> 'a) -> unit Lwt.t diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 9426961..37e28fb 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -144,9 +144,6 @@ module Table = struct (* lwt _ = log ~level:Notice (sprintf "Adding flow %s" (OP.Match.match_to_string t.OP.Flow_mod.of_match)) in *) - let _ = - Console.log - (sprintf "Adding flow %s" (OP.Match.match_to_string t.OP.Flow_mod.of_match)) in let entry = Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); cache_entries=[];}) in @@ -190,7 +187,7 @@ module Table = struct | head::tail -> is_output_port out_port tail let del_flow table ?(xid=(Random.int32 Int32.max_int)) - ?(reason=OP.Flow_removed.DELETE) tuple out_port t = + ?(reason=OP.Flow_removed.DELETE) tuple out_port t verbose = (* Delete all matching entries from the flow table*) let remove_flow = Hashtbl.fold ( @@ -230,13 +227,11 @@ module Table = struct * flow modification warnings *) Lwt_list.iter_s ( fun (of_match, flow) -> -(* lwt _ = - log ~level:Notice - (sprintf "Adding flow %s" (OP.Match.match_to_string of_match)) in *) let _ = + if verbose then Console.log - (sprintf "Adding flow %s" (OP.Match.match_to_string of_match)) in - + (sprintf "Removing flow %s" (OP.Match.match_to_string of_match)) + in match(t, flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) with | (Some t, true) -> let duration_sec = Int32.sub (Int32.of_float (OS.Clock.time ())) @@ -264,7 +259,7 @@ module Table = struct table.stats.OP.Stats.lookup_count 1L (* monitor thread to timeout flows *) - let check_flow_timeout table t = + let check_flow_timeout table t verbose = let ts = (Int32.of_float (OS.Clock.time ())) in let flows = Hashtbl.fold ( fun of_match entry ret -> @@ -281,14 +276,14 @@ module Table = struct ) table.entries [] in Lwt_list.iter_s ( fun (of_match, entry, reason) -> - del_flow table ~reason of_match OP.Port.No_port t + del_flow table ~reason of_match OP.Port.No_port t verbose ) flows - let monitor_flow_timeout table t = + let monitor_flow_timeout table t verbose = while_lwt true do lwt _ = OS.Time.sleep 1.0 in - check_flow_timeout table t + check_flow_timeout table t verbose done end @@ -300,7 +295,7 @@ module Switch = struct port_name: string; counter: OP.Port.stats; phy: OP.Port.phy; - queue: Cstruct.t Queue.t; + queue: Cstruct.t Queue.t; } let init_port mgr port_no ethif = let name = Manager.get_intf_name mgr ethif in @@ -330,7 +325,7 @@ module Switch = struct supported=features; peer=features;}) in {port_id=port_no; mgr; port_name=name; counter; - ethif;phy;queue=(Queue.create ())} + ethif;phy;queue=(Queue.create ());} type stats = { mutable n_frags: uint64; @@ -356,15 +351,11 @@ module Switch = struct p_sflow: uint32; (** probability for sFlow sampling *) mutable errornum : uint32; mutable portnum : int; - packet_queue : (Cstruct.t * Net.Manager.id) Lwt_stream.t; - push_packet : ((Cstruct.t * Net.Manager.id) option -> unit); - (* TODO: add this in the port definition and make also - * packet output assyncronous *) - mutable queue_len : int; features : OP.Switch.features; mutable packet_buffer: OP.Packet_in.t list; mutable packet_buffer_id: int32; ready : unit Lwt_condition.t ; + verbose : bool; } let supported_actions () = OP.Switch.({ output=true; set_vlan_id=true; set_vlan_pcp=true; strip_vlan=true; @@ -775,21 +766,21 @@ let process_openflow st t msg = match msg with | OP.Hello (h) -> (* Reply to HELLO with a HELLO and a feature request *) - cp "HELLO"; - return () + let _ = if st.Switch.verbose then cp "HELLO" in + return () | OP.Echo_req h -> (* Reply to ECHO requests *) - cp "ECHO_REQ"; + let _ = if st.Switch.verbose then cp "ECHO_REQ" in Ofsocket.send_packet t (OP.Echo_req OP.Header.(create ~xid:h.xid ECHO_RESP sizeof_ofp_header)) | OP.Features_req (h) -> - cp "FEAT_REQ"; + let _ = if st.Switch.verbose then cp "FEAT_REQ" in let h = OP.Header.create ~xid:(h.OP.Header.xid) OP.Header.FEATURES_RESP (OP.Switch.get_len st.Switch.features) in Ofsocket.send_packet t (OP.Features_resp (h, st.Switch.features)) | OP.Stats_req(h, req) -> begin let xid = h.OP.Header.xid in - cp "STATS_REQ"; + let _ = if st.Switch.verbose then cp "STATS_REQ" in match req with | OP.Stats.Desc_req(req) -> let p = @@ -879,13 +870,15 @@ let process_openflow st t msg = OP.Switch.config_get_len in Ofsocket.send_packet t (OP.Get_config_resp(h, resp)) | OP.Barrier_req(h) -> - cp (sp "BARRIER_REQ: %s" (OP.Header.header_to_string h)); + let _ = if st.Switch.verbose then cp (sp "BARRIER_REQ: %s" + (OP.Header.header_to_string h)) in let resp_h = (OP.Header.create ~xid:h.OP.Header.xid OP.Header.BARRIER_RESP (OP.Header.sizeof_ofp_header)) in Ofsocket.send_packet t (OP.Barrier_resp(resp_h)) | OP.Packet_out(h, pkt) -> -(* cp (sp "PACKET_OUT: %s" (OP.Packet_out.packet_out_to_string pkt)); *) + let _ = if st.Switch.verbose then cp (sp "PACKET_OUT: %s" + (OP.Packet_out.packet_out_to_string pkt)); in if (pkt.OP.Packet_out.buffer_id = -1l) then Switch.apply_of_actions st pkt.OP.Packet_out.in_port pkt.OP.Packet_out.data pkt.OP.Packet_out.actions @@ -913,7 +906,8 @@ let process_openflow st t msg = pkt_in.OP.Packet_in.data pkt.OP.Packet_out.actions end | OP.Flow_mod(h,fm) -> - cp (sp "FLOW_MOD: %s" (OP.Flow_mod.flow_mod_to_string fm)); + let _ = if st.Switch.verbose then + cp (sp "FLOW_MOD: %s" (OP.Flow_mod.flow_mod_to_string fm)) in let of_match = fm.OP.Flow_mod.of_match in let of_actions = fm.OP.Flow_mod.actions in lwt _ = @@ -921,13 +915,18 @@ let process_openflow st t msg = | OP.Flow_mod.ADD | OP.Flow_mod.MODIFY | OP.Flow_mod.MODIFY_STRICT -> - Table.add_flow st st.Switch.table fm + let _ = + if (st.Switch.verbose) then + Console.log + (sprintf "Adding flow %s" (OP.Match.match_to_string fm.OP.Flow_mod.of_match)) + in + Table.add_flow st st.Switch.table fm | OP.Flow_mod.DELETE | OP.Flow_mod.DELETE_STRICT -> (* Need to implemente strict deletion in order to enable signpost * switching *) - Table.del_flow st.Switch.table of_match fm.OP.Flow_mod.out_port - (Some t) + Table.del_flow st.Switch.table of_match fm.OP.Flow_mod.out_port + (Some t) st.Switch.verbose in if (fm.OP.Flow_mod.buffer_id = -1l) then return () @@ -994,8 +993,9 @@ let control_channel_run st conn t = lwt _ = ( lwt _ = t in return (printf "thread terminated\n%!")) echo () - (lwt _ = Table.monitor_flow_timeout st.Switch.table (Some conn) in return (pp - "[switch] terminated flow_timeout thread") ) + (lwt _ = Table.monitor_flow_timeout st.Switch.table (Some conn) + st.Switch.verbose in + return (pp "[switch] terminated flow_timeout thread") ) in let _ = Ofsocket.close conn in let _ = st.Switch.controller <- None in @@ -1068,11 +1068,11 @@ let del_port mgr sw name = let of_match = OP.Match.create_flow_match (OP.Wildcards.full_wildcard ()) () in lwt _ = Table.del_flow sw.Switch.table of_match (OP.Port.port_of_int port.Switch.port_id) - sw.Switch.controller in + sw.Switch.controller sw.Switch.verbose in let of_match = OP.Match.create_flow_match (OP.Wildcards.in_port_match ()) ~in_port:(port.Switch.port_id) () in lwt _ = Table.del_flow sw.Switch.table of_match - OP.Port.No_port sw.Switch.controller in + OP.Port.No_port sw.Switch.controller sw.Switch.verbose in (* lwt _ = log ~level:Notice (sprintf "Removing port %s (port_id=%d)" name port.Switch.port_id) in @@ -1121,15 +1121,16 @@ let add_port_local mgr sw ethif = let add_flow st fm = Table.add_flow st st.Switch.table fm let del_flow st m = Table.del_flow st.Switch.table m OP.Port.No_port st.Switch.controller + st.Switch.verbose -let create_switch dpid = - let (packet_queue, push_packet) = Lwt_stream.create () in +let create_switch ?(verbose=false) dpid = Switch.( { ports = []; int_to_port = (Hashtbl.create 64); dev_to_port=(Hashtbl.create 64); - p_sflow = 0_l; controller=None; errornum = 0l; portnum=0; packet_queue; push_packet; - queue_len = 0; stats={n_frags=0L; n_hits=0L;n_missed=0L;n_lost=0L;}; - table = (Table.init_table ()); features=(Switch.switch_features dpid); - packet_buffer=[]; packet_buffer_id=0l;ready=(Lwt_condition.create ());}) + p_sflow = 0_l; controller=None; errornum = 0l; portnum=0; + stats={n_frags=0L; n_hits=0L;n_missed=0L;n_lost=0L;}; + table = (Table.init_table ()); features=(Switch.switch_features dpid); + packet_buffer=[]; packet_buffer_id=0l;ready=(Lwt_condition.create ()); + verbose;}) let listen st mgr loc = Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index 25c39ca..be87b44 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -23,7 +23,7 @@ val add_port_local : Net.Manager.t -> t -> Net.Manager.id -> unit Lwt.t val add_flow : t -> Ofpacket.Flow_mod.t -> unit Lwt.t val del_flow : t -> Ofpacket.Match.t -> unit Lwt.t val get_flow_stats : t -> Ofpacket.Match.t -> Ofpacket.Flow.stats list -val create_switch : int64 -> t +val create_switch : ?verbose:bool -> int64 -> t val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> unit Lwt.t val connect : t -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 83cf5a7..2896416 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: b6e8b4245b50e2cce10c824f28c99f46) *) +(* DO NOT EDIT (digest: 87e30635909bd1f2bf7921b65b55b4de) *) module OASISGettext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -335,7 +335,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -351,7 +351,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index 4e52110..76f5b7b 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 152779c70a75a31419a30a533e9cc554) *) +(* DO NOT EDIT (digest: d2abab3bd5e7749f13853bc52e038401) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISContext.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISString.ml" *) +(* # 1 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISUtils.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) +(* # 71 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISMessage.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISVersion.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISLicense.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) @@ -1020,7 +1020,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 104 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) +(* # 104 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1186,7 +1186,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1270,7 +1270,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISHostPath.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISHostPath.ml" *) open Filename @@ -1303,7 +1303,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISSection.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1386,12 +1386,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExecutable.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1424,7 +1424,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISLibrary.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1604,7 +1604,7 @@ module OASISLibrary = struct end module OASISObject = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISObject.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext @@ -1669,7 +1669,7 @@ module OASISObject = struct end module OASISFindlib = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFindlib.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFindlib.ml" *) open OASISTypes @@ -1956,32 +1956,32 @@ module OASISFindlib = struct end module OASISFlag = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFlag.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISPackage.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTest.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISDocument.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExec.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -2059,7 +2059,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2256,7 +2256,7 @@ end # 2257 "setup.ml" module BaseEnvLight = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2354,7 +2354,7 @@ end # 2355 "setup.ml" module BaseContext = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseContext.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseContext.ml" *) open OASISContext @@ -2365,7 +2365,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseMessage.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2384,7 +2384,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnv.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2844,7 +2844,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseArgExt.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2872,7 +2872,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseCheck.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2998,7 +2998,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -3114,7 +3114,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseStandardVar.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3478,7 +3478,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseFileAB.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3526,7 +3526,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseLog.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseLog.ml" *) open OASISUtils @@ -3645,7 +3645,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseBuilt.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3813,7 +3813,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseCustom.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3863,7 +3863,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseDynVar.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3910,7 +3910,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseTest.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -4000,7 +4000,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseDoc.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -4035,7 +4035,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseSetup.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4616,7 +4616,7 @@ end # 4617 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4872,7 +4872,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5457,7 +5457,7 @@ end # 5458 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5559,7 +5559,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5766,7 +5766,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/Users/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -6149,7 +6149,8 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "¢¾@\bò\130\027­°\011)«ò\131H\031"; + oasis_digest = + Some "\162\190@\b\242\130\027\173\176\011)\171\242\131H\031"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6157,6 +6158,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6161 "setup.ml" +# 6162 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 68e50bd70f3e2268efaf6e5fd541a8388fcffec7 Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Tue, 5 Mar 2013 14:39:59 +0000 Subject: [PATCH 45/75] remove second register for PORT_STATUS_CANGE events --- lib/flowvisor.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index 7c4461b..9ca6282 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -718,7 +718,6 @@ let process_switch_channel flv st dpid e = let _ = OC.register_cb st OE.AGGR_FLOW_STATS_REPLY fn in let _ = OC.register_cb st OE.PORT_STATUS_CHANGE fn in let _ = OC.register_cb st OE.TABLE_STATS_REPLY fn in - let _ = OC.register_cb st OE.PORT_STATUS_CHANGE fn in () let create_flowvisor ?(verbose=false) () = From 67a21c827bb8a8a7278a67a539340887df973259 Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Wed, 6 Mar 2013 14:37:18 +0000 Subject: [PATCH 46/75] fixing code for stats reply on flowvisor --- lib/flowvisor.ml | 44 ++++++++++++++++++++++++++++++++++---------- lib/ofpacket.ml | 2 ++ lib/ofpacket.mli | 2 ++ lib/ofswitch.ml | 18 ++++++++++++++++-- 4 files changed, 54 insertions(+), 12 deletions(-) diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index 9ca6282..f2b71a7 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -126,9 +126,33 @@ let get_new_xid old_xid st src dst cache = let _ = Hashtbl.replace st.xid_map xid r in xid -let handle_xid st xid = return () - -let timeout_xid st = +let handle_xid flv st xid_st = + match xid_st.cache with + | Flows flows -> + let stats = OP.Stats.({st_ty=FLOW; more=true;}) in + let (_, _, t) = List.find ( + fun (dpid, _, _) -> dpid = xid_st.src ) + flv.controllers in + lwt (_, flows) = + Lwt_list. fold_right_s ( + fun fl (sz, flows) -> + let fl_sz = OP.Flow.flow_stats_len fl in + if (sz + fl_sz > 0xffff) then + let r = OP.Stats.Flow_resp(stats, flows) in + let h = OP.Header.create ~xid:(xid_st.xid) OP.Header.STATS_RESP 0 in + lwt _ = Ofsocket.send_packet t (OP.Stats_resp (h, r)) in + return ((OP.Header.get_len + OP.Stats.get_resp_hdr_size + fl_sz), [fl]) + else + return ((sz + fl_sz), (fl::flows)) ) + flows ((OP.Header.get_len + OP.Stats.get_resp_hdr_size), []) in + let stats = OP.Stats.({st_ty=FLOW; more=false;}) in + let r = OP.Stats.Flow_resp(stats, flows) in + let h = OP.Header.create ~xid:xid_st.xid OP.Header.STATS_RESP 0 in + let _ = pr "XXXXX flowvisor controller received stats\n%!" in + Ofsocket.send_packet t (OP.Stats_resp (h, r)) + | _ -> return () + +let timeout_xid flv st = while_lwt true do lwt _ = OS.Time.sleep 120.0 in let time = OS.Clock.time () in @@ -140,7 +164,7 @@ let timeout_xid st = r :: ret else ret ) st.xid_map [] in - lwt _ = Lwt_list.iter_p (handle_xid st) xid in + lwt _ = Lwt_list.iter_p (handle_xid flv st) xid in OS.Time.sleep 600. done @@ -358,7 +382,7 @@ let process_openflow st dpid t msg = send_controller t (OP.Features_resp(h, feat)) | OP.Stats_req(h, req) -> begin (* TODO Need to translate the xid here *) - let _ = if st.verbose then cp "[flowvisor-switch] STATS_REQ\n%!" in + let _ = if st.verbose then cp "[flowvisor-switch] STATS_REQ" in match req with | OP.Stats.Desc_req(req) -> let desc = @@ -640,15 +664,15 @@ let process_switch_channel flv st dpid e = let _ = if not more then xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst - in + in if (List.length xid_st.dst = 0 ) then let _ = Hashtbl.remove flv.xid_map xid in - handle_xid st xid_st + handle_xid flv st xid_st else let _ = Hashtbl.replace flv.xid_map xid xid_st in return () | _ -> return () - with Not_found -> return () + with Not_found -> return (pr "[flowvisor-ctrl] Unknown stats reply xid\n%!") end | OE.Aggr_flow_stats_reply(xid, pkts, bytes, flows, dpid) -> begin try_lwt @@ -666,7 +690,7 @@ let process_switch_channel flv st dpid e = in if (List.length xid_st.dst = 0 ) then let _ = Hashtbl.remove flv.xid_map xid in - handle_xid st xid_st + handle_xid flv st xid_st else let _ = Hashtbl.replace flv.xid_map xid xid_st in return () @@ -691,7 +715,7 @@ let process_switch_channel flv st dpid e = in if (List.length xid_st.dst = 0 ) then let _ = Hashtbl.remove flv.xid_map xid in - handle_xid st xid_st + handle_xid flv st xid_st else let _ = Hashtbl.replace flv.xid_map xid xid_st in return () diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index 2eabc09..bab27b2 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -2305,6 +2305,8 @@ module Stats = struct uint16_t flags } as big_endian + let get_resp_hdr_size = sizeof_ofp_stats_reply + cstruct ofp_desc_stats { uint8_t mfr_desc[256]; uint8_t hw_desc[256]; diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index 1d91791..a04e2d0 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -304,6 +304,7 @@ module Flow : } val marshal_flow_stats : stats list -> Cstruct.t -> int val string_of_flow_stat : stats -> string + val flow_stats_len : stats -> int end module Packet_in : sig @@ -472,6 +473,7 @@ module Stats : type resp_hdr = { st_ty : stats_type; more : bool; } val int_of_stats_type : stats_type -> int val stats_type_of_int : int -> stats_type + val get_resp_hdr_size : int type resp = Desc_resp of resp_hdr * desc | Flow_resp of resp_hdr * Flow.stats list diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 37e28fb..fd45879 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -795,10 +795,24 @@ let process_openflow st t msg = (*TODO Need to consider the table_id and the out_port and * split reply over multiple openflow packets if they don't * fit a single packet. *) - let flows = get_flow_stats st of_match in + let flows = get_flow_stats st of_match in + let stats = OP.Stats.({st_ty=FLOW; more=true;}) in + + lwt (_, flows) = + Lwt_list. fold_right_s ( + fun fl (sz, flows) -> + let fl_sz = OP.Flow.flow_stats_len fl in + if (sz + fl_sz > 0xffff) then + let r = OP.Stats.Flow_resp(stats, flows) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + lwt _ = Ofsocket.send_packet t (OP.Stats_resp (h, r)) in + return ((OP.Header.get_len + OP.Stats.get_resp_hdr_size + fl_sz), [fl]) + else + return ((sz + fl_sz), (fl::flows)) ) + flows ((OP.Header.get_len + OP.Stats.get_resp_hdr_size), []) in let stats = OP.Stats.({st_ty=FLOW; more=false;}) in let r = OP.Stats.Flow_resp(stats, flows) in - let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in Ofsocket.send_packet t (OP.Stats_resp (h, r)) | OP.Stats.Aggregate_req (req_h, of_match, table, port) -> let aggr_flow_bytes = ref 0L in From 2bbabbcb9ec0caf45359f7066933b4bc82f484d7 Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Tue, 23 Apr 2013 09:54:20 +0100 Subject: [PATCH 47/75] Updating flowvisor functionality --- lib/flowvisor.ml | 29 +++++++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index f2b71a7..b7dfc90 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -148,7 +148,6 @@ let handle_xid flv st xid_st = let stats = OP.Stats.({st_ty=FLOW; more=false;}) in let r = OP.Stats.Flow_resp(stats, flows) in let h = OP.Header.create ~xid:xid_st.xid OP.Header.STATS_RESP 0 in - let _ = pr "XXXXX flowvisor controller received stats\n%!" in Ofsocket.send_packet t (OP.Stats_resp (h, r)) | _ -> return () @@ -573,14 +572,35 @@ let del_flowvisor_port flv desc = let map_flv_port flv dpid port = (* map the new port *) - let port = + let p = Hashtbl.fold ( fun flv_port (sw_dpid, sw_port, _) r -> if ((dpid = sw_dpid) && (sw_port = port)) then flv_port else r ) flv.port_map (-1) in - if (port < 0) then raise Not_found - else OP.Port.Port (port) + if (p < 0) then OP.Port.Port(port) + else OP.Port.Port (p) + +let translate_stat flv dpid f = + (* Translate match *) + let _ = + match (f.OP.Flow.of_match.OP.Match.wildcards.OP.Wildcards.in_port, + f.OP.Flow.of_match.OP.Match.in_port) with + | (false, OP.Port.Port(p) ) -> + f.OP.Flow.of_match.OP.Match.in_port <- map_flv_port flv dpid p + | _ -> () + in + + let _ = + f.OP.Flow.action <- List.map + (fun act -> + match act with + | OP.Flow.Output(OP.Port.Port(p), len ) -> + let p = map_flv_port flv dpid p in + OP.Flow.Output(p, len ) + | _ -> act) f.OP.Flow.action in + (* Translate actions *) + f let process_switch_channel flv st dpid e = try_lwt @@ -661,6 +681,7 @@ let process_switch_channel flv st dpid e = | Flows fl -> (* Group reply separation *) let _ = xid_st.cache <- (Flows (fl @ flows)) in + let flows = List.map (translate_stat flv dpid) flows in let _ = if not more then xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst From 819dfcbb4ee500f655a4050ce29a755b071b5b50 Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 25 Apr 2013 10:52:15 +0100 Subject: [PATCH 48/75] fixing flowvisor to avoid a bad case of packet flooding --- lib/flowvisor.ml | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index b7dfc90..2fc9b86 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -219,11 +219,27 @@ let packet_out_create st msg xid in_port bid data actions = let rec pkt_out_process st xid inp bid data msg acts = function | (OP.Flow.Output(OP.Port.All, len))::tail | (OP.Flow.Output(OP.Port.Flood, len))::tail -> begin - let actions = acts @ [OP.Flow.Output(OP.Port.All, len)] in + let actions = acts @ [OP.Flow.Output(OP.Port.Flood, len)] in (* OP.Port.None is not the appropriate way to handle this. Need to find the * port that connects the two switches probably. *) - let msg = packet_out_create st msg xid inp bid data actions in - lwt _ = send_all_switches st msg in + let in_dpid = + try + let (in_dpid, _, _) = Hashtbl.find st.port_map (OP.Port.int_of_port + inp) in in_dpid + with Not_found -> 0L + in +(* let _ = pp "sending packet from port %d to port %d\n%!" + * (OP.Port.int_of_port inp) (in_p) in *) + let msg = packet_out_create st msg xid OP.Port.No_port (-1l) data actions in + lwt _ = + Lwt_list.iter_p ( + fun (dpid, ch) -> + if (dpid = in_dpid) then + Ofcontroller.send_data ch dpid + (packet_out_create st msg xid inp (-1l) data actions) + else + Ofcontroller.send_data ch dpid msg + ) (Hashtbl.fold (fun dpid ch c -> c @[(dpid, ch)]) st.switches []) in pkt_out_process st xid inp bid data msg acts tail end | (OP.Flow.Output(OP.Port.In_port, len))::tail -> begin @@ -549,7 +565,7 @@ let switch_channel st dpid of_m sock = let add_flowvisor_port flv dpid port = let port_id = flv.portnum in let _ = flv.portnum <- flv.portnum + 1 in - let phy = OP.Port.translate_port_phy port port_id in + let phy = OP.Port.translate_port_phy port port_id in let _ = Hashtbl.add flv.port_map port_id (dpid, port.OP.Port.port_no, phy) in lwt _ = Flowvisor_topology.add_port flv.flv_topo dpid port.OP.Port.port_no From 688e3da3730473998e9b8e2081fd2d52b08b3764 Mon Sep 17 00:00:00 2001 From: Charalampos Rotsos Date: Mon, 16 Sep 2013 14:50:53 +0100 Subject: [PATCH 49/75] synching with the latest version of the mirage-net code --- _oasis | 2 +- _tags | 6 +- lib/META | 4 +- lib/flowvisor.ml | 4 +- lib/flowvisor.mli | 1 + lib/flowvisor_topology.ml | 12 +- lib/flowvisor_topology.mli | 2 +- lib/lldp.ml | 38 +-- lib/lldp.mli | 10 +- lib/ofcontroller.ml | 2 +- lib/ofpacket.ml | 332 +++++++------------------- lib/ofpacket.mli | 49 ++-- lib/ofsocket.ml | 2 +- lib/ofswitch.ml | 88 +++---- lib/ofswitch.mli | 16 +- lib/ofswitch_config.ml | 460 ++++++++++++++++++------------------- lib/ofswitch_standalone.ml | 7 +- myocamlbuild.ml | 82 +++---- setup.ml | 456 ++++++++---------------------------- 19 files changed, 566 insertions(+), 1007 deletions(-) diff --git a/_oasis b/_oasis index bbadc11..8467ec5 100644 --- a/_oasis +++ b/_oasis @@ -31,7 +31,7 @@ Library openflow CompiledObject: native Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch, Ofsocket, Ofswitch_standalone, Flowvisor, Flowvisor_topology, Lldp Pack: True - BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0), re.str, ocamlgraph + BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0), re.str, ocamlgraph,ipaddr Document openflow Title: OpenFlow docs diff --git a/_tags b/_tags index 15b4052..3350757 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: f0415f9a3dd34b20d88d6dd1bb10f621) +# DO NOT EDIT (digest: 2372650f9c40e894f1ba8a24df10b624) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -34,6 +34,7 @@ "lib/ofswitch_ctrl.native": pkg_mirage "lib/ofswitch_ctrl.native": pkg_mirage-net "lib/ofswitch_ctrl.native": pkg_ocamlgraph +"lib/ofswitch_ctrl.native": pkg_ipaddr : use_openflow : pkg_cstruct : pkg_cstruct.syntax @@ -43,6 +44,7 @@ : pkg_mirage : pkg_mirage-net : pkg_ocamlgraph +: pkg_ipaddr "lib/ofswitch_ctrl.native": custom # Executable learning_switch_lwt "controller/learning_switch.native": use_openflow @@ -54,6 +56,7 @@ "controller/learning_switch.native": pkg_mirage "controller/learning_switch.native": pkg_mirage-net "controller/learning_switch.native": pkg_ocamlgraph +"controller/learning_switch.native": pkg_ipaddr : use_openflow : pkg_cstruct : pkg_cstruct.syntax @@ -63,6 +66,7 @@ : pkg_mirage : pkg_mirage-net : pkg_ocamlgraph +: pkg_ipaddr "controller/learning_switch.native": custom # OASIS_STOP true: annot diff --git a/lib/META b/lib/META index 3500586..66fde9f 100644 --- a/lib/META +++ b/lib/META @@ -1,9 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: af22db32fa2321ef21a267936ae9c0ff) +# DO NOT EDIT (digest: 2f0201055e20e2bbeb0610a6d9578c8b) version = "0.3.0" description = "OpenFlow protocol and switch implementations in pure OCaml" requires = -"cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net re.str ocamlgraph" +"cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net re.str ocamlgraph ipaddr" archive(byte) = "openflow.cma" archive(byte, plugin) = "openflow.cma" archive(native) = "openflow.cmxa" diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index 2fc9b86..f6bf72e 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -569,7 +569,7 @@ let add_flowvisor_port flv dpid port = let _ = Hashtbl.add flv.port_map port_id (dpid, port.OP.Port.port_no, phy) in lwt _ = Flowvisor_topology.add_port flv.flv_topo dpid port.OP.Port.port_no - (Net.Nettypes.ethernet_mac_of_bytes port.OP.Port.hw_addr) in + port.OP.Port.hw_addr in let h = OP.Header.(create PORT_STATUS 0 ) in let status = OP.Port_status(h, (OP.Port.({reason=OP.Port.ADD; desc=phy;}))) in Lwt_list.iter_p @@ -792,7 +792,7 @@ let add_slice mgr flv of_m dst dpid = while_lwt true do try_lwt let switch_connect (addr, port) t = - let rs = Nettypes.ipv4_addr_to_string addr in + let rs = Ipaddr.V4.to_string addr in let _ = pp "[flowvisor-switch]+ controller %s:%d\n%!" rs port in (* Trigger the dance between the 2 nodes *) let sock = Ofsocket.init_socket_conn_state t in diff --git a/lib/flowvisor.mli b/lib/flowvisor.mli index 7474653..7dd1b4f 100644 --- a/lib/flowvisor.mli +++ b/lib/flowvisor.mli @@ -20,6 +20,7 @@ open Net.Nettypes type t + val listen: t -> Manager.t -> ipv4_src -> unit Lwt.t val local_listen: t -> Ofsocket.conn_state -> unit Lwt.t val create_flowvisor: ?verbose:bool -> unit -> t diff --git a/lib/flowvisor_topology.ml b/lib/flowvisor_topology.ml index 285bcb5..c8b70f3 100644 --- a/lib/flowvisor_topology.ml +++ b/lib/flowvisor_topology.ml @@ -72,7 +72,7 @@ end module Dijkstra = Path.Dijkstra(Graph)(W) type t = { - ports : (int64 * int, ethernet_mac * bool) Hashtbl.t; + ports : (int64 * int, Macaddr.t * bool) Hashtbl.t; channels : (int64, Ofcontroller.t) Hashtbl.t; topo : Graph.t; } @@ -86,10 +86,10 @@ let add_channel t dpid ch = Hashtbl.replace t.channels dpid ch let generate_lldp_discovery dpid src_mac port = - let bits = OS.Io_page.to_cstruct (OS.Io_page.get ()) in + let bits = OS.Io_page.to_cstruct (OS.Io_page.get 1) in let _ = Cstruct.BE.set_uint64 bits 0 dpid in let dpid = Cstruct.to_string (Cstruct.sub bits 0 8) in - let bits = OS.Io_page.to_cstruct (OS.Io_page.get ()) in + let bits = OS.Io_page.to_cstruct (OS.Io_page.get 1) in let _ = Cstruct.BE.set_uint16 bits 0 port in let port = Cstruct.(to_string (sub bits 0 2)) in marshal_and_sub (marsal_lldp_tlvs src_mac @@ -98,7 +98,7 @@ let generate_lldp_discovery dpid src_mac port = Tlv_ttl(120); Tlv(LLDP_TYPE_SYSTEM_DESCR, dpid); Tlv_end;]) - (OS.Io_page.to_cstruct (OS.Io_page.get ())) + (OS.Io_page.to_cstruct (OS.Io_page.get 1)) let send_port_lldp t dpid port mac = let data = generate_lldp_discovery dpid mac port in @@ -114,7 +114,7 @@ let add_port t dpid port mac = send_port_lldp t dpid port mac let mark_port_down t dpid port down = - let fmac = Net.Nettypes.ethernet_mac_of_bytes "\xff\xff\xff\xff\xff\xff" in + let fmac = Macaddr.of_bytes_exn "\xff\xff\xff\xff\xff\xff" in try let (mac, _) = Hashtbl.find t.ports (dpid, port) in Hashtbl.replace t.ports (dpid, port) (mac, down) @@ -163,7 +163,7 @@ let process_lldp_packet t src_dpid src_port pkt = ) bits in (!dpid, port, mac) | _ -> (dpid, port, mac) - ) tlvs (0L, 0, Net.Nettypes.ethernet_mac_broadcast) in + ) tlvs (0L, 0, Macaddr.broadcast ) in match (Hashtbl.mem t.channels dst_dpid) with | false -> false | true -> diff --git a/lib/flowvisor_topology.mli b/lib/flowvisor_topology.mli index ba17728..43baed6 100644 --- a/lib/flowvisor_topology.mli +++ b/lib/flowvisor_topology.mli @@ -19,7 +19,7 @@ open Net.Nettypes type t val init_topology: unit -> t -val add_port: t -> int64 -> int -> ethernet_mac -> unit Lwt.t +val add_port: t -> int64 -> int -> Macaddr.t -> unit Lwt.t val add_channel: t -> int64 -> Ofcontroller.t -> unit val discover: t-> unit Lwt.t val process_lldp_packet: t -> int64 -> int -> Cstruct.t -> bool diff --git a/lib/lldp.ml b/lib/lldp.ml index 736a596..2ef8fa3 100644 --- a/lib/lldp.ml +++ b/lib/lldp.ml @@ -186,14 +186,14 @@ type lldp_tvl = | Tlv_chassis_id_chassis_comp of string | Tlv_chassis_id_intf_alias of string | Tlv_chassis_id_port_comp of string - | Tlv_chassis_id_mac of ethernet_mac - | Tlv_chassis_id_net of ipv4_addr + | Tlv_chassis_id_mac of Macaddr.t + | Tlv_chassis_id_net of Ipaddr.V4.t | Tlv_chassis_id_intf_name of string | Tlv_chassis_id_local of string | Tlv_port_id_intf_alias of string | Tlv_port_id_port_comp of string - | Tlv_port_id_mac of ethernet_mac - | Tlv_port_id_net of ipv4_addr + | Tlv_port_id_mac of Macaddr.t + | Tlv_port_id_net of Ipaddr.V4.t | Tlv_port_id_intf_name of string | Tlv_port_id_circ_id of string | Tlv_port_id_local of string @@ -219,10 +219,13 @@ let parse_lldp_tlv bits = Tlv_chassis_id_intf_alias(data) | Some(LLDP_CHASSIS_PORT_COMP_SUBTYPE) -> Tlv_chassis_id_port_comp(data) - | Some(LLDP_CHASSIS_MAC_ADDR_SUBTYPE) -> - Tlv_chassis_id_mac(Net.Nettypes.ethernet_mac_of_bytes data) + | Some(LLDP_CHASSIS_MAC_ADDR_SUBTYPE) -> begin + match (Macaddr.of_bytes data) with + | None -> raise (Unparsable bits) + | Some addr -> (Tlv_chassis_id_mac addr) + end | Some(LLDP_CHASSIS_NETWORK_ADDR_SUBTYPE)-> - let ip = ipv4_addr_of_uint32 + let ip = Ipaddr.V4.of_int32 (Cstruct.BE.get_uint32 bits 3) in Tlv_chassis_id_net(ip) | Some(LLDP_CHASSIS_INTF_NAME_SUBTYPE) -> @@ -240,10 +243,13 @@ let parse_lldp_tlv bits = Tlv_port_id_intf_alias(data) | Some(LLDP_PORT_PORT_COMP_SUBTYPE) -> Tlv_port_id_port_comp(data) - | Some(LLDP_PORT_MAC_ADDR_SUBTYPE) -> - Tlv_port_id_mac(Net.Nettypes.ethernet_mac_of_bytes data) + | Some(LLDP_PORT_MAC_ADDR_SUBTYPE) -> begin + match (Macaddr.of_bytes data) with + | None -> raise (Unparsable(bits)) + | Some addr -> Tlv_port_id_mac(addr) + end | Some(LLDP_PORT_NETWORK_ADDR_SUBTYPE) -> - let ip = ipv4_addr_of_uint32 + let ip = Ipaddr.V4.of_int32 (Cstruct.BE.get_uint32 bits 3) in Tlv_port_id_net(ip) | Some(LLDP_PORT_INTF_NAME_SUBTYPE) -> @@ -306,12 +312,11 @@ let marsal_lldp_tlv tlv bits = | Tlv_chassis_id_intf_alias(data) -> set_lldp_tlv_typ_subtyp_data bits 1 2 data | Tlv_chassis_id_port_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 1 3 data | Tlv_chassis_id_mac(mac) -> set_lldp_tlv_typ_subtyp_data bits 1 4 - (Net.Nettypes.ethernet_mac_to_bytes mac) + (Macaddr.to_bytes mac) | Tlv_chassis_id_net(ip) -> let _ = Cstruct.BE.set_uint16 bits 0 0x205 in let _ = Cstruct.set_uint8 bits 2 5 in - let _ = Cstruct.BE.set_uint32 bits 3 (Net.Nettypes.ipv4_addr_to_uint32 - ip) in + let _ = Cstruct.BE.set_uint32 bits 3 (Ipaddr.V4.to_int32 ip) in 7 | Tlv_chassis_id_intf_name(data) -> set_lldp_tlv_typ_subtyp_data bits 1 6 data | Tlv_chassis_id_local(data) -> set_lldp_tlv_typ_subtyp_data bits 1 8 data @@ -319,12 +324,11 @@ let marsal_lldp_tlv tlv bits = | Tlv_port_id_intf_alias(data) -> set_lldp_tlv_typ_subtyp_data bits 2 1 data | Tlv_port_id_port_comp(data) -> set_lldp_tlv_typ_subtyp_data bits 2 2 data | Tlv_port_id_mac(mac) -> set_lldp_tlv_typ_subtyp_data bits 2 3 - (Net.Nettypes.ethernet_mac_to_bytes mac) + (Macaddr.to_bytes mac) | Tlv_port_id_net(ip) -> let _ = Cstruct.BE.set_uint16 bits 0 0x405 in let _ = Cstruct.set_uint8 bits 2 4 in - let _ = Cstruct.BE.set_uint32 bits 3 (Net.Nettypes.ipv4_addr_to_uint32 - ip) in + let _ = Cstruct.BE.set_uint32 bits 3 (Ipaddr.V4.to_int32 ip) in 7 | Tlv_port_id_intf_name(data) -> set_lldp_tlv_typ_subtyp_data bits 2 5 data | Tlv_port_id_circ_id(data) -> set_lldp_tlv_typ_subtyp_data bits 2 6 data @@ -342,7 +346,7 @@ let marsal_lldp_tlv tlv bits = let marsal_lldp_tlvs mac tlvs bits = let _ = Net.Ethif.set_ethernet_dst "\x01\x80\xc2\x00\x00\x0e" 0 bits in - let _ = Net.Ethif.set_ethernet_src (Net.Nettypes.ethernet_mac_to_bytes mac) + let _ = Net.Ethif.set_ethernet_src (Macaddr.to_bytes mac) 0 bits in let _ = Net.Ethif.set_ethernet_ethertype bits 0x88cc in let bits = Cstruct.shift bits Ethif.sizeof_ethernet in diff --git a/lib/lldp.mli b/lib/lldp.mli index 352755e..62e6f62 100644 --- a/lib/lldp.mli +++ b/lib/lldp.mli @@ -35,14 +35,14 @@ type lldp_tvl = | Tlv_chassis_id_chassis_comp of string | Tlv_chassis_id_intf_alias of string | Tlv_chassis_id_port_comp of string - | Tlv_chassis_id_mac of ethernet_mac - | Tlv_chassis_id_net of ipv4_addr + | Tlv_chassis_id_mac of Macaddr.t + | Tlv_chassis_id_net of Ipaddr.V4.t | Tlv_chassis_id_intf_name of string | Tlv_chassis_id_local of string | Tlv_port_id_intf_alias of string | Tlv_port_id_port_comp of string - | Tlv_port_id_mac of ethernet_mac - | Tlv_port_id_net of ipv4_addr + | Tlv_port_id_mac of Macaddr.t + | Tlv_port_id_net of Ipaddr.V4.t | Tlv_port_id_intf_name of string | Tlv_port_id_circ_id of string | Tlv_port_id_local of string @@ -52,4 +52,4 @@ type lldp_tvl = | Tlv_unk of int * string val parse_lldp_tlvs: t -> lldp_tvl list -val marsal_lldp_tlvs: ethernet_mac -> lldp_tvl list -> t -> int +val marsal_lldp_tlvs: Macaddr.t -> lldp_tvl list -> t -> int diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 9410c72..2291178 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -299,7 +299,7 @@ let controller_run st conn = return () let socket_controller st (remote_addr, remote_port) t = - let rs = Nettypes.ipv4_addr_to_string remote_addr in + let rs = Ipaddr.V4.to_string remote_addr in let _ = pp "[controller]+ Controller %s:%d\n%!" rs remote_port in let conn = init_socket_conn_state t in controller_run st conn diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index bab27b2..dba3cd5 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -54,14 +54,10 @@ type uint64 = int64 let uint8_of_int i = Char.chr i -(* XXX network specific types that should have a proper home *) - -type ipv4 = uint32 -let ipv4_to_string i = - sp "%ld.%ld.%ld.%ld" - ((i &&& 0x0_ff000000_l) >>> 24) ((i &&& 0x0_00ff0000_l) >>> 16) - ((i &&& 0x0_0000ff00_l) >>> 8) ((i &&& 0x0_000000ff_l) ) +let zero_mac = Macaddr.of_bytes_exn "\x00\x00\x00\x00\x00\x00" +let zero_ip = Ipaddr.V4.of_int32 0l +(* XXX network specific types that should have a proper home *) type byte = uint8 let byte (i:int) : byte = Char.chr i let int_of_byte b = int_of_char b @@ -69,27 +65,9 @@ let int32_of_byte b = b |> int_of_char |> Int32.of_int let int32_of_int (i:int) = Int32.of_int i type bytes = string -type eaddr = bytes let bytes_to_hex_string bs = bs |> Array.map (fun b -> sp "%02x." (int_of_byte b)) -let eaddr_to_string s = - let l = String.length s in - let hp s i = sp "%02x" (int_of_char s.[i]) in - String.concat ":" (Array.init l (fun i -> hp s i) |> Array.to_list) - -external ipv4_addr_of_uint32: int32 -> Net.Nettypes.ipv4_addr = "%identity" -external ipv4_addr_to_uint32: Net.Nettypes.ipv4_addr -> int32 = "%identity" - -let eaddr_is_broadcast s = - match s with - | "\xFF\xFF\xFF\xFF\xFF\xFF" -> true - | _ -> false - -let ipv4_addr_of_bytes bs = - ((bs.[0] |> int32_of_byte <<< 24) ||| (bs.[1] |> int32_of_byte <<< 16) - ||| (bs.[2] |> int32_of_byte <<< 8) ||| (bs.[3] |> int32_of_byte)) - (*********************************************************************** *) (* for readability *) @@ -148,7 +126,7 @@ module Header = struct uint32_t xid } as big_endian - (*cenum msg_code { + cenum msg_code { HELLO = 0; ERROR = 1; ECHO_REQ = 2; @@ -171,108 +149,9 @@ module Header = struct BARRIER_RESP = 19; QUEUE_GET_CONFIG_REQ = 20; QUEUE_GET_CONFIG_RESP = 21 - } as uint8_t *) - type msg_code = - HELLO - | ERROR - | ECHO_REQ - | ECHO_RESP - | VENDOR - | FEATURES_REQ - | FEATURES_RESP - | GET_CONFIG_REQ - | GET_CONFIG_RESP - | SET_CONFIG - | PACKET_IN - | FLOW_REMOVED - | PORT_STATUS - | PACKET_OUT - | FLOW_MOD - | PORT_MOD - | STATS_REQ - | STATS_RESP - | BARRIER_REQ - | BARRIER_RESP - | QUEUE_GET_CONFIG_REQ - | QUEUE_GET_CONFIG_RESP - - let msg_code_of_int = - function - | 0 -> Some HELLO - | 1 -> Some ERROR - | 2 -> Some ECHO_REQ - | 3 -> Some ECHO_RESP - | 4 -> Some VENDOR - | 5 -> Some FEATURES_REQ - | 6 -> Some FEATURES_RESP - | 7 -> Some GET_CONFIG_REQ - | 8 -> Some GET_CONFIG_RESP - | 9 -> Some SET_CONFIG - | 10 -> Some PACKET_IN - | 11 -> Some FLOW_REMOVED - | 12 -> Some PORT_STATUS - | 13 -> Some PACKET_OUT - | 14 -> Some FLOW_MOD - | 15 -> Some PORT_MOD - | 16 -> Some STATS_REQ - | 17 -> Some STATS_RESP - | 18 -> Some BARRIER_REQ - | 19 -> Some BARRIER_RESP - | 20 -> Some QUEUE_GET_CONFIG_REQ - | 21 -> Some QUEUE_GET_CONFIG_RESP - | _ -> None - - let msg_code_to_int = - function - | HELLO -> 0 - | ERROR -> 1 - | ECHO_REQ -> 2 - | ECHO_RESP -> 3 - | VENDOR -> 4 - | FEATURES_REQ -> 5 - | FEATURES_RESP -> 6 - | GET_CONFIG_REQ -> 7 - | GET_CONFIG_RESP -> 8 - | SET_CONFIG -> 9 - | PACKET_IN -> 10 - | FLOW_REMOVED -> 11 - | PORT_STATUS -> 12 - | PACKET_OUT -> 13 - | FLOW_MOD -> 14 - | PORT_MOD -> 15 - | STATS_REQ -> 16 - | STATS_RESP -> 17 - | BARRIER_REQ -> 18 - | BARRIER_RESP -> 19 - | QUEUE_GET_CONFIG_REQ -> 20 - | QUEUE_GET_CONFIG_RESP -> 21 - - let msg_code_to_string = - function - | HELLO -> "HELLO" - | ERROR -> "ERROR" - | ECHO_REQ -> "ECHO_REQ" - | ECHO_RESP -> "ECHO_RESP" - | VENDOR -> "VENDOR" - | FEATURES_REQ -> "FEATURES_REQ" - | FEATURES_RESP -> "FEATURES_RESP" - | GET_CONFIG_REQ -> "GET_CONFIG_REQ" - | GET_CONFIG_RESP -> "GET_CONFIG_RESP" - | SET_CONFIG -> "SET_CONFIG" - | PACKET_IN -> "PACKET_IN" - | FLOW_REMOVED -> "FLOW_REMOVED" - | PORT_STATUS -> "PORT_STATUS" - | PACKET_OUT -> "PACKET_OUT" - | FLOW_MOD -> "FLOW_MOD" - | PORT_MOD -> "PORT_MOD" - | STATS_REQ -> "STATS_REQ" - | STATS_RESP -> "STATS_RESP" - | BARRIER_REQ -> "BARRIER_REQ" - | BARRIER_RESP -> "BARRIER_RESP" - | QUEUE_GET_CONFIG_REQ -> "QUEUE_GET_CONFIG_REQ" - | QUEUE_GET_CONFIG_RESP -> "QUEUE_GET_CONFIG_RESP" - - type h = { + } as uint8_t + +type h = { ver: uint8; ty: msg_code; len: uint16; @@ -283,7 +162,7 @@ module Header = struct let parse_header bits = match ((get_ofp_header_version bits), - (msg_code_of_int (get_ofp_header_typ bits))) with + (int_to_msg_code (get_ofp_header_typ bits))) with | (1, Some(ty)) -> let ret = { ver=(char_of_int (get_ofp_header_version bits)); @@ -480,7 +359,7 @@ module Port = struct type phy = { port_no: uint16; - hw_addr: eaddr; + hw_addr: Macaddr.t; name: string; config: config; state: state; @@ -506,7 +385,7 @@ module Port = struct let phy_len = 48 let parse_phy bits = let port_no = (get_ofp_phy_port_port_no bits) in - let hw_addr=(Cstruct.to_string (get_ofp_phy_port_hw_addr bits)) in + let hw_addr=Macaddr.of_bytes_exn (Cstruct.to_string (get_ofp_phy_port_hw_addr bits)) in let name=(Cstruct.to_string (get_ofp_phy_port_name bits)) in let config = (parse_config (get_ofp_phy_port_config bits)) in let state = (parse_state (get_ofp_phy_port_state bits)) in @@ -529,7 +408,7 @@ module Port = struct in aux [] bits - let init_port_phy ?(port_no = 0) ?(hw_addr="\x11\x11\x11\x11\x11\x11") + let init_port_phy ?(port_no = 0) ?(hw_addr=Macaddr.broadcast) ?(name="") () = {port_no; hw_addr; name; config=init_port_config; state=init_port_state; curr=init_port_features; @@ -546,7 +425,7 @@ module Port = struct let marshal_phy phy bits = let _ = set_ofp_phy_port_port_no bits phy.port_no in - let _ = set_ofp_phy_port_hw_addr phy.hw_addr 0 bits in + let _ = set_ofp_phy_port_hw_addr (Macaddr.to_bytes phy.hw_addr) 0 bits in let name = String.make 16 (char_of_int 0) in let _ = String.blit phy.name 0 name 0 (String.length phy.name) in let _ = set_ofp_phy_port_name name 0 bits in @@ -560,7 +439,7 @@ module Port = struct let string_of_phy ph = (sp "port_no:%d,hw_addr:%s,name:%s" - ph.port_no (eaddr_to_string ph.hw_addr) ph.name) + ph.port_no (Macaddr.to_string ph.hw_addr) ph.name) type stats = { mutable port_id: uint16; @@ -629,37 +508,11 @@ module Port = struct h.rx_frame_err h.rx_over_err h.rx_crc_err h.collisions (string_of_port_stats_reply q)) -(* cenum reason { + cenum reason { ADD = 0; DEL = 1; MOD = 2 - } as uint8_t*) - - type reason = ADD | DEL | MOD - - let reason_of_int = - function | 0 -> Some ADD | 1 -> Some DEL | 2 -> Some MOD | _ -> None - - let reason_to_int = function | ADD -> 0 | DEL -> 1 | MOD -> 2 - - let reason_to_string = - function | ADD -> "ADD" | DEL -> "DEL" | MOD -> "MOD" - - -(* type reason = ADD | DEL | MOD - let reason_of_int = function - | 0 -> ADD - | 1 -> DEL - | 2 -> MOD - | _ -> invalid_arg "reason_of_int" - and int_of_reason = function - | ADD -> 0 - | DEL -> 1 - | MOD -> 2 - and string_of_reason = function - | ADD -> sp "ADD" - | DEL -> sp "DEL" - | MOD -> sp "MOD"*) + } as uint8_t type status = { reason: reason; @@ -681,7 +534,7 @@ module Port = struct let parse_status bits = let reason = - match (reason_of_int (get_ofp_port_status_reason bits)) with + match (int_to_reason (get_ofp_port_status_reason bits)) with | Some(reason) -> reason | None -> raise(Unparsable("reason_of_int", bits)) in @@ -958,13 +811,13 @@ module Match = struct type t = { mutable wildcards: Wildcards.t; mutable in_port: Port.t; - mutable dl_src: eaddr; - mutable dl_dst: eaddr; + mutable dl_src: Macaddr.t; + mutable dl_dst: Macaddr.t; mutable dl_vlan: uint16; mutable dl_vlan_pcp: byte; mutable dl_type: uint16; - mutable nw_src: uint32; - mutable nw_dst: uint32; + mutable nw_src: Ipaddr.V4.t; + mutable nw_dst: Ipaddr.V4.t; mutable nw_tos: byte; mutable nw_proto: byte; mutable tp_src: uint16; @@ -973,16 +826,16 @@ module Match = struct let wildcard () = {wildcards=(Wildcards.full_wildcard ()); in_port=Port.No_port; - dl_src="\000\000\000\000\000\000"; - dl_dst="\000\000\000\000\000\000"; - dl_vlan=0; dl_vlan_pcp='\000'; dl_type=0; nw_src=0l; nw_dst=0l; + dl_src=zero_mac; dl_dst=zero_mac; + dl_vlan=0; dl_vlan_pcp='\000'; dl_type=0; + nw_src=zero_ip; nw_dst=zero_ip; nw_tos='\000';nw_proto='\000';tp_src=0; tp_dst=0;} let arp () = {wildcards=(Wildcards.full_wildcard ()); in_port=Port.No_port; - dl_src="\000\000\000\000\000\000"; - dl_dst="\000\000\000\000\000\000"; - dl_vlan=0; dl_vlan_pcp='\000'; dl_type=0; nw_src=0l; nw_dst=0l; - nw_tos='\000';nw_proto='\000';tp_src=0; tp_dst=0;} + dl_src=zero_mac; dl_dst=zero_mac; + dl_vlan=0; dl_vlan_pcp='\000'; dl_type=0; nw_src=zero_ip; + nw_dst=zero_ip; nw_tos='\000';nw_proto='\000';tp_src=0; + tp_dst=0;} cstruct ofp_match { @@ -1008,15 +861,15 @@ module Match = struct let _ = set_ofp_match_wildcards bits (Wildcards.marshal_wildcard m.wildcards) in let _ = set_ofp_match_in_port bits (Port.int_of_port m.in_port) in - let _ = set_ofp_match_dl_src m.dl_src 0 bits in - let _ = set_ofp_match_dl_dst m.dl_dst 0 bits in + let _ = set_ofp_match_dl_src (Macaddr.to_bytes m.dl_src) 0 bits in + let _ = set_ofp_match_dl_dst (Macaddr.to_bytes m.dl_dst) 0 bits in let _ = set_ofp_match_dl_vlan bits m.dl_vlan in let _ = set_ofp_match_dl_vlan_pcp bits (int_of_char m.dl_vlan_pcp) in let _ = set_ofp_match_dl_type bits m.dl_type in let _ = set_ofp_match_nw_tos bits (int_of_char m.nw_tos) in let _ = set_ofp_match_nw_proto bits (int_of_char m.nw_proto) in - let _ = set_ofp_match_nw_src bits m.nw_src in - let _ = set_ofp_match_nw_dst bits m.nw_dst in + let _ = set_ofp_match_nw_src bits (Ipaddr.V4.to_int32 m.nw_src) in + let _ = set_ofp_match_nw_dst bits (Ipaddr.V4.to_int32 m.nw_dst) in let _ = set_ofp_match_tp_src bits m.tp_src in let _ = set_ofp_match_tp_dst bits m.tp_dst in sizeof_ofp_match @@ -1024,15 +877,15 @@ module Match = struct let parse_match bits = let wildcards = Wildcards.parse_wildcards (get_ofp_match_wildcards bits) in let in_port = Port.port_of_int (get_ofp_match_in_port bits) in - let dl_src = Cstruct.to_string (get_ofp_match_dl_src bits) in - let dl_dst = Cstruct.to_string (get_ofp_match_dl_dst bits) in + let dl_src = Macaddr.of_bytes_exn (Cstruct.to_string (get_ofp_match_dl_src bits)) in + let dl_dst = Macaddr.of_bytes_exn (Cstruct.to_string (get_ofp_match_dl_dst bits)) in let dl_vlan = get_ofp_match_dl_vlan bits in let dl_vlan_pcp = char_of_int (get_ofp_match_dl_vlan_pcp bits) in let dl_type = get_ofp_match_dl_type bits in let nw_tos = char_of_int (get_ofp_match_nw_tos bits) in let nw_proto = char_of_int (get_ofp_match_nw_proto bits) in - let nw_src = get_ofp_match_nw_src bits in - let nw_dst = get_ofp_match_nw_dst bits in + let nw_src = Ipaddr.V4.of_int32 (get_ofp_match_nw_src bits) in + let nw_dst = Ipaddr.V4.of_int32 (get_ofp_match_nw_dst bits) in let tp_src = get_ofp_match_tp_src bits in let tp_dst = get_ofp_match_tp_dst bits in let _ = Cstruct.shift bits sizeof_ofp_match in @@ -1040,13 +893,11 @@ module Match = struct dl_type; nw_tos; nw_proto; nw_src; nw_dst; tp_src; tp_dst;} (* Check if the flow object is include in flow_def match *) - let null_eaddr = "\x00\x00\x00\x00\x00\x00" let create_flow_match wildcards - ?(in_port = 0) ?(dl_src=null_eaddr) ?(dl_dst=null_eaddr) + ?(in_port = 0) ?(dl_src=zero_mac) ?(dl_dst=zero_mac) ?(dl_vlan=0xffff) ?(dl_vlan_pcp=(char_of_int 0)) ?(dl_type=0) - ?(nw_tos=(char_of_int 0)) - ?(nw_proto=(char_of_int 0)) - ?(nw_src=(Int32.of_int 0)) ?(nw_dst=(Int32.of_int 0)) + ?(nw_tos=(char_of_int 0)) ?(nw_proto=(char_of_int 0)) + ?(nw_src=zero_ip) ?(nw_dst=zero_ip) ?(tp_src=0) ?(tp_dst=0) () = { wildcards; in_port=(Port.port_of_int in_port); @@ -1068,8 +919,6 @@ module Match = struct | None -> d | Some v -> v in - let zero_mac = (* Net.Nettypes.ethernet_mac_of_bytes *) - "\x00\x00\x00\x00\x00\x00" in let flow_wild = Wildcards.({ in_port=(is_none in_port); dl_vlan=(is_none dl_vlan); dl_src=(is_none dl_src); dl_dst=(is_none dl_dst); @@ -1086,8 +935,8 @@ module Match = struct ~dl_type:(option_default dl_type 0) ~nw_tos:(option_default nw_tos (char_of_int 0)) ~nw_proto:(option_default nw_proto (char_of_int 0)) - ~nw_src:(option_default nw_src 0l) - ~nw_dst:(option_default nw_dst 0l) + ~nw_src:(option_default nw_src zero_ip ) + ~nw_dst:(option_default nw_dst zero_ip ) ~tp_src:(option_default tp_src 0) ~tp_dst:(option_default tp_dst 0) () @@ -1138,14 +987,15 @@ module Match = struct } as big_endian let raw_packet_to_match in_port bits = - let dl_dst = Cstruct.to_string (get_dl_header_dl_dst bits) in - let dl_src = Cstruct.to_string (get_dl_header_dl_src bits) in + let dl_dst = Macaddr.of_bytes_exn (Cstruct.to_string (get_dl_header_dl_dst bits)) in + let dl_src = Macaddr.of_bytes_exn (Cstruct.to_string (get_dl_header_dl_src + bits)) in let dl_type = get_dl_header_dl_type bits in let bits = Cstruct.shift bits sizeof_dl_header in match (dl_type) with | 0x0800 -> begin - let nw_src = get_nw_header_nw_src bits in - let nw_dst = get_nw_header_nw_dst bits in + let nw_src = Ipaddr.V4.of_int32 (get_nw_header_nw_src bits) in + let nw_dst = Ipaddr.V4.of_int32 (get_nw_header_nw_dst bits) in let nw_proto = get_nw_header_nw_proto bits in let nw_tos = char_of_int (get_nw_header_nw_tos bits) in let len = (get_nw_header_hlen_version bits) land 0xf in @@ -1174,18 +1024,19 @@ module Match = struct nw_proto=(char_of_int nw_proto); tp_src=0; tp_dst=0; } end | 0x0806 -> - {wildcards=(Wildcards.arp_match ()); + let nw_src = Ipaddr.V4.of_int32 (get_nw_header_nw_src bits) in + let nw_dst = Ipaddr.V4.of_int32 (get_nw_header_nw_dst bits) in + {wildcards=(Wildcards.arp_match ()); in_port; dl_src; dl_dst; dl_type; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0); - nw_src=(get_arphdr_nw_src bits); - nw_dst=(get_arphdr_nw_dst bits); + nw_src; nw_dst; nw_proto=( char_of_int (get_arphdr_ar_op bits)); nw_tos=(char_of_int 0); tp_src=0; tp_dst=0} | _ -> {wildcards=(Wildcards.l2_match ()); in_port; dl_src; dl_dst; dl_type; dl_vlan=0xffff; dl_vlan_pcp=(char_of_int 0); - nw_src=0l; nw_dst=0l; + nw_src=zero_ip; nw_dst=zero_ip; nw_tos=(char_of_int 0); nw_proto=(char_of_int 0); tp_src=0; tp_dst=0} @@ -1199,18 +1050,16 @@ module Match = struct sprintf "%s%s%s%s%s%s%s%s%s%s%s%s" (print_field m.wildcards.Wildcards.in_port "in_port" (Port.string_of_port m.in_port)) - (print_field m.wildcards.Wildcards.dl_src "dl_src" (eaddr_to_string m.dl_src)) - (print_field m.wildcards.Wildcards.dl_dst "dl_dst" (eaddr_to_string m.dl_dst)) + (print_field m.wildcards.Wildcards.dl_src "dl_src" (Macaddr.to_string m.dl_src)) + (print_field m.wildcards.Wildcards.dl_dst "dl_dst" (Macaddr.to_string m.dl_dst)) (print_field m.wildcards.Wildcards.dl_vlan "dl_vlan" (string_of_int m.dl_vlan)) (print_field m.wildcards.Wildcards.dl_vlan_pcp "dl_pcp" (string_of_int (int_of_char m.dl_vlan_pcp) )) (print_field m.wildcards.Wildcards.dl_type "dl_type" (string_of_int m.dl_type)) (print_field (m.wildcards.Wildcards.nw_src >= '\x20') "nw_src" - (sprintf "%s/%d" (Net.Nettypes.ipv4_addr_to_string (ipv4_addr_of_uint32 m.nw_src)) - (int_of_char m.wildcards.Wildcards.nw_src) )) + (sprintf "%s/%d" (Ipaddr.V4.to_string m.nw_src) (int_of_char m.wildcards.Wildcards.nw_src) )) (print_field (m.wildcards.Wildcards.nw_dst >= '\x20') "nw_dst" - (sprintf "%s/%d" (Net.Nettypes.ipv4_addr_to_string (ipv4_addr_of_uint32 m.nw_dst) ) - (int_of_char m.wildcards.Wildcards.nw_dst) )) + (sprintf "%s/%d" (Ipaddr.V4.to_string m.nw_dst) (int_of_char m.wildcards.Wildcards.nw_dst) )) (print_field m.wildcards.Wildcards.nw_tos "nw_tos" (string_of_int (int_of_char m.nw_tos))) (print_field m.wildcards.Wildcards.nw_proto "nw_proto" (string_of_int (int_of_char m.nw_proto))) (print_field m.wildcards.Wildcards.tp_src "tp_src" (string_of_int m.tp_src)) @@ -1253,11 +1102,11 @@ module Match = struct ((wildcard.Wildcards.tp_src) || (flow.tp_src = flow_def.tp_src)) && ((wildcard.Wildcards.tp_dst) || (flow.tp_dst = flow_def.tp_dst)) && ((nw_src_mask <= 0) || - (Int32.shift_right_logical flow.nw_src nw_src_mask) = - (Int32.shift_right_logical flow_def.nw_src nw_src_mask)) && + (Int32.shift_right_logical (Ipaddr.V4.to_int32 flow.nw_src) nw_src_mask) = + (Int32.shift_right_logical (Ipaddr.V4.to_int32 flow_def.nw_src) nw_src_mask)) && ((nw_dst_mask <= 0) || - (Int32.shift_right_logical flow.nw_dst nw_dst_mask) = - (Int32.shift_right_logical flow_def.nw_dst nw_dst_mask)) && + (Int32.shift_right_logical (Ipaddr.V4.to_int32 flow.nw_dst) nw_dst_mask) = + (Int32.shift_right_logical (Ipaddr.V4.to_int32 flow_def.nw_dst) nw_dst_mask)) && ((wildcard.Wildcards.nw_tos) || (flow.nw_tos = flow_def.nw_tos)) && ((wildcard.Wildcards.dl_vlan_pcp) || flow.dl_vlan_pcp = flow_def.dl_vlan_pcp)) @@ -1270,10 +1119,10 @@ module Flow = struct | Set_vlan_vid of int | Set_vlan_pcp of int | STRIP_VLAN - | Set_dl_src of eaddr - | Set_dl_dst of eaddr - | Set_nw_src of ipv4 - | Set_nw_dst of ipv4 + | Set_dl_src of Macaddr.t + | Set_dl_dst of Macaddr.t + | Set_nw_src of Ipaddr.V4.t + | Set_nw_dst of Ipaddr.V4.t | Set_nw_tos of byte | Set_tp_src of int16 | Set_tp_dst of int16 @@ -1285,10 +1134,10 @@ module Flow = struct | 1 -> Set_vlan_vid(0xffff) | 2 -> Set_vlan_pcp(0) | 3 -> STRIP_VLAN - | 4 -> Set_dl_src("\xff\xff\xff\xff\xff\xff") - | 5 -> Set_dl_dst("\xff\xff\xff\xff\xff\xff") - | 6 -> Set_nw_src(0xFFFFFFFFl) - | 7 -> Set_nw_dst(0xFFFFFFFFl) + | 4 -> Set_dl_src(Macaddr.broadcast) + | 5 -> Set_dl_dst(Macaddr.broadcast) + | 6 -> Set_nw_src(Ipaddr.V4.broadcast) + | 7 -> Set_nw_dst(Ipaddr.V4.broadcast) | 8 -> Set_nw_tos(char_of_int 0) | 9 -> Set_tp_src (0) | 10 -> Set_tp_dst (0) @@ -1315,10 +1164,10 @@ module Flow = struct | Set_vlan_vid vlan -> sp "SET_VLAN_VID %d" vlan | Set_vlan_pcp (pcp) -> sp "SET_VLAN_PCP %d" pcp | STRIP_VLAN -> sp "STRIP_VLAN" - | Set_dl_src(eaddr) -> (sp "SET_DL_SRC %s" (eaddr_to_string eaddr)) - | Set_dl_dst(eaddr) -> (sp "SET_DL_DST %s" (eaddr_to_string eaddr)) - | Set_nw_src (ip) -> sp "SET_NW_SRC %s" (ipv4_to_string ip) - | Set_nw_dst (ip) -> sp "SET_NW_DST %s" (ipv4_to_string ip) + | Set_dl_src(eaddr) -> (sp "SET_DL_SRC %s" (Macaddr.to_string eaddr)) + | Set_dl_dst(eaddr) -> (sp "SET_DL_DST %s" (Macaddr.to_string eaddr)) + | Set_nw_src (ip) -> sp "SET_NW_SRC %s" (Ipaddr.V4.to_string ip) + | Set_nw_dst (ip) -> sp "SET_NW_DST %s" (Ipaddr.V4.to_string ip) | Set_nw_tos (tos) -> sp "SET_NW_TOS %d" (int_of_char tos) | Set_tp_src (port) -> sp "SET_TP_SRC %d" port | Set_tp_dst (port) -> sp "SET_TP_DST %d" port @@ -1426,13 +1275,13 @@ module Flow = struct | Set_dl_dst(eaddr) -> let _ = set_ofp_action_dl_addr_typ bits (int_of_action m) in let _ = set_ofp_action_dl_addr_len bits 16 in - let _ = set_ofp_action_dl_addr_dl_addr eaddr 0 bits in + let _ = set_ofp_action_dl_addr_dl_addr (Macaddr.to_bytes eaddr) 0 bits in sizeof_ofp_action_dl_addr | Set_nw_src (ip) | Set_nw_dst (ip) -> let _ = set_ofp_action_nw_addr_typ bits (int_of_action m) in let _ = set_ofp_action_nw_addr_len bits 8 in - let _ = set_ofp_action_nw_addr_nw_addr bits ip in + let _ = set_ofp_action_nw_addr_nw_addr bits (Ipaddr.V4.to_int32 ip) in sizeof_ofp_action_nw_addr | Set_nw_tos (tos) -> let _ = set_ofp_action_nw_tos_typ bits (int_of_action m) in @@ -1481,18 +1330,20 @@ module Flow = struct | STRIP_VLAN -> (sizeof_ofp_action_header, STRIP_VLAN) | Set_dl_src( _ ) -> - let eaddr = Cstruct.to_string - (get_ofp_action_dl_addr_dl_addr bits) in + let eaddr = Macaddr.of_bytes_exn ( + Cstruct.to_string ( + get_ofp_action_dl_addr_dl_addr bits)) in (sizeof_ofp_action_dl_addr, Set_dl_src(eaddr)) | Set_dl_dst( _ ) -> - let eaddr = Cstruct.to_string - (get_ofp_action_dl_addr_dl_addr bits) in + let eaddr = Macaddr.of_bytes_exn + (Cstruct.to_string + (get_ofp_action_dl_addr_dl_addr bits)) in (sizeof_ofp_action_dl_addr, Set_dl_dst(eaddr)) | Set_nw_src( _ ) -> - let ip = get_ofp_action_nw_addr_nw_addr bits in + let ip = Ipaddr.V4.of_int32 (get_ofp_action_nw_addr_nw_addr bits) in (sizeof_ofp_action_nw_addr, Set_nw_src( ip )) | Set_nw_dst( _ ) -> - let ip = get_ofp_action_nw_addr_nw_addr bits in + let ip = Ipaddr.V4.of_int32 (get_ofp_action_nw_addr_nw_addr bits) in (sizeof_ofp_action_nw_addr, Set_nw_dst( ip )) | Set_nw_tos( _ ) -> let tos = char_of_int (get_ofp_action_nw_tos_nw_tos bits) in @@ -1521,20 +1372,11 @@ module Flow = struct printf "len of action cstruct %d\n%!" (Cstruct.len bits); raise (Unparsable("parse_actions", bits)) - type reason = IDLE_TIMEOUT | HARD_TIMEOUT | DELETE - let reason_of_int = function - | 0 -> IDLE_TIMEOUT - | 1 -> HARD_TIMEOUT - | 2 -> DELETE - | _ -> invalid_arg "reason_of_int" - and int_of_reason = function - | IDLE_TIMEOUT -> 0 - | HARD_TIMEOUT -> 1 - | DELETE -> 2 - and string_of_reason = function - | IDLE_TIMEOUT -> 0 - | HARD_TIMEOUT -> 1 - | DELETE -> 2 + cenum reason { + IDLE_TIMEOUT =00; + HARD_TIMEOUT =1; + DELETE = 2 + } as uint8_t type stats = { mutable table_id: byte; @@ -1965,7 +1807,7 @@ end module Port_mod = struct type t = { port_no: Port.t; - hw_addr: eaddr; + hw_addr: Macaddr.t; config: Port.config; mask: Port.config; advertise: Port.features; @@ -2746,4 +2588,4 @@ let marshal msg = | Queue_get_config_req of Header.h * Port.t | Queue_get_config_resp of Header.h * Port.t * Queue.t array *) - marshal_and_sub marshal (OS.Io_page.to_cstruct (OS.Io_page.get ())) + marshal_and_sub marshal (OS.Io_page.to_cstruct (OS.Io_page.get 1)) diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index a04e2d0..dc21403 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -23,10 +23,8 @@ type uint8 = char type uint16 = int type uint32 = int32 type uint64 = int64 -type ipv4 = uint32 type byte = uint8 type bytes = string -type eaddr = bytes type vendor = uint32 type queue_id = uint32 type datapath_id = uint64 @@ -118,7 +116,7 @@ module Port : } type phy = { port_no : uint16; - hw_addr : eaddr; + hw_addr : Macaddr.t; name : string; config : config; state : state; @@ -127,7 +125,7 @@ module Port : supported : features; peer : features; } - val init_port_phy: ?port_no:int -> ?hw_addr:eaddr -> + val init_port_phy: ?port_no:int -> ?hw_addr:Macaddr.t -> ?name:string -> unit -> phy val translate_port_phy : phy -> int -> phy val string_of_phy : phy -> string @@ -224,13 +222,13 @@ module Match : type t = { mutable wildcards : Wildcards.t; mutable in_port : Port.t; - mutable dl_src : eaddr; - mutable dl_dst : eaddr; + mutable dl_src : Macaddr.t; + mutable dl_dst : Macaddr.t; mutable dl_vlan : uint16; mutable dl_vlan_pcp : byte; mutable dl_type : uint16; - mutable nw_src : uint32; - mutable nw_dst : uint32; + mutable nw_src : Ipaddr.V4.t; + mutable nw_dst : Ipaddr.V4.t; mutable nw_tos : byte; mutable nw_proto : byte; mutable tp_src : uint16; @@ -239,27 +237,27 @@ module Match : val wildcard: unit -> t val create_match : ?in_port:int option -> ?dl_vlan:int option -> - ?dl_src:(* Net.Nettypes.ethernet_mac *) eaddr option -> - ?dl_dst:(* Net.Nettypes.ethernet_mac *) eaddr option -> + ?dl_src:(* Net.Nettypes.ethernet_mac *) Macaddr.t option -> + ?dl_dst:(* Net.Nettypes.ethernet_mac *) Macaddr.t option -> ?dl_type:int option -> ?nw_proto:char option -> ?tp_dst:int option -> ?tp_src:int option -> - ?nw_dst:int32 option -> ?nw_dst_len:int -> - ?nw_src:int32 option -> ?nw_src_len:int -> + ?nw_dst:Ipaddr.V4.t option -> ?nw_dst_len:int -> + ?nw_src:Ipaddr.V4.t option -> ?nw_src_len:int -> ?dl_vlan_pcp:char option -> ?nw_tos:char option -> unit -> t val flow_match_compare : t -> t -> Wildcards.t -> bool val create_flow_match : Wildcards.t -> ?in_port:int16 -> - ?dl_src:eaddr -> - ?dl_dst:eaddr -> + ?dl_src:Macaddr.t -> + ?dl_dst:Macaddr.t -> ?dl_vlan:uint16 -> ?dl_vlan_pcp:byte -> ?dl_type:uint16 -> ?nw_tos:byte -> ?nw_proto:byte -> - ?nw_src:uint32 -> - ?nw_dst:uint32 -> ?tp_src:uint16 -> ?tp_dst:uint16 -> unit -> t + ?nw_src:Ipaddr.V4.t -> + ?nw_dst:Ipaddr.V4.t -> ?tp_src:uint16 -> ?tp_dst:uint16 -> unit -> t val translate_port : t -> Port.t -> t val raw_packet_to_match : Port.t -> Cstruct.t -> t val match_to_string : t -> string @@ -271,10 +269,10 @@ module Flow : | Set_vlan_vid of int | Set_vlan_pcp of int | STRIP_VLAN - | Set_dl_src of eaddr - | Set_dl_dst of eaddr - | Set_nw_src of ipv4 - | Set_nw_dst of ipv4 + | Set_dl_src of Macaddr.t + | Set_dl_dst of Macaddr.t + | Set_nw_src of Ipaddr.V4.t + | Set_nw_dst of Ipaddr.V4.t | Set_nw_tos of byte | Set_tp_src of int16 | Set_tp_dst of int16 @@ -285,10 +283,11 @@ module Flow : val string_of_action : action -> string val string_of_actions : action list -> string val marshal_action : action -> Cstruct.t -> int - type reason = IDLE_TIMEOUT | HARD_TIMEOUT | DELETE - val reason_of_int : int -> reason - val int_of_reason : reason -> int - val string_of_reason : reason -> int + cenum reason { + IDLE_TIMEOUT = 0; + HARD_TIMEOUT = 1; + DELETE = 2 + } as uint8_t type stats = { mutable table_id : byte; mutable of_match : Match.t; @@ -399,7 +398,7 @@ module Port_mod : sig type t = { port_no : Port.t; - hw_addr : eaddr; + hw_addr : Macaddr.t; config : Port.config; mask : Port.config; advertise : Port.features; diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index f855d99..086d40f 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -28,7 +28,7 @@ let cp = pp "%s\n%!" let resolve t = Lwt.on_success t (fun _ -> ()) let get_new_buffer len = - let buf = OS.Io_page.to_cstruct (OS.Io_page.get ()) in + let buf = OS.Io_page.to_cstruct (OS.Io_page.get 1) in Cstruct.sub buf 0 len module Socket = struct diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index a8667dd..d35216d 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -40,7 +40,6 @@ type uint16 = OP.uint16 type uint32 = OP.uint32 type uint64 = OP.uint64 type byte = OP.byte -type eaddr = OP.eaddr type port = uint16 type cookie = uint64 @@ -50,9 +49,15 @@ type device = string (* XXX placeholder! *) let resolve t = Lwt.on_success t (fun _ -> ()) let get_new_buffer len = - let buf = OS.Io_page.to_cstruct (OS.Io_page.get ()) in + let buf = OS.Io_page.to_cstruct (OS.Io_page.get 1) in Cstruct.sub buf 0 len +let get_ethif mgr id = + let lst = Manager.get_intfs mgr in + let (_, ethif) = List.find (fun (dev_id,_) -> id = dev_id) lst in + ethif + + module Entry = struct type table_counter = { n_active: uint32; @@ -147,8 +152,8 @@ module Table = struct let entry = Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); cache_entries=[];}) in - (* log data to the visualisation server *) - let _ = + (* TODO log data to the visualisation server *) +(* let _ = match (Lwt.get OS.Topology.node_name) with | None -> () | Some(node_name) -> @@ -161,7 +166,7 @@ module Table = struct ("action", (Rpc.String action_str)); ] in OS.Console.broadcast "flow" (Jsonrpc.to_string msg) - in + in *) let _ = Hashtbl.replace table.entries t.OP.Flow_mod.of_match entry in (* In the fast path table, I need to delete any conflicting entries *) @@ -199,7 +204,7 @@ module Table = struct let _ = Hashtbl.remove table.entries of_match in (* log removal of flow *) - let _ = +(* let _ = match Lwt.get OS.Topology.node_name with | None -> () | Some(node_name) -> @@ -211,7 +216,7 @@ module Table = struct ("flow", (Rpc.String flow_str)); ("action", (Rpc.String action_str));] in OS.Console.broadcast "flow" (Jsonrpc.to_string msg) - in + in *) (of_match, flow)::ret ) else ret ) table.entries [] in @@ -297,10 +302,11 @@ module Switch = struct phy: OP.Port.phy; queue: Cstruct.t Queue.t; } - let init_port mgr port_no ethif = - let name = Manager.get_intf_name mgr ethif in - let hw_addr = Nettypes.ethernet_mac_to_bytes - (Manager.get_intf_mac mgr ethif) in + + let init_port mgr port_no id = + let ethif = Manager.get_ethif ( get_ethif mgr id ) in + let name = OS.Netif.string_of_id (OS.Netif.id (Ethif.get_netif ethif )) in + let hw_addr = Ethif.mac ethif in let counter = OP.Port.( { port_id=port_no; rx_packets=0L; tx_packets=0L; rx_bytes=0L; tx_bytes=0L; rx_dropped=0L; tx_dropped=0L; rx_errors=0L; @@ -325,7 +331,7 @@ module Switch = struct supported=features; peer=features;}) in {port_id=port_no; mgr; port_name=name; counter; - ethif;phy;queue=(Queue.create ());} + ethif=id;phy;queue=(Queue.create ());} type stats = { mutable n_frags: uint64; @@ -440,10 +446,10 @@ module Switch = struct } as big_endian let tcp_checksum ~src ~dst = - let pbuf = Cstruct.sub (Cstruct.of_bigarray (OS.Io_page.get ())) 0 sizeof_pseudo_header in + let pbuf = Cstruct.sub (Cstruct.of_bigarray (OS.Io_page.get 1)) 0 sizeof_pseudo_header in fun data -> - set_pseudo_header_src pbuf (ipv4_addr_to_uint32 src); - set_pseudo_header_dst pbuf (ipv4_addr_to_uint32 dst); + set_pseudo_header_src pbuf (Ipaddr.V4.to_int32 src); + set_pseudo_header_dst pbuf (Ipaddr.V4.to_int32 dst); set_pseudo_header_res pbuf 0; set_pseudo_header_proto pbuf 6; set_pseudo_header_len pbuf (Cstruct.lenv data); @@ -460,9 +466,9 @@ module Switch = struct let _ = match (get_nw_header_nw_proto ip_data) with | 6 (* TCP *) -> - let src = Net.Nettypes.ipv4_addr_of_uint32 (get_nw_header_nw_src + let src = Ipaddr.V4.of_int32 (get_nw_header_nw_src ip_data) in - let dst = Net.Nettypes.ipv4_addr_of_uint32 (get_nw_header_nw_dst + let dst = Ipaddr.V4.of_int32 (get_nw_header_nw_dst ip_data) in let tp_data = Cstruct.shift ip_data (len*4) in let _ = set_tcpv4_checksum tp_data 0 in @@ -544,10 +550,10 @@ module Switch = struct lwt _ = forward_frame st in_port bits pkt_size checksum port in return false | OP.Flow.Set_dl_src(eaddr) -> - let _ = set_dl_header_dl_src eaddr 0 bits in + let _ = set_dl_header_dl_src (Macaddr.to_bytes eaddr) 0 bits in return checksum | OP.Flow.Set_dl_dst(eaddr) -> - let _ = set_dl_header_dl_dst eaddr 0 bits in + let _ = set_dl_header_dl_dst (Macaddr.to_bytes eaddr) 0 bits in return checksum (* TODO: Add for this actions to check when inserted if * the flow is an ip flow *) @@ -559,11 +565,11 @@ module Switch = struct * *) | OP.Flow.Set_nw_src(ip) -> let ip_data = Cstruct.shift bits sizeof_dl_header in - let _ = set_nw_header_nw_src ip_data ip in + let _ = set_nw_header_nw_src ip_data (Ipaddr.V4.to_int32 ip) in return true | OP.Flow.Set_nw_dst(ip) -> let ip_data = Cstruct.shift bits sizeof_dl_header in - let _ = set_nw_header_nw_dst ip_data ip in + let _ = set_nw_header_nw_dst ip_data (Ipaddr.V4.to_int32 ip) in return true | OP.Flow.Set_tp_src(port) -> let ip_data = Cstruct.shift bits sizeof_dl_header in @@ -744,7 +750,7 @@ let process_frame st p _ frame = *************************************************) type endhost = { - ip: Nettypes.ipv4_addr; + ip: Ipaddr.V4.t; port: int; } @@ -1016,7 +1022,7 @@ let control_channel_run st conn t = return (printf "control channel thread returned\n%!") let control_channel st (remote_addr, remote_port) t = - let rs = Nettypes.ipv4_addr_to_string remote_addr in + let rs = Ipaddr.V4.to_string remote_addr in Printf.eprintf "OpenFlow Switch: controller %s:%d" rs remote_port; let conn = Ofsocket.init_socket_conn_state t in let _ = st.Switch.controller <- (Some conn) in @@ -1026,17 +1032,15 @@ let control_channel st (remote_addr, remote_port) t = (* * Interaface with external applications * *) -let add_port mgr ?(use_mac=false) sw ethif = +let add_port mgr ?(use_mac=false) sw id = sw.Switch.portnum <- sw.Switch.portnum + 1; - let hw_addr = - (Net.Nettypes.ethernet_mac_to_string - (Manager.get_intf_mac mgr ethif)) in - let _ = pr "Adding port %d (%s) '%s' \n %!" sw.Switch.portnum - (Net.Manager.get_intf_name mgr ethif) hw_addr in + let ethif = Manager.get_ethif (get_ethif mgr id) in + let hw_addr = (Macaddr.to_string (Ethif.mac ethif)) in + let dev_name = OS.Netif.string_of_id (OS.Netif.id (Ethif.get_netif ethif)) in + let _ = Console.log (sprintf "Adding port %d (%s) '%s' \n %!" sw.Switch.portnum + dev_name hw_addr) in (* lwt _ = log ~level:Notice (sprintf "Adding port %s (port_id=%d)" ethif sw.Switch.portnum) in *) - let _ = Console.log (sprintf "Adding port %s (port_id=%d)" ethif - sw.Switch.portnum) in (* lwt _ = if (use_mac) then lwt _ = Lwt_unix.system (sprintf "ifconfig tap0 lladdr %s" hw_addr) in @@ -1044,13 +1048,13 @@ let add_port mgr ?(use_mac=false) sw ethif = else return () in*) - let port = Switch.init_port mgr sw.Switch.portnum ethif in + let port = Switch.init_port mgr sw.Switch.portnum id in sw.Switch.ports <- sw.Switch.ports @ [port]; Hashtbl.add sw.Switch.int_to_port sw.Switch.portnum (ref port); - Hashtbl.add sw.Switch.dev_to_port ethif (ref port); + Hashtbl.add sw.Switch.dev_to_port id (ref port); sw.Switch.features.OP.Switch.ports <- sw.Switch.features.OP.Switch.ports @ [port.Switch.phy]; - let _ = Net.Manager.set_promiscuous mgr ethif (process_frame sw port) in + let _ = Net.Manager.set_promiscuous mgr id (process_frame sw port) in let h,p = OP.Port.create_port_status OP.Port.ADD port.Switch.phy in lwt _ = match sw.Switch.controller with @@ -1064,17 +1068,19 @@ let del_port mgr sw name = let port = List.find ( fun a -> - name = (Net.Manager.get_intf_name mgr a.Switch.ethif) + let ethif = Manager.get_ethif (get_ethif mgr a.Switch.ethif) in + let dev_name = OS.Netif.string_of_id (OS.Netif.id (Ethif.get_netif ethif)) in + name = dev_name ) sw.Switch.ports in let _ = sw.Switch.ports <- List.filter ( fun a -> - if (name = (Net.Manager.get_intf_name mgr a.Switch.ethif)) then - let _ = printf "removing port %s\n%!" (Net.Manager.get_intf_name mgr - a.Switch.ethif) in + let ethif = Manager.get_ethif (get_ethif mgr a.Switch.ethif) in + let dev_name = OS.Netif.string_of_id (OS.Netif.id (Ethif.get_netif ethif)) in + if (name = dev_name) then + let _ = Console.log (sprintf "removing port %s" dev_name ) in false else true -(* not (name = (Net.Manager.get_intf_name mgr a.Switch.ethif) ) *) ) sw.Switch.ports in let _ = Hashtbl.remove sw.Switch.int_to_port port.Switch.port_id in let _ = Hashtbl.remove sw.Switch.dev_to_port port.Switch.ethif in @@ -1127,8 +1133,8 @@ let add_port_local mgr sw ethif = lwt _ = log ~level:Notice (sprintf "Adding port %s (port_id=%d)" ethif local_port_id) in *) - let _ = Console.log (sprintf "Adding port %s (port_id=%d)" ethif - local_port_id) in + let _ = Console.log (sprintf "Adding port %s (port_id=%d)" + (OS.Netif.string_of_id ethif) local_port_id) in let _ = Net.Manager.set_promiscuous mgr ethif (process_frame sw port) in return () diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index 52cefdc..a94733f 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -14,23 +14,23 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) - +open Net type t -val add_port : Net.Manager.t -> ?use_mac:bool -> t -> string -> unit Lwt.t -val del_port : Net.Manager.t -> t -> string -> unit Lwt.t -val add_port_local : Net.Manager.t -> t -> Net.Manager.id -> unit Lwt.t +val add_port : Manager.t -> ?use_mac:bool -> t -> Manager.id -> unit Lwt.t +val del_port : Manager.t -> t -> string -> unit Lwt.t +val add_port_local : Manager.t -> t -> Manager.id -> unit Lwt.t val add_flow : t -> Ofpacket.Flow_mod.t -> unit Lwt.t val del_flow : t -> Ofpacket.Match.t -> unit Lwt.t val get_flow_stats : t -> Ofpacket.Match.t -> Ofpacket.Flow.stats list val create_switch : ?verbose:bool -> int64 -> t -val listen : t -> Net.Manager.t -> Net.Nettypes.ipv4_src -> +val listen : t -> Manager.t -> Nettypes.ipv4_src -> unit Lwt.t -val connect : t -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> +val connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t -val local_connect : t -> Net.Manager.t -> Ofsocket.conn_state -> unit Lwt.t +val local_connect : t -> Manager.t -> Ofsocket.conn_state -> unit Lwt.t (* -val lwt_connect : t -> ?standalone:bool -> Net.Manager.t -> Net.Nettypes.ipv4_dst -> +val lwt_connect : t -> ?standalone:bool -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t *) diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 9ccca81..4a23d69 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -22,72 +22,65 @@ module OP = Ofpacket let parse_actions actions = let actions = Re_str.split (Re_str.regexp "/") actions in let split_action = Re_str.regexp ":" in - List.fold_right ( - fun action actions -> - try - match (Re_str.split split_action action) with - | "output"::port::_ -> begin - match (OP.Port.port_of_string port) with - | Some port -> - actions @ [(OP.Flow.Output(port, 2000))] - | None -> - let _ = printf "[ofswitch-config] Invalid port %s\n%!" port in - actions + List.fold_right ( + fun action actions -> + try + match (Re_str.split split_action action) with + | "output"::port::_ -> begin + match (OP.Port.port_of_string port) with + | Some port -> + actions @ [(OP.Flow.Output(port, 2000))] + | None -> + let _ = printf "[ofswitch-config] Invalid port %s\n%!" port in + actions end - | "set_vlan_vid"::vif::_ -> - actions @ [(OP.Flow.Set_vlan_vid(int_of_string vif))] - | "set_vlan_pcp"::pcp::_ -> - actions @ [(OP.Flow.Set_vlan_pcp(int_of_string pcp))] - | "set_dl_src"::addr::_ -> begin - match (Net.Nettypes.ethernet_mac_of_string addr) with - | None -> - let _ = printf "[ofswitch-config] Invalid mac %s\n%!" action in - actions - | Some addr -> - actions @ - [(OP.Flow.Set_dl_src(Net.Nettypes.ethernet_mac_to_bytes addr))] + | "set_vlan_vid"::vif::_ -> + actions @ [(OP.Flow.Set_vlan_vid(int_of_string vif))] + | "set_vlan_pcp"::pcp::_ -> + actions @ [(OP.Flow.Set_vlan_pcp(int_of_string pcp))] + | "set_dl_src"::addr::_ -> begin + match (Macaddr.of_string addr) with + | None -> + let _ = printf "[ofswitch-config] Invalid mac %s\n%!" action in + actions + | Some addr -> actions @[(OP.Flow.Set_dl_src(addr))] end - | "set_dl_dst"::addr::_ -> begin - match (Net.Nettypes.ethernet_mac_of_string addr) with - | None -> - let _ = printf "[ofswitch-config] Invalid mac %s\n%!" action in - actions - | Some addr -> - actions @ - [(OP.Flow.Set_dl_dst(Net.Nettypes.ethernet_mac_to_bytes addr))] + | "set_dl_dst"::addr::_ -> begin + match (Macaddr.of_string addr) with + | None -> + let _ = printf "[ofswitch-config] Invalid mac %s\n%!" action in + actions + | Some addr -> actions @[(OP.Flow.Set_dl_dst(addr))] end - | "set_nw_src"::addr::_ -> begin - match (Net.Nettypes.ipv4_addr_of_string addr) with - | None -> - let _ = printf "[ofswitch-config] invalid ip %s\n%!" addr in - actions - | Some ip -> - actions @ - [(OP.Flow.Set_nw_src(Net.Nettypes.ipv4_addr_to_uint32 ip))] + | "set_nw_src"::addr::_ -> begin + match (Ipaddr.V4.of_string addr) with + | None -> + let _ = printf "[ofswitch-config] invalid ip %s\n%!" addr in + actions + | Some ip -> actions @ [(OP.Flow.Set_nw_src(ip))] end - | "set_nw_dst"::addr::_ -> begin - match (Net.Nettypes.ipv4_addr_of_string addr) with - | None -> - let _ = printf "[ofswitch-config] invalid ip %s\n%!" addr in - actions - | Some ip -> actions @ - [(OP.Flow.Set_nw_dst(Net.Nettypes.ipv4_addr_to_uint32 ip))] + | "set_nw_dst"::addr::_ -> begin + match (Ipaddr.V4.of_string addr) with + | None -> + let _ = printf "[ofswitch-config] invalid ip %s\n%!" addr in + actions + | Some ip -> actions @ [(OP.Flow.Set_nw_dst(ip))] end - | "set_nw_tos"::tos::_ -> - actions @ [(OP.Flow.Set_nw_tos(char_of_int (int_of_string tos)))] - | "set_tp_src"::port::_ -> - actions @ [(OP.Flow.Set_tp_src(int_of_string port))] - | "set_tp_dst"::port::_ -> - actions @ [(OP.Flow.Set_tp_dst(int_of_string port))] - | _ -> - let _ = eprintf "[ofswitch-config] invalid action %s" action in - actions - with exn -> - let _ = printf "[ofswitch-config] error parsing action %s\n%!" action in + | "set_nw_tos"::tos::_ -> + actions @ [(OP.Flow.Set_nw_tos(char_of_int (int_of_string tos)))] + | "set_tp_src"::port::_ -> + actions @ [(OP.Flow.Set_tp_src(int_of_string port))] + | "set_tp_dst"::port::_ -> + actions @ [(OP.Flow.Set_tp_dst(int_of_string port))] + | _ -> + let _ = eprintf "[ofswitch-config] invalid action %s" action in actions - ) actions [] + with exn -> + let _ = printf "[ofswitch-config] error parsing action %s\n%!" action in + actions + ) actions [] + - let hashtbl_to_flow_match t = let of_match = OP.Match.wildcard () in let map = @@ -95,196 +88,195 @@ let hashtbl_to_flow_match t = fun (name, value) r -> let _ = Hashtbl.add r name (Rpc.string_of_rpc value) in let _ = printf "Adding %s = %s\n%!" name - (Rpc.string_of_rpc value) in + (Rpc.string_of_rpc value) in r - ) t (Hashtbl.create 10) in + ) t (Hashtbl.create 10) in let _ = Hashtbl.iter ( fun name value -> match name with | "in_port" -> begin - match (OP.Port.port_of_string value) with + match (OP.Port.port_of_string value) with | Some port -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.in_port <- - false in - let _ = of_match.OP.Match.in_port <- port in - () + let _ = of_match.OP.Match.wildcards.OP.Wildcards.in_port <- + false in + let _ = of_match.OP.Match.in_port <- port in + () | None -> - let _ = printf "[ofswitch-config] Invalid port %s\n%!" value in - () - end - | "dl_vlan" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan <- false in - let _ = of_match.OP.Match.dl_vlan <- int_of_string value in + let _ = printf "[ofswitch-config] Invalid port %s\n%!" value in () + end + | "dl_vlan" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan <- false in + let _ = of_match.OP.Match.dl_vlan <- int_of_string value in + () | "dl_vlan_pcp" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan_pcp <- false in - let _ = of_match.OP.Match.dl_vlan_pcp <- char_of_int (int_of_string value) in - () - | "dl_src" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_src <- false in - let _ = - match (Net.Nettypes.ethernet_mac_of_string value) with - | None -> printf "Invalid mac addr %s\n%!" value - | Some t -> of_match.OP.Match.dl_src <- Net.Nettypes.ethernet_mac_to_bytes t - in - () - | "dl_dst" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_dst <- false in - let _ = - match (Net.Nettypes.ethernet_mac_of_string value) with - | None -> printf "Invalid mac addr %s\n%!" value - | Some t -> of_match.OP.Match.dl_dst <- Net.Nettypes.ethernet_mac_to_bytes t - in - () - | "dl_type" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_type <- false in - let _ = of_match.OP.Match.dl_type <- int_of_string value in - () - | "nw_src" -> begin - match (Re_str.split (Re_str.regexp "/") value) with - | ip::mask::_ -> begin - match (Net.Nettypes.ipv4_addr_of_string ip) with - | None -> printf "Invalid ip definition" - | Some ip -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_src <- - char_of_int (int_of_string mask) in - let _ = of_match.OP.Match.nw_src <- - Net.Nettypes.ipv4_addr_to_uint32 ip in - () - end - | _ -> printf "Invalid ip definition" - end - | "nw_dst" -> begin - match (Re_str.split (Re_str.regexp "/") value) with - | ip::mask::_ -> begin - match (Net.Nettypes.ipv4_addr_of_string ip) with - | None -> printf "Invalid ip definition" - | Some ip -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_dst <- - char_of_int (int_of_string mask) in - let _ = of_match.OP.Match.nw_dst <- - Net.Nettypes.ipv4_addr_to_uint32 ip in - () - end - | _ -> printf "Invalid ip definition" - end - | "nw_tos" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_tos <- false in - let _ = of_match.OP.Match.nw_tos <- char_of_int (int_of_string - value) in - () - | "nw_proto" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_proto <- false in - let _ = of_match.OP.Match.nw_proto <- char_of_int (int_of_string - value) in - () - | "tp_src" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.tp_src <- false in - let _ = of_match.OP.Match.tp_src <- int_of_string value in - () - | "tp_dst" -> - let _ = of_match.OP.Match.wildcards.OP.Wildcards.tp_dst <- false in - let _ = of_match.OP.Match.tp_dst <- int_of_string value in - () - | _ -> - let _ = eprintf "Invalid field name %s" name in - () + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_vlan_pcp <- false in + let _ = of_match.OP.Match.dl_vlan_pcp <- char_of_int (int_of_string value) in + () + | "dl_src" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_src <- false in + let _ = + match (Macaddr.of_string value) with + | None -> printf "Invalid mac addr %s\n%!" value + | Some t -> of_match.OP.Match.dl_src <- t + in + () + | "dl_dst" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_dst <- false in + let _ = + match (Macaddr.of_string value) with + | None -> printf "Invalid mac addr %s\n%!" value + | Some t -> of_match.OP.Match.dl_dst <- t + in + () + | "dl_type" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.dl_type <- false in + let _ = of_match.OP.Match.dl_type <- int_of_string value in + () + | "nw_src" -> begin + match (Re_str.split (Re_str.regexp "/") value) with + | ip::mask::_ -> begin + match (Ipaddr.V4.of_string ip) with + | None -> printf "Invalid ip definition" + | Some ip -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_src <- + char_of_int (int_of_string mask) in + let _ = of_match.OP.Match.nw_src <- ip in + () + end + | _ -> printf "Invalid ip definition" + end + | "nw_dst" -> begin + match (Re_str.split (Re_str.regexp "/") value) with + | ip::mask::_ -> begin + match (Ipaddr.V4.of_string ip) with + | None -> printf "Invalid ip definition" + | Some ip -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_dst <- + char_of_int (int_of_string mask) in + let _ = of_match.OP.Match.nw_dst <- ip + in + () + end + | _ -> printf "Invalid ip definition" + end + | "nw_tos" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_tos <- false in + let _ = of_match.OP.Match.nw_tos <- char_of_int (int_of_string + value) in + () + | "nw_proto" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.nw_proto <- false in + let _ = of_match.OP.Match.nw_proto <- char_of_int (int_of_string + value) in + () + | "tp_src" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.tp_src <- false in + let _ = of_match.OP.Match.tp_src <- int_of_string value in + () + | "tp_dst" -> + let _ = of_match.OP.Match.wildcards.OP.Wildcards.tp_dst <- false in + let _ = of_match.OP.Match.tp_dst <- int_of_string value in + () + | _ -> + let _ = eprintf "Invalid field name %s" name in + () ) map in - of_match + of_match let listen_t mgr del_port get_stats add_flow del_flow port = let manage (dip,dpt) t = try_lwt lwt req = Net.Channel.read_line t in - let req = - List.fold_right ( - fun a r -> - r ^ (Cstruct.to_string a) - ) req "" in - let req = Jsonrpc.call_of_string req in - lwt success = - match (req.Rpc.name, req.Rpc.params) with - | ("add-port", (Rpc.String (dev))::_) -> - let _ = Net.Manager.attach mgr dev in - return (Rpc.Enum [(Rpc.String "true")]) - | ("del-port", (Rpc.String (dev))::_) -> - lwt _ = del_port dev in - lwt _ = Net.Manager.detach mgr dev in - return (Rpc.Enum [(Rpc.String "true")]) - | ("dump-flows", (Rpc.Dict t)::_) -> - let of_match = hashtbl_to_flow_match t in - let _ = printf "Find rules matching %s\n%!" - (OP.Match.match_to_string of_match) in - let flows = get_stats of_match in - let res = - List.fold_right ( - fun a r -> - r @ [(Rpc.String (OP.Flow.string_of_flow_stat a))] - ) flows [] in - return (Rpc.Enum res) - | ("add-flow", (Rpc.Dict t)::_) -> - let _ = printf "adding flow %s\n%!" (Rpc.string_of_call req) in - let fm = OP.Flow_mod.create (OP.Match.wildcard () ) - 0L OP.Flow_mod.ADD [] () in - let map = - List.fold_right ( - fun (name, value) r -> - match name with - | "actions" -> - let _ = fm.OP.Flow_mod.actions <- - (parse_actions (Rpc.string_of_rpc value) ) in - r - | "idle_timeout" -> - let _ = - fm.OP.Flow_mod.idle_timeout <- (Rpc.int_of_rpc value) in - r - | "hard_timeout" -> - let _ = - fm.OP.Flow_mod.hard_timeout <- (Rpc.int_of_rpc value) in - r - | "priority" -> - let _ = - fm.OP.Flow_mod.priority <- (Rpc.int_of_rpc value) in - r - | _ -> r @ [(name, value)] - ) t [] in - let _ = fm.OP.Flow_mod.of_match <- hashtbl_to_flow_match map in - let _ = printf "Add flow %s\n%!" (OP.Flow_mod.flow_mod_to_string fm) in - lwt _ = add_flow fm in - return (Rpc.Enum [(Rpc.String "true")] ) - | ("del-flow", (Rpc.Dict t)::_) -> - let of_match = hashtbl_to_flow_match t in - let _ = printf "Find rules matching %s\n%!" - (OP.Match.match_to_string of_match) in - lwt _ = del_flow of_match in - return (Rpc.Enum [(Rpc.String "true")] ) - | (_, _) -> - let _ = printf "[ofswitch-config] invalid action %s\n%!" - (req.Rpc.name) in - return (Rpc.Enum [(Rpc.String "false")]) - in - let resp = - Jsonrpc.string_of_response (Rpc.success success) in - let _ = Net.Channel.write_line t resp in - lwt _ = Net.Channel.flush t in - lwt _ = Net.Channel.close t in - return () - with - | End_of_file -> return () - | exn -> - let _ = OS.Console.log - "[ofswitch_config] server error" in -(* let resp = Jsonrpc.string_of_response - (Rpc.failure (Rpc.Enum [(Rpc.String "false")])) in - lwt _ = Lwt_io.write_line output resp in - lwt _ = Lwt_io.close output in - lwt _ = Lwt_io.close input in *) - return () - - - in - let _ = Net.Channel.listen mgr (`TCPv4 ((None, 6634), manage )) in - return () + let req = + List.fold_right ( + fun a r -> + r ^ (Cstruct.to_string a) + ) req "" in + let req = Jsonrpc.call_of_string req in + lwt success = + match (req.Rpc.name, req.Rpc.params) with + | ("add-port", (Rpc.String (dev))::_) -> + (* let _ = Net.Manager.attach mgr dev in *) + return (Rpc.Enum [(Rpc.String "true")]) + | ("del-port", (Rpc.String (dev))::_) -> + lwt _ = del_port dev in +(* lwt _ = Net.Manager.detach mgr dev in *) +return (Rpc.Enum [(Rpc.String "true")]) +| ("dump-flows", (Rpc.Dict t)::_) -> +let of_match = hashtbl_to_flow_match t in +let _ = printf "Find rules matching %s\n%!" + (OP.Match.match_to_string of_match) in +let flows = get_stats of_match in +let res = + List.fold_right ( + fun a r -> + r @ [(Rpc.String (OP.Flow.string_of_flow_stat a))] + ) flows [] in +return (Rpc.Enum res) +| ("add-flow", (Rpc.Dict t)::_) -> +let _ = printf "adding flow %s\n%!" (Rpc.string_of_call req) in +let fm = OP.Flow_mod.create (OP.Match.wildcard () ) + 0L OP.Flow_mod.ADD [] () in +let map = + List.fold_right ( + fun (name, value) r -> + match name with + | "actions" -> + let _ = fm.OP.Flow_mod.actions <- + (parse_actions (Rpc.string_of_rpc value) ) in + r + | "idle_timeout" -> + let _ = + fm.OP.Flow_mod.idle_timeout <- (Rpc.int_of_rpc value) in + r + | "hard_timeout" -> + let _ = + fm.OP.Flow_mod.hard_timeout <- (Rpc.int_of_rpc value) in + r + | "priority" -> + let _ = + fm.OP.Flow_mod.priority <- (Rpc.int_of_rpc value) in + r + | _ -> r @ [(name, value)] + ) t [] in +let _ = fm.OP.Flow_mod.of_match <- hashtbl_to_flow_match map in +let _ = printf "Add flow %s\n%!" (OP.Flow_mod.flow_mod_to_string fm) in +lwt _ = add_flow fm in +return (Rpc.Enum [(Rpc.String "true")] ) +| ("del-flow", (Rpc.Dict t)::_) -> +let of_match = hashtbl_to_flow_match t in +let _ = printf "Find rules matching %s\n%!" + (OP.Match.match_to_string of_match) in +lwt _ = del_flow of_match in +return (Rpc.Enum [(Rpc.String "true")] ) +| (_, _) -> +let _ = printf "[ofswitch-config] invalid action %s\n%!" + (req.Rpc.name) in +return (Rpc.Enum [(Rpc.String "false")]) +in +let resp = + Jsonrpc.string_of_response (Rpc.success success) in +let _ = Net.Channel.write_line t resp in +lwt _ = Net.Channel.flush t in +lwt _ = Net.Channel.close t in +return () +with +| End_of_file -> return () +| exn -> + let _ = OS.Console.log + "[ofswitch_config] server error" in + (* let resp = Jsonrpc.string_of_response + (Rpc.failure (Rpc.Enum [(Rpc.String "false")])) in + lwt _ = Lwt_io.write_line output resp in + lwt _ = Lwt_io.close output in + lwt _ = Lwt_io.close input in *) + return () + + +in +let _ = Net.Channel.listen mgr (`TCPv4 ((None, 6634), manage )) in +return () diff --git a/lib/ofswitch_standalone.ml b/lib/ofswitch_standalone.ml index 758676f..86787de 100644 --- a/lib/ofswitch_standalone.ml +++ b/lib/ofswitch_standalone.ml @@ -31,12 +31,12 @@ let sp = Printf.sprintf (* TODO this the mapping is incorrect. the datapath must be moved to the key * of the hashtbl *) type mac_switch = { - addr: OP.eaddr; + addr: Macaddr.t; switch: OP.datapath_id; } type switch_state = { - mutable mac_cache: (OP.eaddr, OP.Port.t) Hashtbl.t; + mutable mac_cache: (Macaddr.t, OP.Port.t) Hashtbl.t; req_count: int ref; } @@ -98,9 +98,8 @@ let packet_in_cb controller dpid evt = (* check if I know the output port in order to define what type of message * we need to send *) - let broadcast = String.make 6 '\255' in let ix = m.OP.Match.dl_dst in - if ( (ix = broadcast) + if ( (ix = Macaddr.broadcast ) || (not (Hashtbl.mem switch_data.mac_cache ix)) ) then ( let bs = diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 563e320..0c84238 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 80289e4e4350149036c82b97b636efa8) *) +(* DO NOT EDIT (digest: fbb3c99856cfddeac4941c0abf1cced2) *) module OASISGettext = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) +(* # 21 "src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) +(* # 21 "src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) +(* # 21 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -234,21 +234,19 @@ module MyOCamlbuildFindlib = struct Ocamlbuild_pack.Lexers.blank_sep_strings let split s ch = - let buf = Buffer.create 13 in - let x = ref [] in - let flush () = - x := (Buffer.contents buf) :: !x; - Buffer.clear buf + let x = + ref [] in - String.iter - (fun c -> - if c = ch then - flush () - else - Buffer.add_char buf c) - s; - flush (); - List.rev !x + let rec go s = + let pos = + String.index s ch + in + x := (String.before s pos)::!x; + go (String.after s (pos + 1)) + in + try + go s + with Not_found -> !x let split_nl s = split s '\n' @@ -283,27 +281,17 @@ module MyOCamlbuildFindlib = struct (* When one link an OCaml library/binary/package, one should use -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - flag ["ocaml"; "link"; "output_obj"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> - let base_args = [A"-package"; A pkg] in - let syn_args = [A"-syntax"; A "camlp4o"] in - let args = - (* heuristic to identify syntax extensions: - whether they end in ".syntax"; some might not *) - if Filename.check_suffix pkg "syntax" - then syn_args @ base_args - else base_args - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; end (find_packages ()); @@ -335,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -351,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { @@ -464,24 +452,6 @@ module MyOCamlbuildBase = struct ) t.lib_c; - (* Add output_obj rules mapped to .nobj.o *) - let native_output_obj x = - OC.link_gen "cmx" "cmxa" !Options.ext_lib [!Options.ext_obj; "cmi"] - OC.ocamlopt_link_prog - (fun tags -> tags++"ocaml"++"link"++"native"++"output_obj") x - in - rule "ocaml: cmx* and o* -> .nobj.o" ~prod:"%.nobj.o" ~deps:["%.cmx"; "%.o"] - (native_output_obj "%.cmx" "%.nobj.o"); - - (* Add output_obj rules mapped to .bobj.o *) - let bytecode_output_obj x = - OC.link_gen "cmo" "cma" !Options.ext_lib [!Options.ext_obj; "cmi"] - OC.ocamlc_link_prog - (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") x - in - rule "ocaml: cmo* -> .nobj.o" ~prod:"%.bobj.o" ~deps:["%.cmo"] - (bytecode_output_obj "%.cmo" "%.bobj.o"); - (* Add flags *) List.iter (fun (tags, cond_specs) -> @@ -503,7 +473,7 @@ module MyOCamlbuildBase = struct end -# 506 "myocamlbuild.ml" +# 476 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -516,6 +486,6 @@ let package_default = let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 520 "myocamlbuild.ml" +# 490 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index 2253f0c..54b7465 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ -(* setup.ml generated for the first time by OASIS v0.3.1 *) +(* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 17f0e41fa6f048081ffd93663158f7e4) *) +(* DO NOT EDIT (digest: b767096e08fa686b006c3ab0f2a5c26f) *) (* - Regenerated by OASIS v0.3.1 + Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISGettext.ml" *) +(* # 21 "src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISContext.ml" *) +(* # 21 "src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISString.ml" *) +(* # 1 "src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISUtils.ml" *) +(* # 21 "src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) +(* # 21 "src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/PropList.ml" *) +(* # 71 "src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISMessage.ml" *) +(* # 21 "src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISVersion.ml" *) +(* # 21 "src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISLicense.ml" *) +(* # 21 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExpr.ml" *) +(* # 21 "src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) +(* # 21 "src/oasis/OASISTypes.ml" *) @@ -964,8 +964,6 @@ module OASISTypes = struct type compiled_object = | Byte | Native - | Native_object - | Bytecode_object | Best @@ -1020,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 104 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTypes.ml" *) +(* # 102 "src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1068,13 +1066,6 @@ module OASISTypes = struct lib_findlib_containers: findlib_name list; } - - type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - } - type executable = { exec_custom: bool; @@ -1135,7 +1126,6 @@ module OASISTypes = struct type section = | Library of common_section * build_section * library - | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository @@ -1144,7 +1134,7 @@ module OASISTypes = struct type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { @@ -1186,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISUnixPath.ml" *) +(* # 21 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1270,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISHostPath.ml" *) +(* # 21 "src/oasis/OASISHostPath.ml" *) open Filename @@ -1303,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISSection.ml" *) +(* # 21 "src/oasis/OASISSection.ml" *) open OASISTypes @@ -1311,8 +1301,6 @@ module OASISSection = struct function | Library (cs, _, _) -> `Library, cs - | Object (cs, _, _) -> - `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> @@ -1330,7 +1318,6 @@ module OASISSection = struct let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) - | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) @@ -1351,7 +1338,6 @@ module OASISSection = struct in (match k with | `Library -> "library" - | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" @@ -1386,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISBuildSection.ml" *) +(* # 21 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExecutable.ml" *) +(* # 21 "src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1404,8 +1390,6 @@ module OASISExecutable = struct let is_native_exec = match bs.bs_compiled_object with | Native -> true - | Native_object -> false - | Bytecode_object -> false | Best -> is_native () | Byte -> false in @@ -1424,15 +1408,30 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISLibrary.ml" *) +(* # 21 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + library * + group_t list) + (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists bs modul = + let find_module source_file_exists (cs, bs, lib) modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) @@ -1473,7 +1472,7 @@ module OASISLibrary = struct let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> - match find_module source_file_exists bs modul with + match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> @@ -1497,7 +1496,7 @@ module OASISLibrary = struct let find_modules lst ext = let find_module modul = - match find_module source_file_exists bs modul with + match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, _) -> [base_fn] | `No_sources lst -> @@ -1532,8 +1531,6 @@ module OASISLibrary = struct (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true - | Native_object -> false - | Bytecode_object -> false | Best -> is_native | Byte -> false in @@ -1571,11 +1568,11 @@ module OASISLibrary = struct [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with - | Native | Native_object -> + | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) - | Byte | Bytecode_object | Best -> + | Byte | Best -> byte acc_nopath in @@ -1601,100 +1598,7 @@ module OASISLibrary = struct acc_nopath) (headers @ cmxs) -end - -module OASISObject = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISObject.ml" *) - - open OASISTypes - open OASISGettext - - let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = - List.fold_left - (fun acc modul -> - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name; - acc) - [] - obj.obj_modules - - - let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = - - let find_module ext modul = - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, _) -> [base_fn ^ ext] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name ; - lst - in - - let header, byte, native, c_object, f = - match obj.obj_modules with - | [ m ] -> (find_module ".cmi" m, - find_module ".cmo" m, - find_module ".cmx" m, - find_module ".o" m, - fun x -> x) - | _ -> ([cs.cs_name ^ ".cmi"], - [cs.cs_name ^ ".cmo"], - [cs.cs_name ^ ".cmx"], - [cs.cs_name ^ ".o"], - OASISUnixPath.concat bs.bs_path) - in - List.map (List.map f) ( - match bs.bs_compiled_object with - | Native | Native_object -> - native :: c_object :: byte :: header :: [] - | Best when is_native -> - native :: c_object :: byte :: header :: [] - | Byte | Bytecode_object | Best -> - byte :: header :: []) - -end - -module OASISFindlib = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFindlib.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - [`Library of library | `Object of object_] * - group_t list) - - type data = common_section * - build_section * - [`Library of library | `Object of object_] + type data = common_section * build_section * library type tree = | Node of (data option) * (tree MapString.t) | Leaf of data @@ -1737,23 +1641,6 @@ module OASISFindlib = struct mp end - | Object (cs, _, obj) -> - begin - let obj_name = cs.cs_name in - if MapString.mem obj_name mp then - failwithf - (f_ "The object name '%s' is used more than once.") - obj_name; - let findlib_full_name = match obj.obj_findlib_fullname with - | Some ns -> String.concat "." ns - | None -> obj_name - in - MapString.add - obj_name - (`Solved findlib_full_name) - mp - end - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty @@ -1891,9 +1778,7 @@ module OASISFindlib = struct (fun mp -> function | Library (cs, bs, lib) -> - add (cs, bs, `Library lib) mp - | Object (cs, bs, obj) -> - add (cs, bs, `Object obj) mp + add (cs, bs, lib) mp | _ -> mp) MapString.empty @@ -1956,32 +1841,32 @@ module OASISFindlib = struct end module OASISFlag = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFlag.ml" *) +(* # 21 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISPackage.ml" *) +(* # 21 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISTest.ml" *) +(* # 21 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISDocument.ml" *) +(* # 21 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISExec.ml" *) +(* # 21 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -2059,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/oasis/OASISFileUtil.ml" *) +(* # 21 "src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2254,9 +2139,9 @@ module OASISFileUtil = struct end -# 2257 "setup.ml" +# 2142 "setup.ml" module BaseEnvLight = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnvLight.ml" *) +(* # 21 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2352,9 +2237,9 @@ module BaseEnvLight = struct end -# 2355 "setup.ml" +# 2240 "setup.ml" module BaseContext = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseContext.ml" *) +(* # 21 "src/base/BaseContext.ml" *) open OASISContext @@ -2365,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseMessage.ml" *) +(* # 21 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2384,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseEnv.ml" *) +(* # 21 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2844,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseArgExt.ml" *) +(* # 21 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2872,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseCheck.ml" *) +(* # 21 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2998,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -3114,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseStandardVar.ml" *) +(* # 21 "src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3478,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseFileAB.ml" *) +(* # 21 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3526,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseLog.ml" *) +(* # 21 "src/base/BaseLog.ml" *) open OASISUtils @@ -3645,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseBuilt.ml" *) +(* # 21 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3656,7 +3541,6 @@ module BaseBuilt = struct | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) - | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = @@ -3665,7 +3549,6 @@ module BaseBuilt = struct | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" - | BObj -> "obj" | BDoc -> "doc")^ "_"^nm @@ -3729,8 +3612,6 @@ module BaseBuilt = struct (f_ "executable %s") | BLib -> (f_ "library %s") - | BObj -> - (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); @@ -3793,27 +3674,10 @@ module BaseBuilt = struct in evs, unix_lst - - let of_object ffn (cs, bs, obj) = - let unix_lst = - OASISObject.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - (cs, bs, obj) - in - let evs = - [BObj, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - end module BaseCustom = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseCustom.ml" *) +(* # 21 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3863,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseDynVar.ml" *) +(* # 21 "src/base/BaseDynVar.ml" *) open OASISTypes @@ -3904,13 +3768,13 @@ module BaseDynVar = struct (f_ "Executable '%s' not yet built.") cs.cs_name))))) - | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseTest.ml" *) +(* # 21 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -4000,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseDoc.ml" *) +(* # 21 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -4035,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/base/BaseSetup.ml" *) +(* # 21 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4282,7 +4146,6 @@ module BaseSetup = struct (f t.package (cs, doc)) args | Library _ - | Object _ | Executable _ | Flag _ | SrcRepo _ -> @@ -4614,9 +4477,9 @@ module BaseSetup = struct end -# 4617 "setup.ml" +# 4480 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4793,20 +4656,6 @@ module InternalConfigurePlugin = struct | None -> () end; - (* Make sure the findlib version is fine for the OCaml compiler. *) - begin - let ocaml_ge4 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) - (OASISVersion.version_of_string "4.0.0") >= 0 in - if ocaml_ge4 then - let findlib_lt132 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) - (OASISVersion.version_of_string "1.3.2") < 0 in - if findlib_lt132 then - add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" - end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || @@ -4872,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -4882,7 +4731,7 @@ module InternalInstallPlugin = struct open BaseStandardVar open BaseMessage open OASISTypes - open OASISFindlib + open OASISLibrary open OASISGettext open OASISUtils @@ -4892,9 +4741,6 @@ module InternalInstallPlugin = struct let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) - let obj_hook = - ref (fun (cs, bs, obj) -> cs, bs, obj, []) - let doc_hook = ref (fun (cs, doc) -> cs, doc) @@ -5115,75 +4961,6 @@ module InternalInstallPlugin = struct begin (f_data, acc) end - and files_of_object (f_data, acc) data_obj = - let cs, bs, obj, obj_extra = - !obj_hook data_obj - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then - begin - let acc = - (* Start with acc + obj_extra *) - List.rev_append obj_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - acc - end) - acc - obj.obj_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BObj - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the object *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - in (* Install one group of library *) @@ -5194,10 +4971,8 @@ module InternalInstallPlugin = struct match grp with | Container (_, children) -> data_and_files, children - | Package (_, cs, bs, `Library lib, children) -> + | Package (_, cs, bs, lib, children) -> files_of_library data_and_files (cs, bs, lib), children - | Package (_, cs, bs, `Object obj, children) -> - files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux @@ -5455,9 +5230,9 @@ module InternalInstallPlugin = struct end -# 5458 "setup.ml" +# 5233 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5559,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5590,19 +5365,6 @@ module OCamlbuildPlugin = struct in_build_dir (OASISHostPath.of_unix fn) in - (* Checks if the string [fn] ends with [nd] *) - let ends_with nd fn = - let nd_len = - String.length nd - in - (String.length fn >= nd_len) - && - (String.sub - fn - (String.length fn - nd_len) - nd_len) = nd - in - let cond_targets = List.fold_left (fun acc -> @@ -5615,6 +5377,18 @@ module OCamlbuildPlugin = struct (cs, bs, lib) in + let ends_with nd fn = + let nd_len = + String.length nd + in + (String.length fn >= nd_len) + && + (String.sub + fn + (String.length fn - nd_len) + nd_len) = nd + in + let tgts = List.flatten (List.filter @@ -5639,35 +5413,6 @@ module OCamlbuildPlugin = struct cs.cs_name end - | Object (cs, bs, obj) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_object - in_build_dir_of_unix - (cs, bs, obj) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ".cmo" fn - || ends_with ".cmx" fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for object %s") - cs.cs_name - end - | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = @@ -5699,12 +5444,8 @@ module OCamlbuildPlugin = struct (* Add executable *) let acc = match bs.bs_compiled_object with - | Native_object -> - (target ".nobj.o") :: acc - | Bytecode_object -> - (target ".bobj.o") :: acc | Native -> - (target ".native") :: acc + (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte @@ -5714,7 +5455,7 @@ module OCamlbuildPlugin = struct acc end - | Library _ | Object _ | Executable _ | Test _ + | Library _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] @@ -5766,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/local/scratch/cr409/.opam/4.00.1+mirage-ns3-direct/build/oasis-mirage.0.3.0a/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5814,7 +5555,7 @@ module OCamlbuildDocPlugin = struct end -# 5817 "setup.ml" +# 5558 "setup.ml" open OASISTypes;; let setup_t = @@ -5959,7 +5700,8 @@ let setup_t = ("mirage-net", Some (OASISVersion.VGreaterEqual "0.3.0")); FindlibPackage ("re.str", None); - FindlibPackage ("ocamlgraph", None) + FindlibPackage ("ocamlgraph", None); + FindlibPackage ("ipaddr", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -6088,8 +5830,8 @@ let setup_t = plugin_data = []; }; oasis_fn = Some "_oasis"; - oasis_version = "0.3.1"; - oasis_digest = Some "{\245\179v\221P2\000\207\190\212\212\1620\177\253"; + oasis_version = "0.3.0"; + oasis_digest = Some "\214K\028\241~7Z}\189\248d\214o\254k3"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6097,6 +5839,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6101 "setup.ml" +# 5843 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 04db4c1fc40e5f5f3276e2d445dfd392b8df5b40 Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 16 Sep 2013 17:42:15 +0100 Subject: [PATCH 50/75] adding merlin project file --- .merlin | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 .merlin diff --git a/.merlin b/.merlin new file mode 100644 index 0000000..9fba6b2 --- /dev/null +++ b/.merlin @@ -0,0 +1,12 @@ +S . +S ./lib/ +S ./controller/ +S ./switch/ +B _build/src +PKG lwt +PKG mirage +PKG mirage-net +PKG cstruct +PKG re +PKG ipaddr +PKG pttcp From f4d095e420e54484cf09ed35e1aeacc09111c53e Mon Sep 17 00:00:00 2001 From: Haris Rotsos Date: Tue, 17 Sep 2013 19:23:00 +0100 Subject: [PATCH 51/75] Update _oasis --- _oasis | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/_oasis b/_oasis index bbadc11..663b167 100644 --- a/_oasis +++ b/_oasis @@ -31,7 +31,7 @@ Library openflow CompiledObject: native Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch, Ofsocket, Ofswitch_standalone, Flowvisor, Flowvisor_topology, Lldp Pack: True - BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0), re.str, ocamlgraph + BuildDepends: ipaddr, cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0), re.str, ocamlgraph Document openflow Title: OpenFlow docs From 2356778b73150bb4a5b08cd3669a974c0e9b81a8 Mon Sep 17 00:00:00 2001 From: crotsos Date: Sat, 21 Sep 2013 10:20:38 +0100 Subject: [PATCH 52/75] extract a portion of the ocamlgraph library and adding as a standalone in order to allow compilation for xen backend --- lib/bitv.ml | 622 ++++++++++++++++++++++++++++++ lib/bitv.mli | 195 ++++++++++ lib/blocks.ml | 919 +++++++++++++++++++++++++++++++++++++++++++++ lib/components.ml | 87 +++++ lib/components.mli | 58 +++ lib/heap.ml | 236 ++++++++++++ lib/heap.mli | 99 +++++ lib/imperative.ml | 665 ++++++++++++++++++++++++++++++++ lib/imperative.mli | 159 ++++++++ lib/path.ml | 238 ++++++++++++ lib/path.mli | 143 +++++++ lib/sig.mli | 360 ++++++++++++++++++ lib/util.ml | 50 +++ lib/util.mli | 47 +++ 14 files changed, 3878 insertions(+) create mode 100644 lib/bitv.ml create mode 100644 lib/bitv.mli create mode 100644 lib/blocks.ml create mode 100644 lib/components.ml create mode 100644 lib/components.mli create mode 100644 lib/heap.ml create mode 100644 lib/heap.mli create mode 100644 lib/imperative.ml create mode 100644 lib/imperative.mli create mode 100644 lib/path.ml create mode 100644 lib/path.mli create mode 100644 lib/sig.mli create mode 100644 lib/util.ml create mode 100644 lib/util.mli diff --git a/lib/bitv.ml b/lib/bitv.ml new file mode 100644 index 0000000..d565d66 --- /dev/null +++ b/lib/bitv.ml @@ -0,0 +1,622 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*i $Id: bitv.ml,v 1.18 2008/04/01 09:59:03 filliatr Exp $ i*) + +(*s Bit vectors. The interface and part of the code are borrowed from the + [Array] module of the ocaml standard library (but things are simplified + here since we can always initialize a bit vector). This module also + provides bitwise operations. *) + +(*s We represent a bit vector by a vector of integers (field [bits]), + and we keep the information of the size of the bit vector since it + can not be found out with the size of the array (field [length]). *) + +type t = { + length : int; + bits : int array } + +let length v = v.length + +(*s Each element of the array is an integer containing [bpi] bits, where + [bpi] is determined according to the machine word size. Since we do not + use the sign bit, [bpi] is 30 on a 32-bits machine and 62 on a 64-bits + machines. We maintain the following invariant: + {\em The unused bits of the last integer are always + zeros.} This is ensured by [create] and maintained in other functions + using [normalize]. [bit_j], [bit_not_j], [low_mask] and [up_mask] + are arrays used to extract and mask bits in a single integer. *) + +let bpi = Sys.word_size - 2 + +let max_length = Sys.max_array_length * bpi + +let bit_j = Array.init bpi (fun j -> 1 lsl j) +let bit_not_j = Array.init bpi (fun j -> max_int - bit_j.(j)) + +let low_mask = Array.create (succ bpi) 0 +let _ = + for i = 1 to bpi do low_mask.(i) <- low_mask.(i-1) lor bit_j.(pred i) done + +let keep_lowest_bits a j = a land low_mask.(j) + +let high_mask = Array.init (succ bpi) (fun j -> low_mask.(j) lsl (bpi-j)) + +let keep_highest_bits a j = a land high_mask.(j) + +(*s Creating and normalizing a bit vector is easy: it is just a matter of + taking care of the invariant. Copy is immediate. *) + +let create n b = + let initv = if b then max_int else 0 in + let r = n mod bpi in + if r = 0 then + { length = n; bits = Array.create (n / bpi) initv } + else begin + let s = n / bpi in + let b = Array.create (succ s) initv in + b.(s) <- b.(s) land low_mask.(r); + { length = n; bits = b } + end + +let normalize v = + let r = v.length mod bpi in + if r > 0 then + let b = v.bits in + let s = Array.length b in + b.(s-1) <- b.(s-1) land low_mask.(r) + +let copy v = { length = v.length; bits = Array.copy v.bits } + +(*s Access and assignment. The [n]th bit of a bit vector is the [j]th + bit of the [i]th integer, where [i = n / bpi] and [j = n mod + bpi]. Both [i] and [j] and computed by the function [pos]. + Accessing a bit is testing whether the result of the corresponding + mask operation is non-zero, and assigning it is done with a + bitwiwe operation: an {\em or} with [bit_j] to set it, and an {\em + and} with [bit_not_j] to unset it. *) + +let pos n = + let i = n / bpi and j = n mod bpi in + if j < 0 then (i - 1, j + bpi) else (i,j) + +let unsafe_get v n = + let (i,j) = pos n in + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_j j)) > 0 + +let unsafe_set v n b = + let (i,j) = pos n in + if b then + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) lor (Array.unsafe_get bit_j j)) + else + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_not_j j)) + +(*s The corresponding safe operations test the validiy of the access. *) + +let get v n = + if n < 0 or n >= v.length then invalid_arg "Bitv.get"; + let (i,j) = pos n in + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_j j)) > 0 + +let set v n b = + if n < 0 or n >= v.length then invalid_arg "Bitv.set"; + let (i,j) = pos n in + if b then + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) lor (Array.unsafe_get bit_j j)) + else + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_not_j j)) + +(*s [init] is implemented naively using [unsafe_set]. *) + +let init n f = + let v = create n false in + for i = 0 to pred n do + unsafe_set v i (f i) + done; + v + +(*s Handling bits by packets is the key for efficiency of functions + [append], [concat], [sub] and [blit]. + We start by a very general function [blit_bits a i m v n] which blits + the bits [i] to [i+m-1] of a native integer [a] + onto the bit vector [v] at index [n]. It assumes that [i..i+m-1] and + [n..n+m-1] are respectively valid subparts of [a] and [v]. + It is optimized when the bits fit the lowest boundary of an integer + (case [j == 0]). *) + +let blit_bits a i m v n = + let (i',j) = pos n in + if j == 0 then + Array.unsafe_set v i' + ((keep_lowest_bits (a lsr i) m) lor + (keep_highest_bits (Array.unsafe_get v i') (bpi - m))) + else + let d = m + j - bpi in + if d > 0 then begin + Array.unsafe_set v i' + (((keep_lowest_bits (a lsr i) (bpi - j)) lsl j) lor + (keep_lowest_bits (Array.unsafe_get v i') j)); + Array.unsafe_set v (succ i') + ((keep_lowest_bits (a lsr (i + bpi - j)) d) lor + (keep_highest_bits (Array.unsafe_get v (succ i')) (bpi - d))) + end else + Array.unsafe_set v i' + (((keep_lowest_bits (a lsr i) m) lsl j) lor + ((Array.unsafe_get v i') land (low_mask.(j) lor high_mask.(-d)))) + +(*s [blit_int] implements [blit_bits] in the particular case when + [i=0] and [m=bpi] i.e. when we blit all the bits of [a]. *) + +let blit_int a v n = + let (i,j) = pos n in + if j == 0 then + Array.unsafe_set v i a + else begin + Array.unsafe_set v i + ( (keep_lowest_bits (Array.unsafe_get v i) j) lor + ((keep_lowest_bits a (bpi - j)) lsl j)); + Array.unsafe_set v (succ i) + ((keep_highest_bits (Array.unsafe_get v (succ i)) (bpi - j)) lor + (a lsr (bpi - j))) + end + +(*s When blitting a subpart of a bit vector into another bit vector, there + are two possible cases: (1) all the bits are contained in a single integer + of the first bit vector, and a single call to [blit_bits] is the + only thing to do, or (2) the source bits overlap on several integers of + the source array, and then we do a loop of [blit_int], with two calls + to [blit_bits] for the two bounds. *) + +let unsafe_blit v1 ofs1 v2 ofs2 len = + if len > 0 then + let (bi,bj) = pos ofs1 in + let (ei,ej) = pos (ofs1 + len - 1) in + if bi == ei then + blit_bits (Array.unsafe_get v1 bi) bj len v2 ofs2 + else begin + blit_bits (Array.unsafe_get v1 bi) bj (bpi - bj) v2 ofs2; + let n = ref (ofs2 + bpi - bj) in + for i = succ bi to pred ei do + blit_int (Array.unsafe_get v1 i) v2 !n; + n := !n + bpi + done; + blit_bits (Array.unsafe_get v1 ei) 0 (succ ej) v2 !n + end + +let blit v1 ofs1 v2 ofs2 len = + if len < 0 or ofs1 < 0 or ofs1 + len > v1.length + or ofs2 < 0 or ofs2 + len > v2.length + then invalid_arg "Bitv.blit"; + unsafe_blit v1.bits ofs1 v2.bits ofs2 len + +(*s Extracting the subvector [ofs..ofs+len-1] of [v] is just creating a + new vector of length [len] and blitting the subvector of [v] inside. *) + +let sub v ofs len = + if ofs < 0 or len < 0 or ofs + len > v.length then invalid_arg "Bitv.sub"; + let r = create len false in + unsafe_blit v.bits ofs r.bits 0 len; + r + +(*s The concatenation of two bit vectors [v1] and [v2] is obtained by + creating a vector for the result and blitting inside the two vectors. + [v1] is copied directly. *) + +let append v1 v2 = + let l1 = v1.length + and l2 = v2.length in + let r = create (l1 + l2) false in + let b1 = v1.bits in + let b2 = v2.bits in + let b = r.bits in + for i = 0 to Array.length b1 - 1 do + Array.unsafe_set b i (Array.unsafe_get b1 i) + done; + unsafe_blit b2 0 b l1 l2; + r + +(*s The concatenation of a list of bit vectors is obtained by iterating + [unsafe_blit]. *) + +let concat vl = + let size = List.fold_left (fun sz v -> sz + v.length) 0 vl in + let res = create size false in + let b = res.bits in + let pos = ref 0 in + List.iter + (fun v -> + let n = v.length in + unsafe_blit v.bits 0 b !pos n; + pos := !pos + n) + vl; + res + +(*s Filling is a particular case of blitting with a source made of all + ones or all zeros. Thus we instanciate [unsafe_blit], with 0 and + [max_int]. *) + +let blit_zeros v ofs len = + if len > 0 then + let (bi,bj) = pos ofs in + let (ei,ej) = pos (ofs + len - 1) in + if bi == ei then + blit_bits 0 bj len v ofs + else begin + blit_bits 0 bj (bpi - bj) v ofs; + let n = ref (ofs + bpi - bj) in + for i = succ bi to pred ei do + blit_int 0 v !n; + n := !n + bpi + done; + blit_bits 0 0 (succ ej) v !n + end + +let blit_ones v ofs len = + if len > 0 then + let (bi,bj) = pos ofs in + let (ei,ej) = pos (ofs + len - 1) in + if bi == ei then + blit_bits max_int bj len v ofs + else begin + blit_bits max_int bj (bpi - bj) v ofs; + let n = ref (ofs + bpi - bj) in + for i = succ bi to pred ei do + blit_int max_int v !n; + n := !n + bpi + done; + blit_bits max_int 0 (succ ej) v !n + end + +let fill v ofs len b = + if ofs < 0 or len < 0 or ofs + len > v.length then invalid_arg "Bitv.fill"; + if b then blit_ones v.bits ofs len else blit_zeros v.bits ofs len + +(*s All the iterators are implemented as for traditional arrays, using + [unsafe_get]. For [iter] and [map], we do not precompute [(f + true)] and [(f false)] since [f] is likely to have + side-effects. *) + +let iter f v = + for i = 0 to v.length - 1 do f (unsafe_get v i) done + +let map f v = + let l = v.length in + let r = create l false in + for i = 0 to l - 1 do + unsafe_set r i (f (unsafe_get v i)) + done; + r + +let iteri f v = + for i = 0 to v.length - 1 do f i (unsafe_get v i) done + +let mapi f v = + let l = v.length in + let r = create l false in + for i = 0 to l - 1 do + unsafe_set r i (f i (unsafe_get v i)) + done; + r + +let fold_left f x v = + let r = ref x in + for i = 0 to v.length - 1 do + r := f !r (unsafe_get v i) + done; + !r + +let fold_right f v x = + let r = ref x in + for i = v.length - 1 downto 0 do + r := f (unsafe_get v i) !r + done; + !r + +let foldi_left f x v = + let r = ref x in + for i = 0 to v.length - 1 do + r := f !r i (unsafe_get v i) + done; + !r + +let foldi_right f v x = + let r = ref x in + for i = v.length - 1 downto 0 do + r := f i (unsafe_get v i) !r + done; + !r + +let iteri_true f v = + Array.iteri + (fun i n -> if n != 0 then begin + let i_bpi = i * bpi in + for j = 0 to bpi - 1 do + if n land (Array.unsafe_get bit_j j) > 0 then f (i_bpi + j) + done + end) + v.bits + +(*s Bitwise operations. It is straigthforward, since bitwise operations + can be realized by the corresponding bitwise operations over integers. + However, one has to take care of normalizing the result of [bwnot] + which introduces ones in highest significant positions. *) + +let bw_and v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_and"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) land b2.(i) + done; + { length = l; bits = a } + +let bw_or v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_or"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) lor b2.(i) + done; + { length = l; bits = a } + +let bw_xor v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_xor"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) lxor b2.(i) + done; + { length = l; bits = a } + +let bw_not v = + let b = v.bits in + let n = Array.length b in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- max_int land (lnot b.(i)) + done; + let r = { length = v.length; bits = a } in + normalize r; + r + +(*s Shift operations. It is easy to reuse [unsafe_blit], although it is + probably slightly less efficient than a ad-hoc piece of code. *) + +let rec shiftl v d = + if d == 0 then + copy v + else if d < 0 then + shiftr v (-d) + else begin + let n = v.length in + let r = create n false in + if d < n then unsafe_blit v.bits 0 r.bits d (n - d); + r + end + +and shiftr v d = + if d == 0 then + copy v + else if d < 0 then + shiftl v (-d) + else begin + let n = v.length in + let r = create n false in + if d < n then unsafe_blit v.bits d r.bits 0 (n - d); + r + end + +(*s Testing for all zeros and all ones. *) + +let all_zeros v = + let b = v.bits in + let n = Array.length b in + let rec test i = + (i == n) || ((Array.unsafe_get b i == 0) && test (succ i)) + in + test 0 + +let all_ones v = + let b = v.bits in + let n = Array.length b in + let rec test i = + if i == n - 1 then + let m = v.length mod bpi in + (Array.unsafe_get b i) == (if m == 0 then max_int else low_mask.(m)) + else + ((Array.unsafe_get b i) == max_int) && test (succ i) + in + test 0 + +(*s Conversions to and from strings. *) + +let to_string v = + let n = v.length in + let s = String.make n '0' in + for i = 0 to n - 1 do + if unsafe_get v i then s.[i] <- '1' + done; + s + +let print fmt v = Format.pp_print_string fmt (to_string v) + +let of_string s = + let n = String.length s in + let v = create n false in + for i = 0 to n - 1 do + let c = String.unsafe_get s i in + if c = '1' then + unsafe_set v i true + else + if c <> '0' then invalid_arg "Bitv.of_string" + done; + v + +(*s Iteration on all bit vectors of length [n] using a Gray code. *) + +let first_set v n = + let rec lookup i = + if i = n then raise Not_found ; + if unsafe_get v i then i else lookup (i + 1) + in + lookup 0 + +let gray_iter f n = + let bv = create n false in + let rec iter () = + f bv; + unsafe_set bv 0 (not (unsafe_get bv 0)); + f bv; + let pos = succ (first_set bv n) in + if pos < n then begin + unsafe_set bv pos (not (unsafe_get bv pos)); + iter () + end + in + if n > 0 then iter () + + +(*s Coercions to/from lists of integers *) + +let of_list l = + let n = List.fold_left max 0 l in + let b = create (succ n) false in + let add_element i = + (* negative numbers are invalid *) + if i < 0 then invalid_arg "Bitv.of_list"; + unsafe_set b i true + in + List.iter add_element l; + b + +let of_list_with_length l len = + let b = create len false in + let add_element i = + if i < 0 || i >= len then invalid_arg "Bitv.of_list_with_length"; + unsafe_set b i true + in + List.iter add_element l; + b + +let to_list b = + let n = length b in + let rec make i acc = + if i < 0 then acc + else make (pred i) (if unsafe_get b i then i :: acc else acc) + in + make (pred n) [] + + +(*s To/from integers. *) + +(* [int] *) +let of_int_us i = + { length = bpi; bits = [| i land max_int |] } +let to_int_us v = + if v.length < bpi then invalid_arg "Bitv.to_int_us"; + v.bits.(0) + +let of_int_s i = + { length = succ bpi; bits = [| i land max_int; (i lsr bpi) land 1 |] } +let to_int_s v = + if v.length < succ bpi then invalid_arg "Bitv.to_int_s"; + v.bits.(0) lor (v.bits.(1) lsl bpi) + +(* [Int32] *) +let of_int32_us i = match Sys.word_size with + | 32 -> { length = 31; + bits = [| (Int32.to_int i) land max_int; + let hi = Int32.shift_right_logical i 30 in + (Int32.to_int hi) land 1 |] } + | 64 -> { length = 31; bits = [| (Int32.to_int i) land 0x7fffffff |] } + | _ -> assert false +let to_int32_us v = + if v.length < 31 then invalid_arg "Bitv.to_int32_us"; + match Sys.word_size with + | 32 -> + Int32.logor (Int32.of_int v.bits.(0)) + (Int32.shift_left (Int32.of_int (v.bits.(1) land 1)) 30) + | 64 -> + Int32.of_int (v.bits.(0) land 0x7fffffff) + | _ -> assert false + +(* this is 0xffffffff (ocaml >= 3.08 checks for literal overflow) *) +let ffffffff = (0xffff lsl 16) lor 0xffff + +let of_int32_s i = match Sys.word_size with + | 32 -> { length = 32; + bits = [| (Int32.to_int i) land max_int; + let hi = Int32.shift_right_logical i 30 in + (Int32.to_int hi) land 3 |] } + | 64 -> { length = 32; bits = [| (Int32.to_int i) land ffffffff |] } + | _ -> assert false +let to_int32_s v = + if v.length < 32 then invalid_arg "Bitv.to_int32_s"; + match Sys.word_size with + | 32 -> + Int32.logor (Int32.of_int v.bits.(0)) + (Int32.shift_left (Int32.of_int (v.bits.(1) land 3)) 30) + | 64 -> + Int32.of_int (v.bits.(0) land ffffffff) + | _ -> assert false + +(* [Int64] *) +let of_int64_us i = match Sys.word_size with + | 32 -> { length = 63; + bits = [| (Int64.to_int i) land max_int; + (let mi = Int64.shift_right_logical i 30 in + (Int64.to_int mi) land max_int); + let hi = Int64.shift_right_logical i 60 in + (Int64.to_int hi) land 1 |] } + | 64 -> { length = 63; + bits = [| (Int64.to_int i) land max_int; + let hi = Int64.shift_right_logical i 62 in + (Int64.to_int hi) land 1 |] } + | _ -> assert false +let to_int64_us v = failwith "todo" + +let of_int64_s i = failwith "todo" +let to_int64_s v = failwith "todo" + +(* [Nativeint] *) +let select_of f32 f64 = match Sys.word_size with + | 32 -> (fun i -> f32 (Nativeint.to_int32 i)) + | 64 -> (fun i -> f64 (Int64.of_nativeint i)) + | _ -> assert false +let of_nativeint_s = select_of of_int32_s of_int64_s +let of_nativeint_us = select_of of_int32_us of_int64_us +let select_to f32 f64 = match Sys.word_size with + | 32 -> (fun i -> Nativeint.of_int32 (f32 i)) + | 64 -> (fun i -> Int64.to_nativeint (f64 i)) + | _ -> assert false +let to_nativeint_s = select_to to_int32_s to_int64_s +let to_nativeint_us = select_to to_int32_us to_int64_us + + diff --git a/lib/bitv.mli b/lib/bitv.mli new file mode 100644 index 0000000..69421df --- /dev/null +++ b/lib/bitv.mli @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*s {\bf Module Bitv}. + This module implements bit vectors, as an abstract datatype [t]. + Since bit vectors are particular cases of arrays, this module provides + the same operations as the module [Array] (Sections~\ref{barray} + up to \ref{earray}). It also provides bitwise operations + (Section~\ref{bitwise}). In the following, [false] stands for the bit 0 + and [true] for the bit 1. *) + +type t + +(*s {\bf Creation, access and assignment.} \label{barray} + [(Bitv.create n b)] creates a new bit vector of length [n], + initialized with [b]. + [(Bitv.init n f)] returns a fresh vector of length [n], + with bit number [i] initialized to the result of [(f i)]. + [(Bitv.set v n b)] sets the [n]th bit of [v] to the value [b]. + [(Bitv.get v n)] returns the [n]th bit of [v]. + [Bitv.length] returns the length (number of elements) of the given + vector. *) + +val create : int -> bool -> t + +val init : int -> (int -> bool) -> t + +val set : t -> int -> bool -> unit + +val get : t -> int -> bool + +val length : t -> int + +(*s [max_length] is the maximum length of a bit vector (System dependent). *) + +val max_length : int + +(*s {\bf Copies and concatenations.} + [(Bitv.copy v)] returns a copy of [v], + that is, a fresh vector containing the same elements as + [v]. [(Bitv.append v1 v2)] returns a fresh vector containing the + concatenation of the vectors [v1] and [v2]. [Bitv.concat] is + similar to [Bitv.append], but catenates a list of vectors. *) + +val copy : t -> t + +val append : t -> t -> t + +val concat : t list -> t + +(*s {\bf Sub-vectors and filling.} + [(Bitv.sub v start len)] returns a fresh + vector of length [len], containing the bits number [start] to + [start + len - 1] of vector [v]. Raise [Invalid_argument + "Bitv.sub"] if [start] and [len] do not designate a valid + subvector of [v]; that is, if [start < 0], or [len < 0], or [start + + len > Bitv.length a]. + + [(Bitv.fill v ofs len b)] modifies the vector [v] in place, + storing [b] in elements number [ofs] to [ofs + len - 1]. Raise + [Invalid_argument "Bitv.fill"] if [ofs] and [len] do not designate + a valid subvector of [v]. + + [(Bitv.blit v1 o1 v2 o2 len)] copies [len] elements from vector + [v1], starting at element number [o1], to vector [v2], starting at + element number [o2]. It {\em does not work} correctly if [v1] and [v2] are + the same vector with the source and destination chunks overlapping. + Raise [Invalid_argument "Bitv.blit"] if [o1] and [len] do not + designate a valid subvector of [v1], or if [o2] and [len] do not + designate a valid subvector of [v2]. *) + +val sub : t -> int -> int -> t + +val fill : t -> int -> int -> bool -> unit + +val blit : t -> int -> t -> int -> int -> unit + +(*s {\bf Iterators.} \label{earray} + [(Bitv.iter f v)] applies function [f] in turn to all + the elements of [v]. Given a function [f], [(Bitv.map f v)] applies + [f] to all + the elements of [v], and builds a vector with the results returned + by [f]. [Bitv.iteri] and [Bitv.mapi] are similar to [Bitv.iter] + and [Bitv.map] respectively, but the function is applied to the + index of the element as first argument, and the element itself as + second argument. + + [(Bitv.fold_left f x v)] computes [f (... (f (f x (get v 0)) (get + v 1)) ...) (get v (n-1))], where [n] is the length of the vector + [v]. + + [(Bitv.fold_right f a x)] computes [f (get v 0) (f (get v 1) + ( ... (f (get v (n-1)) x) ...))], where [n] is the length of the + vector [v]. *) + +val iter : (bool -> unit) -> t -> unit +val map : (bool -> bool) -> t -> t + +val iteri : (int -> bool -> unit) -> t -> unit +val mapi : (int -> bool -> bool) -> t -> t + +val fold_left : ('a -> bool -> 'a) -> 'a -> t -> 'a +val fold_right : (bool -> 'a -> 'a) -> t -> 'a -> 'a +val foldi_left : ('a -> int -> bool -> 'a) -> 'a -> t -> 'a +val foldi_right : (int -> bool -> 'a -> 'a) -> t -> 'a -> 'a + +(*s [gray_iter f n] iterates function [f] on all bit vectors + of length [n], once each, using a Gray code. The order in which + bit vectors are processed is unspecified. *) + +val gray_iter : (t -> unit) -> int -> unit + +(*s {\bf Bitwise operations.} \label{bitwise} [bwand], [bwor] and + [bwxor] implement logical and, or and exclusive or. They return + fresh vectors and raise [Invalid_argument "Bitv.xxx"] if the two + vectors do not have the same length (where \texttt{xxx} is the + name of the function). [bwnot] implements the logical negation. + It returns a fresh vector. + [shiftl] and [shiftr] implement shifts. They return fresh vectors. + [shiftl] moves bits from least to most significant, and [shiftr] + from most to least significant (think [lsl] and [lsr]). + [all_zeros] and [all_ones] respectively test for a vector only + containing zeros and only containing ones. *) + +val bw_and : t -> t -> t +val bw_or : t -> t -> t +val bw_xor : t -> t -> t +val bw_not : t -> t + +val shiftl : t -> int -> t +val shiftr : t -> int -> t + +val all_zeros : t -> bool +val all_ones : t -> bool + +(*s {\bf Conversions to and from strings.} + Least significant bit comes first. *) + +val to_string : t -> string +val of_string : string -> t +val print : Format.formatter -> t -> unit + +(*s {\bf Conversions to and from lists of integers.} + The list gives the indices of bits which are set (ie [true]). *) + +val to_list : t -> int list +val of_list : int list -> t +val of_list_with_length : int list -> int -> t + +(*s Interpretation of bit vectors as integers. Least significant bit + comes first (ie is at index 0 in the bit vector). + [to_xxx] functions truncate when the bit vector is too wide, + and raise [Invalid_argument] when it is too short. + Suffix [_s] indicates that sign bit is kept, + and [_us] that it is discarded. *) + +(* type [int] (length 31/63 with sign, 30/62 without) *) +val of_int_s : int -> t +val to_int_s : t -> int +val of_int_us : int -> t +val to_int_us : t -> int +(* type [Int32.t] (length 32 with sign, 31 without) *) +val of_int32_s : Int32.t -> t +val to_int32_s : t -> Int32.t +val of_int32_us : Int32.t -> t +val to_int32_us : t -> Int32.t +(* type [Int64.t] (length 64 with sign, 63 without) *) +val of_int64_s : Int64.t -> t +val to_int64_s : t -> Int64.t +val of_int64_us : Int64.t -> t +val to_int64_us : t -> Int64.t +(* type [Nativeint.t] (length 32/64 with sign, 31/63 without) *) +val of_nativeint_s : Nativeint.t -> t +val to_nativeint_s : t -> Nativeint.t +val of_nativeint_us : Nativeint.t -> t +val to_nativeint_us : t -> Nativeint.t + +(*s Only if you know what you are doing... *) + +val unsafe_set : t -> int -> bool -> unit +val unsafe_get : t -> int -> bool diff --git a/lib/blocks.ml b/lib/blocks.ml new file mode 100644 index 0000000..4b410cc --- /dev/null +++ b/lib/blocks.ml @@ -0,0 +1,919 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Common implementation to persistent and imperative graphs. *) + +open Sig +open Util + +let first_value_for_cpt_vertex = 0 +let cpt_vertex = ref first_value_for_cpt_vertex + (* global counter for abstract vertex *) + +(* [max_cpt t1 t2] returns the maximum of [t1] and [t2] wrt the total ordering + induced by tags creation. This ordering is defined as follow: + forall tags t1 t2, + t1 <= t2 iff + t1 is before t2 in the finite sequence + [0; 1; ..; max_int; min_int; min_int-1; -1] *) +let max_cpt c1 c2 = max (c1 + min_int) (c2 + min_int) - min_int + +(* This function must be called after the unserialisation of any abstract + vertex if you want to create new vertices. *) +let after_unserialization serialized_cpt_vertex = + cpt_vertex := max_cpt serialized_cpt_vertex !cpt_vertex + +(* ************************************************************************* *) +(** {2 Association table builder} *) +(* ************************************************************************* *) + +(** Common signature to an imperative/persistent association table *) +module type HM = sig + type 'a return + type 'a t + type key + val create : ?size:int -> unit -> 'a t + val create_from : 'a t -> 'a t + val empty : 'a return + val clear: 'a t -> unit + val is_empty : 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val remove : key -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val find : key -> 'a t -> 'a + val find_and_raise : key -> 'a t -> string -> 'a + (** [find_and_raise k t s] is equivalent to [find k t] but + raises [Invalid_argument s] when [find k t] raises [Not_found] *) + val iter : (key -> 'a -> unit) -> 'a t -> unit + val map : (key -> 'a -> key * 'a) -> 'a t -> 'a t + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val copy : 'a t -> 'a t +end + +module type TBL_BUILDER = functor(X: COMPARABLE) -> HM with type key = X.t + +(** [HM] implementation using hashtbl. *) +module Make_Hashtbl(X: COMPARABLE) = struct + + include Hashtbl.Make(X) + + type 'a return = unit + let empty = () + (* never call and not visible for the user thank's to signature + constraints *) + + let create_from h = create (length h) + let create ?(size=97) () = create size + + let is_empty h = (length h = 0) + + let find_and_raise k h s = try find h k with Not_found -> invalid_arg s + + let map f h = + let h' = create_from h in + iter (fun k v -> let k, v = f k v in add h' k v) h; + h' + + let add k v h = replace h k v; h + let remove k h = remove h k; h + let mem k h = mem h k + let find k h = find h k + +end + +(** [HM] implementation using map *) +module Make_Map(X: COMPARABLE) = struct + include Map.Make(X) + type 'a return = 'a t + let is_empty m = (m = empty) + let create ?size () = assert false + (* never call and not visible for the user thank's to + signature constraints *) + let create_from _ = empty + let copy m = m + let map f m = fold (fun k v m -> let k, v = f k v in add k v m) m empty + let find_and_raise k h s = try find k h with Not_found -> invalid_arg s + let clear _ = assert false + (* never call and not visible for the user thank's to + signature constraints *) +end + +(* ************************************************************************* *) +(** {2 Blocks builder} *) +(* ************************************************************************* *) + +(** Common implementation to all (directed) graph implementations. *) +module Minimal(S: Set.S)(HM: HM) = struct + + type vertex = HM.key + + let is_directed = true + let empty = HM.empty + let create = HM.create + let is_empty = HM.is_empty + let copy = HM.copy + let clear = HM.clear + + let nb_vertex g = HM.fold (fun _ _ -> succ) g 0 + let nb_edges g = HM.fold (fun _ s n -> n + S.cardinal s) g 0 + let out_degree g v = + S.cardinal + (try HM.find v g with Not_found -> invalid_arg "[ocamlgraph] out_degree") + + let mem_vertex g v = HM.mem v g + + let unsafe_add_vertex g v = HM.add v S.empty g + let unsafe_add_edge g v1 v2 = HM.add v1 (S.add v2 (HM.find v1 g)) g + + let add_vertex g v = if HM.mem v g then g else unsafe_add_vertex g v + + let iter_vertex f = HM.iter (fun v _ -> f v) + let fold_vertex f = HM.fold (fun v _ -> f v) + +end + +(** All the predecessor operations from the iterators on the edges *) +module Pred + (S: sig + module PV: COMPARABLE + module PE: EDGE with type vertex = PV.t + type t + val mem_vertex : PV.t -> t -> bool + val iter_edges : (PV.t -> PV.t -> unit) -> t -> unit + val fold_edges : (PV.t -> PV.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_edges_e : (PE.t -> unit) -> t -> unit + val fold_edges_e : (PE.t -> 'a -> 'a) -> t -> 'a -> 'a + end) = +struct + + open S + + let iter_pred f g v = + if not (mem_vertex v g) then invalid_arg "[ocamlgraph] iter_pred"; + iter_edges (fun v1 v2 -> if PV.equal v v2 then f v1) g + + let fold_pred f g v = + if not (mem_vertex v g) then invalid_arg "[ocamlgraph] fold_pred"; + fold_edges (fun v1 v2 a -> if PV.equal v v2 then f v1 a else a) g + + let pred g v = fold_pred (fun v l -> v :: l) g v [] + + let in_degree g v = + if not (mem_vertex v g) then invalid_arg "[ocamlgraph] in_degree"; + fold_pred (fun v n -> n + 1) g v 0 + + let iter_pred_e f g v = + if not (mem_vertex v g) then invalid_arg "[ocamlgraph] iter_pred_e"; + iter_edges_e (fun e -> if PV.equal v (PE.dst e) then f e) g + + let fold_pred_e f g v = + if not (mem_vertex v g) then invalid_arg "[ocamlgraph] fold_pred_e"; + fold_edges_e (fun e a -> if PV.equal v (PE.dst e) then f e a else a) g + + let pred_e g v = fold_pred_e (fun v l -> v :: l) g v [] + +end + +(** Common implementation to all the unlabeled (directed) graphs. *) +module Unlabeled(V: COMPARABLE)(HM: HM with type key = V.t) = struct + + module S = Set.Make(V) + + module E = struct + type vertex = V.t + include OTProduct(V)(V) + let src = fst + let dst = snd + type label = unit + let label _ = () + let create v1 () v2 = v1, v2 + end + type edge = E.t + + let mem_edge g v1 v2 = + try S.mem v2 (HM.find v1 g) + with Not_found -> false + + let mem_edge_e g (v1, v2) = mem_edge g v1 v2 + + let find_edge g v1 v2 = if mem_edge g v1 v2 then v1, v2 else raise Not_found + let find_all_edges g v1 v2 = try [ find_edge g v1 v2 ] with Not_found -> [] + + let unsafe_remove_edge g v1 v2 = HM.add v1 (S.remove v2 (HM.find v1 g)) g + let unsafe_remove_edge_e g (v1, v2) = unsafe_remove_edge g v1 v2 + + let remove_edge g v1 v2 = + if not (HM.mem v2 g) then invalid_arg "[ocamlgraph] remove_edge"; + HM.add + v1 (S.remove v2 (HM.find_and_raise v1 g "[ocamlgraph] remove_edge")) g + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + let iter_succ f g v = + S.iter f (HM.find_and_raise v g "[ocamlgraph] iter_succ") + + let fold_succ f g v = + S.fold f (HM.find_and_raise v g "[ocamlgraph] fold_succ") + + let iter_succ_e f g v = iter_succ (fun v2 -> f (v, v2)) g v + let fold_succ_e f g v = fold_succ (fun v2 -> f (v, v2)) g v + + let succ g v = S.elements (HM.find_and_raise v g "[ocamlgraph] succ") + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map (fun v s -> f v, S.fold (fun v s -> S.add (f v) s) s S.empty) + + module I = struct + type t = S.t HM.t + module PV = V + module PE = E + let iter_edges f = HM.iter (fun v -> S.iter (f v)) + let fold_edges f = HM.fold (fun v -> S.fold (f v)) + let iter_edges_e f = iter_edges (fun v1 v2 -> f (v1, v2)) + let fold_edges_e f = fold_edges (fun v1 v2 a -> f (v1, v2) a) + end + include I + + include Pred(struct include I let mem_vertex = HM.mem end) + +end + +(** Common implementation to all the labeled (directed) graphs. *) +module Labeled(V: COMPARABLE)(E: ORDERED_TYPE)(HM: HM with type key = V.t) = +struct + + module VE = OTProduct(V)(E) + module S = Set.Make(VE) + + module E = struct + type vertex = V.t + type label = E.t + type t = vertex * label * vertex + let src (v, _, _) = v + let dst (_, _, v) = v + let label (_, l, _) = l + let create v1 l v2 = v1, l, v2 + module C = OTProduct(V)(VE) + let compare (x1, x2, x3) (y1, y2, y3) = + C.compare (x1, (x3, x2)) (y1, (y3, y2)) + end + type edge = E.t + + let mem_edge g v1 v2 = + try S.exists (fun (v2', _) -> V.equal v2 v2') (HM.find v1 g) + with Not_found -> false + + let mem_edge_e g (v1, l, v2) = + try + let ve = v2, l in + S.exists (fun ve' -> VE.compare ve ve' = 0) (HM.find v1 g) + with Not_found -> + false + + exception Found of edge + let find_edge g v1 v2 = + try + S.iter + (fun (v2', l) -> if V.equal v2 v2' then raise (Found (v1, l, v2'))) + (HM.find v1 g); + raise Not_found + with Found e -> + e + + let find_all_edges g v1 v2 = + try + S.fold + (fun (v2', l) acc -> + if V.equal v2 v2' then (v1, l, v2') :: acc else acc) + (HM.find v1 g) + [] + with Not_found -> + [] + + let unsafe_remove_edge g v1 v2 = + HM.add + v1 + (S.filter (fun (v2', _) -> not (V.equal v2 v2')) (HM.find v1 g)) + g + + let unsafe_remove_edge_e g (v1, l, v2) = + HM.add v1 (S.remove (v2, l) (HM.find v1 g)) g + + let remove_edge g v1 v2 = + if not (HM.mem v2 g) then invalid_arg "[ocamlgraph] remove_edge"; + HM.add + v1 + (S.filter + (fun (v2', _) -> not (V.equal v2 v2')) + (HM.find_and_raise v1 g "[ocamlgraph] remove_edge")) + g + + let remove_edge_e g (v1, l, v2) = + if not (HM.mem v2 g) then invalid_arg "[ocamlgraph] remove_edge_e"; + HM.add + v1 + (S.remove (v2, l) (HM.find_and_raise v1 g "[ocamlgraph] remove_edge_e")) + g + + let iter_succ f g v = + S.iter (fun (w, _) -> f w) (HM.find_and_raise v g "[ocamlgraph] iter_succ") + let fold_succ f g v = + S.fold (fun (w, _) -> f w) (HM.find_and_raise v g "[ocamlgraph] fold_succ") + + let iter_succ_e f g v = + S.iter + (fun (w, l) -> f (v, l, w)) + (HM.find_and_raise v g "[ocamlgraph] iter_succ_e") + + let fold_succ_e f g v = + S.fold + (fun (w, l) -> f (v, l, w)) + (HM.find_and_raise v g "[ocamlgraph] fold_succ_e") + + let succ g v = fold_succ (fun w l -> w :: l) g v [] + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map + (fun v s -> f v, S.fold (fun (v, l) s -> S.add (f v, l) s) s S.empty) + + module I = struct + type t = S.t HM.t + module PV = V + module PE = E + let iter_edges f = HM.iter (fun v -> S.iter (fun (w, _) -> f v w)) + let fold_edges f = HM.fold (fun v -> S.fold (fun (w, _) -> f v w)) + let iter_edges_e f = + HM.iter (fun v -> S.iter (fun (w, l) -> f (v, l, w))) + let fold_edges_e f = + HM.fold (fun v -> S.fold (fun (w, l) -> f (v, l, w))) + end + include I + + include Pred(struct include I let mem_vertex = HM.mem end) + +end + +(** The vertex module and the vertex table for the concrete graphs. *) +module ConcreteVertex(F : TBL_BUILDER)(V: COMPARABLE) = struct + module V = struct + include V + type label = t + let label v = v + let create v = v + end + module HM = F(V) +end + +module Make_Abstract + (G: sig + module HM: HM + module S: Set.S + include G with type t = S.t HM.t and type V.t = HM.key + val remove_edge: t -> vertex -> vertex -> t + val remove_edge_e: t -> edge -> t + val unsafe_add_vertex: t -> vertex -> t + val unsafe_add_edge: t -> vertex -> S.elt -> t + val unsafe_remove_edge: t -> vertex -> vertex -> t + val unsafe_remove_edge_e: t -> edge -> t + val create: ?size:int -> unit -> t + val clear: t -> unit + end) = +struct + + module I = struct + type t = { edges : G.t; mutable size : int } + (* BE CAREFUL: [size] is only mutable in the imperative version. As + there is no extensible records in current ocaml version, and for + genericity purpose, [size] is mutable in both imperative and + persistent implementations. + Do not modify size in the persistent implementation! *) + + type vertex = G.vertex + type edge = G.edge + + module PV = G.V + module PE = G.E + + let iter_edges f g = G.iter_edges f g.edges + let fold_edges f g = G.fold_edges f g.edges + let iter_edges_e f g = G.iter_edges_e f g.edges + let fold_edges_e f g = G.fold_edges_e f g.edges + let mem_vertex v g = G.mem_vertex g.edges v + let create ?size () = { edges = G.create ?size (); size = 0 } + let clear g = G.clear g.edges; g.size <- 0 + end + include I + + include Pred(I) + + (* optimisations *) + + let is_empty g = g.size = 0 + let nb_vertex g = g.size + + (* redefinitions *) + module V = G.V + module E = G.E + module HM = G.HM + module S = G.S + + let unsafe_add_edge = G.unsafe_add_edge + let unsafe_remove_edge = G.unsafe_remove_edge + let unsafe_remove_edge_e = G.unsafe_remove_edge_e + let is_directed = G.is_directed + + let remove_edge g = G.remove_edge g.edges + let remove_edge_e g = G.remove_edge_e g.edges + + let out_degree g = G.out_degree g.edges + let in_degree g = G.in_degree g.edges + + let nb_edges g = G.nb_edges g.edges + let succ g = G.succ g.edges + let mem_vertex g = G.mem_vertex g.edges + let mem_edge g = G.mem_edge g.edges + let mem_edge_e g = G.mem_edge_e g.edges + let find_edge g = G.find_edge g.edges + let find_all_edges g = G.find_all_edges g.edges + + let iter_vertex f g = G.iter_vertex f g.edges + let fold_vertex f g = G.fold_vertex f g.edges + let iter_succ f g = G.iter_succ f g.edges + let fold_succ f g = G.fold_succ f g.edges + let succ_e g = G.succ_e g.edges + let iter_succ_e f g = G.iter_succ_e f g.edges + let fold_succ_e f g = G.fold_succ_e f g.edges + let map_vertex f g = { g with edges = G.map_vertex f g.edges } + + (* reimplementation *) + + let copy g = + let h = HM.create () in + let vertex v = + try + HM.find v h + with Not_found -> + let v' = V.create (V.label v) in + let h' = HM.add v v' h in + assert (h == h'); + v' + in + map_vertex vertex g + +end + +(** Support for explicitly maintaining edge set of + predecessors. Crucial for algorithms that do a lot of backwards + traversal. *) + +module BidirectionalMinimal(S:Set.S)(HM:HM) = struct + + type vertex = HM.key + + let is_directed = true + let empty = HM.empty + let create = HM.create + let clear = HM.clear + let is_empty = HM.is_empty + let copy = HM.copy + + let nb_vertex g = HM.fold (fun _ _ -> succ) g 0 + let nb_edges g = HM.fold (fun _ (_,s) n -> n + S.cardinal s) g 0 + let out_degree g v = + S.cardinal + (snd (try HM.find v g + with Not_found -> invalid_arg "[ocamlgraph] out_degree")) + + let mem_vertex g v = HM.mem v g + + let unsafe_add_vertex g v = HM.add v (S.empty, S.empty) g + let add_vertex g v = if HM.mem v g then g else unsafe_add_vertex g v + + let iter_vertex f = HM.iter (fun v _ -> f v) + let fold_vertex f = HM.fold (fun v _ -> f v) + +end + +module BidirectionalUnlabeled(V:COMPARABLE)(HM:HM with type key = V.t) = struct + + module S = Set.Make(V) + + module E = struct + type vertex = V.t + include OTProduct(V)(V) + let src = fst + let dst = snd + type label = unit + let label _ = () + let create v1 () v2 = v1, v2 + end + type edge = E.t + + let mem_edge g v1 v2 = + try S.mem v2 (snd (HM.find v1 g)) + with Not_found -> false + + let mem_edge_e g (v1,v2) = mem_edge g v1 v2 + + let find_edge g v1 v2 = if mem_edge g v1 v2 then v1, v2 else raise Not_found + let find_all_edges g v1 v2 = try [ find_edge g v1 v2 ] with Not_found -> [] + + let unsafe_remove_edge g v1 v2 = + let in_set, out_set = HM.find v1 g in + let g = HM.add v1 (in_set, S.remove v2 out_set) g in + let in_set, out_set = HM.find v2 g in + HM.add v2 (S.remove v1 in_set, out_set) g + + let unsafe_remove_edge_e g (v1,v2) = unsafe_remove_edge g v1 v2 + + let remove_edge g v1 v2 = + if not (HM.mem v2 g && HM.mem v1 g) then + invalid_arg "[ocamlgraph] remove_edge"; + unsafe_remove_edge g v1 v2 + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + let iter_succ f g v = + S.iter f (snd (HM.find_and_raise v g "[ocamlgraph] iter_succ")) + + let fold_succ f g v = + S.fold f (snd (HM.find_and_raise v g "[ocamlgraph] fold_succ")) + + let iter_succ_e f g v = iter_succ (fun v2 -> f (v, v2)) g v + let fold_succ_e f g v = fold_succ (fun v2 -> f (v, v2)) g v + + let succ g v = S.elements (snd (HM.find_and_raise v g "[ocamlgraph] succ")) + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map + (fun v (s1,s2) -> + f v, + (S.fold (fun v s -> S.add (f v) s) s1 S.empty, + S.fold (fun v s -> S.add (f v) s) s2 S.empty)) + + module I = struct + (* we keep sets for both incoming and outgoing edges *) + type t = (S.t (* incoming *) * S.t (* outgoing *)) HM.t + module PV = V + module PE = E + let iter_edges f = HM.iter (fun v (_, outset) -> S.iter (f v) outset) + let fold_edges f = HM.fold (fun v (_, outset) -> S.fold (f v) outset) + let iter_edges_e f = iter_edges (fun v1 v2 -> f (v1, v2)) + let fold_edges_e f = fold_edges (fun v1 v2 a -> f (v1, v2) a) + end + include I + + let iter_pred f g v = + S.iter f (fst (HM.find_and_raise v g "[ocamlgraph] iter_pred")) + + let fold_pred f g v = + S.fold f (fst (HM.find_and_raise v g "[ocamlgraph] fold_pred")) + + let pred g v = S.elements (fst (HM.find_and_raise v g "[ocamlgraph] pred")) + + let in_degree g v = + S.cardinal + (fst (try HM.find v g + with Not_found -> invalid_arg "[ocamlgraph] in_degree")) + + let iter_pred_e f g v = iter_pred (fun v2 -> f (v2, v)) g v + let fold_pred_e f g v = fold_pred (fun v2 -> f (v2, v)) g v + + let pred_e g v = fold_pred_e (fun e l -> e :: l) g v [] + +end + +module BidirectionalLabeled + (V:COMPARABLE)(E:ORDERED_TYPE)(HM:HM with type key = V.t) = +struct + + module VE = OTProduct(V)(E) + module S = Set.Make(VE) + + module E = struct + type vertex = V.t + type label = E.t + type t = vertex * label * vertex + let src (v, _, _) = v + let dst (_, _, v) = v + let label (_, l, _) = l + let create v1 l v2 = v1, l, v2 + module C = OTProduct(V)(VE) + let compare (x1, x2, x3) (y1, y2, y3) = + C.compare (x1, (x3, x2)) (y1, (y3, y2)) + end + type edge = E.t + + let mem_edge g v1 v2 = + try S.exists (fun (v2', _) -> V.equal v2 v2') (snd (HM.find v1 g)) + with Not_found -> false + + let mem_edge_e g (v1, l, v2) = + try + let ve = v2, l in + S.exists (fun ve' -> VE.compare ve ve' = 0) (snd (HM.find v1 g)) + with Not_found -> + false + + exception Found of edge + let find_edge g v1 v2 = + try + S.iter + (fun (v2', l) -> if V.equal v2 v2' then raise (Found (v1, l, v2'))) + (snd (HM.find v1 g)); + raise Not_found + with Found e -> + e + + let find_all_edges g v1 v2 = + try + S.fold + (fun (v2', l) acc -> + if V.equal v2 v2' then (v1, l, v2') :: acc else acc) + (snd (HM.find v1 g)) + [] + with Not_found -> + [] + + let unsafe_remove_edge g v1 v2 = + let in_set, out_set = HM.find v1 g in + let del v set = S.filter (fun (v', _) -> not (V.equal v v')) set in + let g = HM.add v1 (in_set, del v2 out_set) g in + let in_set, out_set = HM.find v2 g in + HM.add v2 (del v1 in_set, out_set) g + + let unsafe_remove_edge_e g (v1, l, v2) = + let in_set, out_set = HM.find v1 g in + let g = HM.add v1 (in_set, S.remove (v2, l) out_set) g in + let in_set, out_set = HM.find v2 g in + HM.add v2 (S.remove (v1, l) in_set, out_set) g + + let remove_edge g v1 v2 = +(* if not (HM.mem v2 g) then invalid_arg "[ocamlgraph] remove_edge";*) + let in_set, out_set = HM.find_and_raise v1 g "[ocamlgraph] remove_edge" in + let del v set = S.filter (fun (v', _) -> not (V.equal v v')) set in + let g = HM.add v1 (in_set, del v2 out_set) g in + let in_set, out_set = HM.find_and_raise v2 g "[ocamlgraph] remove_edge" in + HM.add v2 (del v1 in_set, out_set) g + + let remove_edge_e g (v1, l, v2) = +(* if not (HM.mem v2 g) then invalid_arg "[ocamlgraph] remove_edge_e";*) + let in_set, out_set = HM.find_and_raise v1 g "[ocamlgraph] remove_edge_e" in + let g = HM.add v1 (in_set, S.remove (v2, l) out_set) g in + let in_set, out_set = HM.find_and_raise v2 g "[ocamlgraph] remove_edge_e" in + HM.add v2 (S.remove (v1, l) in_set, out_set) g + + let iter_succ f g v = + S.iter + (fun (w, _) -> f w) + (snd (HM.find_and_raise v g "[ocamlgraph] iter_succ")) + + let fold_succ f g v = + S.fold + (fun (w, _) -> f w) + (snd (HM.find_and_raise v g "[ocamlgraph] fold_succ")) + + let iter_succ_e f g v = + S.iter + (fun (w, l) -> f (v, l, w)) + (snd (HM.find_and_raise v g "[ocamlgraph] iter_succ_e")) + + let fold_succ_e f g v = + S.fold + (fun (w, l) -> f (v, l, w)) + (snd (HM.find_and_raise v g "[ocamlgraph] fold_succ_e")) + + let succ g v = fold_succ (fun w l -> w :: l) g v [] + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map + (fun v (s1,s2) -> + f v, + (S.fold (fun (v, l) s -> S.add (f v, l) s) s1 S.empty, + S.fold (fun (v, l) s -> S.add (f v, l) s) s2 S.empty)) + + module I = struct + type t = (S.t * S.t) HM.t + module PV = V + module PE = E + let iter_edges f = HM.iter (fun v (_,outset) -> + S.iter (fun (w, _) -> f v w) outset) + let fold_edges f = HM.fold (fun v (_,outset) -> + S.fold (fun (w, _) -> f v w) outset) + let iter_edges_e f = HM.iter (fun v (_,outset) -> + S.iter (fun (w, l) -> f (v, l, w)) outset) + let fold_edges_e f = HM.fold (fun v (_,outset) -> + S.fold (fun (w, l) -> f (v, l, w)) outset) + end + include I + + let iter_pred f g v = + S.iter + (fun (w, _) -> f w) + (fst (HM.find_and_raise v g "[ocamlgraph] iter_pred")) + + let fold_pred f g v = + S.fold + (fun (w, _) -> f w) + (fst (HM.find_and_raise v g "[ocamlgraph] fold_pred")) + + let in_degree g v = + S.cardinal + (fst (try HM.find v g + with Not_found -> invalid_arg "[ocamlgraph] in_degree")) + + let iter_pred_e f g v = + S.iter + (fun (w, l) -> f (w, l, v)) + (fst (HM.find_and_raise v g "[ocamlgraph] iter_pred_e")) + + let fold_pred_e f g v = + S.fold + (fun (w, l) -> f (w, l, v)) + (fst (HM.find_and_raise v g "[ocamlgraph] fold_pred_e")) + + let pred g v = fold_pred (fun w l -> w :: l) g v [] + let pred_e g v = fold_pred_e (fun e l -> e :: l) g v [] + +end + +(** Build persistent (resp. imperative) graphs from a persistent (resp. + imperative) association table *) +module Make(F : TBL_BUILDER) = struct + + module Digraph = struct + + module Concrete(V: COMPARABLE) = struct + + include ConcreteVertex(F)(V) + include Unlabeled(V)(HM) + include Minimal(S)(HM) + + let add_edge g v1 v2 = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + unsafe_add_edge g v1 v2 + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + end + + module ConcreteBidirectional(V: COMPARABLE) = struct + + include ConcreteVertex(F)(V) + include BidirectionalUnlabeled(V)(HM) + include BidirectionalMinimal(S)(HM) + + let unsafe_add_edge g v1 v2 = + let in_set, out_set = HM.find v1 g in + let g = HM.add v1 (in_set,S.add v2 out_set) g in + let in_set, out_set = HM.find v2 g in + HM.add v2 (S.add v1 in_set,out_set) g + + let add_edge g v1 v2 = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + unsafe_add_edge g v1 v2 + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + end + + module ConcreteLabeled(V: COMPARABLE)(Edge: ORDERED_TYPE_DFT) = struct + + include ConcreteVertex(F)(V) + include Labeled(V)(Edge)(HM) + include Minimal(S)(HM) + + let add_edge_e g (v1, l, v2) = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + unsafe_add_edge g v1 (v2, l) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + end + + module ConcreteBidirectionalLabeled + (V: COMPARABLE)(Edge: ORDERED_TYPE_DFT) = + struct + + include ConcreteVertex(F)(V) + include BidirectionalLabeled(V)(Edge)(HM) + include BidirectionalMinimal(S)(HM) + + let unsafe_add_edge_e g (v1, l, v2) = + let in_set, out_set = HM.find v1 g in + let g = HM.add v1 (in_set,S.add (v2,l) out_set) g in + let in_set, out_set = HM.find v2 g in + HM.add v2 (S.add (v1,l) in_set,out_set) g + + let unsafe_add_edge g v1 v2 = + unsafe_add_edge_e g (v1, Edge.default, v2) + + let add_edge_e g (v1, l, v2) = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + unsafe_add_edge_e g (v1, l, v2) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + end + + module Abstract(V: VERTEX) = struct + module G = struct + module V = V + module HM = F(V) + include Unlabeled(V)(HM) + include Minimal(S)(HM) + end + include Make_Abstract(G) + end + + module AbstractLabeled(V: VERTEX)(E: ORDERED_TYPE_DFT) = struct + module G = struct + module V = V + module HM = F(V) + include Labeled(V)(E)(HM) + include Minimal(S)(HM) + end + include Make_Abstract(G) + end + + end + +end + +(** Implementation of undirected graphs from implementation of directed + graphs. *) +module Graph + (G: sig + include Sig.G + val create: ?size:int -> unit -> t + val clear: t -> unit + val copy: t -> t + type return + val add_vertex: t -> vertex -> return + val remove_vertex: t -> vertex -> return + end) = +struct + + include G + + let is_directed = false + + (* Redefine iterators and [nb_edges]. *) + + let iter_edges f = + iter_edges (fun v1 v2 -> if V.compare v1 v2 >= 0 then f v1 v2) + + let fold_edges f = + fold_edges + (fun v1 v2 acc -> if V.compare v1 v2 >= 0 then f v1 v2 acc else acc) + + let iter_edges_e f = + iter_edges_e (fun e -> if V.compare (E.src e) (E.dst e) >= 0 then f e) + + let fold_edges_e f = + fold_edges_e + (fun e acc -> + if V.compare (E.src e) (E.dst e) >= 0 then f e acc else acc) + + let nb_edges g = fold_edges_e (fun _ -> (+) 1) g 0 + + (* Redefine operations on predecessors: + predecessors are successors in an undirected graph. *) + + let pred = succ + let in_degree = out_degree + let iter_pred = iter_succ + let fold_pred = fold_succ + let pred_e = succ_e + let iter_pred_e = iter_succ_e + let fold_pred_e = fold_succ_e + +end + +(* +Local Variables: +compile-command: "make -C .." +End: +*) diff --git a/lib/components.ml b/lib/components.ml new file mode 100644 index 0000000..04de431 --- /dev/null +++ b/lib/components.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: components.ml,v 1.9 2004-10-22 14:42:06 signoles Exp $ *) + +open Util + +module type G = sig + type t + module V : Sig.COMPARABLE + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit +end + +module Make(G: G) = struct + + module H = Hashtbl.Make(G.V) + + let scc g = + let root = H.create 997 in + let hashcomp = H.create 997 in + let stack = ref [] in + let numdfs = ref 0 in + let numcomp = ref 0 in + let rec pop x = function + | (y, w) :: l when y > x -> + H.add hashcomp w !numcomp; + pop x l + | l -> l + in + let rec visit v = + if not (H.mem root v) then begin + let n = incr numdfs; !numdfs in + H.add root v n; + G.iter_succ + (fun w -> + visit w; + if not (H.mem hashcomp w) then + H.replace root v (min (H.find root v) (H.find root w))) + g v; + if H.find root v = n then begin + H.add hashcomp v !numcomp; + let s = pop n !stack in + stack:= s; + incr numcomp + end else + stack := (n,v) :: !stack; + end + in + G.iter_vertex visit g; + !numcomp, (fun v -> H.find hashcomp v) + + let scc_array g = + let n,f = scc g in + let t = Array.make n [] in + G.iter_vertex (fun v -> let i = f v in t.(i) <- v :: t.(i)) g; + t + + let scc_list g = + let _,scc = scc g in + let tbl = Hashtbl.create 97 in + G.iter_vertex + (fun v -> + let n = scc v in + try + let l = Hashtbl.find tbl n in + l := v :: !l + with Not_found -> + Hashtbl.add tbl n (ref [ v ])) + g; + Hashtbl.fold (fun _ v l -> !v :: l) tbl [] + +end diff --git a/lib/components.mli b/lib/components.mli new file mode 100644 index 0000000..b1e380c --- /dev/null +++ b/lib/components.mli @@ -0,0 +1,58 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: components.mli,v 1.12 2004-10-22 14:42:06 signoles Exp $ *) + +(** Strongly connected components. *) + +(** Minimal graph signature required by {!Make}. + Sub-signature of {!Sig.G}. *) +module type G = sig + type t + module V : Sig.COMPARABLE + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit +end + +(** Functor providing functions to compute strongly connected components of a + graph. *) +module Make (G: G) : sig + + val scc : G.t -> int * (G.V.t -> int) + (** [scc g] computes the strongly connected components of [g]. + The result is a pair [(n,f)] where [n] is the number of + components. Components are numbered from [0] to [n-1], and + [f] is a function mapping each vertex to its component + number. In particular, [f u = f v] if and only if [u] and + [v] are in the same component. Another property of the + numbering is that components are numbered in a topological + order: if there is an arc from [u] to [v], then [f u >= f u] + + Not tail-recursive. + Complexity: O(V+E) + The function returned has complexity O(1) *) + + val scc_array : G.t -> G.V.t list array + (** [scc_array] computes the strongly connected components of [g]. + Components are stored in the resulting array, indexed with a + numbering with the same properties as for [scc] above. *) + + val scc_list : G.t -> G.V.t list list + (** [scc_list] computes the strongly connected components of [g]. + The result is a partition of the set of the vertices of [g]. *) + +end diff --git a/lib/heap.ml b/lib/heap.ml new file mode 100644 index 0000000..0079109 --- /dev/null +++ b/lib/heap.ml @@ -0,0 +1,236 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id:$ *) + +module type Ordered = sig + type t + val compare : t -> t -> int +end + +exception EmptyHeap + +(*s Imperative implementation *) + +module Imperative(X : Ordered) = struct + + (* The heap is encoded in the array [data], where elements are stored + from [0] to [size - 1]. From an element stored at [i], the left + (resp. right) subtree, if any, is rooted at [2*i+1] (resp. [2*i+2]). *) + + type t = { mutable size : int; mutable data : X.t array } + + (* When [create n] is called, we cannot allocate the array, since there is + no known value of type [X.t]; we'll wait for the first addition to + do it, and we remember this situation with a negative size. *) + + let create n = + if n <= 0 then invalid_arg "create"; + { size = -n; data = [||] } + + let is_empty h = h.size <= 0 + + (* [resize] doubles the size of [data] *) + + let resize h = + let n = h.size in + assert (n > 0); + let n' = 2 * n in + let d = h.data in + let d' = Array.create n' d.(0) in + Array.blit d 0 d' 0 n; + h.data <- d' + + let add h x = + (* first addition: we allocate the array *) + if h.size < 0 then begin + h.data <- Array.create (- h.size) x; h.size <- 0 + end; + let n = h.size in + (* resizing if needed *) + if n == Array.length h.data then resize h; + let d = h.data in + (* moving [x] up in the heap *) + let rec moveup i = + let fi = (i - 1) / 2 in + if i > 0 && X.compare d.(fi) x < 0 then begin + d.(i) <- d.(fi); + moveup fi + end else + d.(i) <- x + in + moveup n; + h.size <- n + 1 + + let maximum h = + if h.size <= 0 then raise EmptyHeap; + h.data.(0) + + let remove h = + if h.size <= 0 then raise EmptyHeap; + let n = h.size - 1 in + h.size <- n; + let d = h.data in + let x = d.(n) in + (* moving [x] down in the heap *) + let rec movedown i = + let j = 2 * i + 1 in + if j < n then + let j = + let j' = j + 1 in + if j' < n && X.compare d.(j') d.(j) > 0 then j' else j + in + if X.compare d.(j) x > 0 then begin + d.(i) <- d.(j); + movedown j + end else + d.(i) <- x + else + d.(i) <- x + in + movedown 0 + + let pop_maximum h = let m = maximum h in remove h; m + + let iter f h = + let d = h.data in + for i = 0 to h.size - 1 do f d.(i) done + + let fold f h x0 = + let n = h.size in + let d = h.data in + let rec foldrec x i = + if i >= n then x else foldrec (f d.(i) x) (succ i) + in + foldrec x0 0 + +end + + +(*s Functional implementation *) + +module type FunctionalSig = sig + type elt + type t + val empty : t + val add : elt -> t -> t + val maximum : t -> elt + val remove : t -> t + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a +end + +module Functional(X : Ordered) = struct + + (* Heaps are encoded as complete binary trees, i.e., binary trees + which are full expect, may be, on the bottom level where it is filled + from the left. + These trees also enjoy the heap property, namely the value of any node + is greater or equal than those of its left and right subtrees. + + There are 4 kinds of complete binary trees, denoted by 4 constructors: + [FFF] for a full binary tree (and thus 2 full subtrees); + [PPF] for a partial tree with a partial left subtree and a full + right subtree; + [PFF] for a partial tree with a full left subtree and a full right subtree + (but of different heights); + and [PFP] for a partial tree with a full left subtree and a partial + right subtree. *) + + type elt = X.t + + type t = + | Empty + | FFF of t * X.t * t (* full (full, full) *) + | PPF of t * X.t * t (* partial (partial, full) *) + | PFF of t * X.t * t (* partial (full, full) *) + | PFP of t * X.t * t (* partial (full, partial) *) + + let empty = Empty + + (* smart constructors for insertion *) + let p_f l x r = match l with + | Empty | FFF _ -> PFF (l, x, r) + | _ -> PPF (l, x, r) + + let pf_ l x = function + | Empty | FFF _ as r -> FFF (l, x, r) + | r -> PFP (l, x, r) + + let rec add x = function + | Empty -> + FFF (Empty, x, Empty) + (* insertion to the left *) + | FFF (l, y, r) | PPF (l, y, r) -> + if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r + (* insertion to the right *) + | PFF (l, y, r) | PFP (l, y, r) -> + if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r) + + let maximum = function + | Empty -> raise EmptyHeap + | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x + + (* smart constructors for removal; note that they are different + from the ones for insertion! *) + let p_f l x r = match l with + | Empty | FFF _ -> FFF (l, x, r) + | _ -> PPF (l, x, r) + + let pf_ l x = function + | Empty | FFF _ as r -> PFF (l, x, r) + | r -> PFP (l, x, r) + + let rec remove = function + | Empty -> + raise EmptyHeap + | FFF (Empty, _, Empty) -> + Empty + | PFF (l, _, Empty) -> + l + (* remove on the left *) + | PPF (l, x, r) | PFF (l, x, r) -> + let xl = maximum l in + let xr = maximum r in + let l' = remove l in + if X.compare xl xr >= 0 then + p_f l' xl r + else + p_f l' xr (add xl (remove r)) + (* remove on the right *) + | FFF (l, x, r) | PFP (l, x, r) -> + let xl = maximum l in + let xr = maximum r in + let r' = remove r in + if X.compare xl xr > 0 then + pf_ (add xr (remove l)) xl r' + else + pf_ l xr r' + + let rec iter f = function + | Empty -> + () + | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> + iter f l; f x; iter f r + + let rec fold f h x0 = match h with + | Empty -> + x0 + | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> + fold f l (fold f r (f x x0)) + +end diff --git a/lib/heap.mli b/lib/heap.mli new file mode 100644 index 0000000..701a4b5 --- /dev/null +++ b/lib/heap.mli @@ -0,0 +1,99 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + + +module type Ordered = sig + type t + val compare : t -> t -> int +end + +exception EmptyHeap + +(*S Imperative implementation. *) + +module Imperative(X: Ordered) : sig + + (* Type of imperative heaps. + (In the following [n] refers to the number of elements in the heap) *) + + type t + + (* [create c] creates a new heap, with initial capacity of [c] *) + val create : int -> t + + (* [is_empty h] checks the emptiness of [h] *) + val is_empty : t -> bool + + (* [add x h] adds a new element [x] in heap [h]; size of [h] is doubled + when maximum capacity is reached; complexity $O(log(n))$ *) + val add : t -> X.t -> unit + + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(1)$ *) + val maximum : t -> X.t + + (* [remove h] removes the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(log(n))$ *) + val remove : t -> unit + + (* [pop_maximum h] removes the maximum element of [h] and returns it; + raises [EmptyHeap] when [h] is empty; complexity $O(log(n))$ *) + val pop_maximum : t -> X.t + + (* usual iterators and combinators; elements are presented in + arbitrary order *) + val iter : (X.t -> unit) -> t -> unit + + val fold : (X.t -> 'a -> 'a) -> t -> 'a -> 'a + +end + +(*S Functional implementation. *) + +module type FunctionalSig = sig + + (* heap elements *) + type elt + + (* Type of functional heaps *) + type t + + (* The empty heap *) + val empty : t + + (* [add x h] returns a new heap containing the elements of [h], plus [x]; + complexity $O(log(n))$ *) + val add : elt -> t -> t + + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(1)$ *) + val maximum : t -> elt + + (* [remove h] returns a new heap containing the elements of [h], except + the maximum of [h]; raises [EmptyHeap] when [h] is empty; + complexity $O(log(n))$ *) + val remove : t -> t + + (* usual iterators and combinators; elements are presented in + arbitrary order *) + val iter : (elt -> unit) -> t -> unit + + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + +end + +module Functional(X: Ordered) : FunctionalSig with type elt = X.t diff --git a/lib/imperative.ml b/lib/imperative.ml new file mode 100644 index 0000000..d18c944 --- /dev/null +++ b/lib/imperative.ml @@ -0,0 +1,665 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +open Sig +open Blocks + +module type S = sig + + (** Imperative Unlabeled Graphs *) + module Concrete (V: COMPARABLE) : + Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t + and type E.label = unit + + (** Abstract Imperative Unlabeled Graphs *) + module Abstract(V: sig type t end) : + Sig.IM with type V.label = V.t and type E.label = unit + and type E.label = unit + + (** Imperative Labeled Graphs *) + module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : + Sig.I with type V.t = V.t and type V.label = V.t + and type E.t = V.t * E.t * V.t and type E.label = E.t + + (** Abstract Imperative Labeled Graphs *) + module AbstractLabeled (V: sig type t end)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + +end + +module I = Make(Make_Hashtbl) + +type 'a abstract_vertex = { tag : int; label : 'a; mutable mark : int } + +(* Implement module type [MARK]. *) +module Make_Mark + (X: sig + type graph + type label + val iter_vertex : (label abstract_vertex -> unit) -> graph -> unit + end) = +struct + type vertex = X.label abstract_vertex + type graph = X.graph + let get v = v.mark + let set v m = v.mark <- m + let clear g = X.iter_vertex (fun v -> set v 0) g +end + +(* Vertex for abstract imperative graphs: + comparing to vertex for abstract **persistent** graphs, marks are added. *) +module AbstractVertex(V: sig type t end) = struct + type label = V.t + type t = label abstract_vertex + let compare x y = Pervasives.compare x.tag y.tag + let hash x = x.tag + let equal x y = x.tag = y.tag + let label x = x.label + let create l = + if !cpt_vertex = first_value_for_cpt_vertex - 1 then + invalid_arg "Too much vertices"; + incr cpt_vertex; + { tag = !cpt_vertex; label = l; mark = 0 } +end + +module Digraph = struct + + module Concrete(V: COMPARABLE) = struct + include I.Digraph.Concrete(V) + let add_vertex g v = ignore (add_vertex g v) + let add_edge g v1 v2 = ignore (add_edge g v1 v2) + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + let add_edge_e g e = ignore (add_edge_e g e) + let remove_vertex g v = + if HM.mem v g then begin + ignore (HM.remove v g); + HM.iter (fun k s -> ignore (HM.add k (S.remove v s) g)) g + end + end + + module ConcreteLabeled(V: COMPARABLE)(E: ORDERED_TYPE_DFT) = struct + include I.Digraph.ConcreteLabeled(V)(E) + let add_vertex g v = ignore (add_vertex g v) + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + let add_edge_e g e = ignore (add_edge_e g e) + let add_edge g v1 v2 = ignore (add_edge g v1 v2) + let remove_vertex g v = + if HM.mem v g then begin + ignore (HM.remove v g); + let remove v = S.filter (fun (v2, _) -> not (V.equal v v2)) in + HM.iter (fun k s -> ignore (HM.add k (remove v s) g)) g + end + end + + module ConcreteBidirectional(V: COMPARABLE) = struct + + include I.Digraph.ConcreteBidirectional(V) + + let add_vertex g v = ignore (add_vertex g v) + + let add_edge g v1 v2 = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g v1 v2) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + let remove_vertex g v = + if HM.mem v g then begin + iter_pred_e (fun e -> remove_edge_e g e) g v; + iter_succ_e (fun e -> remove_edge_e g e) g v; + ignore (HM.remove v g) + end + + end + + module ConcreteBidirectionalLabeled(V:COMPARABLE)(E:ORDERED_TYPE_DFT) = struct + + include I.Digraph.ConcreteBidirectionalLabeled(V)(E) + + let add_vertex g v = ignore (add_vertex g v) + + let add_edge g v1 v2 = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g v1 v2) + + let add_edge_e g (v1, l, v2) = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge_e g (v1, l, v2)) + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + let remove_vertex g v = + if HM.mem v g then begin + iter_pred_e (fun e -> remove_edge_e g e) g v; + iter_succ_e (fun e -> remove_edge_e g e) g v; + ignore (HM.remove v g) + end + + end + + module Abstract(V: sig type t end) = struct + + include I.Digraph.Abstract(AbstractVertex(V)) + + let add_vertex g v = + if not (HM.mem v g.edges) then begin + g.size <- Pervasives.succ g.size; + ignore (G.unsafe_add_vertex g.edges v) + end + + let add_edge g v1 v2 = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g.edges v1 v2) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_vertex g v = + if HM.mem v g.edges then + let e = g.edges in + ignore (HM.remove v e); + HM.iter (fun k s -> ignore (HM.add k (S.remove v s) e)) e; + g.size <- Pervasives.pred g.size + + module Mark = + Make_Mark + (struct + type graph = t + type label = V.label + let iter_vertex = iter_vertex + end) + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + end + + module AbstractLabeled(V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct + + include I.Digraph.AbstractLabeled(AbstractVertex(V))(Edge) + + let add_vertex g v = + if not (HM.mem v g.edges) then begin + g.size <- Pervasives.succ g.size; + ignore (G.unsafe_add_vertex g.edges v) + end + + let add_edge_e g (v1, l, v2) = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g.edges v1 (v2, l)) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_vertex g v = + if HM.mem v g.edges then + let remove s = + S.fold + (fun (v2, _ as e) s -> if not (V.equal v v2) then S.add e s else s) + s S.empty + in + let e = g.edges in + ignore (HM.remove v e); + HM.iter (fun k s -> ignore (HM.add k (remove s) e)) e; + g.size <- Pervasives.pred g.size + + module Mark = + Make_Mark + (struct + type graph = t + type label = V.label + let iter_vertex = iter_vertex + end) + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + end + +end + +module Graph = struct + + module Concrete(V: COMPARABLE) = struct + + module G = struct include Digraph.Concrete(V) type return = unit end + include Graph(G) + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + G.add_edge g v1 v2; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_add_edge g v2 v1) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_remove_edge g v2 v1) + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + + module ConcreteLabeled (V: COMPARABLE)(Edge: ORDERED_TYPE_DFT) = struct + + module G = struct + include Digraph.ConcreteLabeled(V)(Edge) + type return = unit + end + include Graph(G) + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge_e g (v1, l, v2 as e) = + G.add_edge_e g e; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_add_edge g v2 (v1, l)) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_remove_edge g v2 v1) + + let remove_edge_e g (v1, l, v2 as e) = + G.remove_edge_e g e; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_remove_edge_e g (v2, l, v1)) + + end + + module Abstract(V: sig type t end) = struct + + module G = struct include Digraph.Abstract(V) type return = unit end + include Graph(G) + + (* Export some definitions of [G] *) + module Mark = G.Mark + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + G.add_edge g v1 v2; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_add_edge g.G.edges v2 v1) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_remove_edge g.G.edges v2 v1) + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + + module AbstractLabeled (V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct + + module G = struct + include Digraph.AbstractLabeled(V)(Edge) + type return = unit + end + include Graph(G) + + (* Export some definitions of [G] *) + module Mark = G.Mark + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge_e g (v1, l, v2 as e) = + G.add_edge_e g e; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_add_edge g.G.edges v2 (v1, l)) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_remove_edge g.G.edges v2 v1) + + let remove_edge_e g (v1, l, v2 as e) = + ignore (G.remove_edge_e g e); + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_remove_edge_e g.G.edges (v2, l, v1)) + + end + +end + +module Matrix = struct + + module type S = sig + include Sig.I with type V.t = int and type V.label = int + and type E.t = int * int + val make : int -> t + end + + module Digraph = struct + + module V = struct + type t = int + type label = int + let compare : t -> t -> int = Pervasives.compare + let hash = Hashtbl.hash + let equal = (==) + let create i = i + let label i = i + end + + module E = struct + type t = V.t * V.t + type vertex = V.t + let compare : t -> t -> int = Pervasives.compare + type label = unit + let create v1 _ v2 = (v1, v2) + let src = fst + let dst = snd + let label _ = () + end + + type t = Bitv.t array + type vertex = V.t + type edge = E.t + + let create ?size () = + failwith + "[ocamlgraph] do not use Matrix.create; please use Matrix.make instead" + + let make n = + if n < 0 then invalid_arg "[ocamlgraph] Matrix.make"; + Array.init n (fun _ -> Bitv.create n false) + + let is_directed = true + + let nb_vertex = Array.length + let is_empty g = nb_vertex g = 0 + let nb_edges = + Array.fold_left (Bitv.fold_left (fun n b -> if b then n+1 else n)) 0 + + let mem_vertex g v = 0 <= v && v < nb_vertex g + let mem_edge g i j = Bitv.get g.(i) j + let mem_edge_e g (i,j) = Bitv.get g.(i) j + let find_edge g i j = if mem_edge g i j then i, j else raise Not_found + let find_all_edges g i j = try [ find_edge g i j ] with Not_found -> [] + + (* constructors *) + let add_edge g i j = Bitv.set g.(i) j true + let add_edge_e g (i,j) = Bitv.set g.(i) j true + + let remove_edge g i j = Bitv.set g.(i) j false + let remove_edge_e g (i,j) = Bitv.set g.(i) j false + + let unsafe_add_edge g i j = + Bitv.unsafe_set (Array.unsafe_get g i) j true + let unsafe_remove_edge g i j = + Bitv.unsafe_set (Array.unsafe_get g i) j false + + let remove_vertex g _ = () + let add_vertex g _ = () + + let clear g = + Array.iter (fun b -> Bitv.iteri (fun j _ -> Bitv.set b j false) b) g + + let copy g = Array.init (nb_vertex g) (fun i -> Bitv.copy g.(i)) + + (* iter/fold on all vertices/edges of a graph *) + let iter_vertex f g = + for i = 0 to nb_vertex g - 1 do f i done + + let iter_edges f g = + for i = 0 to nb_vertex g - 1 do + Bitv.iteri (fun j b -> if b then f i j) g.(i) + done + + let fold_vertex f g a = + let n = nb_vertex g in + let rec fold i a = if i = n then a else fold (i+1) (f i a) in fold 0 a + + let fold_edges f g a = + fold_vertex + (fun i a -> + Bitv.foldi_right (fun j b a -> if b then f i j a else a) g.(i) a) + g a + + (* successors and predecessors of a vertex *) + let succ g i = + Bitv.foldi_left (fun l j b -> if b then j::l else l) [] g.(i) + + let pred g i = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then j :: a else a) + g [] + + (* iter/fold on all successor/predecessor of a vertex. *) + let iter_succ f g i = + let si = g.(i) in + for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get si j then f j done + (* optimization w.r.t. + [Bitv.iteri (fun j b -> if b then f j) g.(i)] + *) + + let iter_pred f g i = + for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get g.(j) i then f j done + + let fold_succ f g i a = + Bitv.foldi_right (fun j b a -> if b then f j a else a) g.(i) a + + let fold_pred f g i a = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then f j a else a) + g a + + (* degree *) + let out_degree g i = fold_succ (fun _ n -> n + 1) g i 0 + + let in_degree g i = fold_pred (fun _ n -> n + 1) g i 0 + + (* map iterator on vertex *) + let map_vertex f g = + let n = nb_vertex g in + let g' = make n in + iter_edges + (fun i j -> + let fi = f i in + let fj = f j in + if fi < 0 || fi >= n || fj < 0 || fj >= n then + invalid_arg "[ocamlgraph] map_vertex"; + Bitv.unsafe_set g'.(fi) fj true) + g; + g' + + (* labeled edges going from/to a vertex *) + (* successors and predecessors of a vertex *) + let succ_e g i = + Bitv.foldi_left (fun l j b -> if b then (i,j)::l else l) [] g.(i) + + let pred_e g i = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then (j,i) :: a else a) + g [] + + (* iter/fold on all labeled edges of a graph *) + let iter_edges_e f g = + for i = 0 to nb_vertex g - 1 do + Bitv.iteri (fun j b -> if b then f (i,j)) g.(i) + done + + let fold_edges_e f g a = + fold_vertex + (fun i a -> + Bitv.foldi_right (fun j b a -> if b then f (i,j) a else a) g.(i) a) + g a + + (* iter/fold on all edges going from/to a vertex *) + let iter_succ_e f g i = + let si = g.(i) in + for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get si j then f (i,j) done + + let iter_pred_e f g i = + for j = 0 to nb_vertex g - 1 do + if Bitv.unsafe_get g.(j) i then f (j,i) + done + + let fold_succ_e f g i a = + Bitv.foldi_right (fun j b a -> if b then f (i,j) a else a) g.(i) a + + let fold_pred_e f g i a = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then f (j,i) a else a) + g a + + end + + module Graph = struct + + module G = struct include Digraph type return = unit end + include Blocks.Graph(G) + + (* Export some definitions of [G] *) + let make = G.make + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + G.add_edge g v1 v2; + ignore (G.unsafe_add_edge g v2 v1) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + ignore (G.unsafe_remove_edge g v2 v1) + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + +end + +(* Faster implementations when vertices are not shared between graphs. *) +(**** + +module UV = struct + + let cpt_vertex = ref min_int + + type ('label, 'succ) vertex = { + tag : int; + label : 'label; + mutable mark : int; + mutable succ : 'succ; + } + + module Digraph = struct + + module Abstract(L: ANY_TYPE) : + Sig.IM with type V.label = L.t and type E.label = unit + = + struct + + module rec V : + VERTEX with type label = L.t and type t = (L.t, S.t) vertex = + struct + type label = L.t + type t = (L.t, S.t) vertex + + let compare x y = compare x.tag y.tag + let hash x = Hashtbl.hash x.tag + let equal x y = x.tag = y.tag + let label x = x.label + + let create l = + assert (!cpt_vertex < max_int); + incr cpt_vertex; + { tag = !cpt_vertex; label = l; mark = 0; succ = S.empty } + end + and S : Set.S with type elt = V.t = Set.Make(V) + + type vertex = V.t + + module E = struct + type t = V.t * V.t + type vertex = V.t + let compare = Pervasives.compare + type label = unit + let create v1 _ v2 = (v1, v2) + let src = fst + let dst = snd + let label _ = () + end + + type edge = E.t + + type t = { + mutable vertices : S.t; + } + + let create ?size () = { vertices = S.empty } + let is_directed = true + let is_empty g = S.is_empty g.vertices + let nb_vertex g = S.cardinal g.vertices + let out_degree _ v = S.cardinal v.succ + + let add_vertex g v = g.vertices <- S.add v g.vertices + let mem_vertex g v = S.mem v g.vertices + let iter_vertex f g = S.iter f g.vertices + let fold_vertex f g = S.fold f g.vertices + let succ _ v = S.elements v.succ + + end + + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + = + AbstractLabeled + (V)(struct type t = unit let compare _ _ = 0 let default = () end) + + end + + module Graph = struct + + module Abstract(V: ANY_TYPE) : + Sig.IM with type V.label = V.t and type E.label = unit + + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + + end + +end +*****) + +(* +Local Variables: +compile-command: "make -C .." +End: +*) diff --git a/lib/imperative.mli b/lib/imperative.mli new file mode 100644 index 0000000..60196a6 --- /dev/null +++ b/lib/imperative.mli @@ -0,0 +1,159 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Imperative Graph Implementations. *) + +open Sig + +(** Signature of imperative graphs. *) +module type S = sig + + (** Edges may be labeled or not: + - Unlabeled: there is no label on edges + - Labeled: you have to provide a label implementation as a functor + parameter. + + Vertices may be concrete or abstract: + - Concrete: type of vertex labels and type of vertices are identified. + - Abstract: type of vertices is abstract (in particular it is not equal + to type of vertex labels + + How to choose between concrete and abstract vertices for my graph + implementation? + + Usually, if you fall into one of the following cases, use abstract + vertices: + - you cannot provide efficient comparison/hash functions for vertices; or + - you wish to get two different vertices with the same label. + + In other cases, it is certainly easier to use concrete vertices. *) + + (** Imperative Unlabeled Graphs. *) + module Concrete (V: COMPARABLE) : + Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t + and type E.label = unit + + (** Abstract Imperative Unlabeled Graphs. *) + module Abstract(V: ANY_TYPE) : + Sig.IM with type V.label = V.t and type E.label = unit + + (** Imperative Labeled Graphs. *) + module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : + Sig.I with type V.t = V.t and type V.label = V.t + and type E.t = V.t * E.t * V.t and type E.label = E.t + + (** Abstract Imperative Labeled Graphs. *) + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + +end + +(** Imperative Directed Graphs. *) +module Digraph : sig + + include S + + (** {2 Bidirectional graphs} + + Bidirectional graphs use more memory space (at worse the double) that + standard concrete directional graphs. But accessing predecessors is in + O(1) amortized instead of O(max(|V|,|E|)) and removing a vertex is in + O(D*ln(D)) instead of O(|V|*ln(D)). D is the maximal degree of the + graph. *) + + (** Imperative Unlabeled, bidirectional graph. *) + module ConcreteBidirectional (V: COMPARABLE) : + Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t + and type E.label = unit + + (** Imperative Labeled and bidirectional graph. *) + module ConcreteBidirectionalLabeled(V:COMPARABLE)(E:ORDERED_TYPE_DFT) : + Sig.I with type V.t = V.t and type V.label = V.t + and type E.t = V.t * E.t * V.t and type E.label = E.t + +end + +(** Imperative Undirected Graphs. *) +module Graph : S + +(** Imperative graphs implemented as adjacency matrices. *) +module Matrix : sig + + module type S = sig + + (** Vertices are integers in [0..n-1]. + A vertex label is the vertex itself. + Edges are unlabeled. *) + + include Sig.I with type V.t = int and type V.label = int + and type E.t = int * int + + (** Creation. graphs are not resizeable: size is given at creation time. + Thus [make] must be used instead of [create]. *) + val make : int -> t + + (** Note: [add_vertex] and [remove_vertex] have no effect. + [clear] only removes edges, not vertices. *) + + end + + module Digraph : S + (** Imperative Directed Graphs implemented with adjacency matrices. *) + + module Graph : S + (** Imperative Undirected Graphs implemented with adjacency matrices. *) + +end + +(**** +(** Faster implementations for abstract (un)labeled (di)graphs + when vertices are _not shared_ between different graphs. + This means that, when using the following implementations, two different + graphs (created with two calls to [create]) must have disjoint sets of + vertices. *) +module UV : sig + + (** directed graphs *) + module Digraph : sig + + module Abstract(V: ANY_TYPE) : + Sig.IM with type V.label = V.t and type E.label = unit + + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + + end + + (** undirected graphs *) + module Graph : sig + + module Abstract(V: ANY_TYPE) : + Sig.IM with type V.label = V.t and type E.label = unit + + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + + end + +end +****) + +(* +Local Variables: +compile-command: "make -C .." +End: +*) diff --git a/lib/path.ml b/lib/path.ml new file mode 100644 index 0000000..08b6014 --- /dev/null +++ b/lib/path.ml @@ -0,0 +1,238 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: path.ml,v 1.6 2005-07-18 07:10:35 filliatr Exp $ *) + +module type WEIGHT = sig + type label + type t + val weight : label -> t + val compare : t -> t -> int + val add : t -> t -> t + val zero : t +end + +module type G = sig + type t + module V : Sig.COMPARABLE + module E : sig + type t + type label + val label : t -> label + val src : t -> V.t + val dst : t -> V.t + end + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit + val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a + val nb_vertex : t -> int +end + +module Dijkstra + (G: G) + (W: WEIGHT with type label = G.E.label) = +struct + + open G.E + + module H = Hashtbl.Make(G.V) + + module Elt = struct + type t = W.t * G.V.t * G.E.t list + + (* weights are compared first, and minimal weights come first in the + queue *) + let compare (w1,v1,_) (w2,v2,_) = + let cw = W.compare w2 w1 in + if cw != 0 then cw else G.V.compare v1 v2 + end + + module PQ = Heap.Imperative(Elt) + + let shortest_path g v1 v2 = + let visited = H.create 97 in + let dist = H.create 97 in + let q = PQ.create 17 in + let rec loop () = + if PQ.is_empty q then raise Not_found; + let (w,v,p) = PQ.pop_maximum q in + if G.V.compare v v2 = 0 then + List.rev p, w + else begin + if not (H.mem visited v) then begin + H.add visited v (); + G.iter_succ_e + (fun e -> + let ev = dst e in + if not (H.mem visited ev) then begin + let dev = W.add w (W.weight (label e)) in + let improvement = + try W.compare dev (H.find dist ev) < 0 with Not_found -> true + in + if improvement then begin + H.replace dist ev dev; + PQ.add q (dev, ev, e :: p) + end + end) + g v + end; + loop () + end + in + PQ.add q (W.zero, v1, []); + H.add dist v1 W.zero; + loop () + +end + +(* The following module is a contribution of Yuto Takei (University of Tokyo) *) + +module BellmanFord + (G: G) + (W: WEIGHT with type label = G.E.label) = +struct + + open G.E + + module H = Hashtbl.Make(G.V) + + exception NegativeCycle of G.E.t list + + let all_shortest_paths g vs = + let dist = H.create 97 in + H.add dist vs W.zero; + let admissible = H.create 97 in + let build_cycle_from x0 = + let rec traverse_parent x ret = + let e = H.find admissible x in + let s = src e in + if G.V.equal s x0 then e :: ret else traverse_parent s (e :: ret) + in + traverse_parent x0 [] + in + let find_cycle x0 = + let visited = H.create 97 in + let rec visit x = + if H.mem visited x then + build_cycle_from x + else begin + H.add visited x (); + let e = H.find admissible x in + visit (src e) + end + in + visit x0 + in + let rec relax i = + let update = G.fold_edges_e + (fun e x -> + let ev1 = src e in + let ev2 = dst e in + try begin + let dev1 = H.find dist ev1 in + let dev2 = W.add dev1 (W.weight (label e)) in + let improvement = + try W.compare dev2 (H.find dist ev2) < 0 + with Not_found -> true + in + if improvement then begin + H.replace dist ev2 dev2; + H.replace admissible ev2 e; + Some ev2 + end else x + end with Not_found -> x) g None in + match update with + | Some x -> + if i == G.nb_vertex g then raise (NegativeCycle (find_cycle x)) + else relax (i + 1) + | None -> dist + in + relax 0 + + let find_negative_cycle_from g vs = + try let _ = all_shortest_paths g vs in raise Not_found + with NegativeCycle l -> l + + + module Comp = Components.Make(G) + + (* This is rather inefficient implementation. Indeed, for each + strongly connected component, we run a full Bellman-Ford + algorithm using one of its vertex as source, taking all edges + into consideration. Instead, we could limit ourselves to the + edges of the component. *) + let find_negative_cycle g = + let rec iter = function + | [] -> + raise Not_found + | (x :: _) :: cl -> + begin try find_negative_cycle_from g x with Not_found -> iter cl end + | [] :: _ -> + assert false (* a component is not empty *) + in + iter (Comp.scc_list g) + +end + + +module Check + (G : + sig + type t + module V : Sig.COMPARABLE + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + end) = +struct + + module HV = Hashtbl.Make(G.V) + module HVV = Hashtbl.Make(Util.HTProduct(G.V)(G.V)) + + (* the cache contains the path tests already computed *) + type path_checker = { cache : bool HVV.t; graph : G.t } + + let create g = { cache = HVV.create 97; graph = g } + + let check_path pc v1 v2 = + try + HVV.find pc.cache (v1, v2) + with Not_found -> + (* the path is not in cache; we check it with Dijkstra *) + let visited = HV.create 97 in + let q = Queue.create () in + let rec loop () = + if Queue.is_empty q then begin + HVV.add pc.cache (v1, v2) false; + false + end else begin + let v = Queue.pop q in + HVV.add pc.cache (v1, v) true; + if G.V.compare v v2 = 0 then + true + else begin + if not (HV.mem visited v) then begin + HV.add visited v (); + G.iter_succ (fun v' -> Queue.add v' q) pc.graph v + end; + loop () + end + end + in + Queue.add v1 q; + loop () + +end diff --git a/lib/path.mli b/lib/path.mli new file mode 100644 index 0000000..25e0a84 --- /dev/null +++ b/lib/path.mli @@ -0,0 +1,143 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: path.mli,v 1.9 2005-07-18 07:10:35 filliatr Exp $ *) + +(** Paths *) + +(** Minimal graph signature for Dijkstra's algorithm. + Sub-signature of {!Sig.G}. *) +module type G = sig + type t + module V : Sig.COMPARABLE + module E : sig + type t + type label + val label : t -> label + val src : t -> V.t + val dst : t -> V.t + end + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit + val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a + val nb_vertex : t -> int +end + +(** Signature for edges' weights. *) +module type WEIGHT = sig + type label + (** Type for labels of graph edges. *) + type t + (** Type of edges' weights. *) + val weight : label -> t + (** Get the weight of an edge. *) + val compare : t -> t -> int + (** Weights must be ordered. *) + val add : t -> t -> t + (** Addition of weights. *) + val zero : t + (** Neutral element for {!add}. *) +end + +module Dijkstra + (G: G) + (W: WEIGHT with type label = G.E.label) : +sig + + val shortest_path : G.t -> G.V.t -> G.V.t -> G.E.t list * W.t + (** [shortest_path g v1 v2] computes the shortest path from vertex [v1] + to vertex [v2] in graph [g]. The path is returned as the list of + followed edges, together with the total length of the path. + raise [Not_found] if the path from [v1] to [v2] does not exist. + + Complexity: at most O((V+E)log(V)) *) + +end + +(* The following module is a contribution of Yuto Takei (University of Tokyo) *) + +module BellmanFord + (G: G) + (W: WEIGHT with type label = G.E.label) : +sig + + module H : Hashtbl.S with type key = G.V.t + + exception NegativeCycle of G.E.t list + + val all_shortest_paths : G.t -> G.V.t -> W.t H.t + (** [shortest_path g vs] computes the distances of shortest paths + from vertex [vs] to all other vertices in graph [g]. They are + returned as a hash table mapping each vertex reachable from + [vs] to its distance from [vs]. If [g] contains a + negative-length cycle reachable from [vs], raises + [NegativeCycle l] where [l] is such a cycle. + + Complexity: at most O(VE) *) + + val find_negative_cycle_from: G.t -> G.V.t -> G.E.t list + (** [find_negative_cycle_from g vs] looks for a negative-length + cycle in graph [g] that is reachable from vertex [vs] and + returns it as a list of edges. If no such a cycle exists, + raises [Not_found]. + + Complexity: at most O(VE). *) + + val find_negative_cycle: G.t -> G.E.t list + (** [find_negative_cycle g] looks for a negative-length cycle in + graph [g] and returns it. If the graph [g] is free from such a + cycle, raises [Not_found]. + + Complexity: O(V^2E) *) +end + + +(** Check for a path. *) +module Check + (G : sig + type t + module V : Sig.COMPARABLE + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + end) : +sig + + type path_checker + (** the abstract data type of a path checker; this is a mutable data + structure *) + + val create : G.t -> path_checker + (** [create g] builds a new path checker for the graph [g]; + if the graph is mutable, it must not be mutated while this path + checker is in use (through the function [check_path] below). *) + + val check_path : path_checker -> G.V.t -> G.V.t -> bool + (** [check_path pc v1 v2] checks whether there is a path from [v1] to + [v2] in the graph associated to the path checker [pc]. + + Complexity: The path checker contains a cache of all results computed + so far. This cache is implemented with a hash table so access in this + cache is usually O(1). When the result is not in the cache, Dijkstra's + algorithm is run to check for the path, and all intermediate results + are cached. + + Note: if checks are to be done for almost all pairs of vertices, it + may be more efficient to compute the transitive closure of the graph + (see module [Oper]). + *) + +end diff --git a/lib/sig.mli b/lib/sig.mli new file mode 100644 index 0000000..8e92aaf --- /dev/null +++ b/lib/sig.mli @@ -0,0 +1,360 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** {b Signatures for graph implementations.} *) + +(** {2 Signatures for graph implementations} *) + +(** Signature for vertices. *) +module type VERTEX = sig + + (** Vertices are {!COMPARABLE}. *) + + type t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + + (** Vertices are labeled. *) + + type label + val create : label -> t + val label : t -> label + +end + +(** Signature for edges. *) +module type EDGE = sig + + (** Edges are {!ORDERED_TYPE}. *) + + type t + val compare : t -> t -> int + + (** Edges are directed. *) + + type vertex + + val src : t -> vertex + (** Edge origin. *) + val dst : t -> vertex + (** Edge destination. *) + + (** Edges are labeled. *) + + type label + val create : vertex -> label -> vertex -> t + (** [create v1 l v2] creates an edge from [v1] to [v2] with label [l] *) + val label : t -> label + (** Get the label of an edge. *) + +end + +(** Common signature for all graphs. *) +module type G = sig + + (** {2 Graph structure} *) + + (** Abstract type of graphs *) + type t + + (** Vertices have type [V.t] and are labeled with type [V.label] + (note that an implementation may identify the vertex with its + label) *) + module V : VERTEX + type vertex = V.t + + (** Edges have type [E.t] and are labeled with type [E.label]. + [src] (resp. [dst]) returns the origin (resp. the destination) of a + given edge. *) + module E : EDGE with type vertex = vertex + type edge = E.t + + (** Is this an implementation of directed graphs? *) + val is_directed : bool + + (** {2 Size functions} *) + + val is_empty : t -> bool + val nb_vertex : t -> int + val nb_edges : t -> int + + (** Degree of a vertex *) + + val out_degree : t -> vertex -> int + (** [out_degree g v] returns the out-degree of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val in_degree : t -> vertex -> int + (** [in_degree g v] returns the in-degree of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** {2 Membership functions} *) + + val mem_vertex : t -> vertex -> bool + val mem_edge : t -> vertex -> vertex -> bool + val mem_edge_e : t -> edge -> bool + + val find_edge : t -> vertex -> vertex -> edge + (** [find_edge g v1 v2] returns the edge from [v1] to [v2] if it exists. + Unspecified behaviour if [g] has several edges from [v1] to [v2]. + @raise Not_found if no such edge exists. *) + + val find_all_edges : t -> vertex -> vertex -> edge list + (** [find_all_edges g v1 v2] returns all the edges from [v1] to [v2]. + @since ocamlgraph 1.8 *) + + (** {2 Successors and predecessors} + + You should better use iterators on successors/predecessors (see + Section "Vertex iterators"). *) + + val succ : t -> vertex -> vertex list + (** [succ g v] returns the successors of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val pred : t -> vertex -> vertex list + (** [pred g v] returns the predecessors of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** Labeled edges going from/to a vertex *) + + val succ_e : t -> vertex -> edge list + (** [succ_e g v] returns the edges going from [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val pred_e : t -> vertex -> edge list + (** [pred_e g v] returns the edges going to [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** {2 Graph iterators} *) + + val iter_vertex : (vertex -> unit) -> t -> unit + (** Iter on all vertices of a graph. *) + + val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + (** Fold on all vertices of a graph. *) + + val iter_edges : (vertex -> vertex -> unit) -> t -> unit + (** Iter on all edges of a graph. Edge label is ignored. *) + + val fold_edges : (vertex -> vertex -> 'a -> 'a) -> t -> 'a -> 'a + (** Fold on all edges of a graph. Edge label is ignored. *) + + val iter_edges_e : (edge -> unit) -> t -> unit + (** Iter on all edges of a graph. *) + + val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a + (** Fold on all edges of a graph. *) + + val map_vertex : (vertex -> vertex) -> t -> t + (** Map on all vertices of a graph. *) + + (** {2 Vertex iterators} + + Each iterator [iterator f v g] iters [f] to the successors/predecessors + of [v] in the graph [g] and raises [Invalid_argument] if [v] is not in + [g]. It is the same for functions [fold_*] which use an additional + accumulator. + + Time complexity for ocamlgraph implementations: + operations on successors are in O(1) amortized for imperative graphs and + in O(ln(|V|)) for persistent graphs while operations on predecessors are + in O(max(|V|,|E|)) for imperative graphs and in O(max(|V|,|E|)*ln|V|) for + persistent graphs. *) + + (** iter/fold on all successors/predecessors of a vertex. *) + + val iter_succ : (vertex -> unit) -> t -> vertex -> unit + val iter_pred : (vertex -> unit) -> t -> vertex -> unit + val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val fold_pred : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + (** iter/fold on all edges going from/to a vertex. *) + + val iter_succ_e : (edge -> unit) -> t -> vertex -> unit + val fold_succ_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val iter_pred_e : (edge -> unit) -> t -> vertex -> unit + val fold_pred_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + +end + +(** Signature for persistent (i.e. immutable) graph. *) +module type P = sig + + include G + (** A persistent graph is a graph. *) + + val empty : t + (** The empty graph. *) + + val add_vertex : t -> vertex -> t + (** [add_vertex g v] adds the vertex [v] to the graph [g]. + Just return [g] if [v] is already in [g]. *) + + val remove_vertex : t -> vertex -> t + (** [remove g v] removes the vertex [v] from the graph [g] + (and all the edges going from [v] in [g]). + Just return [g] if [v] is not in [g]. + + Time complexity for ocamlgraph implementations: + O(|V|*ln(|V|)) for unlabeled graphs and + O(|V|*max(ln(|V|),D)) for labeled graphs. + D is the maximal degree of the graph. *) + + val add_edge : t -> vertex -> vertex -> t + (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] + in the graph [g]. + Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. + Just return [g] if this edge is already in [g]. *) + + val add_edge_e : t -> edge -> t + (** [add_edge_e g e] adds the edge [e] in the graph [g]. + Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst + e]) is not in [g]. + Just return [g] if [e] is already in [g]. *) + + val remove_edge : t -> vertex -> vertex -> t + (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the + graph [g]. If the graph is labelled, all the edges going from [v1] to + [v2] are removed from [g]. + Just return [g] if this edge is not in [g]. + @raise Invalid_argument if [v1] or [v2] are not in [g]. *) + + val remove_edge_e : t -> edge -> t + (** [remove_edge_e g e] removes the edge [e] from the graph [g]. + Just return [g] if [e] is not in [g]. + @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) + +end + +(** Signature for imperative (i.e. mutable) graphs. *) +module type I = sig + + include G + (** An imperative graph is a graph. *) + + val create : ?size:int -> unit -> t + (** [create ()] returns an empty graph. Optionally, a size can be + given, which should be on the order of the expected number of + vertices that will be in the graph (for hash tables-based + implementations). The graph grows as needed, so [size] is + just an initial guess. *) + + val clear: t -> unit + (** Remove all vertices and edges from the given graph. + @since ocamlgraph 1.4 *) + + val copy : t -> t + (** [copy g] returns a copy of [g]. Vertices and edges (and eventually + marks, see module [Mark]) are duplicated. *) + + val add_vertex : t -> vertex -> unit + (** [add_vertex g v] adds the vertex [v] to the graph [g]. + Do nothing if [v] is already in [g]. *) + + val remove_vertex : t -> vertex -> unit + (** [remove g v] removes the vertex [v] from the graph [g] + (and all the edges going from [v] in [g]). + Do nothing if [v] is not in [g]. + + Time complexity for ocamlgraph implementations: + O(|V|*ln(D)) for unlabeled graphs and O(|V|*D) for + labeled graphs. D is the maximal degree of the graph. *) + + val add_edge : t -> vertex -> vertex -> unit + (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] + in the graph [g]. + Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. + Do nothing if this edge is already in [g]. *) + + val add_edge_e : t -> edge -> unit + (** [add_edge_e g e] adds the edge [e] in the graph [g]. + Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst + e]) is not in [g]. + Do nothing if [e] is already in [g]. *) + + val remove_edge : t -> vertex -> vertex -> unit + (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the + graph [g]. If the graph is labelled, all the edges going from [v1] to + [v2] are removed from [g]. + Do nothing if this edge is not in [g]. + @raise Invalid_argument if [v1] or [v2] are not in [g]. *) + + val remove_edge_e : t -> edge -> unit + (** [remove_edge_e g e] removes the edge [e] from the graph [g]. + Do nothing if [e] is not in [g]. + @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) + +end + +(** Signature for marks on vertices. *) +module type MARK = sig + type graph + (** Type of graphs. *) + type vertex + (** Type of graph vertices. *) + val clear : graph -> unit + (** [clear g] sets all the marks to 0 for all the vertices of [g]. *) + val get : vertex -> int + (** Mark value (in O(1)). *) + val set : vertex -> int -> unit + (** Set the mark of the given vertex. *) +end + +(** Signature for imperative graphs with marks on vertices. *) +module type IM = sig + include I + (** An imperative graph with marks is an imperative graph. *) + + (** Mark on vertices. + Marks can be used if you want to store some information on vertices: + it is more efficient to use marks than an external table. *) + module Mark : MARK with type graph = t and type vertex = vertex +end + +(** {2 Signature for ordered and hashable types} *) + +(** Signature with only an abstract type. *) +module type ANY_TYPE = sig type t end + +(** Signature equivalent to [Set.OrderedType]. *) +module type ORDERED_TYPE = sig type t val compare : t -> t -> int end + +(** Signature equivalent to [Set.OrderedType] with a default value. *) +module type ORDERED_TYPE_DFT = sig include ORDERED_TYPE val default : t end + +(** Signature equivalent to [Hashtbl.HashedType]. *) +module type HASHABLE = sig + type t + val hash : t -> int + val equal : t -> t -> bool +end + +(** Signature merging {!ORDERED_TYPE} and {!HASHABLE}. *) +module type COMPARABLE = sig + type t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool +end + +(* +Local Variables: +compile-command: "make -C .." +End: +*) diff --git a/lib/util.ml b/lib/util.ml new file mode 100644 index 0000000..a7d50ea --- /dev/null +++ b/lib/util.ml @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +open Sig + +module OTProduct(X: ORDERED_TYPE)(Y: ORDERED_TYPE) = struct + type t = X.t * Y.t + let compare (x1, y1) (x2, y2) = + let cv = X.compare x1 x2 in + if cv != 0 then cv else Y.compare y1 y2 +end + +module HTProduct(X: HASHABLE)(Y: HASHABLE) = struct + type t = X.t * Y.t + let equal (x1, y1) (x2, y2) = X.equal x1 x2 && Y.equal y1 y2 + let hash (x, y) = Hashtbl.hash (X.hash x, Y.hash y) +end + +module CMPProduct(X: COMPARABLE)(Y: COMPARABLE) = struct + include HTProduct(X)(Y) + include (OTProduct(X)(Y): sig val compare : t -> t -> int end) +end + +module DataV(L : sig type t end)(V : Sig.COMPARABLE) = struct + type data = L.t + type label = V.t + type t = data ref * V.t + let compare (_, x) (_, x') = V.compare x x' + let hash (_, x) = V.hash x + let equal (_, x) (_, x') = V.equal x x' + let create y lbl = (ref y, lbl) + let label (_, z) = z + let data (y, _) = !y + let set_data (y, _) = (:=) y +end + diff --git a/lib/util.mli b/lib/util.mli new file mode 100644 index 0000000..63ae42f --- /dev/null +++ b/lib/util.mli @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Some useful operations. *) + +open Sig + +(** Cartesian product of two ordered types. *) +module OTProduct(X: ORDERED_TYPE)(Y: ORDERED_TYPE) : + ORDERED_TYPE with type t = X.t * Y.t + +(** Cartesian product of two hashable types. *) +module HTProduct(X: HASHABLE)(Y: HASHABLE) : + HASHABLE with type t = X.t * Y.t + +(** Cartesian product of two comparable types. *) +module CMPProduct(X: COMPARABLE)(Y: COMPARABLE) : + COMPARABLE with type t = X.t * Y.t + +(** Create a vertex type with some data attached to it *) +module DataV(L : sig type t end)(V : Sig.COMPARABLE) : sig + type data = L.t + and label = V.t + and t = data ref * V.t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + val create : data -> V.t -> t + val label : t -> V.t + val data : t -> data + val set_data : t -> data -> unit +end + From 203cfd0ddfee9f4542e1c24605184c649f02af18 Mon Sep 17 00:00:00 2001 From: crotsos Date: Sat, 21 Sep 2013 10:28:00 +0100 Subject: [PATCH 53/75] splitting openflow functionality in 3 sublibraries --- _oasis | 63 +++++++------------------- _tags | 56 +++++------------------ controller/learning_switch.ml | 6 +-- lib/META | 24 +++++++++- lib/flowvisor.ml | 56 +++++++++++------------ lib/flowvisor.mli | 14 +++--- lib/flowvisor_topology.ml | 10 +++-- lib/flowvisor_topology.mli | 6 +-- lib/flv.mlpack | 6 +++ lib/ofcontroller.ml | 40 ++++++++--------- lib/ofpacket.ml | 85 +++++++++++++---------------------- lib/ofswitch.ml | 73 +++++++++++++++--------------- lib/ofswitch.mli | 8 ++-- lib/ofswitch_config.ml | 2 +- lib/ofswitch_config.mli | 6 +-- lib/ofswitch_standalone.ml | 13 +++--- lib/ofswitch_standalone.mli | 4 +- lib/openflow.mlpack | 8 +--- lib/openflow.odocl | 4 +- lib/openflow_lwt_unix.mllib | 5 --- lib/openflow_mirage.mllib | 5 --- lib/switch.mlpack | 6 +++ myocamlbuild.ml | 9 ++-- setup.ml | 78 +++++++++++++------------------- 24 files changed, 252 insertions(+), 335 deletions(-) create mode 100644 lib/flv.mlpack delete mode 100644 lib/openflow_lwt_unix.mllib delete mode 100644 lib/openflow_mirage.mllib create mode 100644 lib/switch.mlpack diff --git a/_oasis b/_oasis index 8467ec5..141ecb4 100644 --- a/_oasis +++ b/_oasis @@ -29,63 +29,30 @@ Library openflow Path: lib Findlibname: openflow CompiledObject: native - Modules: Ofpacket, Ofcontroller, Ofswitch_config, Ofswitch, Ofsocket, Ofswitch_standalone, Flowvisor, Flowvisor_topology, Lldp + Modules: Ofpacket, Ofcontroller, Ofsocket Pack: True - BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0), re.str, ocamlgraph,ipaddr + BuildDepends: cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0), ipaddr Document openflow Title: OpenFlow docs Type: ocamlbuild (0.2) BuildTools+: ocamldoc XOCamlbuildPath: lib - XOCamlbuildModules: Ofpacket, Ofcontroller, Ofswitch, Ofsocket, Ofswitch_config + XOCamlbuildModules: Ofpacket, Ofcontroller, Ofsocket -Executable "ovs-vsctl" +Library switch Path: lib - MainIs: ofswitch_ctrl.ml - Build$: flag(lwt) - Custom: true + Findlibname: switch + Findlibparent: openflow CompiledObject: native - Install: true - BuildDepends: openflow, re.str - - -Executable learning_switch_lwt - Path: controller - MainIs: learning_switch.ml - Build$: flag(lwt) - Custom: true - CompiledObject: native - Install: true - BuildDepends: cstruct, cstruct.syntax, openflow + Modules: Ofswitch, Ofswitch_config, Ofswitch_standalone + Pack: True + BuildDepends: re.str -(* Executable basic_switch_lwt - Path: switch - MainIs: basic_switch.ml - Build$: flag(lwt) - Custom: true +Library flv + Path: lib + Findlibname: flv + Findlibparent: openflow CompiledObject: native - Install: true - BuildDepends: openflow - -<<<<<<< HEAD -Executable learning_switch_mirage -======= -Executable "learning_switch_mirage.o" ->>>>>>> xen-test - Path: controller - MainIs: learning_switch.ml - Build$: flag(mirage) - Custom: true - CompiledObject: native_object - Install: false - BuildDepends: cstruct, cstruct.syntax, openflow - -(*Executable "basic_switch_mirage.o" - Path: switch - MainIs: basic_switch.ml - Build$: flag(mirage) - Custom: true - CompiledObject: native_object - Install: false - BuildDepends: openflow *) + Modules: Flowvisor,Lldp, Flowvisor_topology + Pack: True diff --git a/_tags b/_tags index 3350757..595ccc0 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 2372650f9c40e894f1ba8a24df10b624) +# DO NOT EDIT (digest: 223fee9da9926174167e33e3c8f49757) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -17,57 +17,25 @@ "lib/openflow.cmxs": use_openflow "lib/ofpacket.cmx": for-pack(Openflow) "lib/ofcontroller.cmx": for-pack(Openflow) -"lib/ofswitch_config.cmx": for-pack(Openflow) -"lib/ofswitch.cmx": for-pack(Openflow) "lib/ofsocket.cmx": for-pack(Openflow) -"lib/ofswitch_standalone.cmx": for-pack(Openflow) -"lib/flowvisor.cmx": for-pack(Openflow) -"lib/flowvisor_topology.cmx": for-pack(Openflow) -"lib/lldp.cmx": for-pack(Openflow) -# Executable ovs-vsctl -"lib/ofswitch_ctrl.native": use_openflow -"lib/ofswitch_ctrl.native": pkg_cstruct -"lib/ofswitch_ctrl.native": pkg_cstruct.syntax -"lib/ofswitch_ctrl.native": pkg_re.str -"lib/ofswitch_ctrl.native": pkg_rpclib -"lib/ofswitch_ctrl.native": pkg_rpclib.json -"lib/ofswitch_ctrl.native": pkg_mirage -"lib/ofswitch_ctrl.native": pkg_mirage-net -"lib/ofswitch_ctrl.native": pkg_ocamlgraph -"lib/ofswitch_ctrl.native": pkg_ipaddr -: use_openflow : pkg_cstruct : pkg_cstruct.syntax -: pkg_re.str : pkg_rpclib : pkg_rpclib.json : pkg_mirage : pkg_mirage-net -: pkg_ocamlgraph : pkg_ipaddr -"lib/ofswitch_ctrl.native": custom -# Executable learning_switch_lwt -"controller/learning_switch.native": use_openflow -"controller/learning_switch.native": pkg_cstruct -"controller/learning_switch.native": pkg_cstruct.syntax -"controller/learning_switch.native": pkg_re.str -"controller/learning_switch.native": pkg_rpclib -"controller/learning_switch.native": pkg_rpclib.json -"controller/learning_switch.native": pkg_mirage -"controller/learning_switch.native": pkg_mirage-net -"controller/learning_switch.native": pkg_ocamlgraph -"controller/learning_switch.native": pkg_ipaddr -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_re.str -: pkg_rpclib -: pkg_rpclib.json -: pkg_mirage -: pkg_mirage-net -: pkg_ocamlgraph -: pkg_ipaddr -"controller/learning_switch.native": custom +# Library switch +"lib/switch.cmxs": use_switch +"lib/ofswitch.cmx": for-pack(Switch) +"lib/ofswitch_config.cmx": for-pack(Switch) +"lib/ofswitch_standalone.cmx": for-pack(Switch) +: pkg_re.str +# Library flv +"lib/flv.cmxs": use_flv +"lib/flowvisor.cmx": for-pack(Flv) +"lib/lldp.cmx": for-pack(Flv) +"lib/flowvisor_topology.cmx": for-pack(Flv) # OASIS_STOP true: annot : syntax_camlp4o diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index c98849b..5924433 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -24,9 +24,9 @@ open Net.Nettypes let resolve t = Lwt.on_success t (fun _ -> ()) -module OP = Ofpacket -module OC = Ofcontroller -module OE = Ofcontroller.Event +module OP = Openflow.Ofpacket +module OC = Openflow.Ofcontroller +module OE = Openflow.Ofcontroller.Event let pp = Printf.printf let sp = Printf.sprintf diff --git a/lib/META b/lib/META index 66fde9f..5d59419 100644 --- a/lib/META +++ b/lib/META @@ -1,13 +1,33 @@ # OASIS_START -# DO NOT EDIT (digest: 2f0201055e20e2bbeb0610a6d9578c8b) +# DO NOT EDIT (digest: 69cff10087bc2c089bf031d3ee41c178) version = "0.3.0" description = "OpenFlow protocol and switch implementations in pure OCaml" requires = -"cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net re.str ocamlgraph ipaddr" +"cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net ipaddr" archive(byte) = "openflow.cma" archive(byte, plugin) = "openflow.cma" archive(native) = "openflow.cmxa" archive(native, plugin) = "openflow.cmxs" exists_if = "openflow.cmxa" +package "switch" ( + version = "0.3.0" + description = "OpenFlow protocol and switch implementations in pure OCaml" + requires = "re.str" + archive(byte) = "switch.cma" + archive(byte, plugin) = "switch.cma" + archive(native) = "switch.cmxa" + archive(native, plugin) = "switch.cmxs" + exists_if = "switch.cmxa" +) + +package "flv" ( + version = "0.3.0" + description = "OpenFlow protocol and switch implementations in pure OCaml" + archive(byte) = "flv.cma" + archive(byte, plugin) = "flv.cma" + archive(native) = "flv.cmxa" + archive(native, plugin) = "flv.cmxs" + exists_if = "flv.cmxa" +) # OASIS_STOP diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index f6bf72e..9d048f5 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -18,9 +18,9 @@ open Lwt open Net open Net.Nettypes -module OP = Ofpacket -module OC = Ofcontroller -module OE = Ofcontroller.Event +module OP = Openflow.Ofpacket +module OC = Openflow.Ofcontroller +module OE = Openflow.Ofcontroller.Event open OP open OP.Flow open OP.Flow_mod @@ -68,8 +68,8 @@ type t = { mutable buffer_id_count: int32; (* controller and switch storage *) - mutable controllers : (int64 * OP.Match.t *Ofsocket.conn_state ) list; - switches : (int64, Ofcontroller.t) Hashtbl.t; + mutable controllers : (int64 * OP.Match.t *Openflow.Ofsocket.conn_state ) list; + switches : (int64, OC.t) Hashtbl.t; (* Mapping transients id values *) xid_map : (int32, xid_state) Hashtbl.t; @@ -104,7 +104,7 @@ let init_flowvisor verbose flv_topo = port_map=(Hashtbl.create 64); controllers=[]; buffer_id_map=(Hashtbl.create 64); buffer_id_count=0l; xid_map=(Hashtbl.create 64); - switches=(Hashtbl.create 64); flv_topo;} + switches=(Hashtbl.create 64); flv_topo; } let supported_actions () = OP.Switch.({ @@ -140,7 +140,7 @@ let handle_xid flv st xid_st = if (sz + fl_sz > 0xffff) then let r = OP.Stats.Flow_resp(stats, flows) in let h = OP.Header.create ~xid:(xid_st.xid) OP.Header.STATS_RESP 0 in - lwt _ = Ofsocket.send_packet t (OP.Stats_resp (h, r)) in + lwt _ = Openflow.Ofsocket.send_packet t (OP.Stats_resp (h, r)) in return ((OP.Header.get_len + OP.Stats.get_resp_hdr_size + fl_sz), [fl]) else return ((sz + fl_sz), (fl::flows)) ) @@ -148,7 +148,7 @@ let handle_xid flv st xid_st = let stats = OP.Stats.({st_ty=FLOW; more=false;}) in let r = OP.Stats.Flow_resp(stats, flows) in let h = OP.Header.create ~xid:xid_st.xid OP.Header.STATS_RESP 0 in - Ofsocket.send_packet t (OP.Stats_resp (h, r)) + Openflow.Ofsocket.send_packet t (OP.Stats_resp (h, r)) | _ -> return () let timeout_xid flv st = @@ -171,21 +171,21 @@ let timeout_xid flv st = let switch_dpid flv = Hashtbl.fold (fun dpid _ r -> r@[dpid]) flv.switches [] let send_all_switches st msg = Lwt_list.iter_p ( - fun (dpid, ch) -> Ofcontroller.send_data ch dpid msg) + fun (dpid, ch) -> OC.send_data ch dpid msg) (Hashtbl.fold (fun dpid ch c -> c @[(dpid, ch)]) st.switches []) let send_switch st dpid msg = try_lwt let ch = Hashtbl.find st.switches dpid in - Ofcontroller.send_data ch dpid msg + OC.send_data ch dpid msg with Not_found -> return (ep "[flowvisor] unregister dpid %Ld\n%!" dpid) -let send_controller t msg = Ofsocket.send_packet t msg +let send_controller t msg = Openflow.Ofsocket.send_packet t msg let inform_controllers flv m msg = (* find the controller that should handle the packet in *) Lwt_list.iter_p (fun (_, rule, t) -> if (OP.Match.flow_match_compare rule m rule.OP.Match.wildcards) then - Ofsocket.send_packet t msg + Openflow.Ofsocket.send_packet t msg else return ()) flv.controllers (************************************************* @@ -235,10 +235,10 @@ let packet_out_create st msg xid in_port bid data actions = Lwt_list.iter_p ( fun (dpid, ch) -> if (dpid = in_dpid) then - Ofcontroller.send_data ch dpid + OC.send_data ch dpid (packet_out_create st msg xid inp (-1l) data actions) else - Ofcontroller.send_data ch dpid msg + OC.send_data ch dpid msg ) (Hashtbl.fold (fun dpid ch c -> c @[(dpid, ch)]) st.switches []) in pkt_out_process st xid inp bid data msg acts tail end @@ -287,7 +287,7 @@ let map_path flv in_dpid in_port out_dpid out_port = dp (OP.Port.string_of_port out_p) ) path in let _ = pp "\n%!" in *) - path + path let map_spanning_tree flv in_dpid in_port = [] @@ -541,12 +541,12 @@ let process_openflow st dpid t msg = let switch_channel st dpid of_m sock = let h = OP.Header.(create ~xid:1l HELLO sizeof_ofp_header) in - lwt _ = Ofsocket.send_packet sock (OP.Hello h) in + lwt _ = Openflow.Ofsocket.send_packet sock (OP.Hello h) in let _ = st.controllers <- (dpid, of_m, sock)::st.controllers in let continue = ref true in while_lwt !continue do try_lwt - lwt ofp = Ofsocket.read_packet sock in + lwt ofp = Openflow.Ofsocket.read_packet sock in process_openflow st dpid sock ofp with | Nettypes.Closed -> @@ -569,12 +569,12 @@ let add_flowvisor_port flv dpid port = let _ = Hashtbl.add flv.port_map port_id (dpid, port.OP.Port.port_no, phy) in lwt _ = Flowvisor_topology.add_port flv.flv_topo dpid port.OP.Port.port_no - port.OP.Port.hw_addr in + port.OP.Port.hw_addr in let h = OP.Header.(create PORT_STATUS 0 ) in let status = OP.Port_status(h, (OP.Port.({reason=OP.Port.ADD; desc=phy;}))) in Lwt_list.iter_p (fun (dpid, _, conn) -> - Ofsocket.send_packet conn status ) flv.controllers + Openflow.Ofsocket.send_packet conn status ) flv.controllers (* * openflow controller threads @@ -584,7 +584,7 @@ let del_flowvisor_port flv desc = let status = OP.Port_status(h, (OP.Port.({reason=OP.Port.ADD;desc;}))) in Lwt_list.iter_p (fun (dpid, _, conn) -> - Ofsocket.send_packet conn status ) flv.controllers + Openflow.Ofsocket.send_packet conn status ) flv.controllers let map_flv_port flv dpid port = (* map the new port *) @@ -623,13 +623,13 @@ let process_switch_channel flv st dpid e = match e with | OE.Datapath_join(dpid, ports) -> let _ = pr "[flowvisor-ctrl]+ switch dpid:%Ld\n%!" dpid in - let _ = Flowvisor_topology.add_channel flv.flv_topo dpid st in + let _ = Flowvisor_topology.add_channel flv.flv_topo dpid st in (* Update local state *) let _ = Hashtbl.add flv.switches dpid st in Lwt_list.iter_p (add_flowvisor_port flv dpid) ports | OE.Datapath_leave(dpid) -> let _ = pr "[flowvisor-ctrl]- switch dpid:%Ld\n%!" dpid in - let _ = Flowvisor_topology.remove_dpid flv.flv_topo dpid in + let _ = Flowvisor_topology.remove_dpid flv.flv_topo dpid in (* Need to remove ports and port mapping and disard any state * pending for replies. *) let removed = @@ -644,7 +644,7 @@ let process_switch_channel flv st dpid e = | OE.Packet_in(in_port, reason, buffer_id, data, dpid) -> begin let m = OP.Match.raw_packet_to_match in_port data in match (in_port, m.OP.Match.dl_type) with - | (OP.Port.Port(p), 0x88cc) -> begin + | (OP.Port.Port(p), 0x88cc) -> begin match (Flowvisor_topology.process_lldp_packet flv.flv_topo dpid p data) with | true -> return () @@ -667,7 +667,7 @@ let process_switch_channel flv st dpid e = let _ = Hashtbl.add flv.buffer_id_map buffer_id (pkt, dpid) in lwt _ = inform_controllers flv m (OP.Packet_in(h, pkt)) in return () - end + end | (OP.Port.Port(p), _) -> return ((*pp "XXXXX supress disable transit port"*)) | _ -> @@ -795,7 +795,7 @@ let add_slice mgr flv of_m dst dpid = let rs = Ipaddr.V4.to_string addr in let _ = pp "[flowvisor-switch]+ controller %s:%d\n%!" rs port in (* Trigger the dance between the 2 nodes *) - let sock = Ofsocket.init_socket_conn_state t in + let sock = Openflow.Ofsocket.init_socket_conn_state t in switch_channel flv dpid of_m sock in Net.Channel.connect mgr @@ -808,10 +808,10 @@ let add_slice mgr flv of_m dst dpid = ) in return () -let listen st mgr loc = Ofcontroller.listen mgr loc (init st) +let listen st mgr loc = OC.listen mgr loc (init st) let local_listen st conn = - let t = Ofcontroller.init_controller () in - Ofcontroller.local_connect t conn (init st) + let t = OC.init_controller () in + OC.local_connect t conn (init st) let remove_slice _ _ = return () let add_local_slice flv of_m conn dpid = diff --git a/lib/flowvisor.mli b/lib/flowvisor.mli index 7dd1b4f..4dfea1e 100644 --- a/lib/flowvisor.mli +++ b/lib/flowvisor.mli @@ -22,13 +22,13 @@ type t val listen: t -> Manager.t -> ipv4_src -> unit Lwt.t -val local_listen: t -> Ofsocket.conn_state -> unit Lwt.t +val local_listen: t -> Openflow.Ofsocket.conn_state -> unit Lwt.t val create_flowvisor: ?verbose:bool -> unit -> t -val remove_slice : t -> Ofpacket.Match.t -> unit Lwt.t -val add_local_slice : Net.Manager.t -> t -> Ofpacket.Match.t -> - Ofsocket.conn_state -> int64 -> unit Lwt.t -val add_slice : Net.Manager.t -> t -> Ofpacket.Match.t -> +val remove_slice : t -> Openflow.Ofpacket.Match.t -> unit Lwt.t +val add_local_slice : Net.Manager.t -> t -> Openflow.Ofpacket.Match.t -> + Openflow.Ofsocket.conn_state -> int64 -> unit Lwt.t +val add_slice : Net.Manager.t -> t -> Openflow.Ofpacket.Match.t -> ipv4_dst -> int64 -> unit Lwt.t -val add_local_slice : t -> Ofpacket.Match.t -> - Ofsocket.conn_state -> int64 -> unit Lwt.t +val add_local_slice : t -> Openflow.Ofpacket.Match.t -> + Openflow.Ofsocket.conn_state -> int64 -> unit Lwt.t diff --git a/lib/flowvisor_topology.ml b/lib/flowvisor_topology.ml index c8b70f3..b66cb30 100644 --- a/lib/flowvisor_topology.ml +++ b/lib/flowvisor_topology.ml @@ -19,9 +19,11 @@ open Printf open Net open Net.Nettypes open Lldp -open Graph -module OP = Ofpacket +module OP = Openflow.Ofpacket +module OC = Openflow.Ofcontroller +module OE = Openflow.Ofcontroller.Event +module OSK = Openflow.Ofsocket open OP let sp = Printf.sprintf @@ -73,7 +75,7 @@ module Dijkstra = Path.Dijkstra(Graph)(W) type t = { ports : (int64 * int, Macaddr.t * bool) Hashtbl.t; - channels : (int64, Ofcontroller.t) Hashtbl.t; + channels : (int64, OC.t) Hashtbl.t; topo : Graph.t; } @@ -106,7 +108,7 @@ let send_port_lldp t dpid port mac = let m = OP.Packet_out.create ~actions:[(OP.Flow.Output(OP.Port.Port(port), 2000))] ~data ~in_port:(OP.Port.No_port) () in let ch = Hashtbl.find t.channels dpid in - Ofcontroller.send_data ch dpid (OP.Packet_out(h, m)) + OC.send_data ch dpid (OP.Packet_out(h, m)) let add_port t dpid port mac = let _ = printf "[flowvisor-topo] adding port %Ld:%d\n%!" dpid port in diff --git a/lib/flowvisor_topology.mli b/lib/flowvisor_topology.mli index 43baed6..dac96ad 100644 --- a/lib/flowvisor_topology.mli +++ b/lib/flowvisor_topology.mli @@ -20,11 +20,11 @@ type t val init_topology: unit -> t val add_port: t -> int64 -> int -> Macaddr.t -> unit Lwt.t -val add_channel: t -> int64 -> Ofcontroller.t -> unit +val add_channel: t -> int64 -> Openflow.Ofcontroller.t -> unit val discover: t-> unit Lwt.t val process_lldp_packet: t -> int64 -> int -> Cstruct.t -> bool -val find_dpid_path: t -> int64 -> Ofpacket.Port.t -> int64 -> - Ofpacket.Port.t -> (int64 * Ofpacket.Port.t * Ofpacket.Port.t) list +val find_dpid_path: t -> int64 -> Openflow.Ofpacket.Port.t -> int64 -> + Openflow.Ofpacket.Port.t -> (int64 * Openflow.Ofpacket.Port.t * Openflow.Ofpacket.Port.t) list val remove_dpid: t -> int64 -> unit val is_transit_port : t -> int64 -> int -> bool diff --git a/lib/flv.mlpack b/lib/flv.mlpack new file mode 100644 index 0000000..499b55f --- /dev/null +++ b/lib/flv.mlpack @@ -0,0 +1,6 @@ +# OASIS_START +# DO NOT EDIT (digest: 1ee3b02f2e7271b683bd994a941b7777) +Flowvisor +Lldp +Flowvisor_topology +# OASIS_STOP diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 2291178..0d77e10 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -48,7 +48,7 @@ module Event = struct | Flow_stats_reply of int32 * bool * OP.Flow.stats list * OP.datapath_id | Aggr_flow_stats_reply of int32 * int64 * int64 * int32 * OP.datapath_id | Port_stats_reply of int32 * bool * OP.Port.stats list * OP.datapath_id - | Table_stats_reply of int32 * bool * OP.Stats.table list * OP.datapath_id + | Table_stats_reply of int32 * bool * OP.Stats.table list * OP.datapath_id | Desc_stats_reply of string * string * string * string * string * OP.datapath_id @@ -167,33 +167,33 @@ let process_of_packet state conn ofp = end | Features_resp (h, sfs) -> begin (* Generate a datapath join event *) let _ = if state.verbose then pp "[controller] FEATURES_RESP\n%!" in - let _ = conn.dpid <- sfs.Switch.datapath_id in - let evt = Event.Datapath_join (sfs.Switch.datapath_id, sfs.Switch.ports) in + let _ = conn.dpid <- sfs.OP.Switch.datapath_id in + let evt = Event.Datapath_join (sfs.OP.Switch.datapath_id, sfs.OP.Switch.ports) in let _ = - if (Hashtbl.mem state.dp_db sfs.Switch.datapath_id) then + if (Hashtbl.mem state.dp_db sfs.OP.Switch.datapath_id) then Printf.printf "[controller] Deleting old state \n%!" in - let _ = Hashtbl.replace state.dp_db sfs.Switch.datapath_id conn in - Lwt_list.iter_p (fun cb -> cb state sfs.Switch.datapath_id evt) + let _ = Hashtbl.replace state.dp_db sfs.OP.Switch.datapath_id conn in + Lwt_list.iter_p (fun cb -> cb state sfs.OP.Switch.datapath_id evt) state.datapath_join_cb end - | Packet_in (h, p) -> begin (* Generate a packet_in event *) + | OP.Packet_in (h, p) -> begin (* Generate a packet_in event *) let _ = if state.verbose then pp "[controller]+ %s|%s\n%!" (OP.Header.header_to_string h) (OP.Packet_in.packet_in_to_string p) in let evt = - Event.Packet_in (p.Packet_in.in_port, p.Packet_in.reason, - p.Packet_in.buffer_id, p.Packet_in.data, conn.dpid) in + Event.Packet_in (p.OP.Packet_in.in_port, p.OP.Packet_in.reason, + p.OP.Packet_in.buffer_id, p.OP.Packet_in.data, conn.dpid) in iter_p (fun cb -> cb state conn.dpid evt) state.packet_in_cb end - | Flow_removed (h, p) -> + | OP.Flow_removed (h, p) -> let _ = if state.verbose then pp "+ %s|%s\n%!" (OP.Header.header_to_string h) (OP.Flow_removed.string_of_flow_removed p) in let evt = Event.Flow_removed ( - p.Flow_removed.of_match, p.Flow_removed.reason, - p.Flow_removed.duration_sec, p.Flow_removed.duration_nsec, - p.Flow_removed.packet_count, p.Flow_removed.byte_count, conn.dpid) + p.OP.Flow_removed.of_match, p.OP.Flow_removed.reason, + p.OP.Flow_removed.duration_sec, p.OP.Flow_removed.duration_nsec, + p.OP.Flow_removed.packet_count, p.OP.Flow_removed.byte_count, conn.dpid) in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_removed_cb | Stats_resp(h, resp) -> begin @@ -203,24 +203,24 @@ let process_of_packet state conn ofp = match resp with | OP.Stats.Flow_resp(resp_h, flows) -> begin let evt = Event.Flow_stats_reply( - h.Header.xid, resp_h.Stats.more, flows, conn.dpid) + h.Header.xid, resp_h.OP.Stats.more, flows, conn.dpid) in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_stats_reply_cb end | OP.Stats.Aggregate_resp(resp_h, aggr) -> begin let evt = Event.Aggr_flow_stats_reply( - h.Header.xid, aggr.Stats.packet_count, - aggr.Stats.byte_count, aggr.Stats.flow_count, conn.dpid) + h.Header.xid, aggr.OP.Stats.packet_count, + aggr.OP.Stats.byte_count, aggr.OP.Stats.flow_count, conn.dpid) in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.aggr_flow_stats_reply_cb end | OP.Stats.Desc_resp (resp_h, aggr) -> begin let evt = Event.Desc_stats_reply( - aggr.Stats.imfr_desc, aggr.Stats.hw_desc, - aggr.Stats.sw_desc, aggr.Stats.serial_num, - aggr.Stats.dp_desc, conn.dpid) + aggr.OP.Stats.imfr_desc, aggr.OP.Stats.hw_desc, + aggr.OP.Stats.sw_desc, aggr.OP.Stats.serial_num, + aggr.OP.Stats.dp_desc, conn.dpid) in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.desc_stats_reply_cb @@ -248,7 +248,7 @@ let process_of_packet state conn ofp = | Port_status(h, st) -> begin let _ = if state.verbose then pp "[controller] + %s|%s" (OP.Header.header_to_string h) (OP.Port.string_of_status st) in - let evt = Event.Port_status (st.Port.reason, st.Port.desc, conn.dpid) in + let evt = Event.Port_status (st.OP.Port.reason, st.OP.Port.desc, conn.dpid) in Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_status_cb end | ofp -> diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index dba3cd5..c2baa0a 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -26,29 +26,16 @@ exception Unparsable of string * Cstruct.t exception Unparsed of string * Cstruct.t exception Unsupported of string -let resolve t = Lwt.on_success t (fun _ -> ()) let (|>) x f = f x (* pipe *) let (>>) f g x = g (f x) (* functor pipe *) let (||>) l f = List.map f l (* element-wise pipe *) -let (+++) x y = Int32.add x y - -let (&&&) x y = Int32.logand x y -let (|||) x y = Int32.logor x y -let (^^^) x y = Int32.logxor x y -let (<<<) x y = Int32.shift_left x y -let (>>>) x y = Int32.shift_right_logical x y - -let join c l = String.concat c l -let stop (x, bits) = x (* drop remainder to stop parsing and demuxing *) - -type int16 = int - (* XXX of dubious merit - but we don't do arithmetic so prefer the documentation benefits for now *) type uint8 = char type uint16 = int +type int16 = int type uint32 = int32 type uint64 = int64 @@ -75,13 +62,6 @@ type vendor = uint32 type queue_id = uint32 type datapath_id = uint64 -let contain_exc l v = - try - Some (v ()) - with exn -> - eprintf "ofpacket %s exn: %s\n%!" l (Printexc.to_string exn); - None - (* * bit manipulation functions for 32-bit integers * *) @@ -111,14 +91,13 @@ let set_int_bit f off v = f lor ((int_of_bool v) lsl off) let marshal_and_sub fn bits = let len = fn bits in - Cstruct.sub bits 0 len + Cstruct.sub bits 0 len let marshal_and_shift fn bits = let len = fn bits in - (len, (Cstruct.shift bits len)) + (len, (Cstruct.shift bits len)) module Header = struct - cstruct ofp_header { uint8_t version; uint8_t typ; @@ -163,16 +142,16 @@ type h = { let parse_header bits = match ((get_ofp_header_version bits), (int_to_msg_code (get_ofp_header_typ bits))) with - | (1, Some(ty)) - -> let ret = - { ver=(char_of_int (get_ofp_header_version bits)); + | (1, Some(ty)) -> + let ret = + { ver=(char_of_int (get_ofp_header_version bits)); ty; len=(get_ofp_header_length bits); xid=(get_ofp_header_xid bits); } in - let _ = Cstruct.shift bits sizeof_ofp_header in + let _ = Cstruct.shift bits sizeof_ofp_header in ret - | (_, _) -> raise (Unparsable ("parse_h", bits)) - + | (_, _) -> raise (Unparsable ("parse_h", bits)) + let header_to_string h = sp "ver:%d type:%s len:%d xid:0x%08lx" (int_of_byte h.ver) (msg_code_to_string h.ty) h.len h.xid @@ -185,7 +164,7 @@ type h = { let _ = set_ofp_header_typ bits (msg_code_to_int h.ty) in let _ = set_ofp_header_length bits h.len in let _ = set_ofp_header_xid bits h.xid in - sizeof_ofp_header + sizeof_ofp_header end module Queue = struct @@ -279,7 +258,7 @@ module Port = struct let ret = set_int32_bit ret 4 config.no_flood in let ret = set_int32_bit ret 5 config.no_fwd in let ret = set_int32_bit ret 6 config.no_packet_in in - ret + ret let init_port_config = {port_down=false; no_stp=false; no_recv=false; no_recv_stp=false; @@ -423,19 +402,19 @@ module Port = struct peer=port.peer;} - let marshal_phy phy bits = - let _ = set_ofp_phy_port_port_no bits phy.port_no in - let _ = set_ofp_phy_port_hw_addr (Macaddr.to_bytes phy.hw_addr) 0 bits in - let name = String.make 16 (char_of_int 0) in - let _ = String.blit phy.name 0 name 0 (String.length phy.name) in - let _ = set_ofp_phy_port_name name 0 bits in - let _ = set_ofp_phy_port_config bits 0l in - let _ = set_ofp_phy_port_state bits 0l in - let _ = set_ofp_phy_port_curr bits 0l in - let _ = set_ofp_phy_port_advertised bits 0l in - let _ = set_ofp_phy_port_supported bits 0l in - let _ = set_ofp_phy_port_peer bits 0l in - Cstruct.shift bits sizeof_ofp_phy_port + let marshal_phy phy bits = + let _ = set_ofp_phy_port_port_no bits phy.port_no in + let _ = set_ofp_phy_port_hw_addr (Macaddr.to_bytes phy.hw_addr) 0 bits in + let name = String.make 16 (char_of_int 0) in + let _ = String.blit phy.name 0 name 0 (String.length phy.name) in + let _ = set_ofp_phy_port_name name 0 bits in + let _ = set_ofp_phy_port_config bits 0l in + let _ = set_ofp_phy_port_state bits 0l in + let _ = set_ofp_phy_port_curr bits 0l in + let _ = set_ofp_phy_port_advertised bits 0l in + let _ = set_ofp_phy_port_supported bits 0l in + let _ = set_ofp_phy_port_peer bits 0l in + Cstruct.shift bits sizeof_ofp_phy_port let string_of_phy ph = (sp "port_no:%d,hw_addr:%s,name:%s" @@ -694,8 +673,7 @@ module Switch = struct miss_send_len: uint16; } - let init_switch_config = - {drop=true; reasm=true;miss_send_len=1000;} + let init_switch_config = {drop=true; reasm=true;miss_send_len=1000;} cstruct ofp_switch_config { uint16_t flags; @@ -2237,8 +2215,7 @@ module Stats = struct let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type DESC) in - let _ = set_ofp_stats_reply_flags bits (int_of_bool - resp_hdr.more) in + let _ = set_ofp_stats_reply_flags bits (int_of_bool resp_hdr.more) in let bits = Cstruct.shift bits sizeof_ofp_stats_reply in let _ = set_ofp_desc_stats_mfr_desc desc.imfr_desc 0 bits in let _ = set_ofp_desc_stats_hw_desc desc.hw_desc 0 bits in @@ -2255,8 +2232,7 @@ module Stats = struct let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in let _ = set_ofp_stats_reply_typ bits (int_of_stats_type FLOW) in - let _ = set_ofp_stats_reply_flags bits (int_of_bool - resp_h.more) in + let _ = set_ofp_stats_reply_flags bits (int_of_bool resp_h.more) in let bits = Cstruct.shift bits sizeof_ofp_stats_reply in let (flows_len, bits) = marshal_and_shift (Flow.marshal_flow_stats flows) bits in @@ -2469,7 +2445,7 @@ let build_echo_resp h bits = let _ = Header.(marshal_header (create ~xid:h.xid ECHO_RESP len ) bits) in - len + len type t = | Hello of Header.h @@ -2581,11 +2557,12 @@ let marshal msg = | Flow_mod (h, fm) -> Flow_mod.marshal_flow_mod ~xid:h.Header.xid fm | _ -> failwith "Unsupported message" - in + in + marshal_and_sub marshal (OS.Io_page.to_cstruct (OS.Io_page.get 1)) (* | Vendor of Header.h * vendor * Cstruct.t | Port_mod of Header.h * Port_mod.t | Queue_get_config_req of Header.h * Port.t | Queue_get_config_resp of Header.h * Port.t * Queue.t array *) - marshal_and_sub marshal (OS.Io_page.to_cstruct (OS.Io_page.get 1)) + diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index d35216d..49a0b1e 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -25,7 +25,8 @@ open Printf open Jsonrpc -module OP = Ofpacket +module OP = Openflow.Ofpacket +module OSK = Openflow.Ofsocket exception Packet_type_unknw @@ -249,7 +250,7 @@ module Table = struct packet_count=flow.Entry.counters.Entry.n_packets; byte_count=flow.Entry.counters.Entry.n_bytes;}) in let h = OP.Header.(create ~xid FLOW_REMOVED (OP.Flow_removed.get_len)) in - Ofsocket.send_packet t (OP.Flow_removed (h,fl_rm)) + OSK.send_packet t (OP.Flow_removed (h,fl_rm)) | _ -> return () ) remove_flow @@ -351,7 +352,7 @@ module Switch = struct (* Mapping port ids to port numbers *) mutable int_to_port: (int, port ref) Hashtbl.t; mutable ports : port list; - mutable controller: Ofsocket.conn_state option; + mutable controller: OSK.conn_state option; table: Table.t; stats: stats; p_sflow: uint32; (** probability for sFlow sampling *) @@ -531,7 +532,7 @@ module Switch = struct (* let _ = printf "[ofswitch] sending packet to controller\n%!" in *) match st.controller with | None -> return () - | Some conn -> Ofsocket.send_packet conn (OP.Packet_in (h, pkt_in)) + | Some conn -> OSK.send_packet conn (OP.Packet_in (h, pkt_in)) end (* | Table * | Normal *) @@ -679,7 +680,7 @@ let process_frame_inner st p frame = return (ignore_result ( match st.Switch.controller with | None -> return () - | Some conn -> Ofsocket.send_packet conn (OP.Packet_in (h, pkt_in)) + | Some conn -> OSK.send_packet conn (OP.Packet_in (h, pkt_in)) )) end (* generate a packet in event *) @@ -776,14 +777,14 @@ let process_openflow st t msg = return () | OP.Echo_req h -> (* Reply to ECHO requests *) let _ = if st.Switch.verbose then cp "ECHO_REQ" in - Ofsocket.send_packet t + OSK.send_packet t (OP.Echo_req OP.Header.(create ~xid:h.xid ECHO_RESP sizeof_ofp_header)) | OP.Features_req (h) -> let _ = if st.Switch.verbose then cp "FEAT_REQ" in let h = OP.Header.create ~xid:(h.OP.Header.xid) OP.Header.FEATURES_RESP (OP.Switch.get_len st.Switch.features) in - Ofsocket.send_packet t (OP.Features_resp (h, st.Switch.features)) + OSK.send_packet t (OP.Features_resp (h, st.Switch.features)) | OP.Stats_req(h, req) -> begin let xid = h.OP.Header.xid in let _ = if st.Switch.verbose then cp "STATS_REQ" in @@ -796,7 +797,7 @@ let process_openflow st t msg = sw_desc="Mirage"; serial_num="0.1";dp_desc="Mirage";} )) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len p) in - Ofsocket.send_packet t (OP.Stats_resp (h, p)) + OSK.send_packet t (OP.Stats_resp (h, p)) | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> (*TODO Need to consider the table_id and the out_port and * split reply over multiple openflow packets if they don't @@ -811,7 +812,7 @@ let process_openflow st t msg = if (sz + fl_sz > 0xffff) then let r = OP.Stats.Flow_resp(stats, flows) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in - lwt _ = Ofsocket.send_packet t (OP.Stats_resp (h, r)) in + lwt _ = OSK.send_packet t (OP.Stats_resp (h, r)) in return ((OP.Header.get_len + OP.Stats.get_resp_hdr_size + fl_sz), [fl]) else return ((sz + fl_sz), (fl::flows)) ) @@ -819,7 +820,7 @@ let process_openflow st t msg = let stats = OP.Stats.({st_ty=FLOW; more=false;}) in let r = OP.Stats.Flow_resp(stats, flows) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in - Ofsocket.send_packet t (OP.Stats_resp (h, r)) + OSK.send_packet t (OP.Stats_resp (h, r)) | OP.Stats.Aggregate_req (req_h, of_match, table, port) -> let aggr_flow_bytes = ref 0L in let aggr_flow_pkts = ref 0L in @@ -842,12 +843,12 @@ let process_openflow st t msg = flow_count=(!aggr_flows);})) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in - Ofsocket.send_packet t (OP.Stats_resp (h, r)) + OSK.send_packet t (OP.Stats_resp (h, r)) | OP.Stats.Table_req(req) -> let stats = OP.Stats.({st_ty=TABLE; more=false;}) in let r = OP.Stats.Table_resp(stats, [st.Switch.table.Table.stats]) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in - Ofsocket.send_packet t (OP.Stats_resp (h, r)) + OSK.send_packet t (OP.Stats_resp (h, r)) | OP.Stats.Port_req(req_h, port) -> begin match port with | OP.Port.No_port -> @@ -855,32 +856,32 @@ let process_openflow st t msg = let stats = OP.Stats.({st_ty=PORT; more=false;}) in let r = OP.Stats.Port_resp(stats, port_stats) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in - Ofsocket.send_packet t (OP.Stats_resp (h, r)) + OSK.send_packet t (OP.Stats_resp (h, r)) | OP.Port.Port(port_id) -> begin try_lwt let port = Hashtbl.find st.Switch.int_to_port port_id in let stats = OP.Stats.({st_ty=PORT; more=false;}) in let r = OP.Stats.Port_resp(stats, [(!port).Switch.counter]) in let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in - Ofsocket.send_packet t (OP.Stats_resp (h, r)) + OSK.send_packet t (OP.Stats_resp (h, r)) with Not_found -> (* TODO reply with right error code *) pr "Invalid port_id in stats\n%!"; let h = OP.Header.create ~xid OP.Header.ERROR (OP.Header.get_len + 4) in - Ofsocket.send_packet t + OSK.send_packet t (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) end | _ -> pr "Invalid port_id in stats\n%!"; let h = OP.Header.create ~xid OP.Header.ERROR 0 in - Ofsocket.send_packet t + OSK.send_packet t OP.(Error (h, ACTION_BAD_OUT_PORT, (marshal msg))) end | _ -> begin let h = OP.Header.create ~xid OP.Header.ERROR (OP.Header.get_len + 4) in - Ofsocket.send_packet t + OSK.send_packet t (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) end end @@ -888,13 +889,13 @@ let process_openflow st t msg = let resp = OP.Switch.init_switch_config in let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.GET_CONFIG_RESP OP.Switch.config_get_len in - Ofsocket.send_packet t (OP.Get_config_resp(h, resp)) + OSK.send_packet t (OP.Get_config_resp(h, resp)) | OP.Barrier_req(h) -> let _ = if st.Switch.verbose then cp (sp "BARRIER_REQ: %s" (OP.Header.header_to_string h)) in let resp_h = (OP.Header.create ~xid:h.OP.Header.xid OP.Header.BARRIER_RESP (OP.Header.sizeof_ofp_header)) in - Ofsocket.send_packet t (OP.Barrier_resp(resp_h)) + OSK.send_packet t (OP.Barrier_resp(resp_h)) | OP.Packet_out(h, pkt) -> let _ = if st.Switch.verbose then cp (sp "PACKET_OUT: %s" @@ -918,7 +919,7 @@ let process_openflow st t msg = let bits = OP.marshal msg in let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR (OP.Header.get_len + 4 + (Cstruct.len bits)) in - Ofsocket.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) + OSK.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) | Some(pkt_in) -> (* let _ = pr "Sending as packet_out data %d\n%!" (Cstruct.len pkt_in.OP.Packet_in.data) in *) @@ -966,7 +967,7 @@ let process_openflow st t msg = let bits = OP.marshal msg in let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR (OP.Header.get_len + 4 + (Cstruct.len bits)) in - Ofsocket.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) + OSK.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) | Some(pkt_in) -> (* TODO check if the match is accurate? *) Switch.apply_of_actions st pkt_in.OP.Packet_in.in_port @@ -989,15 +990,15 @@ let process_openflow st t msg = let bits = OP.marshal msg in let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR (OP.Header.get_len + 4 + (Cstruct.len bits)) in - Ofsocket.send_packet t (OP.Error(h, OP.REQUEST_BAD_TYPE, bits)) + OSK.send_packet t (OP.Error(h, OP.REQUEST_BAD_TYPE, bits)) let control_channel_run st conn t = (* Trigger the dance between the 2 nodes *) let h = OP.Header.(create ~xid:1l HELLO sizeof_ofp_header) in - lwt _ = Ofsocket.send_packet conn (OP.Hello(h)) in + lwt _ = OSK.send_packet conn (OP.Hello(h)) in let rec echo () = try_lwt - lwt ofp = Ofsocket.read_packet conn in + lwt ofp = OSK.read_packet conn in lwt _ = process_openflow st conn ofp in echo () with @@ -1017,14 +1018,14 @@ let control_channel_run st conn t = st.Switch.verbose in return (pp "[switch] terminated flow_timeout thread") ) in - let _ = Ofsocket.close conn in + let _ = OSK.close conn in let _ = st.Switch.controller <- None in return (printf "control channel thread returned\n%!") let control_channel st (remote_addr, remote_port) t = let rs = Ipaddr.V4.to_string remote_addr in Printf.eprintf "OpenFlow Switch: controller %s:%d" rs remote_port; - let conn = Ofsocket.init_socket_conn_state t in + let conn = OSK.init_socket_conn_state t in let _ = st.Switch.controller <- (Some conn) in let t, _ = Lwt.task () in control_channel_run st conn t @@ -1059,7 +1060,7 @@ let add_port mgr ?(use_mac=false) sw id = lwt _ = match sw.Switch.controller with | None -> return () - | Some t -> Ofsocket.send_packet t (OP.Port_status (h,p)) + | Some t -> OSK.send_packet t (OP.Port_status (h,p)) in return () @@ -1102,7 +1103,7 @@ let del_port mgr sw name = lwt _ = match sw.Switch.controller with | None -> return () - | Some t -> Ofsocket.send_packet t (OP.Port_status (h,p)) + | Some t -> OSK.send_packet t (OP.Port_status (h,p)) in return () with exn -> @@ -1154,23 +1155,23 @@ let create_switch ?(verbose=false) dpid = let listen st mgr loc = Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> - (forward_thread st) <&> + (forward_thread st) (* <&> (Ofswitch_config.listen_t mgr - (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) + (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) *) let connect st mgr loc = Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> - (forward_thread st) <&> + (forward_thread st) (* <&> (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) - (add_flow st) (del_flow st) 6634) + (add_flow st) (del_flow st) 6634) *) let local_connect st mgr conn = let _ = st.Switch.controller <- (Some conn) in let t, _ = Lwt.task () in (control_channel_run st conn t) <&> - (forward_thread st) <&> + (forward_thread st) (* <&> (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) - (add_flow st) (del_flow st) 6634) + (add_flow st) (del_flow st) 6634) *) (* let lwt_connect st ?(standalone=true) mgr loc = @@ -1187,7 +1188,7 @@ let lwt_connect st ?(standalone=true) mgr loc = let _ = Console.log "Standalone controller taking over..." in lwt (switch_in, switch_out) = Ofswitch_standalone.run_controller mgr of_ctrl in - let conn = Ofsocket.init_local_conn_state switch_in switch_out in + let conn = OSK.init_local_conn_state switch_in switch_out in let _ = st.Switch.controller <- (Some conn) in lwt _ = control_channel_run st conn t in (* lwt _ = log ~level:Notice "Standalone controller stopped..." in *) @@ -1209,7 +1210,7 @@ let lwt_connect st ?(standalone=true) mgr loc = connect_socket () in lwt sock = connect_socket () in - let conn = Ofsocket.init_unix_conn_state sock in + let conn = OSK.init_unix_conn_state sock in let _ = wakeup u () in let t,_ = Lwt.task () in let _ = st.Switch.controller <- (Some conn) in diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index a94733f..a3e62f5 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -20,16 +20,16 @@ type t val add_port : Manager.t -> ?use_mac:bool -> t -> Manager.id -> unit Lwt.t val del_port : Manager.t -> t -> string -> unit Lwt.t val add_port_local : Manager.t -> t -> Manager.id -> unit Lwt.t -val add_flow : t -> Ofpacket.Flow_mod.t -> unit Lwt.t -val del_flow : t -> Ofpacket.Match.t -> unit Lwt.t -val get_flow_stats : t -> Ofpacket.Match.t -> Ofpacket.Flow.stats list +val add_flow : t -> Openflow.Ofpacket.Flow_mod.t -> unit Lwt.t +val del_flow : t -> Openflow.Ofpacket.Match.t -> unit Lwt.t +val get_flow_stats : t -> Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list val create_switch : ?verbose:bool -> int64 -> t val listen : t -> Manager.t -> Nettypes.ipv4_src -> unit Lwt.t val connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t -val local_connect : t -> Manager.t -> Ofsocket.conn_state -> unit Lwt.t +val local_connect : t -> Manager.t -> Openflow.Ofsocket.conn_state -> unit Lwt.t (* val lwt_connect : t -> ?standalone:bool -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 4a23d69..0e1ca85 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -17,7 +17,7 @@ open Lwt open Printf -module OP = Ofpacket +module OP = Openflow.Ofpacket let parse_actions actions = let actions = Re_str.split (Re_str.regexp "/") actions in diff --git a/lib/ofswitch_config.mli b/lib/ofswitch_config.mli index fbd661a..580ca54 100644 --- a/lib/ofswitch_config.mli +++ b/lib/ofswitch_config.mli @@ -16,7 +16,7 @@ val listen_t: Net.Manager.t -> (string -> unit Lwt.t) -> - (Ofpacket.Match.t -> Ofpacket.Flow.stats list) -> - (Ofpacket.Flow_mod.t -> unit Lwt.t) -> - (Ofpacket.Match.t -> unit Lwt.t) -> + (Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list) -> + (Openflow.Ofpacket.Flow_mod.t -> unit Lwt.t) -> + (Openflow.Ofpacket.Match.t -> unit Lwt.t) -> int -> unit Lwt.t diff --git a/lib/ofswitch_standalone.ml b/lib/ofswitch_standalone.ml index 86787de..9bd6d2b 100644 --- a/lib/ofswitch_standalone.ml +++ b/lib/ofswitch_standalone.ml @@ -20,9 +20,10 @@ open Net.Nettypes let resolve t = Lwt.on_success t (fun _ -> ()) -module OP = Ofpacket -module OC = Ofcontroller -module OE = Ofcontroller.Event +module OP = Openflow.Ofpacket +module OC = Openflow.Ofcontroller +module OE = Openflow.Ofcontroller.Event +module OSK = Openflow.Ofsocket let pp = Printf.printf let sp = Printf.sprintf @@ -104,7 +105,7 @@ let packet_in_cb controller dpid evt = then ( let bs = (OP.Packet_out.create ~buffer_id:buffer_id - ~actions:[ OP.(Flow.Output(Port.All , 2000))] + ~actions:[ OP.Flow.Output(OP.Port.All , 2000)] ~data:data ~in_port:in_port () ) in let h = OP.Header.create OP.Header.PACKET_OUT 0 in OC.send_data controller dpid (OP.Packet_out (h, bs)) @@ -117,7 +118,7 @@ let packet_in_cb controller dpid evt = let bs = OP.Packet_out.create ~buffer_id:buffer_id - ~actions:[ OP.(Flow.Output(out_port, 2000))] + ~actions:[ OP.Flow.Output(out_port, 2000)] ~data:data ~in_port:in_port () in let h = OP.Header.create OP.Header.PACKET_OUT 0 in OC.send_data controller dpid (OP.Packet_out (h, bs)) @@ -146,7 +147,7 @@ let init controller = let init_controller () = OC.init_controller () let run_controller mgr st = - let (controller, switch) = Ofsocket.init_local_conn_state () in + let (controller, switch) = OSK.init_local_conn_state () in let _ = Lwt.ignore_result ( try_lwt OC.local_connect st controller init diff --git a/lib/ofswitch_standalone.mli b/lib/ofswitch_standalone.mli index 82c3bcf..544777e 100644 --- a/lib/ofswitch_standalone.mli +++ b/lib/ofswitch_standalone.mli @@ -14,5 +14,5 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val init_controller : unit -> Ofcontroller.t -val run_controller : Net.Manager.t -> Ofcontroller.t -> Ofsocket.conn_state Lwt.t +val init_controller : unit -> Openflow.Ofcontroller.t +val run_controller : Net.Manager.t -> Openflow.Ofcontroller.t -> Openflow.Ofsocket.conn_state Lwt.t diff --git a/lib/openflow.mlpack b/lib/openflow.mlpack index 2ca8d91..2371ea3 100644 --- a/lib/openflow.mlpack +++ b/lib/openflow.mlpack @@ -1,12 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: f8655b265a303b0b1fd5a6766c3a4bec) +# DO NOT EDIT (digest: b6991de36e646d2bbeea2320259aae59) Ofpacket Ofcontroller -Ofswitch_config -Ofswitch Ofsocket -Ofswitch_standalone -Flowvisor -Flowvisor_topology -Lldp # OASIS_STOP diff --git a/lib/openflow.odocl b/lib/openflow.odocl index 065ffa4..2371ea3 100644 --- a/lib/openflow.odocl +++ b/lib/openflow.odocl @@ -1,8 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: a1ecbcce9d30ec0a1efa572ec81d47c0) +# DO NOT EDIT (digest: b6991de36e646d2bbeea2320259aae59) Ofpacket Ofcontroller -Ofswitch Ofsocket -Ofswitch_config # OASIS_STOP diff --git a/lib/openflow_lwt_unix.mllib b/lib/openflow_lwt_unix.mllib deleted file mode 100644 index b4d2a31..0000000 --- a/lib/openflow_lwt_unix.mllib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: de41b2701caa2c8011a5d2e3e48ede84) -Ofcontroller -Ofswitch -# OASIS_STOP diff --git a/lib/openflow_mirage.mllib b/lib/openflow_mirage.mllib deleted file mode 100644 index b4d2a31..0000000 --- a/lib/openflow_mirage.mllib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: de41b2701caa2c8011a5d2e3e48ede84) -Ofcontroller -Ofswitch -# OASIS_STOP diff --git a/lib/switch.mlpack b/lib/switch.mlpack new file mode 100644 index 0000000..b1c6b86 --- /dev/null +++ b/lib/switch.mlpack @@ -0,0 +1,6 @@ +# OASIS_START +# DO NOT EDIT (digest: a67c0c05231915ebff9464af7a4213ec) +Ofswitch +Ofswitch_config +Ofswitch_standalone +# OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 0c84238..10c29d3 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: fbb3c99856cfddeac4941c0abf1cced2) *) +(* DO NOT EDIT (digest: 5c0327d92c84f6043020022b5ea159eb) *) module OASISGettext = struct (* # 21 "src/oasis/OASISGettext.ml" *) @@ -477,15 +477,16 @@ end open Ocamlbuild_plugin;; let package_default = { - MyOCamlbuildBase.lib_ocaml = [("openflow", ["lib"])]; + MyOCamlbuildBase.lib_ocaml = + [("openflow", ["lib"]); ("switch", ["lib"]); ("flv", ["lib"])]; lib_c = []; flags = []; - includes = [("controller", ["lib"])]; + includes = []; } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 490 "myocamlbuild.ml" +# 491 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index 54b7465..73fb5b3 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: b767096e08fa686b006c3ab0f2a5c26f) *) +(* DO NOT EDIT (digest: d412df15aa76654e76696a3f48373004) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5699,8 +5699,6 @@ let setup_t = FindlibPackage ("mirage-net", Some (OASISVersion.VGreaterEqual "0.3.0")); - FindlibPackage ("re.str", None); - FindlibPackage ("ocamlgraph", None); FindlibPackage ("ipaddr", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; @@ -5714,18 +5712,7 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { - lib_modules = - [ - "Ofpacket"; - "Ofcontroller"; - "Ofswitch_config"; - "Ofswitch"; - "Ofsocket"; - "Ofswitch_standalone"; - "Flowvisor"; - "Flowvisor_topology"; - "Lldp" - ]; + lib_modules = ["Ofpacket"; "Ofcontroller"; "Ofsocket"]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = None; @@ -5760,26 +5747,18 @@ let setup_t = doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; }); - Executable + Library ({ - cs_name = "ovs-vsctl"; + cs_name = "switch"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "lwt", true) - ]; + bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "openflow"; - FindlibPackage ("re.str", None) - ]; + bs_build_depends = [FindlibPackage ("re.str", None)]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -5790,28 +5769,28 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - {exec_custom = true; exec_main_is = "ofswitch_ctrl.ml"; }); - Executable + { + lib_modules = + ["Ofswitch"; "Ofswitch_config"; "Ofswitch_standalone" + ]; + lib_pack = true; + lib_internal_modules = []; + lib_findlib_parent = Some "openflow"; + lib_findlib_name = Some "switch"; + lib_findlib_containers = []; + }); + Library ({ - cs_name = "learning_switch_lwt"; + cs_name = "flv"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "lwt", true) - ]; + bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "controller"; + bs_path = "lib"; bs_compiled_object = Native; - bs_build_depends = - [ - FindlibPackage ("cstruct", None); - FindlibPackage ("cstruct.syntax", None); - InternalLibrary "openflow" - ]; + bs_build_depends = []; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -5822,8 +5801,15 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - {exec_custom = true; exec_main_is = "learning_switch.ml"; - }) + { + lib_modules = + ["Flowvisor"; "Lldp"; "Flowvisor_topology"]; + lib_pack = true; + lib_internal_modules = []; + lib_findlib_parent = Some "openflow"; + lib_findlib_name = Some "flv"; + lib_findlib_containers = []; + }) ]; plugins = [(`Extra, "META", Some "0.2")]; schema_data = PropList.Data.create (); @@ -5831,7 +5817,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "\214K\028\241~7Z}\189\248d\214o\254k3"; + oasis_digest = Some "\b{\243X\220\190\251]\157\023\192rS\189\200\171"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5839,6 +5825,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5843 "setup.ml" +# 5829 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 915d275f3bbca51711b87a44fdeffde2b81815ac Mon Sep 17 00:00:00 2001 From: crotsos Date: Tue, 24 Sep 2013 10:28:29 +0100 Subject: [PATCH 54/75] fixed unix-socket backed compilation --- Makefile | 19 +- _oasis | 66 +++- _tags | 86 +++++- controller/learning_switch.ml | 16 +- lib/META | 11 +- lib/lldp.ml | 21 +- lib/ofswitch_ctrl.ml | 2 +- myocamlbuild.ml | 72 +++-- setup.ml | 556 +++++++++++++++++++++++++++++----- 9 files changed, 709 insertions(+), 140 deletions(-) diff --git a/Makefile b/Makefile index 263f96f..b634d85 100644 --- a/Makefile +++ b/Makefile @@ -4,15 +4,17 @@ all: build NAME=openflow J=4 -LWT ?= $(shell if ocamlfind query lwt.ssl >/dev/null 2>&1; then echo --enable-lwt; fi) -MIRAGE ?= $(shell if [ $MIRAGE_OS = "xen" ]; then echo --enable-mirage; fi) -MIRAGE = --enable-mirage +UNIX ?= $(shell if ocamlfind query lwt.ssl >/dev/null 2>&1; then echo --enable-unix; fi) + +XEN ?= $(shell if [ $MIRAGE_OS = "xen" ]; then echo --enable-xen; fi) +# MIRAGE = --enable-mirage -include Makefile.config setup.data: _oasis - oasis setup - ocaml setup.ml -configure $(LWT) $(MIRAGE) + oasis setup + echo XXXXX $(MIRAGE_NET) $(UNIX) $(XEN) $(DIRECT) + ocaml setup.ml -configure $(UNIX) $(XEN) $(DIRECT) clean: setup.data ocaml setup.ml -clean $(OFLAGS) @@ -25,7 +27,12 @@ distclean: setup.ml setup.data setup: setup.data build: setup.data $(wildcard lib/*.ml) - ocaml setup.ml -build -j $(J) $(OFLAGS) + ifeq ($(MIRAGE_NET), "direct") + DR ?= "--enable-direct" + echo "hello" $(MIRAGE_NET) $(DR) + endif + echo "hello" $(MIRAGE_NET) $(DR) + ocaml setup.ml -build -j $(J) $(OFLAGS) $(DR) doc: setup.data setup.ml ocaml setup.ml -doc -j $(J) $(OFLAGS) diff --git a/_oasis b/_oasis index 141ecb4..e3f8788 100644 --- a/_oasis +++ b/_oasis @@ -4,27 +4,22 @@ Name: openflow Version: 0.3.0 Authors: Charalampos Rotsos, Richard Mortier, Anil Madhavappedy, Balraj Singh License: ISC -Synopsis: OpenFlow protocol and switch implementations in pure OCaml +Synopsis: OpenFlow controller, switch and flowvisor implementation in pure OCaml Plugins: META (0.2) BuildTools: ocamlbuild -Flag lwt - Description: build the Lwt library +Flag direct + Description: build things over the direct xen net Default: false -Flag async - Description: build the Core/Async library +Flag unix + Description: build programs with a depency on lwt.unix Default: false -Flag mirage - Description: build the Mirage library +Flag xen + Description: build xen applications Default: false -Flag nettests - Description: run the internet-using tests - Default: false - - Library openflow Path: lib Findlibname: openflow @@ -44,6 +39,7 @@ Library switch Path: lib Findlibname: switch Findlibparent: openflow + Build$: flag(direct) CompiledObject: native Modules: Ofswitch, Ofswitch_config, Ofswitch_standalone Pack: True @@ -56,3 +52,49 @@ Library flv CompiledObject: native Modules: Flowvisor,Lldp, Flowvisor_topology Pack: True + +Executable "ocaml-ofctl" + Path: lib + MainIs: ofswitch_ctrl.ml + Build$: flag(unix) + Custom: true + CompiledObject: native + Install$: flag(unix) + BuildDepends: openflow, re.str + +Executable ofcontroller_lwt + Path: controller + MainIs: learning_switch.ml + Build$: flag(unix) + Custom: true + CompiledObject: native + Install$: flag(unix) + BuildDepends: openflow + +Executable ofswitch_lwt + Path: switch + MainIs: basic_switch.ml + Build$: flag(unix) && flag(direct) + Custom: true + CompiledObject: native + Install$: flag(unix) && flag(direct) + BuildDepends: openflow + + +Executable "ofcontroller.o" + Path: controller + MainIs: learning_switch.ml + Build$: flag(xen) + Custom: true + CompiledObject: native_object + Install: false + BuildDepends: openflow + +Executable "ofswitch.o" + Path: switch + MainIs: basic_switch.ml + Build$: flag(xen) + Custom: true + CompiledObject: native_object + Install: false + BuildDepends: openflow diff --git a/_tags b/_tags index 595ccc0..54918da 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 223fee9da9926174167e33e3c8f49757) +# DO NOT EDIT (digest: a6346ea7787afaf53f974c8470a6635b) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -18,24 +18,92 @@ "lib/ofpacket.cmx": for-pack(Openflow) "lib/ofcontroller.cmx": for-pack(Openflow) "lib/ofsocket.cmx": for-pack(Openflow) -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_rpclib -: pkg_rpclib.json -: pkg_mirage -: pkg_mirage-net -: pkg_ipaddr # Library switch "lib/switch.cmxs": use_switch "lib/ofswitch.cmx": for-pack(Switch) "lib/ofswitch_config.cmx": for-pack(Switch) "lib/ofswitch_standalone.cmx": for-pack(Switch) -: pkg_re.str # Library flv "lib/flv.cmxs": use_flv "lib/flowvisor.cmx": for-pack(Flv) "lib/lldp.cmx": for-pack(Flv) "lib/flowvisor_topology.cmx": for-pack(Flv) +# Executable ocaml-ofctl +"lib/ofswitch_ctrl.native": use_openflow +"lib/ofswitch_ctrl.native": pkg_re.str +"lib/ofswitch_ctrl.native": pkg_cstruct +"lib/ofswitch_ctrl.native": pkg_cstruct.syntax +"lib/ofswitch_ctrl.native": pkg_rpclib +"lib/ofswitch_ctrl.native": pkg_rpclib.json +"lib/ofswitch_ctrl.native": pkg_mirage +"lib/ofswitch_ctrl.native": pkg_mirage-net +"lib/ofswitch_ctrl.native": pkg_ipaddr +: use_openflow +: pkg_re.str +: pkg_cstruct +: pkg_cstruct.syntax +: pkg_rpclib +: pkg_rpclib.json +: pkg_mirage +: pkg_mirage-net +: pkg_ipaddr +"lib/ofswitch_ctrl.native": custom +# Executable ofcontroller_lwt +"controller/learning_switch.native": use_openflow +"controller/learning_switch.native": pkg_cstruct +"controller/learning_switch.native": pkg_cstruct.syntax +"controller/learning_switch.native": pkg_rpclib +"controller/learning_switch.native": pkg_rpclib.json +"controller/learning_switch.native": pkg_mirage +"controller/learning_switch.native": pkg_mirage-net +"controller/learning_switch.native": pkg_ipaddr +"controller/learning_switch.native": custom +# Executable ofswitch_lwt +"switch/basic_switch.native": use_openflow +"switch/basic_switch.native": pkg_cstruct +"switch/basic_switch.native": pkg_cstruct.syntax +"switch/basic_switch.native": pkg_rpclib +"switch/basic_switch.native": pkg_rpclib.json +"switch/basic_switch.native": pkg_mirage +"switch/basic_switch.native": pkg_mirage-net +"switch/basic_switch.native": pkg_ipaddr +"switch/basic_switch.native": custom +# Executable ofcontroller.o +"controller/learning_switch.nobj.o": use_openflow +"controller/learning_switch.nobj.o": pkg_cstruct +"controller/learning_switch.nobj.o": pkg_cstruct.syntax +"controller/learning_switch.nobj.o": pkg_rpclib +"controller/learning_switch.nobj.o": pkg_rpclib.json +"controller/learning_switch.nobj.o": pkg_mirage +"controller/learning_switch.nobj.o": pkg_mirage-net +"controller/learning_switch.nobj.o": pkg_ipaddr +: use_openflow +: pkg_cstruct +: pkg_cstruct.syntax +: pkg_rpclib +: pkg_rpclib.json +: pkg_mirage +: pkg_mirage-net +: pkg_ipaddr +"controller/learning_switch.nobj.o": custom +# Executable ofswitch.o +"switch/basic_switch.nobj.o": use_openflow +"switch/basic_switch.nobj.o": pkg_cstruct +"switch/basic_switch.nobj.o": pkg_cstruct.syntax +"switch/basic_switch.nobj.o": pkg_rpclib +"switch/basic_switch.nobj.o": pkg_rpclib.json +"switch/basic_switch.nobj.o": pkg_mirage +"switch/basic_switch.nobj.o": pkg_mirage-net +"switch/basic_switch.nobj.o": pkg_ipaddr +: use_openflow +: pkg_cstruct +: pkg_cstruct.syntax +: pkg_rpclib +: pkg_rpclib.json +: pkg_mirage +: pkg_mirage-net +: pkg_ipaddr +"switch/basic_switch.nobj.o": custom # OASIS_STOP true: annot : syntax_camlp4o diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index 5924433..3999b4d 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -34,13 +34,13 @@ let sp = Printf.sprintf (* TODO this the mapping is incorrect. the datapath must be moved to the key * of the hashtbl *) type mac_switch = { - addr: OP.eaddr; + addr: Macaddr.t; switch: OP.datapath_id; } type switch_state = { (* mutable mac_cache: (mac_switch, OP.Port.t) Hashtbl.t; *) - mutable mac_cache: (OP.eaddr, OP.Port.t) Hashtbl.t; + mutable mac_cache: (Macaddr.t, OP.Port.t) Hashtbl.t; (* mutable dpid: OP.datapath_id list; mutable of_ctrl: OC.t list; *) req_count: int ref; @@ -80,7 +80,7 @@ let packet_in_cb controller dpid evt = * we need to send *) let broadcast = String.make 6 '\255' in let ix = m.OP.Match.dl_dst in - if ( (ix = broadcast) + if ( (ix = Macaddr.broadcast) || (not (Hashtbl.mem switch_data.mac_cache ix)) ) then ( let bs = @@ -89,7 +89,7 @@ let packet_in_cb controller dpid evt = (OP.Packet_out.create ~buffer_id:buffer_id ~actions:[ OP.(Flow.Output(Port.All , 2000))] - ~data:data ~in_port:in_port () )) (Cstruct.of_bigarray (OS.Io_page.get ())) in + ~data:data ~in_port:in_port () )) (Cstruct.of_bigarray (OS.Io_page.get 1)) in OC.send_of_data controller dpid bs ) else ( let out_port = (Hashtbl.find switch_data.mac_cache ix) in @@ -104,7 +104,7 @@ let packet_in_cb controller dpid evt = ~buffer_id:buffer_id ~actions:[ OP.(Flow.Output(out_port, 2000))] ~data:data ~in_port:in_port () )) - (Cstruct.of_bigarray (OS.Io_page.get ())) in + (Cstruct.of_bigarray (OS.Io_page.get 1)) in OC.send_of_data controller dpid bs else return () @@ -115,7 +115,7 @@ let packet_in_cb controller dpid evt = (OP.Flow_mod.create m 0_L OP.Flow_mod.ADD ~hard_timeout:0 ~idle_timeout:0 ~buffer_id:(Int32.to_int buffer_id) ~flags [OP.Flow.Output(out_port, 2000)] ())) - (Cstruct.of_bigarray (OS.Io_page.get ())) in + (Cstruct.of_bigarray (OS.Io_page.get 1)) in OC.send_of_data controller dpid pkt ) @@ -134,8 +134,8 @@ let run () = try_lwt let ip = (* (ipv4_addr_of_tuple (10l,0l,0l,253l), *) - ( ipv4_addr_of_tuple (128l, 232l, 32l, 230l), - ipv4_addr_of_tuple (255l,255l,255l,0l), []) in + ( Ipaddr.V4.make 128l 232l 32l 230l, + Ipaddr.V4.make 255l 255l 255l 0l, []) in lwt _ = Manager.configure interface (`IPv4 ip) in OC.listen mgr (None, port) init with | e -> diff --git a/lib/META b/lib/META index 5d59419..8e41e3f 100644 --- a/lib/META +++ b/lib/META @@ -1,7 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 69cff10087bc2c089bf031d3ee41c178) +# DO NOT EDIT (digest: fb3a7474b6d3d22fd415ea0a71caf87e) version = "0.3.0" -description = "OpenFlow protocol and switch implementations in pure OCaml" +description = +"OpenFlow controller, switch and flowvisor implementation in pure OCaml" requires = "cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net ipaddr" archive(byte) = "openflow.cma" @@ -11,7 +12,8 @@ archive(native, plugin) = "openflow.cmxs" exists_if = "openflow.cmxa" package "switch" ( version = "0.3.0" - description = "OpenFlow protocol and switch implementations in pure OCaml" + description = + "OpenFlow controller, switch and flowvisor implementation in pure OCaml" requires = "re.str" archive(byte) = "switch.cma" archive(byte, plugin) = "switch.cma" @@ -22,7 +24,8 @@ package "switch" ( package "flv" ( version = "0.3.0" - description = "OpenFlow protocol and switch implementations in pure OCaml" + description = + "OpenFlow controller, switch and flowvisor implementation in pure OCaml" archive(byte) = "flv.cma" archive(byte, plugin) = "flv.cma" archive(native) = "flv.cmxa" diff --git a/lib/lldp.ml b/lib/lldp.ml index 2ef8fa3..393f0fb 100644 --- a/lib/lldp.ml +++ b/lib/lldp.ml @@ -53,6 +53,13 @@ cenum lldp_port_id_subtype { LLDP_PORT_LOCAL_SUBTYPE = 7 } as uint8_t*) +cstruct ethernet { + uint8_t dst[6]; + uint8_t src[6]; + uint16_t ethertype +} as big_endian + + type lldp_tlv_types = LLDP_TYPE_END | LLDP_TYPE_CHASSIS_ID @@ -274,7 +281,7 @@ let parse_lldp_tlv bits = let parse_lldp_tlvs bits = (* Ignore ethernet headers for now *) - let bits = Cstruct.shift bits Ethif.sizeof_ethernet in + let bits = Cstruct.shift bits sizeof_ethernet in let rec parse_lldp_tlvs_inner bits = match (Cstruct.len bits) with | 0 -> [] @@ -345,11 +352,11 @@ let marsal_lldp_tlv tlv bits = | Tlv_unk (typ, data) -> set_lldp_tlv_typ_data bits typ data let marsal_lldp_tlvs mac tlvs bits = - let _ = Net.Ethif.set_ethernet_dst "\x01\x80\xc2\x00\x00\x0e" 0 bits in - let _ = Net.Ethif.set_ethernet_src (Macaddr.to_bytes mac) + let _ = set_ethernet_dst "\x01\x80\xc2\x00\x00\x0e" 0 bits in + let _ = set_ethernet_src (Macaddr.to_bytes mac) 0 bits in - let _ = Net.Ethif.set_ethernet_ethertype bits 0x88cc in - let bits = Cstruct.shift bits Ethif.sizeof_ethernet in + let _ = set_ethernet_ethertype bits 0x88cc in + let bits = Cstruct.shift bits sizeof_ethernet in let rec marsal_lldp_tlvs_inner tlvs bits = match tlvs with | [] -> 0 @@ -359,6 +366,4 @@ let marsal_lldp_tlvs mac tlvs bits = let rest = marsal_lldp_tlvs_inner t bits in len + rest in - Ethif.sizeof_ethernet + marsal_lldp_tlvs_inner tlvs bits - - + sizeof_ethernet + marsal_lldp_tlvs_inner tlvs bits diff --git a/lib/ofswitch_ctrl.ml b/lib/ofswitch_ctrl.ml index 324bb2f..4affac8 100644 --- a/lib/ofswitch_ctrl.ml +++ b/lib/ofswitch_ctrl.ml @@ -17,7 +17,7 @@ open Lwt open Printf -open Openflow.Ofswitch_config +open Ofswitch_config open Lwt_unix let check_cmd_args cmd count = diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 10c29d3..b7598f9 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 5c0327d92c84f6043020022b5ea159eb) *) +(* DO NOT EDIT (digest: b2a966b3ccd88941fecd0a8f887ad47f) *) module OASISGettext = struct (* # 21 "src/oasis/OASISGettext.ml" *) @@ -234,19 +234,21 @@ module MyOCamlbuildFindlib = struct Ocamlbuild_pack.Lexers.blank_sep_strings let split s ch = - let x = - ref [] + let buf = Buffer.create 13 in + let x = ref [] in + let flush () = + x := (Buffer.contents buf) :: !x; + Buffer.clear buf in - let rec go s = - let pos = - String.index s ch - in - x := (String.before s pos)::!x; - go (String.after s (pos + 1)) - in - try - go s - with Not_found -> !x + String.iter + (fun c -> + if c = ch then + flush () + else + Buffer.add_char buf c) + s; + flush (); + List.rev !x let split_nl s = split s '\n' @@ -281,17 +283,27 @@ module MyOCamlbuildFindlib = struct (* When one link an OCaml library/binary/package, one should use -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + flag ["ocaml"; "link"; "output_obj"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> - flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; + let base_args = [A"-package"; A pkg] in + let syn_args = [A"-syntax"; A "camlp4o"] in + let args = + (* heuristic to identify syntax extensions: + whether they end in ".syntax"; some might not *) + if Filename.check_suffix pkg "syntax" + then syn_args @ base_args + else base_args + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; end (find_packages ()); @@ -452,6 +464,24 @@ module MyOCamlbuildBase = struct ) t.lib_c; + (* Add output_obj rules mapped to .nobj.o *) + let native_output_obj x = + OC.link_gen "cmx" "cmxa" !Options.ext_lib [!Options.ext_obj; "cmi"] + OC.ocamlopt_link_prog + (fun tags -> tags++"ocaml"++"link"++"native"++"output_obj") x + in + rule "ocaml: cmx* and o* -> .nobj.o" ~prod:"%.nobj.o" ~deps:["%.cmx"; "%.o"] + (native_output_obj "%.cmx" "%.nobj.o"); + + (* Add output_obj rules mapped to .bobj.o *) + let bytecode_output_obj x = + OC.link_gen "cmo" "cma" !Options.ext_lib [!Options.ext_obj; "cmi"] + OC.ocamlc_link_prog + (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") x + in + rule "ocaml: cmo* -> .nobj.o" ~prod:"%.bobj.o" ~deps:["%.cmo"] + (bytecode_output_obj "%.cmo" "%.bobj.o"); + (* Add flags *) List.iter (fun (tags, cond_specs) -> @@ -473,7 +503,7 @@ module MyOCamlbuildBase = struct end -# 476 "myocamlbuild.ml" +# 506 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -481,12 +511,12 @@ let package_default = [("openflow", ["lib"]); ("switch", ["lib"]); ("flv", ["lib"])]; lib_c = []; flags = []; - includes = []; + includes = [("switch", ["lib"]); ("controller", ["lib"])]; } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 491 "myocamlbuild.ml" +# 521 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index 73fb5b3..5b119b7 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ -(* setup.ml generated for the first time by OASIS v0.3.0 *) +(* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: d412df15aa76654e76696a3f48373004) *) +(* DO NOT EDIT (digest: f3594f9aca8476215a598758ce81e9dd) *) (* - Regenerated by OASIS v0.3.0 + Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -964,6 +964,8 @@ module OASISTypes = struct type compiled_object = | Byte | Native + | Native_object + | Bytecode_object | Best @@ -1018,7 +1020,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "src/oasis/OASISTypes.ml" *) +(* # 104 "src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1066,6 +1068,13 @@ module OASISTypes = struct lib_findlib_containers: findlib_name list; } + + type object_ = + { + obj_modules: string list; + obj_findlib_fullname: findlib_name list option; + } + type executable = { exec_custom: bool; @@ -1126,6 +1135,7 @@ module OASISTypes = struct type section = | Library of common_section * build_section * library + | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository @@ -1134,7 +1144,7 @@ module OASISTypes = struct type section_kind = - [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { @@ -1301,6 +1311,8 @@ module OASISSection = struct function | Library (cs, _, _) -> `Library, cs + | Object (cs, _, _) -> + `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> @@ -1318,6 +1330,7 @@ module OASISSection = struct let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) + | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) @@ -1338,6 +1351,7 @@ module OASISSection = struct in (match k with | `Library -> "library" + | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" @@ -1390,6 +1404,8 @@ module OASISExecutable = struct let is_native_exec = match bs.bs_compiled_object with | Native -> true + | Native_object -> false + | Bytecode_object -> false | Best -> is_native () | Byte -> false in @@ -1415,23 +1431,8 @@ module OASISLibrary = struct open OASISGettext open OASISSection - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - library * - group_t list) - (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists (cs, bs, lib) modul = + let find_module source_file_exists bs modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) @@ -1472,7 +1473,7 @@ module OASISLibrary = struct let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> - match find_module source_file_exists (cs, bs, lib) modul with + match find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> @@ -1496,7 +1497,7 @@ module OASISLibrary = struct let find_modules lst ext = let find_module modul = - match find_module source_file_exists (cs, bs, lib) modul with + match find_module source_file_exists bs modul with | `Sources (base_fn, _) -> [base_fn] | `No_sources lst -> @@ -1531,6 +1532,8 @@ module OASISLibrary = struct (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true + | Native_object -> false + | Bytecode_object -> false | Best -> is_native | Byte -> false in @@ -1568,11 +1571,11 @@ module OASISLibrary = struct [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with - | Native -> + | Native | Native_object -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) - | Byte | Best -> + | Byte | Bytecode_object | Best -> byte acc_nopath in @@ -1598,7 +1601,100 @@ module OASISLibrary = struct acc_nopath) (headers @ cmxs) - type data = common_section * build_section * library +end + +module OASISObject = struct +(* # 21 "src/oasis/OASISObject.ml" *) + + open OASISTypes + open OASISGettext + + let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = + List.fold_left + (fun acc modul -> + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name; + acc) + [] + obj.obj_modules + + + let generated_unix_files + ~ctxt + ~is_native + ~source_file_exists + (cs, bs, obj) = + + let find_module ext modul = + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, _) -> [base_fn ^ ext] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name ; + lst + in + + let header, byte, native, c_object, f = + match obj.obj_modules with + | [ m ] -> (find_module ".cmi" m, + find_module ".cmo" m, + find_module ".cmx" m, + find_module ".o" m, + fun x -> x) + | _ -> ([cs.cs_name ^ ".cmi"], + [cs.cs_name ^ ".cmo"], + [cs.cs_name ^ ".cmx"], + [cs.cs_name ^ ".o"], + OASISUnixPath.concat bs.bs_path) + in + List.map (List.map f) ( + match bs.bs_compiled_object with + | Native | Native_object -> + native :: c_object :: byte :: header :: [] + | Best when is_native -> + native :: c_object :: byte :: header :: [] + | Byte | Bytecode_object | Best -> + byte :: header :: []) + +end + +module OASISFindlib = struct +(* # 21 "src/oasis/OASISFindlib.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + [`Library of library | `Object of object_] * + group_t list) + + type data = common_section * + build_section * + [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data @@ -1641,6 +1737,23 @@ module OASISLibrary = struct mp end + | Object (cs, _, obj) -> + begin + let obj_name = cs.cs_name in + if MapString.mem obj_name mp then + failwithf + (f_ "The object name '%s' is used more than once.") + obj_name; + let findlib_full_name = match obj.obj_findlib_fullname with + | Some ns -> String.concat "." ns + | None -> obj_name + in + MapString.add + obj_name + (`Solved findlib_full_name) + mp + end + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty @@ -1778,7 +1891,9 @@ module OASISLibrary = struct (fun mp -> function | Library (cs, bs, lib) -> - add (cs, bs, lib) mp + add (cs, bs, `Library lib) mp + | Object (cs, bs, obj) -> + add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty @@ -2139,7 +2254,7 @@ module OASISFileUtil = struct end -# 2142 "setup.ml" +# 2257 "setup.ml" module BaseEnvLight = struct (* # 21 "src/base/BaseEnvLight.ml" *) @@ -2237,7 +2352,7 @@ module BaseEnvLight = struct end -# 2240 "setup.ml" +# 2355 "setup.ml" module BaseContext = struct (* # 21 "src/base/BaseContext.ml" *) @@ -3541,6 +3656,7 @@ module BaseBuilt = struct | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) + | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = @@ -3549,6 +3665,7 @@ module BaseBuilt = struct | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" + | BObj -> "obj" | BDoc -> "doc")^ "_"^nm @@ -3612,6 +3729,8 @@ module BaseBuilt = struct (f_ "executable %s") | BLib -> (f_ "library %s") + | BObj -> + (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); @@ -3674,6 +3793,23 @@ module BaseBuilt = struct in evs, unix_lst + + let of_object ffn (cs, bs, obj) = + let unix_lst = + OASISObject.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + (cs, bs, obj) + in + let evs = + [BObj, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + end module BaseCustom = struct @@ -3768,7 +3904,7 @@ module BaseDynVar = struct (f_ "Executable '%s' not yet built.") cs.cs_name))))) - | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end @@ -4146,6 +4282,7 @@ module BaseSetup = struct (f t.package (cs, doc)) args | Library _ + | Object _ | Executable _ | Flag _ | SrcRepo _ -> @@ -4477,7 +4614,7 @@ module BaseSetup = struct end -# 4480 "setup.ml" +# 4617 "setup.ml" module InternalConfigurePlugin = struct (* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -4656,6 +4793,20 @@ module InternalConfigurePlugin = struct | None -> () end; + (* Make sure the findlib version is fine for the OCaml compiler. *) + begin + let ocaml_ge4 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) + (OASISVersion.version_of_string "4.0.0") >= 0 in + if ocaml_ge4 then + let findlib_lt132 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) + (OASISVersion.version_of_string "1.3.2") < 0 in + if findlib_lt132 then + add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" + end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || @@ -4731,7 +4882,7 @@ module InternalInstallPlugin = struct open BaseStandardVar open BaseMessage open OASISTypes - open OASISLibrary + open OASISFindlib open OASISGettext open OASISUtils @@ -4741,6 +4892,9 @@ module InternalInstallPlugin = struct let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) + let obj_hook = + ref (fun (cs, bs, obj) -> cs, bs, obj, []) + let doc_hook = ref (fun (cs, doc) -> cs, doc) @@ -4961,6 +5115,75 @@ module InternalInstallPlugin = struct begin (f_data, acc) end + and files_of_object (f_data, acc) data_obj = + let cs, bs, obj, obj_extra = + !obj_hook data_obj + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then + begin + let acc = + (* Start with acc + obj_extra *) + List.rev_append obj_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + acc + end) + acc + obj.obj_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BObj + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the object *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + in (* Install one group of library *) @@ -4971,8 +5194,10 @@ module InternalInstallPlugin = struct match grp with | Container (_, children) -> data_and_files, children - | Package (_, cs, bs, lib, children) -> + | Package (_, cs, bs, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children + | Package (_, cs, bs, `Object obj, children) -> + files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux @@ -5230,7 +5455,7 @@ module InternalInstallPlugin = struct end -# 5233 "setup.ml" +# 5458 "setup.ml" module OCamlbuildCommon = struct (* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -5365,6 +5590,19 @@ module OCamlbuildPlugin = struct in_build_dir (OASISHostPath.of_unix fn) in + (* Checks if the string [fn] ends with [nd] *) + let ends_with nd fn = + let nd_len = + String.length nd + in + (String.length fn >= nd_len) + && + (String.sub + fn + (String.length fn - nd_len) + nd_len) = nd + in + let cond_targets = List.fold_left (fun acc -> @@ -5377,18 +5615,6 @@ module OCamlbuildPlugin = struct (cs, bs, lib) in - let ends_with nd fn = - let nd_len = - String.length nd - in - (String.length fn >= nd_len) - && - (String.sub - fn - (String.length fn - nd_len) - nd_len) = nd - in - let tgts = List.flatten (List.filter @@ -5413,6 +5639,35 @@ module OCamlbuildPlugin = struct cs.cs_name end + | Object (cs, bs, obj) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_object + in_build_dir_of_unix + (cs, bs, obj) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ".cmo" fn + || ends_with ".cmx" fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for object %s") + cs.cs_name + end + | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = @@ -5444,8 +5699,12 @@ module OCamlbuildPlugin = struct (* Add executable *) let acc = match bs.bs_compiled_object with + | Native_object -> + (target ".nobj.o") :: acc + | Bytecode_object -> + (target ".bobj.o") :: acc | Native -> - (target ".native") :: acc + (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte @@ -5455,7 +5714,7 @@ module OCamlbuildPlugin = struct acc end - | Library _ | Executable _ | Test _ + | Library _ | Object _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] @@ -5555,7 +5814,7 @@ module OCamlbuildDocPlugin = struct end -# 5558 "setup.ml" +# 5817 "setup.ml" open OASISTypes;; let setup_t = @@ -5599,7 +5858,7 @@ let setup_t = ]; homepage = None; synopsis = - "OpenFlow protocol and switch implementations in pure OCaml"; + "OpenFlow controller, switch and flowvisor implementation in pure OCaml"; description = None; categories = []; conf_type = (`Configure, "internal", Some "0.3"); @@ -5640,42 +5899,34 @@ let setup_t = [ Flag ({ - cs_name = "lwt"; + cs_name = "direct"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - flag_description = Some "build the Lwt library"; + flag_description = + Some "build things over the direct xen net"; flag_default = [(OASISExpr.EBool true, false)]; }); Flag ({ - cs_name = "async"; + cs_name = "unix"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - flag_description = Some "build the Core/Async library"; + flag_description = + Some "build programs with a depency on lwt.unix"; flag_default = [(OASISExpr.EBool true, false)]; }); Flag ({ - cs_name = "mirage"; + cs_name = "xen"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - flag_description = Some "build the Mirage library"; - flag_default = [(OASISExpr.EBool true, false)]; - }); - Flag - ({ - cs_name = "nettests"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "run the internet-using tests"; + flag_description = Some "build xen applications"; flag_default = [(OASISExpr.EBool true, false)]; }); Library @@ -5754,7 +6005,11 @@ let setup_t = cs_plugin_data = []; }, { - bs_build = [(OASISExpr.EBool true, true)]; + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "direct", true) + ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; bs_compiled_object = Native; @@ -5809,15 +6064,174 @@ let setup_t = lib_findlib_parent = Some "openflow"; lib_findlib_name = Some "flv"; lib_findlib_containers = []; - }) + }); + Executable + ({ + cs_name = "ocaml-ofctl"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "unix", true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "unix", true) + ]; + bs_path = "lib"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "openflow"; + FindlibPackage ("re.str", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = true; exec_main_is = "ofswitch_ctrl.ml"; }); + Executable + ({ + cs_name = "ofcontroller_lwt"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "unix", true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "unix", true) + ]; + bs_path = "controller"; + bs_compiled_object = Native; + bs_build_depends = [InternalLibrary "openflow"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = true; exec_main_is = "learning_switch.ml"; + }); + Executable + ({ + cs_name = "ofswitch_lwt"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EAnd + (OASISExpr.EFlag "unix", + OASISExpr.EFlag "direct"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EAnd + (OASISExpr.EFlag "unix", + OASISExpr.EFlag "direct"), + true) + ]; + bs_path = "switch"; + bs_compiled_object = Native; + bs_build_depends = [InternalLibrary "openflow"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = true; exec_main_is = "basic_switch.ml"; }); + Executable + ({ + cs_name = "ofcontroller.o"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "xen", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "controller"; + bs_compiled_object = Native_object; + bs_build_depends = [InternalLibrary "openflow"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = true; exec_main_is = "learning_switch.ml"; + }); + Executable + ({ + cs_name = "ofswitch.o"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "xen", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "switch"; + bs_compiled_object = Native_object; + bs_build_depends = [InternalLibrary "openflow"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = true; exec_main_is = "basic_switch.ml"; }) ]; plugins = [(`Extra, "META", Some "0.2")]; schema_data = PropList.Data.create (); plugin_data = []; }; oasis_fn = Some "_oasis"; - oasis_version = "0.3.0"; - oasis_digest = Some "\b{\243X\220\190\251]\157\023\192rS\189\200\171"; + oasis_version = "0.3.1"; + oasis_digest = Some "\205\242\155\\\000/\243\1843\196\132\189\0311\234e"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5825,6 +6239,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5829 "setup.ml" +# 6243 "setup.ml" (* OASIS_STOP *) let () = setup ();; From ba59b389935ddaf6fd253e2c8785e64fa59bd651 Mon Sep 17 00:00:00 2001 From: crotsos Date: Wed, 25 Sep 2013 19:32:17 +0100 Subject: [PATCH 55/75] documenting and cleaning code for the switch module --- lib/ofswitch.ml | 1095 +++++++++++++++--------------------- lib/ofswitch.mli | 42 +- lib/ofswitch_standalone.ml | 4 +- switch/basic_switch.ml | 33 +- 4 files changed, 520 insertions(+), 654 deletions(-) diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 49a0b1e..3277170 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -16,14 +16,8 @@ *) open Lwt -open OS -open Net -open Nettypes open Ofswitch_config -open Printf -open Jsonrpc - module OP = Openflow.Ofpacket module OSK = Openflow.Ofsocket @@ -54,7 +48,7 @@ let get_new_buffer len = Cstruct.sub buf 0 len let get_ethif mgr id = - let lst = Manager.get_intfs mgr in + let lst = Net.Manager.get_intfs mgr in let (_, ethif) = List.find (fun (dev_id,_) -> id = dev_id) lst in ethif @@ -72,10 +66,10 @@ module Entry = struct flags : OP.Flow_mod.flags; priority: uint16; cookie: int64; - insert_sec: uint32; - insert_nsec: uint32; - mutable last_sec: uint32; - mutable last_nsec: uint32; + insert_sec: int; + insert_nsec: int; + mutable last_sec: int; + mutable last_nsec: int; idle_timeout: int; hard_timeout:int; } @@ -87,10 +81,10 @@ module Entry = struct } let init_flow_counters t = - let ts = Int32.of_float (OS.Clock.time ()) in + let ts = int_of_float (OS.Clock.time ()) in {n_packets=0L; n_bytes=0L; priority=t.OP.Flow_mod.priority; - cookie=t.OP.Flow_mod.cookie; insert_sec=ts; insert_nsec=0l; - last_sec=ts;last_nsec=0l; idle_timeout=t.OP.Flow_mod.idle_timeout; + cookie=t.OP.Flow_mod.cookie; insert_sec=ts; insert_nsec=0; + last_sec=ts;last_nsec=0; idle_timeout=t.OP.Flow_mod.idle_timeout; hard_timeout=t.OP.Flow_mod.hard_timeout; flags=t.OP.Flow_mod.flags; } @@ -102,8 +96,7 @@ module Entry = struct let update_flow pkt_len flow = flow.counters.n_packets <- Int64.add flow.counters.n_packets 1L; flow.counters.n_bytes <- Int64.add flow.counters.n_bytes pkt_len; - let ts = OS.Clock.time () in - flow.counters.last_sec <- (Int32.of_float ts) + flow.counters.last_sec <- int_of_float (OS.Clock.time ()) let flow_counters_to_flow_stats of_match table_id flow = @@ -115,8 +108,10 @@ module Entry = struct let byte_count=flow.counters.n_bytes in let action=flow.actions in OP.Flow.({table_id; of_match; - duration_sec=(Int32.sub flow.counters.last_sec flow.counters.insert_sec); - duration_nsec=(Int32.sub flow.counters.last_nsec flow.counters.insert_nsec); + duration_sec = Int32.of_int (flow.counters.last_sec - + flow.counters.insert_sec); + duration_nsec = Int32.of_int (flow.counters.last_nsec - + flow.counters.insert_nsec); priority; idle_timeout; hard_timeout; cookie; packet_count; byte_count; action; }) @@ -125,10 +120,11 @@ end module Table = struct type t = { tid: cookie; - (* This stores entries as they arrive *) + (* This entry stores wildcard and exact match entries as + * transmitted by the controller *) mutable entries: (OP.Match.t, Entry.t) Hashtbl.t; - (* This stores only exact match entries.*) - (* TODO delete an entry from both tables *) + (* Intermediate table to store exact match flos deriving from wildcard + * entries *) mutable cache : (OP.Match.t, Entry.t ref) Hashtbl.t; stats : OP.Stats.table; } @@ -141,52 +137,39 @@ module Table = struct lookup_count=0L; matched_count=0L});} (* TODO fix flow_mod flag support. overlap is not considered *) - let add_flow st table t = + let add_flow st table t verbose = (* TODO check if the details are correct e.g. IP type etc. *) - let _ = - if (t.OP.Flow_mod.of_match.OP.Match.wildcards=(OP.Wildcards.exact_match ())) then - t.OP.Flow_mod.priority <- 0x1001 + let open OP.Flow_mod in + let open OP.Match in + let _ = + (* max priority for exact match rules *) + if (t.of_match.wildcards=(OP.Wildcards.exact_match ())) then + t.priority <- 0x1001 in -(* lwt _ = - log ~level:Notice - (sprintf "Adding flow %s" (OP.Match.match_to_string t.OP.Flow_mod.of_match)) in *) let entry = Entry.({actions=t.OP.Flow_mod.actions; counters=(init_flow_counters t); cache_entries=[];}) in - - (* TODO log data to the visualisation server *) -(* let _ = - match (Lwt.get OS.Topology.node_name) with - | None -> () - | Some(node_name) -> - let flow_str = OP.Match.match_to_string t.OP.Flow_mod.of_match in - let action_str = OP.Flow.string_of_actions t.OP.Flow_mod.actions in - let msg = Rpc.Dict [ - ("name", (Rpc.String node_name)); - ("type", (Rpc.String "add")); - ("flow", (Rpc.String flow_str)); - ("action", (Rpc.String action_str)); - ] in - OS.Console.broadcast "flow" (Jsonrpc.to_string msg) - in *) - - let _ = Hashtbl.replace table.entries t.OP.Flow_mod.of_match entry in + let _ = Hashtbl.replace table.entries t.of_match entry in (* In the fast path table, I need to delete any conflicting entries *) let _ = Hashtbl.iter ( fun a e -> - if ((OP.Match.flow_match_compare a t.OP.Flow_mod.of_match - t.OP.Flow_mod.of_match.OP.Match.wildcards) && - (entry.Entry.counters.Entry.priority >= (!e).Entry.counters.Entry.priority)) then ( + if ((flow_match_compare a t.of_match t.of_match.wildcards) && + Entry.(entry.counters.priority >= (!e).counters.priority)) then ( let _ = (!e).Entry.cache_entries <- - List.filter (fun c -> not (a = c)) (!e).Entry.cache_entries in + List.filter (fun c -> a <> c) (!e).Entry.cache_entries in let _ = Hashtbl.replace table.cache a (ref entry) in - entry.Entry.cache_entries <- entry.Entry.cache_entries @ [a] + entry.Entry.cache_entries <- a :: entry.Entry.cache_entries ) - ) table.cache in - return () + ) table.cache in + let _ = if (verbose) then + cp (sp "[switch] Adding flow %s" (OP.Match.match_to_string t.of_match)) + in + return () (* check if a list of actions has an output action forwarding packets to - * out_port *) + * out_port. + * Used when removing a port from the switch control in order to clean related + * flows *) let rec is_output_port out_port = function | [] -> false | OP.Flow.Output(port, _)::_ when (port = out_port) -> true @@ -235,17 +218,16 @@ module Table = struct fun (of_match, flow) -> let _ = if verbose then - Console.log - (sprintf "Removing flow %s" (OP.Match.match_to_string of_match)) + cp (sp "[switch] Removing flow %s" (OP.Match.match_to_string of_match)) in match(t, flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) with | (Some t, true) -> - let duration_sec = Int32.sub (Int32.of_float (OS.Clock.time ())) + let duration_sec = (int_of_float (OS.Clock.time ())) - flow.Entry.counters.Entry.insert_sec in let fl_rm = OP.Flow_removed.( {of_match; cookie=flow.Entry.counters.Entry.cookie; priority=flow.Entry.counters.Entry.priority; - reason; duration_sec; duration_nsec=0l; + reason; duration_sec=(Int32.of_int duration_sec); duration_nsec=0l; idle_timeout=flow.Entry.counters.Entry.idle_timeout; packet_count=flow.Entry.counters.Entry.n_packets; byte_count=flow.Entry.counters.Entry.n_bytes;}) in @@ -261,32 +243,32 @@ module Table = struct table.stats.matched_count <- Int64.add table.stats.matched_count 1L let update_table_missed table = - table.stats.OP.Stats.lookup_count <- Int64.add - table.stats.OP.Stats.lookup_count 1L + let open OP.Stats in + table.stats.lookup_count <- Int64.add table.stats.lookup_count 1L (* monitor thread to timeout flows *) - let check_flow_timeout table t verbose = - let ts = (Int32.of_float (OS.Clock.time ())) in - let flows = Hashtbl.fold ( - fun of_match entry ret -> - let hard = Int32.to_int (Int32.sub ts entry.Entry.counters.Entry.insert_sec) in - let idle = Int32.to_int (Int32.sub ts entry.Entry.counters.Entry.last_sec) in - match (hard, idle) with - | (l, _) when ((entry.Entry.counters.Entry.hard_timeout > 0) && - (l >= entry.Entry.counters.Entry.hard_timeout)) -> - ret @ [(of_match, entry, OP.Flow_removed.HARD_TIMEOUT )] - | (_, l) when ((entry.Entry.counters.Entry.idle_timeout > 0) && - (l >= entry.Entry.counters.Entry.idle_timeout)) -> - ret @ [(of_match, entry, OP.Flow_removed.IDLE_TIMEOUT )] - | _ -> ret - ) table.entries [] in - Lwt_list.iter_s ( - fun (of_match, entry, reason) -> - del_flow table ~reason of_match OP.Port.No_port t verbose - ) flows - - let monitor_flow_timeout table t verbose = + let open Entry in + let check_flow_timeout table t verbose = + let ts = int_of_float (OS.Clock.time ()) in + let flows = Hashtbl.fold ( + fun of_match entry ret -> + let hard = ts - entry.counters.insert_sec in + let idle = ts - entry.counters.last_sec in + match (hard, idle) with + | (l, _) when ((entry.counters.hard_timeout > 0) && + (l >= entry.counters.hard_timeout)) -> + (of_match, entry, OP.Flow_removed.HARD_TIMEOUT )::ret + | (_, l) when ((entry.counters.idle_timeout > 0) && + (l >= entry.counters.idle_timeout)) -> + ret @ [(of_match, entry, OP.Flow_removed.IDLE_TIMEOUT )] + | _ -> ret + ) table.entries [] in + Lwt_list.iter_s ( + fun (of_match, entry, reason) -> + del_flow table ~reason of_match OP.Port.No_port t verbose + ) flows + in while_lwt true do lwt _ = OS.Time.sleep 1.0 in check_flow_timeout table t verbose @@ -295,7 +277,7 @@ end module Switch = struct type port = { - mgr: Manager.t; + mgr: Net.Manager.t; port_id: int; ethif: Net.Manager.id; port_name: string; @@ -304,35 +286,35 @@ module Switch = struct queue: Cstruct.t Queue.t; } - let init_port mgr port_no id = - let ethif = Manager.get_ethif ( get_ethif mgr id ) in - let name = OS.Netif.string_of_id (OS.Netif.id (Ethif.get_netif ethif )) in - let hw_addr = Ethif.mac ethif in - let counter = OP.Port.( - { port_id=port_no; rx_packets=0L; tx_packets=0L; rx_bytes=0L; - tx_bytes=0L; rx_dropped=0L; tx_dropped=0L; rx_errors=0L; - tx_errors=0L; rx_frame_err=0L; rx_over_err=0L; rx_crc_err=0L; - collisions=0L;}) in + let init_port mgr port_no id = + let ethif = Net.Manager.get_ethif ( get_ethif mgr id ) in + let name = OS.Netif.string_of_id (OS.Netif.id (Net.Ethif.get_netif ethif )) in + let hw_addr = Net.Ethif.mac ethif in + let counter = OP.Port.( + { port_id=port_no; rx_packets=0L; tx_packets=0L; rx_bytes=0L; + tx_bytes=0L; rx_dropped=0L; tx_dropped=0L; rx_errors=0L; + tx_errors=0L; rx_frame_err=0L; rx_over_err=0L; rx_crc_err=0L; + collisions=0L;}) in let features = OP.Port.( - {pause_asym=true; pause=true; autoneg=true; fiber=true; - copper=true; f_10GB_FD=true; f_1GB_FD=true; f_1GB_HD=true; - f_100MB_FD=true; f_100MB_HD=true; f_10MB_FD=true; - f_10MB_HD=true;}) in + {pause_asym=true; pause=true; autoneg=true; fiber=true; + copper=true; f_10GB_FD=true; f_1GB_FD=true; f_1GB_HD=true; + f_100MB_FD=true; f_100MB_HD=true; f_10MB_FD=true; + f_10MB_HD=true;}) in let port_config = OP.Port.( - { port_down=false; no_stp=false; no_recv=false; - no_recv_stp=false; no_flood=false; no_fwd=false; - no_packet_in=false;}) in + { port_down=false; no_stp=false; no_recv=false; + no_recv_stp=false; no_flood=false; no_fwd=false; + no_packet_in=false;}) in let port_state = OP.Port.( - {link_down =false; stp_listen =false; stp_learn =false; - stp_forward =false; stp_block =false;}) in + {link_down =false; stp_listen =false; stp_learn =false; + stp_forward =false; stp_block =false;}) in let phy = OP.Port.( - {port_no; hw_addr;name; config= port_config; - state= port_state; curr=features; advertised=features; - supported=features; peer=features;}) in + {port_no; hw_addr;name; config= port_config; + state= port_state; curr=features; advertised=features; + supported=features; peer=features;}) in - {port_id=port_no; mgr; port_name=name; counter; - ethif=id;phy;queue=(Queue.create ());} + {port_id=port_no; mgr; port_name=name; counter; + ethif=id;phy;queue=(Queue.create ());} type stats = { mutable n_frags: uint64; @@ -353,9 +335,10 @@ module Switch = struct mutable int_to_port: (int, port ref) Hashtbl.t; mutable ports : port list; mutable controller: OSK.conn_state option; + mutable last_echo_req : float; + mutable echo_resp_received : bool; table: Table.t; stats: stats; - p_sflow: uint32; (** probability for sFlow sampling *) mutable errornum : uint32; mutable portnum : int; features : OP.Switch.features; @@ -378,16 +361,12 @@ module Switch = struct let update_port_tx_stats pkt_len port = - port.counter.OP.Port.tx_packets <- (Int64.add - port.counter.OP.Port.tx_packets 1L); - port.counter.OP.Port.tx_bytes <- (Int64.add - port.counter.OP.Port.tx_bytes pkt_len) + OP.Port.(port.counter.tx_packets <- Int64.add port.counter.tx_packets 1L); + OP.Port.(port.counter.tx_bytes <- Int64.add port.counter.tx_bytes pkt_len) let update_port_rx_stats pkt_len port = - port.counter.OP.Port.rx_packets <- (Int64.add - port.counter.OP.Port.rx_packets 1L); - port.counter.OP.Port.rx_bytes <- (Int64.add - port.counter.OP.Port.rx_bytes pkt_len) + OP.Port.(port.counter.rx_packets <- Int64.add port.counter.rx_packets 1L); + OP.Port.(port.counter.rx_bytes <- Int64.add port.counter.rx_bytes pkt_len) cstruct dl_header { uint8_t dl_dst[6]; @@ -456,6 +435,11 @@ module Switch = struct set_pseudo_header_len pbuf (Cstruct.lenv data); Net.Checksum.ones_complement_list (pbuf::data) + let send_packet port bits = + update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; + Net.Manager.inject_packet port.mgr port.ethif bits + + let forward_frame st in_port bits pkt_size checksum port = let _ = if ((checksum) && ((get_dl_header_dl_type bits) = 0x800)) then @@ -482,43 +466,33 @@ module Switch = struct in match port with | OP.Port.Port(port) -> - if Hashtbl.mem st.int_to_port port then( + if Hashtbl.mem st.int_to_port port then let out_p = (!( Hashtbl.find st.int_to_port port)) in Net.Manager.inject_packet out_p.mgr out_p.ethif bits - (*Net.Ethif.write (Net.Manager.get_netif out_p.mgr out_p.ethif) bits*) - ) else - return (Printf.printf "Port %d not registered \n" port) + return (cp (sp "[switch] forward_frame: Port %d not registered\n%!" port)) | OP.Port.No_port -> return () | OP.Port.Flood |OP.Port.All -> Lwt_list.iter_p - (fun port -> - if(port.port_id != (OP.Port.int_of_port in_port)) then ( - update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; - Net.Manager.inject_packet port.mgr port.ethif bits -(* Net.Ethif.write (Net.Manager.get_netif port.mgr port.ethif) bits*) - ) else return ()) st.ports + (fun port -> + if(port.port_id != (OP.Port.int_of_port in_port)) then + send_packet port bits + else + return () + ) st.ports | OP.Port.In_port -> let port = (OP.Port.int_of_port in_port) in if Hashtbl.mem st.int_to_port port then -(* let _ = printf "sending to port %d\n%!" port in *) - let out_p = !(Hashtbl.find st.int_to_port port) in - update_port_tx_stats (Int64.of_int (Cstruct.len bits)) out_p; - Net.Manager.inject_packet out_p.mgr out_p.ethif bits -(* Net.Ethif.write (Net.Manager.get_netif out_p.mgr out_p.ethif) bits*) + send_packet (!(Hashtbl.find st.int_to_port port)) bits else - return (Printf.printf "Port %d not registered \n%!" port) + return (cp (sp "[switch] forward_frame: Port %d unregistered\n%!" port)) | OP.Port.Local -> - let local_port_id = OP.Port.int_of_port OP.Port.Local in - if Hashtbl.mem st.int_to_port local_port_id then - let out_p = !(Hashtbl.find st.int_to_port local_port_id) in - let _ = update_port_tx_stats (Int64.of_int (Cstruct.len bits)) out_p in - Net.Manager.inject_packet out_p.mgr out_p.ethif bits -(* Net.Ethif.write (Net.Manager.get_netif out_p.mgr out_p.ethif) - * bits*) - else - return (Printf.printf "Port %d not registered \n%!" local_port_id) + let local = OP.Port.int_of_port OP.Port.Local in + if Hashtbl.mem st.int_to_port local then + send_packet !(Hashtbl.find st.int_to_port local) bits + else + return (cp (sp "[switch] forward_frame: Port %d unregistered \n%!" local)) | OP.Port.Controller -> begin let size = if (Cstruct.len bits > pkt_size) then @@ -526,117 +500,117 @@ module Switch = struct else Cstruct.len bits in - let (h, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id:(-1l) ~in_port - ~reason:OP.Packet_in.ACTION - ~data:(Cstruct.sub bits 0 size) in -(* let _ = printf "[ofswitch] sending packet to controller\n%!" in *) + let (h, pkt_in) = + OP.Packet_in.(create_pkt_in ~buffer_id:(-1l) ~in_port + ~reason:ACTION ~data:(Cstruct.sub bits 0 size)) in match st.controller with | None -> return () | Some conn -> OSK.send_packet conn (OP.Packet_in (h, pkt_in)) end (* | Table * | Normal *) - | _ -> return (Printf.printf "Not implemented output port\n") + | _ -> + return (cp (sp "[switch] forward_frame: unsupported output port\n")) (* Assumwe that action are valid. I will not get a flow that sets an ip * address unless it defines that the ethType is ip. Need to enforce * these rule in the parsing process of the flow_mod packets *) let apply_of_actions st in_port bits actions = let apply_of_actions_inner st in_port bits checksum action = - try_lwt - match action with - | OP.Flow.Output (port, pkt_size) -> - (* Make a packet copy in case the buffer is modified and multiple - * outputs are defined? *) - lwt _ = forward_frame st in_port bits pkt_size checksum port in + try_lwt + match action with + | OP.Flow.Output (port, pkt_size) -> + (* Make a packet copy in case the buffer is modified and multiple + * outputs are defined? *) + lwt _ = forward_frame st in_port bits pkt_size checksum port in return false - | OP.Flow.Set_dl_src(eaddr) -> + | OP.Flow.Set_dl_src(eaddr) -> let _ = set_dl_header_dl_src (Macaddr.to_bytes eaddr) 0 bits in - return checksum - | OP.Flow.Set_dl_dst(eaddr) -> + return checksum + | OP.Flow.Set_dl_dst(eaddr) -> let _ = set_dl_header_dl_dst (Macaddr.to_bytes eaddr) 0 bits in - return checksum - (* TODO: Add for this actions to check when inserted if - * the flow is an ip flow *) - | OP.Flow.Set_nw_tos(tos) -> - let ip_data = Cstruct.shift bits sizeof_dl_header in - let _ = set_nw_header_nw_tos ip_data (int_of_char tos) in + return checksum + (* TODO: Add for this actions to check when inserted if + * the flow is an ip flow *) + | OP.Flow.Set_nw_tos(tos) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_tos ip_data (int_of_char tos) in return true - (* TODO: wHAT ABOUT ARP? - * *) - | OP.Flow.Set_nw_src(ip) -> - let ip_data = Cstruct.shift bits sizeof_dl_header in - let _ = set_nw_header_nw_src ip_data (Ipaddr.V4.to_int32 ip) in + (* TODO: wHAT ABOUT ARP? + * *) + | OP.Flow.Set_nw_src(ip) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_src ip_data (Ipaddr.V4.to_int32 ip) in return true - | OP.Flow.Set_nw_dst(ip) -> - let ip_data = Cstruct.shift bits sizeof_dl_header in - let _ = set_nw_header_nw_dst ip_data (Ipaddr.V4.to_int32 ip) in + | OP.Flow.Set_nw_dst(ip) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_dst ip_data (Ipaddr.V4.to_int32 ip) in return true - | OP.Flow.Set_tp_src(port) -> - let ip_data = Cstruct.shift bits sizeof_dl_header in - let len = (get_nw_header_hlen_version ip_data) land 0xf in - let tp_data = Cstruct.shift ip_data (len*4) in - let _ = set_tp_header_tp_src tp_data port in + | OP.Flow.Set_tp_src(port) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tp_header_tp_src tp_data port in return true - | OP.Flow.Set_tp_dst(port) -> - let ip_data = Cstruct.shift bits sizeof_dl_header in - let len = (get_nw_header_hlen_version ip_data) land 0xf in - let tp_data = Cstruct.shift ip_data (len*4) in - let _ = set_tp_header_tp_dst tp_data port in + | OP.Flow.Set_tp_dst(port) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tp_header_tp_dst tp_data port in return true - | OP.Flow.Enqueue(_, _) - | OP.Flow.Set_vlan_pcp _ - | OP.Flow.Set_vlan_vid _ - | OP.Flow.VENDOR_ACT - | OP.Flow.STRIP_VLAN -> - (* VLAN manupulation actions *) - let _ = pr "Unsupported action STRIP_VLAN\n" in - return checksum - with exn -> - let _ = eprintf "apply of action failed (packet size %d) %s %s\n%!" - (Cstruct.len bits) - (OP.Flow.string_of_action action) (Printexc.to_string exn ) in + (* | OP.Flow.Enqueue(_, _) + | OP.Flow.Set_vlan_pcp _ + | OP.Flow.Set_vlan_vid _ + | OP.Flow.VENDOR_ACT + | OP.Flow.STRIP_VLAN *) + | act -> + let _ = cp (sp "[switch] apply_of_actions: Unsupported action %s" + (OP.Flow.string_of_action act)) in + return checksum + with exn -> + let _ = cp(sp "[switch] apply_of_actions: (packet size %d) %s %s\n%!" + (Cstruct.len bits) (OP.Flow.string_of_action action) + (Printexc.to_string exn )) in return checksum in let rec apply_of_actions_rec st in_port bits checksum = function | [] -> return false | head :: actions -> lwt checksum = apply_of_actions_inner st in_port bits checksum head in - apply_of_actions_rec st in_port bits checksum actions + apply_of_actions_rec st in_port bits checksum actions in lwt _ = apply_of_actions_rec st in_port bits false actions in - return () + return () let lookup_flow st of_match = (* Check first the match table cache * NOTE an exact match flow will be found on this step and thus * return a result immediately, without needing to get to the cache table * and consider flow priorities *) - if (Hashtbl.mem st.table.Table.cache of_match ) then ( - let entry = (Hashtbl.find st.table.Table.cache of_match) in - Found(entry) - ) else ( - (* Check the wilcard card table *) - let lookup_flow flow entry r = - match (r, (OP.Match.flow_match_compare of_match flow - flow.OP.Match.wildcards)) with - | (_, false) -> r - | (None, true) -> Some(flow, entry) -(* | (Some(f,e), true) when (flow.OP.Match.wildcards = OP.Match.full_wildcards ()) -> - Some(flow, entry) *) - | (Some(f,e), true) when (Entry.(e.counters.priority > entry.counters.priority)) -> r - | (Some(f,e), true) when (Entry.(e.counters.priority <= entry.counters.priority)) -> - Some(flow, entry) - | (_, _) -> r - in - let flow_match = Hashtbl.fold lookup_flow st.table.Table.entries None in - match (flow_match) with - | None -> NOT_FOUND - | Some(f,e) -> - Hashtbl.add st.table.Table.cache of_match (ref e); - e.Entry.cache_entries <- e.Entry.cache_entries @ [of_match]; - Found(ref e) - ) + let open Table in + let open OP.Match in + if (Hashtbl.mem st.table.cache of_match ) then + let entry = (Hashtbl.find st.table.cache of_match) in + Found(entry) + else begin + (* Check the wilcard card table *) + let lookup_flow flow entry r = + match (r, (flow_match_compare of_match flow flow.wildcards)) with + | (_, false) -> r + | (None, true) -> Some(flow, entry) + | (Some(f,e), true) when (Entry.(e.counters.priority > entry.counters.priority)) -> r + | (Some(f,e), true) when (Entry.(e.counters.priority <= entry.counters.priority)) -> + Some(flow, entry) + | (_, _) -> r + in + let flow_match = Hashtbl.fold lookup_flow st.table.entries None in + match (flow_match) with + | None -> NOT_FOUND + | Some(f,e) -> + Hashtbl.add st.table.cache of_match (ref e); + Entry.(e.cache_entries <- of_match :: e.cache_entries); + Found(ref e) + end end type t = Switch.t @@ -644,80 +618,65 @@ type t = Switch.t (********************************************* * Switch OpenFlow data plane *********************************************) - - -(* - * let process_frame_depr intf_name frame = *) let process_frame_inner st p frame = - try_lwt - let in_port = (OP.Port.port_of_int p.Switch.port_id) in - let tupple = (OP.Match.raw_packet_to_match in_port frame ) in - (* Update port rx statistics *) - let _ = Switch.update_port_rx_stats (Int64.of_int (Cstruct.len frame)) p in - - (* Lookup packet flow to existing flows in table *) - let entry = (Switch.lookup_flow st tupple) in - match entry with - | Switch.NOT_FOUND -> begin - let _ = Table.update_table_missed st.Switch.table in - let buffer_id = st.Switch.packet_buffer_id in + let open Switch in + let open OP.Packet_in in + try_lwt + let in_port = (OP.Port.port_of_int p.Switch.port_id) in + let tupple = (OP.Match.raw_packet_to_match in_port frame ) in + (* Update port rx statistics *) + let _ = Switch.update_port_rx_stats (Int64.of_int (Cstruct.len frame)) p in + + (* Lookup packet flow to existing flows in table *) + match (Switch.lookup_flow st tupple) with + | Switch.NOT_FOUND -> begin + Table.update_table_missed st.table; + let buffer_id = st.packet_buffer_id in (*TODO Move this code in the Switch module *) - st.Switch.packet_buffer_id <- Int32.add st.Switch.packet_buffer_id 1l; - let (h, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id ~in_port - ~reason:OP.Packet_in.NO_MATCH ~data:frame in - let _ = st.Switch.packet_buffer <- st.Switch.packet_buffer @ [pkt_in] in + st.packet_buffer_id <- Int32.add st.packet_buffer_id 1l; + let (h, pkt_in) = create_pkt_in ~buffer_id ~in_port ~reason:NO_MATCH ~data:frame in + st.packet_buffer <- pkt_in::st.packet_buffer; (* Disable for now packet trimming for buffered packets *) -(* let size = - if (Cstruct.len frame > 92) then - 92 - else - Cstruct.len frame - in - let (h, pkt_in) = OP.Packet_in.create_pkt_in ~buffer_id ~in_port - ~reason:OP.Packet_in.NO_MATCH - ~data:(Cstruct.sub frame 0 size) in*) - return (ignore_result ( + let size = + if (Cstruct.len frame > 92) then 92 + else Cstruct.len frame in + let (h, pkt_in) = create_pkt_in ~buffer_id ~in_port ~reason:NO_MATCH + ~data:(Cstruct.sub frame 0 size) in + return ( match st.Switch.controller with - | None -> return () - | Some conn -> OSK.send_packet conn (OP.Packet_in (h, pkt_in)) - )) - end + | None -> () + | Some conn -> ignore_result (OSK.send_packet conn (OP.Packet_in(h,pkt_in))) + ) + end (* generate a packet in event *) - | Switch.Found(entry) -> - let _ = Table.update_table_found st.Switch.table in - let _ = Entry.update_flow (Int64.of_int (Cstruct.len frame)) !entry in - Switch.apply_of_actions st tupple.OP.Match.in_port - frame (!entry).Entry.actions - with exn -> - pp "control channel error: %s\nbt: %s\n%!" - (Printexc.to_string exn) (Printexc.get_backtrace ()); - return () + | Switch.Found(entry) -> + let _ = Table.update_table_found st.table in + let _ = Entry.update_flow (Int64.of_int (Cstruct.len frame)) !entry in + apply_of_actions st tupple.OP.Match.in_port frame (!entry).Entry.actions + with exn -> + return (cp (sp "[switch] process_frame_inner: control channel error: %s\n" + (Printexc.to_string exn))) let forward_thread st = while_lwt true do lwt _ = Lwt_condition.wait st.Switch.ready in - Lwt_list.iter_s ( - fun p -> - if (Queue.is_empty p.Switch.queue) then - return () - else - let frame = Queue.take p.Switch.queue in - process_frame_inner st p frame - ) st.Switch.ports + Lwt_list.iter_s (fun p -> + if (Queue.is_empty p.Switch.queue) then + return () + else + process_frame_inner st p (Queue.take p.Switch.queue) + ) st.Switch.ports done let process_frame st p _ frame = - try_lwt - (*let p = Hashtbl.find st.Switch.dev_to_port intf_name in *) - match frame with - | Net.Ethif.Output _ -> return () - | Net.Ethif.Input frame -> begin -(* process_frame_inner st p intf_name frame *) - let _ = Queue.push frame p.Switch.queue in - let _ = Lwt_condition.signal st.Switch.ready () in - return () - end + let _ = + try + match frame with + | Net.Ethif.Output _ -> () + | Net.Ethif.Input frame -> + Queue.push frame p.Switch.queue; + Lwt_condition.broadcast st.Switch.ready () (* if (st.Switch.queue_len < 256) then ( st.Switch.queue_len <- st.Switch.queue_len + 1; @@ -727,76 +686,63 @@ let process_frame st p _ frame = return () ) *) with - | Not_found -> - return (pr "%03.6f: Invalid port\n%!" (OS.Clock.time ())) - | Packet_type_unknw -> - return (pr "%03.6f: received a malformed packet\n%!" (OS.Clock.time ())) - | exn -> - return (pr "%03.6f: switch error: %s\n%!" (OS.Clock.time ()) (Printexc.to_string exn)) - -(*let data_plane st () = - try_lwt - while_lwt true do - lwt a = Lwt_stream.get st.Switch.packet_queue in - match a with - | Some (pkt, p) -> - st.Switch.queue_len <- st.Switch.queue_len - 1; - process_frame_inner st p pkt - | None -> return () - done *) - + | Not_found -> cp (sp "[switch] process_frame: Invalid port\n%!") + | Packet_type_unknw -> cp (sp "[switch] process_frame: malformed packet\n%!") + | exn -> cp (sp "[switch] process_frame: switch error: %s\n%!" (Printexc.to_string exn)) + in + return () (************************************************* * Switch OpenFlow control channel *************************************************) - -type endhost = { - ip: Ipaddr.V4.t; - port: int; -} - -let get_flow_stats st of_match = +let get_flow_stats st of_match = + let open OP.Match in let match_flows of_match key value ret = - if (OP.Match.flow_match_compare key of_match - of_match.OP.Match.wildcards) then ( - ret @ [ - (Entry.flow_counters_to_flow_stats - key (char_of_int 1) value)] + if (flow_match_compare key of_match of_match.wildcards) then ( + (Entry.flow_counters_to_flow_stats key (char_of_int 1) value)::ret ) else ret in Hashtbl.fold (fun key value r -> match_flows of_match key value r) st.Switch.table.Table.entries [] - -let process_openflow st t msg = +let process_buffer_id st t msg xid buffer_id actions = + let open OP.Header in + let pkt_in = ref None in + let _ = + st.Switch.packet_buffer <- + List.filter ( fun a -> + if (a.OP.Packet_in.buffer_id = buffer_id) then + (pkt_in := Some(a); false ) + else true ) st.Switch.packet_buffer in + match (!pkt_in) with + | None -> + cp (sp "[switch] invalid buffer id %ld\n%!" buffer_id); + let bits = OP.marshal msg in + let h = create ~xid ERROR (get_len + 4 + (Cstruct.len bits)) in + OSK.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) + | Some(pkt_in) -> + OP.Packet_in.(Switch.apply_of_actions st pkt_in.in_port pkt_in.data actions) + +let process_openflow st t msg = + let open OP.Header in + let _ = if st.Switch.verbose then cp (sp "[switch] %s\n%!" (OP.to_string msg)) in match msg with - | OP.Hello (h) -> - (* Reply to HELLO with a HELLO and a feature request *) - let _ = if st.Switch.verbose then cp "HELLO" in - return () + | OP.Hello (h) -> return () + | OP.Echo_resp h -> return (st.Switch.echo_resp_received <- true) | OP.Echo_req h -> (* Reply to ECHO requests *) - let _ = if st.Switch.verbose then cp "ECHO_REQ" in - OSK.send_packet t - (OP.Echo_req - OP.Header.(create ~xid:h.xid ECHO_RESP sizeof_ofp_header)) + OSK.send_packet t (OP.Echo_req (create ~xid:h.xid ECHO_RESP sizeof_ofp_header)) | OP.Features_req (h) -> - let _ = if st.Switch.verbose then cp "FEAT_REQ" in - let h = OP.Header.create ~xid:(h.OP.Header.xid) OP.Header.FEATURES_RESP - (OP.Switch.get_len st.Switch.features) in - OSK.send_packet t (OP.Features_resp (h, st.Switch.features)) + let h = create ~xid:(h.xid) FEATURES_RESP (OP.Switch.get_len st.Switch.features) in + OSK.send_packet t (OP.Features_resp (h, st.Switch.features)) | OP.Stats_req(h, req) -> begin - let xid = h.OP.Header.xid in - let _ = if st.Switch.verbose then cp "STATS_REQ" in - match req with - | OP.Stats.Desc_req(req) -> - let p = - OP.Stats.(Desc_resp ( - {st_ty=DESC; more=false;}, - { imfr_desc="Mirage"; hw_desc="Mirage"; - sw_desc="Mirage"; serial_num="0.1";dp_desc="Mirage";} - )) in - let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len p) in + let xid = h.xid in + match req with + | OP.Stats.Desc_req(req) -> + let p = OP.Stats.(Desc_resp ({st_ty=DESC; more=false;}, + { imfr_desc="Mirage"; hw_desc="Mirage"; + sw_desc="Mirage"; serial_num="0.1";dp_desc="Mirage";})) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len p) in OSK.send_packet t (OP.Stats_resp (h, p)) | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> (*TODO Need to consider the table_id and the out_port and @@ -804,175 +750,104 @@ let process_openflow st t msg = * fit a single packet. *) let flows = get_flow_stats st of_match in let stats = OP.Stats.({st_ty=FLOW; more=true;}) in - lwt (_, flows) = Lwt_list. fold_right_s ( fun fl (sz, flows) -> let fl_sz = OP.Flow.flow_stats_len fl in if (sz + fl_sz > 0xffff) then let r = OP.Stats.Flow_resp(stats, flows) in - let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in lwt _ = OSK.send_packet t (OP.Stats_resp (h, r)) in - return ((OP.Header.get_len + OP.Stats.get_resp_hdr_size + fl_sz), [fl]) + return ((OP.Header.get_len + OP.Stats.get_resp_hdr_size + fl_sz), [fl]) else return ((sz + fl_sz), (fl::flows)) ) - flows ((OP.Header.get_len + OP.Stats.get_resp_hdr_size), []) in + flows ((OP.Header.get_len + OP.Stats.get_resp_hdr_size), []) in let stats = OP.Stats.({st_ty=FLOW; more=false;}) in let r = OP.Stats.Flow_resp(stats, flows) in - let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in - OSK.send_packet t (OP.Stats_resp (h, r)) + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) | OP.Stats.Aggregate_req (req_h, of_match, table, port) -> - let aggr_flow_bytes = ref 0L in - let aggr_flow_pkts = ref 0L in - let aggr_flows = ref 0l in - let match_flows_aggr of_match key value = - if (OP.Match.flow_match_compare key of_match - of_match.OP.Match.wildcards) then ( - aggr_flows := Int32.add (!aggr_flows) 1l; - aggr_flow_bytes := Int64.add (!aggr_flow_bytes) - value.Entry.counters.Entry.n_bytes; - aggr_flow_pkts := Int64.add (!aggr_flow_pkts) - value.Entry.counters.Entry.n_packets - ) in - Hashtbl.iter (fun key value -> match_flows_aggr of_match key value) - st.Switch.table.Table.entries; + let match_flows_aggr of_match key value (fl_b, fl_p, fl)= + let open OP.Match in + let open Entry in + if (flow_match_compare key of_match of_match.wildcards) then + ((Int64.add fl_b value.counters.n_bytes), (Int64.add fl_p + value.counters.n_packets), (Int32.succ fl)) + else (fl_b, fl_p, fl) in + let (byte_count, packet_count,flow_count) = + Hashtbl.fold (match_flows_aggr of_match) + st.Switch.table.Table.entries (0L, 0L, 0l) in let stats = OP.Stats.({st_ty=AGGREGATE; more=false;}) in let r = OP.Stats.Aggregate_resp(stats, - OP.Stats.({byte_count=(!aggr_flow_bytes); - packet_count=(!aggr_flow_pkts); - flow_count=(!aggr_flows);})) - in - let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + OP.Stats.({byte_count;packet_count;flow_count;})) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in OSK.send_packet t (OP.Stats_resp (h, r)) | OP.Stats.Table_req(req) -> let stats = OP.Stats.({st_ty=TABLE; more=false;}) in let r = OP.Stats.Table_resp(stats, [st.Switch.table.Table.stats]) in - let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in OSK.send_packet t (OP.Stats_resp (h, r)) | OP.Stats.Port_req(req_h, port) -> begin - match port with - | OP.Port.No_port -> - let port_stats = List.map (fun p -> p.Switch.counter) st.Switch.ports in - let stats = OP.Stats.({st_ty=PORT; more=false;}) in - let r = OP.Stats.Port_resp(stats, port_stats) in - let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in - OSK.send_packet t (OP.Stats_resp (h, r)) - | OP.Port.Port(port_id) -> begin - try_lwt - let port = Hashtbl.find st.Switch.int_to_port port_id in - let stats = OP.Stats.({st_ty=PORT; more=false;}) in - let r = OP.Stats.Port_resp(stats, [(!port).Switch.counter]) in - let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + match port with + | OP.Port.No_port -> + let port_stats = List.map (fun p -> p.Switch.counter) st.Switch.ports in + let stats = OP.Stats.({st_ty=PORT; more=false;}) in + let r = OP.Stats.Port_resp(stats, port_stats) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Port.Port(port_id) -> begin + try_lwt + let port = Hashtbl.find st.Switch.int_to_port port_id in + let stats = OP.Stats.({st_ty=PORT; more=false;}) in + let r = OP.Stats.Port_resp(stats, [(!port).Switch.counter]) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in OSK.send_packet t (OP.Stats_resp (h, r)) - with Not_found -> + with Not_found -> (* TODO reply with right error code *) - pr "Invalid port_id in stats\n%!"; - let h = OP.Header.create ~xid OP.Header.ERROR - (OP.Header.get_len + 4) in - OSK.send_packet t - (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) - end - | _ -> - pr "Invalid port_id in stats\n%!"; - let h = OP.Header.create ~xid OP.Header.ERROR 0 in - OSK.send_packet t - OP.(Error (h, ACTION_BAD_OUT_PORT, (marshal msg))) + cp (sp "[switch] unregistered port %s\n%!"(OP.Port.string_of_port port)); + let h = create ~xid ERROR (OP.Header.get_len + 4) in + OSK.send_packet t (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) end - | _ -> begin - let h = OP.Header.create ~xid OP.Header.ERROR - (OP.Header.get_len + 4) in - OSK.send_packet t - (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) + | _ -> + cp "[switch] unsupported stats request\n%!"; + let h = create ~xid ERROR (get_len + 4) in + OSK.send_packet t OP.(Error (h, ACTION_BAD_OUT_PORT, (marshal msg))) + end + | _ -> begin + let h = create ~xid ERROR (get_len + 4) in + OSK.send_packet t (OP.Error (h, OP.REQUEST_BAD_SUBTYPE, (get_new_buffer 0))) end - end + end | OP.Get_config_req(h) -> - let resp = OP.Switch.init_switch_config in - let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.GET_CONFIG_RESP - OP.Switch.config_get_len in - OSK.send_packet t (OP.Get_config_resp(h, resp)) + let resp = OP.Switch.init_switch_config in + let h = create ~xid:h.xid GET_CONFIG_RESP OP.Switch.config_get_len in + OSK.send_packet t (OP.Get_config_resp(h, resp)) | OP.Barrier_req(h) -> - let _ = if st.Switch.verbose then cp (sp "BARRIER_REQ: %s" - (OP.Header.header_to_string h)) in - let resp_h = (OP.Header.create ~xid:h.OP.Header.xid OP.Header.BARRIER_RESP - (OP.Header.sizeof_ofp_header)) in - OSK.send_packet t (OP.Barrier_resp(resp_h)) + OSK.send_packet t (OP.Barrier_resp(create ~xid:h.xid BARRIER_RESP sizeof_ofp_header)) | OP.Packet_out(h, pkt) -> - let _ = if st.Switch.verbose then cp (sp "PACKET_OUT: %s" - (OP.Packet_out.packet_out_to_string pkt)); in - if (pkt.OP.Packet_out.buffer_id = -1l) then - Switch.apply_of_actions st pkt.OP.Packet_out.in_port - pkt.OP.Packet_out.data pkt.OP.Packet_out.actions - else begin - let pkt_in = ref None in - let _ = - st.Switch.packet_buffer <- - List.filter ( - fun a -> - if (a.OP.Packet_in.buffer_id = pkt.OP.Packet_out.buffer_id) then - (pkt_in := Some(a); false ) - else true - ) st.Switch.packet_buffer - in - match (!pkt_in) with - | None -> - let bits = OP.marshal msg in - let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR - (OP.Header.get_len + 4 + (Cstruct.len bits)) in - OSK.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) - | Some(pkt_in) -> -(* let _ = pr "Sending as packet_out data %d\n%!" - (Cstruct.len pkt_in.OP.Packet_in.data) in *) - Switch.apply_of_actions st pkt_in.OP.Packet_in.in_port - pkt_in.OP.Packet_in.data pkt.OP.Packet_out.actions - end + let open OP.Packet_out in + if (pkt.buffer_id = -1l) then + Switch.apply_of_actions st pkt.in_port pkt.data pkt.actions + else begin + process_buffer_id st t msg h.xid pkt.buffer_id pkt.actions + end | OP.Flow_mod(h,fm) -> - let _ = if st.Switch.verbose then - cp (sp "FLOW_MOD: %s" (OP.Flow_mod.flow_mod_to_string fm)) in - let of_match = fm.OP.Flow_mod.of_match in - let of_actions = fm.OP.Flow_mod.actions in - lwt _ = - match (fm.OP.Flow_mod.command) with - | OP.Flow_mod.ADD - | OP.Flow_mod.MODIFY - | OP.Flow_mod.MODIFY_STRICT -> - let _ = - if (st.Switch.verbose) then - Console.log - (sprintf "Adding flow %s" (OP.Match.match_to_string fm.OP.Flow_mod.of_match)) - in - Table.add_flow st st.Switch.table fm - | OP.Flow_mod.DELETE - | OP.Flow_mod.DELETE_STRICT -> - (* Need to implemente strict deletion in order to enable signpost - * switching *) - Table.del_flow st.Switch.table of_match fm.OP.Flow_mod.out_port - (Some t) st.Switch.verbose - in - if (fm.OP.Flow_mod.buffer_id = -1l) then - return () - else begin - let pkt_in = ref None in - let _ = - st.Switch.packet_buffer <- - List.filter ( - fun a -> - if (a.OP.Packet_in.buffer_id = fm.OP.Flow_mod.buffer_id) then - (pkt_in := Some(a); false ) - else true - ) st.Switch.packet_buffer - in - match (!pkt_in) with - | None -> - let bits = OP.marshal msg in - let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR - (OP.Header.get_len + 4 + (Cstruct.len bits)) in - OSK.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) - | Some(pkt_in) -> - (* TODO check if the match is accurate? *) - Switch.apply_of_actions st pkt_in.OP.Packet_in.in_port - pkt_in.OP.Packet_in.data of_actions - end + let open OP.Flow_mod in + lwt _ = + match (fm.command) with + | ADD + | MODIFY + | MODIFY_STRICT -> + Table.add_flow st st.Switch.table fm st.Switch.verbose + | DELETE + | DELETE_STRICT -> + (* Need to implemente strict deletion in order to enable signpost + * switching *) + Table.del_flow st.Switch.table fm.of_match fm.out_port (Some t) st.Switch.verbose + in + if (fm.buffer_id = -1l) then return () + else process_buffer_id st t msg h.xid fm.buffer_id fm.actions | OP.Queue_get_config_resp (h, _, _) | OP.Queue_get_config_req (h, _) | OP.Barrier_resp h @@ -985,70 +860,67 @@ let process_openflow st t msg = | OP.Get_config_resp (h, _) | OP.Features_resp (h, _) | OP.Vendor (h, _, _) - | OP.Echo_resp h | OP.Error (h, _, _) -> let bits = OP.marshal msg in let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR (OP.Header.get_len + 4 + (Cstruct.len bits)) in OSK.send_packet t (OP.Error(h, OP.REQUEST_BAD_TYPE, bits)) -let control_channel_run st conn t = +let monitor_control_channel st conn = + let is_active = ref true in + while_lwt !is_active do + let _ = st.Switch.echo_resp_received <- false in + let _ = st.Switch.last_echo_req <- (OS.Clock.time ()) in + lwt _ = OSK.send_packet conn + OP.(Echo_req Header.(create ECHO_REQ sizeof_ofp_header)) in + lwt _ = OS.Time.sleep 10.0 in + return (is_active := st.Switch.echo_resp_received) + done + +let control_channel_run st conn = (* Trigger the dance between the 2 nodes *) let h = OP.Header.(create ~xid:1l HELLO sizeof_ofp_header) in lwt _ = OSK.send_packet conn (OP.Hello(h)) in let rec echo () = try_lwt - lwt ofp = OSK.read_packet conn in - lwt _ = process_openflow st conn ofp in - echo () + OSK.read_packet conn >>= process_openflow st conn >>= echo with - | Nettypes.Closed -> - pr "Controller channel closed....\n%!"; - return () - | OP.Unparsed (m, bs) -> (pr "# unparsed! m=%s\n %!" m); echo () + | Net.Nettypes.Closed -> + return (cp "[switch] ERROR:Controller channel closed....\n%!") + | OP.Unparsed (m, bs) -> + cp (sp "[switch] ERROR:unparsed! m=%s\n %!" m); echo () | exn -> - pr "[OpenFlow-Switch-Control] ERROR:%s\n%!" (Printexc.to_string exn); - (echo () ) - + cp (sp "[switch] ERROR:%s\n%!" (Printexc.to_string exn)); echo () in lwt _ = - ( lwt _ = t in return (printf "thread terminated\n%!")) echo () - (lwt _ = Table.monitor_flow_timeout st.Switch.table (Some conn) - st.Switch.verbose in - return (pp "[switch] terminated flow_timeout thread") ) + Switch.(Table.monitor_flow_timeout st.table (Some conn) st.verbose) + (monitor_control_channel st conn) in let _ = OSK.close conn in let _ = st.Switch.controller <- None in - return (printf "control channel thread returned\n%!") + return (cp "[switch] control channel thread returned\n%!") -let control_channel st (remote_addr, remote_port) t = - let rs = Ipaddr.V4.to_string remote_addr in - Printf.eprintf "OpenFlow Switch: controller %s:%d" rs remote_port; +let control_channel st (addr, port) t = + cp (sp "[switch] controller %s:%d" (Ipaddr.V4.to_string addr) port); let conn = OSK.init_socket_conn_state t in let _ = st.Switch.controller <- (Some conn) in - let t, _ = Lwt.task () in - control_channel_run st conn t + control_channel_run st conn (* * Interaface with external applications * *) +let get_port_name mgr a = + let ethif = Net.Manager.get_ethif (get_ethif mgr a) in + OS.Netif.string_of_id (OS.Netif.id (Net.Ethif.get_netif ethif)) + let add_port mgr ?(use_mac=false) sw id = sw.Switch.portnum <- sw.Switch.portnum + 1; - let ethif = Manager.get_ethif (get_ethif mgr id) in - let hw_addr = (Macaddr.to_string (Ethif.mac ethif)) in - let dev_name = OS.Netif.string_of_id (OS.Netif.id (Ethif.get_netif ethif)) in - let _ = Console.log (sprintf "Adding port %d (%s) '%s' \n %!" sw.Switch.portnum - dev_name hw_addr) in -(* lwt _ = log ~level:Notice (sprintf "Adding port %s (port_id=%d)" ethif - sw.Switch.portnum) in *) -(* lwt _ = - if (use_mac) then - lwt _ = Lwt_unix.system (sprintf "ifconfig tap0 lladdr %s" hw_addr) in - return () - else - return () - in*) + let ethif = Net.Manager.get_ethif (get_ethif mgr id) in + let hw_addr = Macaddr.to_string (Net.Ethif.mac ethif) in + let dev_name = get_port_name mgr id in + let _ = OS.Console.log (sp "[switch] Adding port %d (%s) '%s' \n %!" + sw.Switch.portnum dev_name hw_addr) in let port = Switch.init_port mgr sw.Switch.portnum id in sw.Switch.ports <- sw.Switch.ports @ [port]; Hashtbl.add sw.Switch.int_to_port sw.Switch.portnum (ref port); @@ -1057,166 +929,123 @@ let add_port mgr ?(use_mac=false) sw id = sw.Switch.features.OP.Switch.ports @ [port.Switch.phy]; let _ = Net.Manager.set_promiscuous mgr id (process_frame sw port) in let h,p = OP.Port.create_port_status OP.Port.ADD port.Switch.phy in - lwt _ = - match sw.Switch.controller with - | None -> return () - | Some t -> OSK.send_packet t (OP.Port_status (h,p)) - in - return () + match sw.Switch.controller with + | None -> return () + | Some t -> OSK.send_packet t (OP.Port_status (h,p)) let del_port mgr sw name = - try_lwt - let port = - List.find ( - fun a -> - let ethif = Manager.get_ethif (get_ethif mgr a.Switch.ethif) in - let dev_name = OS.Netif.string_of_id (OS.Netif.id (Ethif.get_netif ethif)) in - name = dev_name - ) sw.Switch.ports in - let _ = sw.Switch.ports <- List.filter ( - fun a -> - let ethif = Manager.get_ethif (get_ethif mgr a.Switch.ethif) in - let dev_name = OS.Netif.string_of_id (OS.Netif.id (Ethif.get_netif ethif)) in - if (name = dev_name) then - let _ = Console.log (sprintf "removing port %s" dev_name ) in - false - else - true - ) sw.Switch.ports in - let _ = Hashtbl.remove sw.Switch.int_to_port port.Switch.port_id in - let _ = Hashtbl.remove sw.Switch.dev_to_port port.Switch.ethif in - let h,p = OP.Port.create_port_status OP.Port.DEL port.Switch.phy in - let of_match = OP.Match.create_flow_match (OP.Wildcards.full_wildcard ()) () in - lwt _ = Table.del_flow sw.Switch.table of_match - (OP.Port.port_of_int port.Switch.port_id) - sw.Switch.controller sw.Switch.verbose in - let of_match = OP.Match.create_flow_match (OP.Wildcards.in_port_match ()) - ~in_port:(port.Switch.port_id) () in - lwt _ = Table.del_flow sw.Switch.table of_match - OP.Port.No_port sw.Switch.controller sw.Switch.verbose in -(* - lwt _ = log ~level:Notice (sprintf "Removing port %s (port_id=%d)" name - port.Switch.port_id) in - *) - let _ = Console.log (sprintf "Removing port %s (port_id=%d)" name - port.Switch.port_id) in - lwt _ = - match sw.Switch.controller with + try_lwt + let open Switch in + let port = + List.find (fun a -> (get_port_name mgr a.ethif) = name) sw.ports in + let _ = + sw.ports <- List.filter (fun a -> (get_port_name mgr a.ethif) <> name ) sw.ports in + let _ = Hashtbl.remove sw.int_to_port port.port_id in + let _ = Hashtbl.remove sw.dev_to_port port.ethif in + let h,p = OP.Port.create_port_status OP.Port.DEL port.phy in + let of_match = OP.Match.create_flow_match (OP.Wildcards.full_wildcard ()) () in + lwt _ = Table.del_flow sw.table of_match + (OP.Port.port_of_int port.port_id) sw.controller sw.verbose in + let of_match = OP.Match.create_flow_match (OP.Wildcards.in_port_match ()) + ~in_port:(port.Switch.port_id) () in + lwt _ = Table.del_flow sw.table of_match + OP.Port.No_port sw.controller sw.verbose in + let _ = cp (sp "[switch] Removing port %s (port_id=%d)" name port.port_id) in + match sw.controller with | None -> return () | Some t -> OSK.send_packet t (OP.Port_status (h,p)) - in - return () with exn -> - let _ = printf "[switch] device not found %s\n%!" name in - return () + return (cp (sp "[switch] del_port: port %s not found\n%!" name)) let add_port_local mgr sw ethif = (*TODO Find first if a port is already registered as port 0 * as port 0 and disable it *) +let open Switch in let local_port_id = OP.Port.int_of_port OP.Port.Local in - let port = Switch.init_port mgr local_port_id ethif in - sw.Switch.ports <- - (List.filter (fun a -> (a.Switch.port_id <> 0)) sw.Switch.ports) - @ [port]; - Hashtbl.replace sw.Switch.int_to_port local_port_id (ref port); + let port = init_port mgr local_port_id ethif in + sw.ports <- port :: (List.filter (fun a -> (a.port_id <> 0)) sw.ports); + Hashtbl.replace sw.int_to_port local_port_id (ref port); Hashtbl.iter - (fun a b -> - if (!b.Switch.port_id = local_port_id) then - Hashtbl.remove sw.Switch.dev_to_port a - ) sw.Switch.dev_to_port; - Hashtbl.add sw.Switch.dev_to_port ethif (ref port); + (fun a b -> if (!b.port_id = local_port_id) then + Hashtbl.remove sw.dev_to_port a + ) sw.dev_to_port; + Hashtbl.add sw.dev_to_port ethif (ref port); (*TODO Need to filter out any 0 port *) - sw.Switch.features.OP.Switch.ports <- - (List.filter (fun a -> (a.OP.Port.port_no <> local_port_id)) - sw.Switch.features.OP.Switch.ports ) - @ [port.Switch.phy]; -(* - lwt _ = log ~level:Notice (sprintf "Adding port %s (port_id=%d)" ethif - local_port_id) in - *) - let _ = Console.log (sprintf "Adding port %s (port_id=%d)" - (OS.Netif.string_of_id ethif) local_port_id) in - let _ = Net.Manager.set_promiscuous mgr ethif (process_frame sw port) in - return () - -let add_flow st fm = Table.add_flow st st.Switch.table fm + sw.features.OP.Switch.ports <- + port.phy :: + (List.filter (fun a -> (a.OP.Port.port_no <> local_port_id)) + sw.Switch.features.OP.Switch.ports ); + let _ = cp (sp "[switch] Adding port %s (port_id=%d)" + (OS.Netif.string_of_id ethif) local_port_id) in + return (Net.Manager.set_promiscuous mgr ethif (process_frame sw port)) + +let add_flow st fm = Switch.(Table.add_flow st st.table fm st.verbose) let del_flow st m = - Table.del_flow st.Switch.table m OP.Port.No_port st.Switch.controller - st.Switch.verbose + Switch.(Table.del_flow st.table m OP.Port.No_port st.controller st.verbose) let create_switch ?(verbose=false) dpid = Switch.( { ports = []; int_to_port = (Hashtbl.create 64); dev_to_port=(Hashtbl.create 64); - p_sflow = 0_l; controller=None; errornum = 0l; portnum=0; + controller=None; errornum = 0l; portnum=0; stats={n_frags=0L; n_hits=0L;n_missed=0L;n_lost=0L;}; table = (Table.init_table ()); features=(Switch.switch_features dpid); - packet_buffer=[]; packet_buffer_id=0l;ready=(Lwt_condition.create ()); + packet_buffer=[]; last_echo_req=0.; echo_resp_received=true; + packet_buffer_id=0l;ready=(Lwt_condition.create ()); verbose;}) let listen st mgr loc = - Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> - (forward_thread st) (* <&> + Net.Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> + (forward_thread st) <&> (Ofswitch_config.listen_t mgr - (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) *) + (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) let connect st mgr loc = - Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> - (forward_thread st) (* <&> + Net.Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> + (forward_thread st) <&> (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) - (add_flow st) (del_flow st) 6634) *) + (add_flow st) (del_flow st) 6634) let local_connect st mgr conn = let _ = st.Switch.controller <- (Some conn) in - let t, _ = Lwt.task () in - (control_channel_run st conn t) <&> - (forward_thread st) (* <&> + (control_channel_run st conn) <&> + (forward_thread st) <&> (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) - (add_flow st) (del_flow st) 6634) *) + (add_flow st) (del_flow st) 6634) -(* -let lwt_connect st ?(standalone=true) mgr loc = +let standalone_connect st mgr loc = let of_ctrl = Ofswitch_standalone.init_controller () in - let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) in - let _ = printf "[switch] Listening socket...\n%!" in + let _ = ignore_result (forward_thread st) in + let _ = cp "[switch] Listening socket...\n%!" in while_lwt true do let t,u = Lwt.task () in - (( -(* lwt _ = log ~level:Notice "Standalone controller taking over..." in - * *) - let _ = Console.log "Standalone controller taking over..." in - lwt (switch_in, switch_out) = - Ofswitch_standalone.run_controller mgr of_ctrl in - let conn = OSK.init_local_conn_state switch_in switch_out in - let _ = st.Switch.controller <- (Some conn) in - lwt _ = control_channel_run st conn t in -(* lwt _ = log ~level:Notice "Standalone controller stopped..." in *) - let _ = Console.log "Standalone controller stopped..." in - return () - ) <&> ( - let rec connect_socket () = - let sock = Lwt_unix.socket - Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in - let dst = Unix.ADDR_INET( - (Unix.inet_addr_of_string "127.0.0.1"), 6633) in - try_lwt - lwt addr = Lwt_unix.connect sock dst in - return sock - with exn -> - lwt _ = Lwt_unix.close sock in - lwt _ = Lwt_unix.sleep 5.0 in - connect_socket () - in - lwt sock = connect_socket () in - let conn = OSK.init_unix_conn_state sock in - let _ = wakeup u () in - let t,_ = Lwt.task () in + let _ = cp "[switch] Standalone controller taking over..." in + lwt conn = + Ofswitch_standalone.run_controller mgr of_ctrl in +(* let conn = OSK.init_local_conn_state switch_in switch_out in *) let _ = st.Switch.controller <- (Some conn) in -(* lwt _ = log ~level:Notice "Remote controller started..." in *) - let _ = Console.log "Remote controller started..." in - control_channel_run st conn t - )) - done - *) + lwt _ = Lwt.pick [(control_channel_run st conn); t] in + let _ = OSK.close conn in + return (cp "[switch] Standalone controller stopped..." ) + ) <&> ( + let rec connect_socket () = + let sock = ref None in + try_lwt + lwt _ = Lwt.pick + [(Net.Channel.connect mgr (`TCPv4(None,loc,(fun t -> return (sock:=Some(t)))))); + (OS.Time.sleep 10.0)] + in + match !sock with + | None -> connect_socket () + | Some t -> return t + with exn -> connect_socket () + in + lwt conn = connect_socket () >|= OSK.init_socket_conn_state in + let _ = wakeup u (st.Switch.controller <- (Some conn)) in + lwt _ = control_channel_run st conn in + let _ = OSK.close conn in + return (cp "[switch ]Remote controller connected...") + ) + done diff --git a/lib/ofswitch.mli b/lib/ofswitch.mli index a3e62f5..01db3cd 100644 --- a/lib/ofswitch.mli +++ b/lib/ofswitch.mli @@ -17,20 +17,44 @@ open Net type t + +(** [create dpid] initializes the state for a switch with a datapth id dpid *) +val create_switch : ?verbose:bool -> int64 -> t + +(** Port Management *) + +(** [add_port mgr st intf] add port intf under the control of the switch st *) val add_port : Manager.t -> ?use_mac:bool -> t -> Manager.id -> unit Lwt.t +(** [del_port mgr st intf] remove port intf from the control of the switch st *) val del_port : Manager.t -> t -> string -> unit Lwt.t +(** [add_port_local mgr st intf] add port intf as the local loopback interface + * of th switch st *) val add_port_local : Manager.t -> t -> Manager.id -> unit Lwt.t + +(** Switch state management *) + +(** [add_flow st fl] add flow definition fl to the switch st *) val add_flow : t -> Openflow.Ofpacket.Flow_mod.t -> unit Lwt.t + +(** [del_flow st fl] remove all flows matching flow definition fl + * from the switch st *) val del_flow : t -> Openflow.Ofpacket.Match.t -> unit Lwt.t + +(** [get_flow_stats st fl] fetch statistics for flows matching flow definition + * fl from the switch st *) val get_flow_stats : t -> Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list -val create_switch : ?verbose:bool -> int64 -> t -val listen : t -> Manager.t -> Nettypes.ipv4_src -> - unit Lwt.t -val connect : t -> Manager.t -> Nettypes.ipv4_dst -> - unit Lwt.t +(** Daemon run *) + +(** [listen st mgr addr] start a listening switch control channel on addr *) +val listen : t -> Manager.t -> Nettypes.ipv4_src -> unit Lwt.t +(** [connect st mgr addr] connect a switch control channel to a controller + * on addr *) +val connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t +(** [local_connect st mgr conn] setup a switch control channel on the local + * Open`flow socket conn *) val local_connect : t -> Manager.t -> Openflow.Ofsocket.conn_state -> unit Lwt.t -(* -val lwt_connect : t -> ?standalone:bool -> Manager.t -> Nettypes.ipv4_dst -> - unit Lwt.t - *) +(** [standalone_connect st mgr addr] same as connect method, but a local + * learning switch is responsible to control the switch, when the remote + * control channel is unresponsive *) +val standalone_connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t diff --git a/lib/ofswitch_standalone.ml b/lib/ofswitch_standalone.ml index 9bd6d2b..62751c4 100644 --- a/lib/ofswitch_standalone.ml +++ b/lib/ofswitch_standalone.ml @@ -144,13 +144,13 @@ let init controller = OC.register_cb controller OE.PORT_STATUS_CHANGE port_status_cb -let init_controller () = OC.init_controller () +let init_controller () = OC.init_controller init let run_controller mgr st = let (controller, switch) = OSK.init_local_conn_state () in let _ = Lwt.ignore_result ( try_lwt - OC.local_connect st controller init + OC.local_connect ~verbose:true st controller with exn -> return (printf "[switch] standalone controller dailed %s\n%!" (Printexc.to_string exn)) diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index 06bfb4b..50501a2 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -24,7 +24,7 @@ let resolve t = Lwt.on_success t (fun _ -> ()) module OP = Openflow.Ofpacket module OC = Openflow.Ofcontroller module OE = Openflow.Ofcontroller.Event -open Openflow.Ofswitch +open Switch.Ofswitch let pp = Printf.printf let sp = Printf.sprintf @@ -40,28 +40,42 @@ let print_time () = done let switch_run () = - let sw = create_switch () in + let sw = create_switch 0x100L in let use_mac = ref true in + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap0" () in +(* let _ = Tuntap.set_ipv4 ~devname:("tap0") ~ipv4:"10.20.0.1" + ~netmask:"255.255.255.0" () in *) + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in + + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap1" () in + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in + try_lwt - Manager.create ~devs:1 (* ~attached:(["en0"]) *) + Manager.create (fun mgr interface id -> - match (Manager.get_intf_name mgr id) with + match (OS.Netif.string_of_id (OS.Netif.id (Ethif.get_netif + (Manager.get_ethif interface)))) with | "tap0" | "0" -> + lwt _ = OS.Time.sleep 5.0 in let _ = printf "connecting switch...\n%!" in - let _ = add_port_local mgr sw id in - let dst_ip = ipv4_addr_of_tuple (0l,0l,0l,0l) in - lwt _ = connect sw mgr (dst_ip, 6633) in + let ip = + ( Ipaddr.V4.make 10l 20l 0l 2l, + Ipaddr.V4.make 255l 255l 255l 0l, + []) in + lwt _ = Manager.configure interface (`IPv4 ip) in + let dst_ip = Ipaddr.V4.make 10l 20l 0l 4l in + lwt _ = standalone_connect sw mgr (dst_ip, 6633) in let _ = printf "connect returned...\n%!" in return () - | _ -> + | str_id -> let find dev = try let _ = Re_str.search_forward (Re_str.regexp "tap") dev 0 in true with Not_found -> false in lwt _ = - if (not (find id) ) then + if (not (find str_id) ) then lwt _ = add_port mgr ~use_mac:(!use_mac) sw id in return (use_mac := false) else @@ -73,5 +87,4 @@ let switch_run () = Printf.eprintf "Error: %s" (Printexc.to_string e); return () - let _ = OS.Main.run(switch_run ()) From 7fa3019e1d039e054cbb12fb014fb0e7bb103600 Mon Sep 17 00:00:00 2001 From: crotsos Date: Wed, 25 Sep 2013 19:33:33 +0100 Subject: [PATCH 56/75] decouple from the controller connect method the controller callback initialization --- controller/learning_switch.ml | 11 ++++++++--- lib/flowvisor.ml | 4 ++-- lib/ofcontroller.ml | 21 ++++++++++++--------- lib/ofcontroller.mli | 4 ++-- 4 files changed, 24 insertions(+), 16 deletions(-) diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index 3999b4d..7d6e599 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -130,14 +130,19 @@ let init controller = let port = 6633 let run () = + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap9" () in + let _ = Tuntap.set_ipv4 ~devname:("tap9") ~ipv4:"10.20.0.3" + ~netmask:"255.255.255.0" () in + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in Net.Manager.create (fun mgr interface id -> try_lwt let ip = (* (ipv4_addr_of_tuple (10l,0l,0l,253l), *) - ( Ipaddr.V4.make 128l 232l 32l 230l, - Ipaddr.V4.make 255l 255l 255l 0l, []) in + ( Ipaddr.V4.make 10l 20l 0l 4l, + Ipaddr.V4.make 255l 255l 255l 0l, + []) in lwt _ = Manager.configure interface (`IPv4 ip) in - OC.listen mgr (None, port) init + OC.listen mgr ~verbose:true (None, port) init with | e -> return (Printf.eprintf "Unexpected exception : %s" (Printexc.to_string e)) ) diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index 9d048f5..c9ca74b 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -810,8 +810,8 @@ let add_slice mgr flv of_m dst dpid = let listen st mgr loc = OC.listen mgr loc (init st) let local_listen st conn = - let t = OC.init_controller () in - OC.local_connect t conn (init st) + let t = OC.init_controller (init st) in + OC.local_connect t conn let remove_slice _ _ = return () let add_local_slice flv of_m conn dpid = diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index 0d77e10..b9d4026 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -164,6 +164,10 @@ let process_of_packet state conn ofp = let _ = if state.verbose then pp "[controller] ECHO_REQ\n%!" in let h = OP.Header.(create ~xid:h.xid ECHO_RESP get_len) in send_packet conn (OP.Echo_resp h) + end + | Echo_resp h -> begin (* Reply to ECHO requests *) + let _ = if state.verbose then pp "[controller] ECHO_RESP\n%!" in + return () end | Features_resp (h, sfs) -> begin (* Generate a datapath join event *) let _ = if state.verbose then pp "[controller] FEATURES_RESP\n%!" in @@ -304,8 +308,8 @@ let socket_controller st (remote_addr, remote_port) t = let conn = init_socket_conn_state t in controller_run st conn -let init_controller ?(verbose=false) () = - { verbose; +let init_controller ?(verbose=false) init = + let t = { verbose; dp_db = Hashtbl.create 0; datapath_join_cb = []; datapath_leave_cb = []; @@ -316,18 +320,17 @@ let init_controller ?(verbose=false) () = desc_stats_reply_cb = []; port_stats_reply_cb = []; table_stats_reply_cb = []; - port_status_cb = []; } + port_status_cb = []; } in + let _ = init t in + t let listen mgr ?(verbose=false) loc init = - let st = init_controller ~verbose () in - let _ = init st in + let st = init_controller ~verbose init in (Channel.listen mgr (`TCPv4 (loc, (socket_controller st) ))) let connect mgr ?(verbose=false) loc init = - let st = init_controller ~verbose () in - let _ = init st in + let st = init_controller ~verbose init in Net.Channel.connect mgr (`TCPv4 (None, loc, (socket_controller st loc) )) -let local_connect st conn init = - let _ = init st in controller_run st conn +let local_connect ?(verbose=false) st conn = controller_run st conn diff --git a/lib/ofcontroller.mli b/lib/ofcontroller.mli index 8717358..46daf71 100644 --- a/lib/ofcontroller.mli +++ b/lib/ofcontroller.mli @@ -56,5 +56,5 @@ val listen : Manager.t -> ?verbose:bool -> Nettypes.ipv4_src -> (t -> 'a) -> unit Lwt.t val connect : Manager.t -> ?verbose:bool -> Nettypes.ipv4_dst -> (t -> 'a) -> unit Lwt.t -val init_controller : ?verbose:bool -> unit -> t -val local_connect : t -> Ofsocket.conn_state -> (t -> 'a) -> unit Lwt.t +val init_controller : ?verbose:bool -> (t -> 'a) -> t +val local_connect : ?verbose:bool -> t -> Ofsocket.conn_state -> unit Lwt.t From 438760a5f05c8949846cbc76f2bf88e925243aa9 Mon Sep 17 00:00:00 2001 From: crotsos Date: Wed, 25 Sep 2013 19:34:04 +0100 Subject: [PATCH 57/75] fixing the build mechanism --- Makefile | 16 ++++++---------- _oasis | 2 +- _tags | 6 +++++- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/Makefile b/Makefile index b634d85..b3040cd 100644 --- a/Makefile +++ b/Makefile @@ -5,15 +5,16 @@ NAME=openflow J=4 UNIX ?= $(shell if ocamlfind query lwt.ssl >/dev/null 2>&1; then echo --enable-unix; fi) - -XEN ?= $(shell if [ $MIRAGE_OS = "xen" ]; then echo --enable-xen; fi) +DIRECT ?= $(shell if [ $(MIRAGE_NET) = "direct" ]; then echo --enable-direct; fi) +XEN ?= $(shell if [ $(MIRAGE_OS) = "xen" ]; then echo --enable-xen; fi) # MIRAGE = --enable-mirage -include Makefile.config -setup.data: _oasis - oasis setup - echo XXXXX $(MIRAGE_NET) $(UNIX) $(XEN) $(DIRECT) +setup.ml: _oasis + oasis setup + +setup.data: setup.ml ocaml setup.ml -configure $(UNIX) $(XEN) $(DIRECT) clean: setup.data @@ -27,11 +28,6 @@ distclean: setup.ml setup.data setup: setup.data build: setup.data $(wildcard lib/*.ml) - ifeq ($(MIRAGE_NET), "direct") - DR ?= "--enable-direct" - echo "hello" $(MIRAGE_NET) $(DR) - endif - echo "hello" $(MIRAGE_NET) $(DR) ocaml setup.ml -build -j $(J) $(OFLAGS) $(DR) doc: setup.data setup.ml diff --git a/_oasis b/_oasis index e3f8788..344b52f 100644 --- a/_oasis +++ b/_oasis @@ -78,7 +78,7 @@ Executable ofswitch_lwt Custom: true CompiledObject: native Install$: flag(unix) && flag(direct) - BuildDepends: openflow + BuildDepends: openflow, openflow.switch Executable "ofcontroller.o" diff --git a/_tags b/_tags index 54918da..7b86318 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: a6346ea7787afaf53f974c8470a6635b) +# DO NOT EDIT (digest: b9736de46cc3c7f8e4f2274631f835f5) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -60,6 +60,8 @@ "controller/learning_switch.native": custom # Executable ofswitch_lwt "switch/basic_switch.native": use_openflow +"switch/basic_switch.native": use_switch +"switch/basic_switch.native": pkg_re.str "switch/basic_switch.native": pkg_cstruct "switch/basic_switch.native": pkg_cstruct.syntax "switch/basic_switch.native": pkg_rpclib @@ -67,6 +69,8 @@ "switch/basic_switch.native": pkg_mirage "switch/basic_switch.native": pkg_mirage-net "switch/basic_switch.native": pkg_ipaddr +: use_switch +: pkg_re.str "switch/basic_switch.native": custom # Executable ofcontroller.o "controller/learning_switch.nobj.o": use_openflow From ff95348dc51a6a22a6a4912df658100a49103b31 Mon Sep 17 00:00:00 2001 From: crotsos Date: Wed, 25 Sep 2013 20:00:01 +0100 Subject: [PATCH 58/75] adding documentation and cleaning the controller code --- lib/ofcontroller.ml | 138 +++++++++++++------------------------ lib/ofcontroller.mli | 28 +++++++- lib/ofswitch_standalone.ml | 2 +- setup.ml | 10 +-- 4 files changed, 81 insertions(+), 97 deletions(-) diff --git a/lib/ofcontroller.ml b/lib/ofcontroller.ml index b9d4026..fa4e43a 100644 --- a/lib/ofcontroller.ml +++ b/lib/ofcontroller.ml @@ -15,22 +15,14 @@ *) open Lwt -open Lwt_list open Net -open Printexc -open Printf open Ofsocket let sp = Printf.sprintf -let pp = Printf.printf -let ep = Printf.eprintf let cp = OS.Console.log module OP = Ofpacket - -exception ReadError - module Event = struct type t = | DATAPATH_JOIN | DATAPATH_LEAVE | PACKET_IN | FLOW_REMOVED @@ -152,58 +144,41 @@ let register_cb controller e cb = ) let process_of_packet state conn ofp = + let _ = if state.verbose then cp (sp "[controller] rcv: %s\n%!" (OP.to_string ofp)) in OP.( match ofp with - | Hello (h) -> begin (* Reply to HELLO with a HELLO and a feature request *) - let _ = if state.verbose then pp "[controller] HELLO\n%!" in + | Hello (h) -> (* Reply to HELLO with a HELLO and a feature request *) lwt _ = send_packet conn (OP.Hello (h)) in let h = OP.Header.create OP.Header.FEATURES_REQ OP.Header.get_len in - send_packet conn (OP.Features_req (h) ) - end - | Echo_req h -> begin (* Reply to ECHO requests *) - let _ = if state.verbose then pp "[controller] ECHO_REQ\n%!" in - let h = OP.Header.(create ~xid:h.xid ECHO_RESP get_len) in - send_packet conn (OP.Echo_resp h) - end - | Echo_resp h -> begin (* Reply to ECHO requests *) - let _ = if state.verbose then pp "[controller] ECHO_RESP\n%!" in - return () - end + send_packet conn (OP.Features_req (h) ) + | Echo_req h -> (* Reply to ECHO requests *) + send_packet conn (OP.Echo_resp OP.Header.(create ~xid:h.xid ECHO_RESP get_len)) + | Echo_resp h -> return () (* At the moment ignore echo responses *) | Features_resp (h, sfs) -> begin (* Generate a datapath join event *) - let _ = if state.verbose then pp "[controller] FEATURES_RESP\n%!" in - let _ = conn.dpid <- sfs.OP.Switch.datapath_id in - let evt = Event.Datapath_join (sfs.OP.Switch.datapath_id, sfs.OP.Switch.ports) in + let open OP.Switch in + let _ = conn.dpid <- sfs.datapath_id in + let evt = Event.Datapath_join (sfs.datapath_id, sfs.ports) in let _ = - if (Hashtbl.mem state.dp_db sfs.OP.Switch.datapath_id) then - Printf.printf "[controller] Deleting old state \n%!" + if (Hashtbl.mem state.dp_db sfs.datapath_id) then + cp (sp "[controller] Deleting old state for %Lx\n%!" conn.dpid) in - let _ = Hashtbl.replace state.dp_db sfs.OP.Switch.datapath_id conn in - Lwt_list.iter_p (fun cb -> cb state sfs.OP.Switch.datapath_id evt) + let _ = Hashtbl.replace state.dp_db sfs.datapath_id conn in + Lwt_list.iter_p (fun cb -> cb state sfs.datapath_id evt) state.datapath_join_cb end - | OP.Packet_in (h, p) -> begin (* Generate a packet_in event *) - let _ = if state.verbose then pp "[controller]+ %s|%s\n%!" - (OP.Header.header_to_string h) - (OP.Packet_in.packet_in_to_string p) in + | OP.Packet_in (h, p) -> begin (* Generate a packet_in event *) + let open OP.Packet_in in let evt = - Event.Packet_in (p.OP.Packet_in.in_port, p.OP.Packet_in.reason, - p.OP.Packet_in.buffer_id, p.OP.Packet_in.data, conn.dpid) in - iter_p (fun cb -> cb state conn.dpid evt) state.packet_in_cb + Event.Packet_in (p.in_port, p.reason, p.buffer_id, p.data, conn.dpid) in + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.packet_in_cb end - | OP.Flow_removed (h, p) -> - let _ = if state.verbose then pp "+ %s|%s\n%!" - (OP.Header.header_to_string h) - (OP.Flow_removed.string_of_flow_removed p) in + | OP.Flow_removed (h, p) -> + let open OP.Flow_removed in let evt = Event.Flow_removed ( - p.OP.Flow_removed.of_match, p.OP.Flow_removed.reason, - p.OP.Flow_removed.duration_sec, p.OP.Flow_removed.duration_nsec, - p.OP.Flow_removed.packet_count, p.OP.Flow_removed.byte_count, conn.dpid) - in - Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_removed_cb + p.of_match, p.reason, p.duration_sec, p.duration_nsec, + p.packet_count, p.byte_count, conn.dpid) in + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.flow_removed_cb | Stats_resp(h, resp) -> begin - let _ = if state.verbose then - pp "[controller] + %s|%s\n%!" (OP.Header.header_to_string h) - (OP.Stats.string_of_stats resp) in match resp with | OP.Stats.Flow_resp(resp_h, flows) -> begin let evt = Event.Flow_stats_reply( @@ -246,65 +221,48 @@ let process_of_packet state conn ofp = Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.table_stats_reply_cb end - | _ -> OS.Console.log "New stats response received"; return (); + | _ -> return (cp "[controller] unsupported stats response ") end | Port_status(h, st) -> begin - let _ = if state.verbose then pp "[controller] + %s|%s" (OP.Header.header_to_string h) - (OP.Port.string_of_status st) in - let evt = Event.Port_status (st.OP.Port.reason, st.OP.Port.desc, conn.dpid) in - Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_status_cb + let evt = Event.Port_status (st.OP.Port.reason, st.OP.Port.desc, conn.dpid) in + Lwt_list.iter_p (fun cb -> cb state conn.dpid evt) state.port_status_cb end - | ofp -> - let _ = pp "[controller] Unsupported %s" (OP.to_string ofp) in - return () + | ofp -> return (cp (sp "[controller] Unsupported %s" (OP.to_string ofp))) ) let send_of_data controller dpid bits = - let conn = Hashtbl.find controller.dp_db dpid in - Ofsocket.send_data_raw conn bits + Ofsocket.send_data_raw (Hashtbl.find controller.dp_db dpid ) bits let send_data controller dpid ofp = - let conn = Hashtbl.find controller.dp_db dpid in - Ofsocket.send_packet conn ofp - -let mem_dbg name = - Gc.compact (); - let s = Gc.stat () in - Printf.printf "blocks %s: l=%d f=%d \n %!" name s.Gc.live_blocks s.Gc.free_blocks - -let main_loop st conn = - while_lwt true do - lwt ofp = read_packet conn in - process_of_packet st conn ofp - done + Ofsocket.send_packet (Hashtbl.find controller.dp_db dpid ) ofp let controller_run st conn = lwt _ = - try_lwt - main_loop st conn + try_lwt + while_lwt true do + read_packet conn >>= process_of_packet st conn + done with - | Nettypes.Closed -> begin - return (printf "[controller] switch disconnected\n%!") - end - | OP.Unparsed(m, bs) - | OP.Unparsable(m, bs) -> - let _ = cp (sp "# unparsed! m=%s" m) in - return (Cstruct.hexdump bs) - | exn -> return (pp "[controller] ERROR:%s\n%!" (Printexc.to_string exn)) + | Nettypes.Closed -> return (cp "[controller] switch disconnected\n%!") + | OP.Unparsed(m, bs) + | OP.Unparsable(m, bs) -> + let _ = cp (sp "# unparsed! m=%s" m) in + return (Cstruct.hexdump bs) + | exn -> return (cp (sp "[controller] ERROR:%s\n%!" (Printexc.to_string exn))) in - if (conn.dpid > 0L) then - let evt = Event.Datapath_leave (conn.dpid) in - lwt _ = Lwt_list.iter_p (fun cb -> cb st conn.dpid evt) - st.datapath_leave_cb in - let _ = Hashtbl.remove st.dp_db conn.dpid in - return () - else - return () + if (conn.dpid > 0L) then + let evt = Event.Datapath_leave (conn.dpid) in + lwt _ = Lwt_list.iter_p (fun cb -> cb st conn.dpid evt) + st.datapath_leave_cb in + let _ = Hashtbl.remove st.dp_db conn.dpid in + return () + else + return () let socket_controller st (remote_addr, remote_port) t = let rs = Ipaddr.V4.to_string remote_addr in - let _ = pp "[controller]+ Controller %s:%d\n%!" rs remote_port in + let _ = cp (sp "[controller]+ Controller %s:%d\n%!" rs remote_port) in let conn = init_socket_conn_state t in controller_run st conn @@ -333,4 +291,4 @@ let connect mgr ?(verbose=false) loc init = Net.Channel.connect mgr (`TCPv4 (None, loc, (socket_controller st loc) )) -let local_connect ?(verbose=false) st conn = controller_run st conn +let local_connect st conn = controller_run st conn diff --git a/lib/ofcontroller.mli b/lib/ofcontroller.mli index 46daf71..2a897d9 100644 --- a/lib/ofcontroller.mli +++ b/lib/ofcontroller.mli @@ -20,6 +20,7 @@ open Net module Event : sig open Ofpacket + (** Event messages *) type t = DATAPATH_JOIN | DATAPATH_LEAVE @@ -45,16 +46,39 @@ module Event : sig | Table_stats_reply of int32 * bool * Stats.table list * datapath_id | Desc_stats_reply of string * string * string * string * string * datapath_id | Port_status of Port.reason * Port.phy * datapath_id + + (** convert a controller event to a string representation *) val string_of_event : e -> string end type t + +(** [register_cb ctrl evt fn] registers a callback for a specific event on + * controller ctrl *) val register_cb : t -> Event.t -> (t -> Ofpacket.datapath_id -> Event.e -> unit Lwt.t) -> unit + +(** Controll channel packet transmission *) + +(** [send_of_data ctrl dpid bits] send a byte packet to the switch with datapath + * dpid throught the ctrl controller *) val send_of_data : t -> Ofpacket.datapath_id -> Cstruct.t -> unit Lwt.t +(** [send_data ctrl dpid pkt] send the pkt OpenFlow message to the switch with datapath + * dpid throught the ctrl controller *) val send_data : t -> Ofpacket.datapath_id -> Ofpacket.t -> unit Lwt.t + +(** Controller daemon setup *) + +(** [init_controller init] create the state for an openflow controller and + * initialize it using the init method *) +val init_controller : ?verbose:bool -> (t -> 'a) -> t +(** [listen mgr addr init] listen on addr for connection switches. Intialize the + * state for each control channel unsing the init method. *) val listen : Manager.t -> ?verbose:bool -> Nettypes.ipv4_src -> (t -> 'a) -> unit Lwt.t +(** [connect mgr addr init] connect to the switch on addr. Intialize the + * state of the control channel unsing the init method. *) val connect : Manager.t -> ?verbose:bool -> Nettypes.ipv4_dst -> (t -> 'a) -> unit Lwt.t -val init_controller : ?verbose:bool -> (t -> 'a) -> t -val local_connect : ?verbose:bool -> t -> Ofsocket.conn_state -> unit Lwt.t + (** [local_connect ctrl conn] connect to the switch using a local OpenFlow + * socket. *) +val local_connect : t -> Ofsocket.conn_state -> unit Lwt.t diff --git a/lib/ofswitch_standalone.ml b/lib/ofswitch_standalone.ml index 62751c4..acb0479 100644 --- a/lib/ofswitch_standalone.ml +++ b/lib/ofswitch_standalone.ml @@ -150,7 +150,7 @@ let run_controller mgr st = let (controller, switch) = OSK.init_local_conn_state () in let _ = Lwt.ignore_result ( try_lwt - OC.local_connect ~verbose:true st controller + OC.local_connect st controller with exn -> return (printf "[switch] standalone controller dailed %s\n%!" (Printexc.to_string exn)) diff --git a/setup.ml b/setup.ml index 5b119b7..adb9ee7 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: f3594f9aca8476215a598758ce81e9dd) *) +(* DO NOT EDIT (digest: 52a3bd2a68b634cd2e887befec9ad7fc) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6157,7 +6157,9 @@ let setup_t = ]; bs_path = "switch"; bs_compiled_object = Native; - bs_build_depends = [InternalLibrary "openflow"]; + bs_build_depends = + [InternalLibrary "openflow"; InternalLibrary "switch" + ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6231,7 +6233,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "\205\242\155\\\000/\243\1843\196\132\189\0311\234e"; + oasis_digest = Some "9m\028^\001\214\\l8\001\191B\202\221<8"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6239,6 +6241,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6243 "setup.ml" +# 6245 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 7cb29d0b6db581ade544c3974d0bb114025f0091 Mon Sep 17 00:00:00 2001 From: crotsos Date: Wed, 25 Sep 2013 20:08:06 +0100 Subject: [PATCH 59/75] documenting the openflow socket module --- lib/ofsocket.ml | 17 ++--------------- lib/ofsocket.mli | 20 ++++++++++++++------ 2 files changed, 16 insertions(+), 21 deletions(-) diff --git a/lib/ofsocket.ml b/lib/ofsocket.ml index 086d40f..8b5adf5 100644 --- a/lib/ofsocket.ml +++ b/lib/ofsocket.ml @@ -15,16 +15,8 @@ *) open Net open Lwt -open Printf module OP = Ofpacket -exception ReadError - -let sp = Printf.sprintf -let pp = Printf.printf -let ep = Printf.eprintf -let cp = pp "%s\n%!" - let resolve t = Lwt.on_success t (fun _ -> ()) let get_new_buffer len = @@ -47,13 +39,7 @@ let write_buffer t bits = let close t = Channel.close t.sock -(* let cache_size t = - List.fold_right ( - fun a r -> - r + (Cstruct.len a) ) t.data_cache 0*) - let read_data t len = -(* Printf.printf "let rec read_data t data_cache %d = \n%!" len; *) match (len, (Cstruct.len !(t.data_cache) ) ) with | (0, _) -> return (get_new_buffer 0) | (_, 0) -> @@ -133,7 +119,8 @@ let close conn = try_lwt Socket.close t with exn -> - return (printf "[socket] close error: %s\n%!" (Printexc.to_string exn)) + return (OS.Console.log (Printf.sprintf "[socket] close error: %s\n%!" + (Printexc.to_string exn))) ) | Local (_, output) -> output None diff --git a/lib/ofsocket.mli b/lib/ofsocket.mli index 025d075..208cd60 100644 --- a/lib/ofsocket.mli +++ b/lib/ofsocket.mli @@ -14,21 +14,29 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -exception ReadError - -open Net - +(** OpenFlow socket structure *) type conn_type type conn_state = { mutable dpid : Ofpacket.datapath_id; t : conn_type; } -val init_socket_conn_state : Channel.t -> conn_state +(** Socket initialization *) -(* val init_unix_conn_state : Lwt_unix.file_descr -> conn_state *) +(** initialize an OpenFlow socket from a Net.Channel.t socket*) +val init_socket_conn_state : Net.Channel.t -> conn_state +(** create an emulated local socket using Lwt_stream structures *) val init_local_conn_state: unit -> (conn_state * conn_state) + +(** Socket access methods *) + +(** [read_packet conn] read a complete and parsed OpenFlow packet from the + * control channel socket *) val read_packet : conn_state -> Ofpacket.t Lwt.t +(** [send_packet conn pkt] send an complete OpenFlow packet over the control + * channel socket *) val send_packet : conn_state -> Ofpacket.t -> unit Lwt.t +(** [send_data_raw conn bits] send raw bits over the control channel socket *) val send_data_raw : conn_state -> Cstruct.t -> unit Lwt.t +(** [conn conn] teardown the control channel socket *) val close : conn_state -> unit From c55a3599248c83a9eadf553ff8a788ac983dd565 Mon Sep 17 00:00:00 2001 From: crotsos Date: Wed, 25 Sep 2013 20:20:16 +0100 Subject: [PATCH 60/75] fixing ofswitch_config code --- lib/ofswitch_config.ml | 176 ++++++++++++++++++---------------------- lib/ofswitch_config.mli | 2 + 2 files changed, 82 insertions(+), 96 deletions(-) diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 0e1ca85..8eefaf8 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -19,6 +19,9 @@ open Printf module OP = Openflow.Ofpacket +let sp = Printf.sprintf +let cp = OS.Console.log + let parse_actions actions = let actions = Re_str.split (Re_str.regexp "/") actions in let split_action = Re_str.regexp ":" in @@ -41,28 +44,28 @@ let parse_actions actions = | "set_dl_src"::addr::_ -> begin match (Macaddr.of_string addr) with | None -> - let _ = printf "[ofswitch-config] Invalid mac %s\n%!" action in + let _ = cp (sp "[ofswitch-config] Invalid mac %s\n%!" action) in actions | Some addr -> actions @[(OP.Flow.Set_dl_src(addr))] end | "set_dl_dst"::addr::_ -> begin match (Macaddr.of_string addr) with | None -> - let _ = printf "[ofswitch-config] Invalid mac %s\n%!" action in + let _ = cp (sp "[ofswitch-config] Invalid mac %s\n%!" action) in actions | Some addr -> actions @[(OP.Flow.Set_dl_dst(addr))] end | "set_nw_src"::addr::_ -> begin match (Ipaddr.V4.of_string addr) with | None -> - let _ = printf "[ofswitch-config] invalid ip %s\n%!" addr in + let _ = cp (sp "[ofswitch-config] invalid ip %s\n%!" addr) in actions | Some ip -> actions @ [(OP.Flow.Set_nw_src(ip))] end | "set_nw_dst"::addr::_ -> begin match (Ipaddr.V4.of_string addr) with | None -> - let _ = printf "[ofswitch-config] invalid ip %s\n%!" addr in + let _ = cp (sp "[ofswitch-config] invalid ip %s\n%!" addr) in actions | Some ip -> actions @ [(OP.Flow.Set_nw_dst(ip))] end @@ -73,10 +76,10 @@ let parse_actions actions = | "set_tp_dst"::port::_ -> actions @ [(OP.Flow.Set_tp_dst(int_of_string port))] | _ -> - let _ = eprintf "[ofswitch-config] invalid action %s" action in + let _ = cp (sp "[ofswitch-config] invalid action %s" action) in actions with exn -> - let _ = printf "[ofswitch-config] error parsing action %s\n%!" action in + let _ = cp (sp "[ofswitch-config] error parsing action %s\n%!" action) in actions ) actions [] @@ -87,8 +90,8 @@ let hashtbl_to_flow_match t = List.fold_right ( fun (name, value) r -> let _ = Hashtbl.add r name (Rpc.string_of_rpc value) in - let _ = printf "Adding %s = %s\n%!" name - (Rpc.string_of_rpc value) in +(* let _ = printf "Adding %s = %s\n%!" name + (Rpc.string_of_rpc value) in *) r ) t (Hashtbl.create 10) in let _ = @@ -190,93 +193,74 @@ let listen_t mgr del_port get_stats add_flow del_flow port = let manage (dip,dpt) t = try_lwt lwt req = Net.Channel.read_line t in - let req = - List.fold_right ( - fun a r -> - r ^ (Cstruct.to_string a) - ) req "" in - let req = Jsonrpc.call_of_string req in - lwt success = - match (req.Rpc.name, req.Rpc.params) with - | ("add-port", (Rpc.String (dev))::_) -> + let req = + List.fold_right ( + fun a r -> + r ^ (Cstruct.to_string a) + ) req "" in + let req = Jsonrpc.call_of_string req in + lwt success = + match (req.Rpc.name, req.Rpc.params) with + | ("add-port", (Rpc.String (dev))::_) -> (* let _ = Net.Manager.attach mgr dev in *) - return (Rpc.Enum [(Rpc.String "true")]) - | ("del-port", (Rpc.String (dev))::_) -> - lwt _ = del_port dev in + return (Rpc.Enum [(Rpc.String "true")]) + | ("del-port", (Rpc.String (dev))::_) -> + lwt _ = del_port dev in (* lwt _ = Net.Manager.detach mgr dev in *) -return (Rpc.Enum [(Rpc.String "true")]) -| ("dump-flows", (Rpc.Dict t)::_) -> -let of_match = hashtbl_to_flow_match t in -let _ = printf "Find rules matching %s\n%!" - (OP.Match.match_to_string of_match) in -let flows = get_stats of_match in -let res = - List.fold_right ( - fun a r -> - r @ [(Rpc.String (OP.Flow.string_of_flow_stat a))] - ) flows [] in -return (Rpc.Enum res) -| ("add-flow", (Rpc.Dict t)::_) -> -let _ = printf "adding flow %s\n%!" (Rpc.string_of_call req) in -let fm = OP.Flow_mod.create (OP.Match.wildcard () ) - 0L OP.Flow_mod.ADD [] () in -let map = - List.fold_right ( - fun (name, value) r -> - match name with - | "actions" -> - let _ = fm.OP.Flow_mod.actions <- - (parse_actions (Rpc.string_of_rpc value) ) in - r - | "idle_timeout" -> - let _ = - fm.OP.Flow_mod.idle_timeout <- (Rpc.int_of_rpc value) in - r - | "hard_timeout" -> - let _ = - fm.OP.Flow_mod.hard_timeout <- (Rpc.int_of_rpc value) in - r - | "priority" -> - let _ = - fm.OP.Flow_mod.priority <- (Rpc.int_of_rpc value) in - r - | _ -> r @ [(name, value)] - ) t [] in -let _ = fm.OP.Flow_mod.of_match <- hashtbl_to_flow_match map in -let _ = printf "Add flow %s\n%!" (OP.Flow_mod.flow_mod_to_string fm) in -lwt _ = add_flow fm in -return (Rpc.Enum [(Rpc.String "true")] ) -| ("del-flow", (Rpc.Dict t)::_) -> -let of_match = hashtbl_to_flow_match t in -let _ = printf "Find rules matching %s\n%!" - (OP.Match.match_to_string of_match) in -lwt _ = del_flow of_match in -return (Rpc.Enum [(Rpc.String "true")] ) -| (_, _) -> -let _ = printf "[ofswitch-config] invalid action %s\n%!" - (req.Rpc.name) in -return (Rpc.Enum [(Rpc.String "false")]) -in -let resp = - Jsonrpc.string_of_response (Rpc.success success) in -let _ = Net.Channel.write_line t resp in -lwt _ = Net.Channel.flush t in -lwt _ = Net.Channel.close t in -return () -with -| End_of_file -> return () -| exn -> - let _ = OS.Console.log - "[ofswitch_config] server error" in - (* let resp = Jsonrpc.string_of_response - (Rpc.failure (Rpc.Enum [(Rpc.String "false")])) in - lwt _ = Lwt_io.write_line output resp in - lwt _ = Lwt_io.close output in - lwt _ = Lwt_io.close input in *) - return () - - -in -let _ = Net.Channel.listen mgr (`TCPv4 ((None, 6634), manage )) in -return () - + return (Rpc.Enum [(Rpc.String "true")]) + | ("dump-flows", (Rpc.Dict t)::_) -> + let of_match = hashtbl_to_flow_match t in + let _ = cp (sp "Find rules matching %s\n%!" + (OP.Match.match_to_string of_match)) in + let flows = get_stats of_match in + let res = + List.fold_right ( + fun a r -> (Rpc.String (OP.Flow.string_of_flow_stat a))::r) flows [] in + return (Rpc.Enum res) + | ("add-flow", (Rpc.Dict t)::_) -> + let _ = cp (sp "adding flow %s\n%!" (Rpc.string_of_call req)) in + let fm = OP.Flow_mod.create (OP.Match.wildcard () ) 0L OP.Flow_mod.ADD [] () in + let map = + List.fold_right ( + fun (name, value) r -> + match name with + | "actions" -> + fm.OP.Flow_mod.actions <- parse_actions (Rpc.string_of_rpc value); + r + | "idle_timeout" -> + fm.OP.Flow_mod.idle_timeout <- (Rpc.int_of_rpc value); + r + | "hard_timeout" -> + fm.OP.Flow_mod.hard_timeout <- (Rpc.int_of_rpc value); + r + | "priority" -> + fm.OP.Flow_mod.priority <- (Rpc.int_of_rpc value); + r + | _ -> r @ [(name, value)] + ) t [] in + let _ = fm.OP.Flow_mod.of_match <- hashtbl_to_flow_match map in + let _ = cp (sp "Add flow %s\n%!" (OP.Flow_mod.flow_mod_to_string fm)) in + lwt _ = add_flow fm in + return (Rpc.Enum [(Rpc.String "true")] ) + | ("del-flow", (Rpc.Dict t)::_) -> + let of_match = hashtbl_to_flow_match t in + lwt _ = del_flow of_match in + return (Rpc.Enum [(Rpc.String "true")] ) + | (_, _) -> + let _ = printf "[ofswitch-config] invalid action %s\n%!" + (req.Rpc.name) in + return (Rpc.Enum [(Rpc.String "false")]) + in + let resp = + Jsonrpc.string_of_response (Rpc.success success) in + let _ = Net.Channel.write_line t resp in + lwt _ = Net.Channel.flush t in + lwt _ = Net.Channel.close t in + return () + with + | End_of_file -> return () + | exn -> + let _ = cp "[ofswitch_config] server error" in + return () + in + Net.Channel.listen mgr (`TCPv4 ((None, 6634), manage )) diff --git a/lib/ofswitch_config.mli b/lib/ofswitch_config.mli index 580ca54..3e5f7d1 100644 --- a/lib/ofswitch_config.mli +++ b/lib/ofswitch_config.mli @@ -14,6 +14,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) + +(** initalize a switch configration daemon *) val listen_t: Net.Manager.t -> (string -> unit Lwt.t) -> (Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list) -> From da0c60abb338c411a29ef84426e90c8b9462bdaa Mon Sep 17 00:00:00 2001 From: crotsos Date: Wed, 25 Sep 2013 20:33:45 +0100 Subject: [PATCH 61/75] documenting flowvisor topology module and lldp parsing module --- lib/flowvisor_topology.ml | 37 +++++++++++++------------------------ lib/flowvisor_topology.mli | 16 +++++++++++++++- lib/lldp.mli | 12 ++++++------ 3 files changed, 34 insertions(+), 31 deletions(-) diff --git a/lib/flowvisor_topology.ml b/lib/flowvisor_topology.ml index b66cb30..7286d06 100644 --- a/lib/flowvisor_topology.ml +++ b/lib/flowvisor_topology.ml @@ -27,9 +27,6 @@ module OSK = Openflow.Ofsocket open OP let sp = Printf.sprintf -let pr = Printf.printf -let pp = Printf.printf -let ep = Printf.eprintf let cp = OS.Console.log module V = struct @@ -54,12 +51,6 @@ module E = struct let default = (0L, 0, 0L, 0, 1) end -(*module PortSet = Set.Make ( - struct - type t = (int64 * int) - let compare = Pervasives.compare -end) *) - module Graph = Imperative.Graph.ConcreteLabeled(V)(E) module W = struct @@ -84,8 +75,7 @@ let init_topology () = {ports=(Hashtbl.create 64); channels=(Hashtbl.create 64); topo;} -let add_channel t dpid ch = - Hashtbl.replace t.channels dpid ch +let add_channel t dpid ch = Hashtbl.replace t.channels dpid ch let generate_lldp_discovery dpid src_mac port = let bits = OS.Io_page.to_cstruct (OS.Io_page.get 1) in @@ -94,13 +84,13 @@ let generate_lldp_discovery dpid src_mac port = let bits = OS.Io_page.to_cstruct (OS.Io_page.get 1) in let _ = Cstruct.BE.set_uint16 bits 0 port in let port = Cstruct.(to_string (sub bits 0 2)) in - marshal_and_sub (marsal_lldp_tlvs src_mac - [Tlv_chassis_id_mac(src_mac); - Tlv_port_id_port_comp(port); - Tlv_ttl(120); - Tlv(LLDP_TYPE_SYSTEM_DESCR, dpid); - Tlv_end;]) - (OS.Io_page.to_cstruct (OS.Io_page.get 1)) + marshal_and_sub (marsal_lldp_tlvs src_mac + [Tlv_chassis_id_mac(src_mac); + Tlv_port_id_port_comp(port); + Tlv_ttl(120); + Tlv(LLDP_TYPE_SYSTEM_DESCR, dpid); + Tlv_end;]) + (OS.Io_page.to_cstruct (OS.Io_page.get 1)) let send_port_lldp t dpid port mac = let data = generate_lldp_discovery dpid mac port in @@ -111,12 +101,12 @@ let send_port_lldp t dpid port mac = OC.send_data ch dpid (OP.Packet_out(h, m)) let add_port t dpid port mac = - let _ = printf "[flowvisor-topo] adding port %Ld:%d\n%!" dpid port in + let _ = cp (sp "[flowvisor-topo] adding port %Ld:%d\n%!" dpid port) in let _ = Hashtbl.replace t.ports (dpid, port) (mac, false) in send_port_lldp t dpid port mac let mark_port_down t dpid port down = - let fmac = Macaddr.of_bytes_exn "\xff\xff\xff\xff\xff\xff" in + let fmac = Macaddr.broadcast in try let (mac, _) = Hashtbl.find t.ports (dpid, port) in Hashtbl.replace t.ports (dpid, port) (mac, down) @@ -170,8 +160,8 @@ let process_lldp_packet t src_dpid src_port pkt = | false -> false | true -> let v = (src_dpid, (src_dpid, src_port, dst_dpid, dst_port, 1), dst_dpid) in - let _ = printf "[flowvisor-topo] adding link %Ld:%d-%Ld:%d\n%!" - src_dpid src_port dst_dpid dst_port in + let _ = cp (sp "[flowvisor-topo] adding link %Ld:%d-%Ld:%d\n%!" + src_dpid src_port dst_dpid dst_port) in let _ = Graph.add_edge_e t.topo v in let _ = mark_port_down t src_dpid src_port true in let _ = mark_port_down t dst_dpid dst_port true in @@ -184,8 +174,7 @@ let remove_dpid t dpid = fun (dp, p) _ -> if (dpid = dp) then Hashtbl.remove t.ports (dp, p)) t.ports in - let _ = Hashtbl.remove t.channels dpid in - () + Hashtbl.remove t.channels dpid let is_transit_port t dpid port = try diff --git a/lib/flowvisor_topology.mli b/lib/flowvisor_topology.mli index dac96ad..93439fe 100644 --- a/lib/flowvisor_topology.mli +++ b/lib/flowvisor_topology.mli @@ -18,13 +18,27 @@ open Net.Nettypes type t +(** FlowVisor topology discovery *) + + +(** Initialize a topology struct *) val init_topology: unit -> t -val add_port: t -> int64 -> int -> Macaddr.t -> unit Lwt.t + +(** Add to the structure a new switch and the relevant controller channel *) val add_channel: t -> int64 -> Openflow.Ofcontroller.t -> unit +(** Add a new port on a switch *) +val add_port: t -> int64 -> int -> Macaddr.t -> unit Lwt.t +(** run a daemon which broadcasts lldp packet every 120 seconds in order to + * discover physical connectivity between switches *) val discover: t-> unit Lwt.t + +(** parse and process an lldp packet *) val process_lldp_packet: t -> int64 -> int -> Cstruct.t -> bool +(** discover a path between two ports of connected switches *) val find_dpid_path: t -> int64 -> Openflow.Ofpacket.Port.t -> int64 -> Openflow.Ofpacket.Port.t -> (int64 * Openflow.Ofpacket.Port.t * Openflow.Ofpacket.Port.t) list +(** remove all ports of a specific switch *) val remove_dpid: t -> int64 -> unit +(** reports if a link function a a transit link between two adjacent switches *) val is_transit_port : t -> int64 -> int -> bool diff --git a/lib/lldp.mli b/lib/lldp.mli index 62e6f62..054e8e6 100644 --- a/lib/lldp.mli +++ b/lib/lldp.mli @@ -14,12 +14,10 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Net -open Net.Nettypes -open Cstruct - exception Unparsable of Cstruct.t +(** LLDP basic message tbl types *) + type lldp_tlv_types = | LLDP_TYPE_END | LLDP_TYPE_CHASSIS_ID @@ -51,5 +49,7 @@ type lldp_tvl = | Tlv of lldp_tlv_types * string | Tlv_unk of int * string -val parse_lldp_tlvs: t -> lldp_tvl list -val marsal_lldp_tlvs: Macaddr.t -> lldp_tvl list -> t -> int +(** [parse_lldp_tlvs bits] extract an lldp packet from a raw packet*) +val parse_lldp_tlvs: Cstruct.t -> lldp_tvl list +(** [marshal_lldp_tlvs mac tlvs bits] marshal lldp tlvs to bits memory address *) +val marsal_lldp_tlvs: Macaddr.t -> lldp_tvl list -> Cstruct.t -> int From 5fe1b98cabdb9dc7b1c813c1e0fb5908dbfc2dbc Mon Sep 17 00:00:00 2001 From: crotsos Date: Wed, 25 Sep 2013 20:40:33 +0100 Subject: [PATCH 62/75] adding comments on flowvisor interface --- lib/flowvisor.mli | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/lib/flowvisor.mli b/lib/flowvisor.mli index 4dfea1e..b7e22f3 100644 --- a/lib/flowvisor.mli +++ b/lib/flowvisor.mli @@ -20,15 +20,29 @@ open Net.Nettypes type t +(* + * TODO: + * + * expose read write permissions to slices + * *) + +(** initialize required state for a flowvisor instance *) +val create_flowvisor: ?verbose:bool -> unit -> t + +(** switch listening daemons *) val listen: t -> Manager.t -> ipv4_src -> unit Lwt.t val local_listen: t -> Openflow.Ofsocket.conn_state -> unit Lwt.t -val create_flowvisor: ?verbose:bool -> unit -> t -val remove_slice : t -> Openflow.Ofpacket.Match.t -> unit Lwt.t -val add_local_slice : Net.Manager.t -> t -> Openflow.Ofpacket.Match.t -> + +(** slice management methods *) + +(** connect to a local control socket and expose a slice of the network control + * traffic *) +val add_local_slice : t -> Openflow.Ofpacket.Match.t -> Openflow.Ofsocket.conn_state -> int64 -> unit Lwt.t +(** connect to a remote controller and expose a slice of the network control + * traffic *) val add_slice : Net.Manager.t -> t -> Openflow.Ofpacket.Match.t -> ipv4_dst -> int64 -> unit Lwt.t -val add_local_slice : t -> Openflow.Ofpacket.Match.t -> - Openflow.Ofsocket.conn_state -> int64 -> unit Lwt.t - +(** stop exposing a control slice *) +val remove_slice : t -> Openflow.Ofpacket.Match.t -> unit Lwt.t From 823a1a3647b702cfd29080ccd0e1c3b4f628ad7d Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 26 Sep 2013 17:59:33 +0100 Subject: [PATCH 63/75] flowvisor cleaning up the code of the flowvisorw --- lib/flowvisor.ml | 531 ++++++++++++++++++-------------------- lib/flowvisor.mli | 6 +- lib/flowvisor_topology.ml | 1 - 3 files changed, 253 insertions(+), 285 deletions(-) diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index c9ca74b..51bb721 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -16,21 +16,20 @@ open Lwt open Net -open Net.Nettypes module OP = Openflow.Ofpacket module OC = Openflow.Ofcontroller module OE = Openflow.Ofcontroller.Event +module OSK = Openflow.Ofsocket open OP open OP.Flow open OP.Flow_mod open OP.Match let sp = Printf.sprintf -let pr = Printf.printf -let pp = Printf.printf -let ep = Printf.eprintf let cp = OS.Console.log +let to_port = OP.Port.port_of_int +let of_port = OP.Port.int_of_port exception Ofcontroller_error of int32 * OP.error_code * OP.t exception Ofswitch_error of int64 * int32 * OP.error_code * OP.t @@ -106,13 +105,6 @@ let init_flowvisor verbose flv_topo = buffer_id_count=0l; xid_map=(Hashtbl.create 64); switches=(Hashtbl.create 64); flv_topo; } -let supported_actions () = - OP.Switch.({ - output=true; set_vlan_id=true; set_vlan_pcp=true; strip_vlan=true; - set_dl_src=true; set_dl_dst=true; set_nw_src=true; set_nw_dst=true; - set_nw_tos=true; set_tp_src=true; set_tp_dst=true; enqueue=false; - vendor=true; }) - (* xid buffer controller functions *) let match_dpid_buffer_id st dpid buffer_id = try @@ -153,7 +145,6 @@ let handle_xid flv st xid_st = let timeout_xid flv st = while_lwt true do - lwt _ = OS.Time.sleep 120.0 in let time = OS.Clock.time () in let xid = Hashtbl.fold ( @@ -169,6 +160,26 @@ let timeout_xid flv st = (* communication primitives *) let switch_dpid flv = Hashtbl.fold (fun dpid _ r -> r@[dpid]) flv.switches [] +let switch_chan_dpid flv = Hashtbl.fold (fun dpid ch r -> (dpid,ch)::r) flv.switches [] +let dpid_of_port st inp = + try + let (in_dpid, _, _) = Hashtbl.find st.port_map (of_port inp) in + in_dpid + with Not_found -> 0L +let port_of_port st inp = + try + let (_, inp, _) = Hashtbl.find st.port_map (of_port inp) in + OP.Port.Port(inp) + with Not_found -> OP.Port.No_port +let dpid_port_of_port_exn st inp xid msg = + try + let (dpid, p, _) = Hashtbl.find st.port_map (of_port inp) in + (dpid, OP.Port.Port(p)) + with Not_found -> + raise (Ofcontroller_error (xid, OP.ACTION_BAD_OUT_PORT, msg) ) + + + let send_all_switches st msg = Lwt_list.iter_p ( fun (dpid, ch) -> OC.send_data ch dpid msg) @@ -177,9 +188,9 @@ let send_switch st dpid msg = try_lwt let ch = Hashtbl.find st.switches dpid in OC.send_data ch dpid msg - with Not_found -> return (ep "[flowvisor] unregister dpid %Ld\n%!" dpid) + with Not_found -> return (cp (sp "[flowvisor] unregister dpid %Ld\n%!" dpid)) -let send_controller t msg = Openflow.Ofsocket.send_packet t msg +let send_controller t msg = OSK.send_packet t msg let inform_controllers flv m msg = (* find the controller that should handle the packet in *) Lwt_list.iter_p @@ -191,7 +202,7 @@ let inform_controllers flv m msg = (************************************************* * Switch OpenFlow control channel *************************************************) -let packet_out_create st msg xid in_port bid data actions = +let packet_out_create st msg xid inp bid data actions = let data = match (bid) with | -1l -> data @@ -204,17 +215,11 @@ let packet_out_create st msg xid in_port bid data actions = pkt.OP.Packet_in.data | _ -> raise (Ofcontroller_error(xid, OP.REQUEST_BUFFER_UNKNOWN, msg) ) in - let in_port = - try - let (_, in_port, _) = Hashtbl.find st.port_map (OP.Port.int_of_port - in_port) in - OP.Port.Port(in_port) - with Not_found -> OP.Port.No_port - in - let m = OP.Packet_out.create ~buffer_id:(-1l) - ~actions ~in_port ~data () in - let h = OP.Header.create ~xid OP.Header.PACKET_OUT 0 in - OP.Packet_out (h,m) + let in_port = port_of_port st inp in + let m = OP.Packet_out.create ~buffer_id:(-1l) + ~actions ~in_port ~data () in + let h = OP.Header.(create ~xid PACKET_OUT 0) in + OP.Packet_out (h,m) let rec pkt_out_process st xid inp bid data msg acts = function | (OP.Flow.Output(OP.Port.All, len))::tail @@ -222,12 +227,7 @@ let packet_out_create st msg xid in_port bid data actions = let actions = acts @ [OP.Flow.Output(OP.Port.Flood, len)] in (* OP.Port.None is not the appropriate way to handle this. Need to find the * port that connects the two switches probably. *) - let in_dpid = - try - let (in_dpid, _, _) = Hashtbl.find st.port_map (OP.Port.int_of_port - inp) in in_dpid - with Not_found -> 0L - in + let in_dpid = dpid_of_port st inp in (* let _ = pp "sending packet from port %d to port %d\n%!" * (OP.Port.int_of_port inp) (in_p) in *) let msg = packet_out_create st msg xid OP.Port.No_port (-1l) data actions in @@ -244,22 +244,23 @@ let packet_out_create st msg xid in_port bid data actions = end | (OP.Flow.Output(OP.Port.In_port, len))::tail -> begin (* output packet to the last hop of the path *) - let (dpid, out_p, _) = Hashtbl.find st.port_map (OP.Port.int_of_port inp) in + let (dpid, out_p) = dpid_port_of_port_exn st inp xid msg in let actions = acts @ [OP.Flow.Output(OP.Port.In_port, len)] in - let msg = packet_out_create st msg xid (OP.Port.Port(out_p)) bid data actions in - lwt _ = send_switch st dpid msg in + lwt _ = send_switch st dpid + (packet_out_create st msg xid out_p bid data actions) in pkt_out_process st xid inp bid data msg acts tail end | (OP.Flow.Output(OP.Port.Port(p), len))::tail -> begin (* output packet to the last hop of the path *) - let (dpid, out_p, _) = Hashtbl.find st.port_map p in - let actions = acts @ [OP.Flow.Output((OP.Port.port_of_int out_p), len)] in + let (dpid, out_p) = dpid_port_of_port_exn st (to_port p) xid msg in + let actions = acts @ [OP.Flow.Output(out_p, len)] in let msg = packet_out_create st msg xid inp bid data actions in - lwt _ = send_switch st dpid msg in - pkt_out_process st xid inp bid data msg acts tail + lwt _ = send_switch st dpid + (packet_out_create st msg xid inp bid data actions) in + pkt_out_process st xid inp bid data msg acts tail end - | (OP.Flow.Output(OP.Port.Table, len))::tail | (OP.Flow.Output(OP.Port.Controller, len))::tail + | (OP.Flow.Output(OP.Port.Table, len))::tail | (OP.Flow.Output(OP.Port.Local, len))::tail | (OP.Flow.Output(OP.Port.No_port, len))::tail | (OP.Flow.Output(OP.Port.Normal, len))::tail -> @@ -273,11 +274,10 @@ let map_path flv in_dpid in_port out_dpid out_port = (* let _ = pp "[flowvisor-switch] mapping a path between %Ld:%s - %Ld:%s\n%!" in_dpid (OP.Port.string_of_port in_port) out_dpid (OP.Port.string_of_port out_port) in *) - if (in_dpid = out_dpid) then - [(out_dpid, in_port, out_port)] - else - let path = Flowvisor_topology.find_dpid_path flv.flv_topo - in_dpid in_port out_dpid out_port in + if (in_dpid = out_dpid) then [(out_dpid, in_port, out_port)] + else + Flowvisor_topology.find_dpid_path flv.flv_topo + in_dpid in_port out_dpid out_port (* let path = List.rev path in *) (* let _ = List.iter ( @@ -286,9 +286,10 @@ let map_path flv in_dpid in_port out_dpid out_port = (OP.Port.string_of_port in_p) dp (OP.Port.string_of_port out_p) ) path in - let _ = pp "\n%!" in *) - path + let _ = pp "\n%!" in + path *) +(* TODO fixme!!!! *) let map_spanning_tree flv in_dpid in_port = [] let rec send_flow_mod_to_path st xid msg pkt len actions path = @@ -301,18 +302,18 @@ let rec send_flow_mod_to_path st xid msg pkt len actions path = let fm = OP.Flow_mod.( {pkt with buffer_id=(-1l);out_port=(OP.Port.No_port);actions;}) in lwt _ = send_switch st dpid (OP.Flow_mod(h, fm)) in - match (pkt.buffer_id) with - | -1l -> return () - | bid when (Hashtbl.mem st.buffer_id_map bid) -> - (* if we have a buffer id in cache, use those data *) - let (pkt, _ ) = Hashtbl.find st.buffer_id_map bid in - let msg = packet_out_create st msg xid (OP.Port.No_port) - (-1l) (pkt.OP.Packet_in.data) actions in - lwt _ = send_switch st dpid msg in - return () - | _ -> - (* if buffer id is unknown, send error *) - raise (Ofcontroller_error(xid, OP.REQUEST_BUFFER_UNKNOWN, msg)) + match (pkt.buffer_id) with + | -1l -> return () + | bid when (Hashtbl.mem st.buffer_id_map bid) -> + (* if we have a buffer id in cache, use those data *) + let (pkt, _ ) = Hashtbl.find st.buffer_id_map bid in + let msg = packet_out_create st msg xid (OP.Port.No_port) + (-1l) (pkt.OP.Packet_in.data) actions in + lwt _ = send_switch st dpid msg in + return () + | _ -> + (* if buffer id is unknown, send error *) + raise (Ofcontroller_error(xid, OP.REQUEST_BUFFER_UNKNOWN, msg)) end | ((dpid, in_port, out_port)::rest) -> begin let _ = pkt.of_match.in_port <- in_port in @@ -339,23 +340,21 @@ let rec flow_mod_translate_inner st msg xid pkt in_dpid in_port acts = function [(in_dpid, OP.Port.Port(in_port), OP.Port.Controller)] in flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail | (OP.Flow.Output(OP.Port.Port(p), len))::tail -> - let (out_dpid, out_port, _) = Hashtbl.find st.port_map p in + let (out_dpid, out_port) = dpid_port_of_port_exn st (to_port p) xid msg in lwt _ = send_flow_mod_to_path st xid msg pkt len acts (map_path st in_dpid (OP.Port.Port(in_port) ) - out_dpid (OP.Port.Port(out_port))) in - flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail + out_dpid out_port) in + flow_mod_translate_inner st msg xid pkt in_dpid in_port acts tail | (OP.Flow.Output(OP.Port.Table, _))::_ | (OP.Flow.Output(OP.Port.Local, _))::_ - | (OP.Flow.Output(OP.Port.No_port, _))::_ | (OP.Flow.Output(OP.Port.Normal, _))::_ -> raise (Ofcontroller_error (xid, OP.REQUEST_BAD_STAT, msg) ) | a :: tail -> flow_mod_translate_inner st msg xid pkt in_dpid in_port (acts@[a]) tail | [] -> return () let flow_mod_add_translate st msg xid pkt = - let (in_dpid, in_port, _) = Hashtbl.find st.port_map - (OP.Port.int_of_port pkt.of_match.in_port) in - flow_mod_translate_inner st msg xid pkt in_dpid in_port [] pkt.actions + let (in_dpid, in_port) = dpid_port_of_port_exn st pkt.of_match.in_port xid msg in + flow_mod_translate_inner st msg xid pkt in_dpid (of_port in_port) [] pkt.actions let flow_mod_del_translate st msg xid pkt = match (pkt.of_match.OP.Match.wildcards.OP.Wildcards.in_port, @@ -365,119 +364,111 @@ let flow_mod_del_translate st msg xid pkt = let h = OP.Header.(create ~xid FLOW_MOD 0) in send_all_switches st (OP.Flow_mod(h, pkt)) | (false, OP.Port.Port(p), OP.Port.No_port) -> - let (dpid, port, _) = Hashtbl.find st.port_map p in - let _ = pkt.of_match.in_port <- OP.Port.Port(port) in + let (dpid, port) = dpid_port_of_port_exn st (to_port p) xid msg in + let _ = pkt.of_match.in_port <- port in let h = OP.Header.(create ~xid FLOW_MOD 0) in send_switch st dpid (OP.Flow_mod(h, pkt)) | (false, OP.Port.Port(in_p), OP.Port.Port(out_p)) -> - let (in_dpid, in_port, _) = Hashtbl.find st.port_map in_p in - let (out_dpid, out_port, _) = Hashtbl.find st.port_map out_p in + let (in_dpid, in_port) = dpid_port_of_port_exn st + pkt.of_match.OP.Match.in_port xid msg in + let (out_dpid, out_port) = dpid_port_of_port_exn st + pkt.OP.Flow_mod.out_port xid msg in lwt _ = send_flow_mod_to_path st xid msg pkt 0 [] - (map_path st in_dpid (OP.Port.Port(in_port) ) - out_dpid (OP.Port.Port(out_port))) in + (map_path st in_dpid in_port out_dpid out_port) in return () | _ -> raise (Ofcontroller_error (xid, OP.REQUEST_BAD_STAT, msg) ) let process_openflow st dpid t msg = + let _ = if st.verbose then cp (sp "[flowvisor-switch] %s\n%!" (OP.to_string msg)) in match msg with - | OP.Hello (h) -> - let _ = if st.verbose then cp "[flowvisor-switch] HELLO\n%!" in - return () + | OP.Hello (h) -> return () | OP.Echo_req (h) -> (* Reply to ECHO requests *) - let _ = if st.verbose then cp "[flowvisor-switch] ECHO_REQ\n%!" in - let h = OP.Header.(create ECHO_RESP ~xid:h.xid sizeof_ofp_header) in - send_controller t (OP.Echo_resp h) + let open OP.Header in + send_controller t (OP.Echo_resp (create ECHO_RESP ~xid:h.xid get_len)) | OP.Features_req (h) -> - let _ = if st.verbose then cp "[flowvisor-switch] FEATURES_REQ\n%!" in - let h = OP.Header.(create FEATURES_RESP - ~xid:h.OP.Header.xid sizeof_ofp_header) in - let feat = switch_features dpid + let h = OP.Header.(create FEATURES_RESP ~xid:h.xid 0) in + let f = switch_features dpid (Hashtbl.fold (fun _ (_, _, p) r -> p::r) st.port_map []) in - send_controller t (OP.Features_resp(h, feat)) + send_controller t (OP.Features_resp(h, f)) | OP.Stats_req(h, req) -> begin (* TODO Need to translate the xid here *) - let _ = if st.verbose then cp "[flowvisor-switch] STATS_REQ" in match req with | OP.Stats.Desc_req(req) -> - let desc = - OP.Stats.({ imfr_desc="Mirage"; hw_desc="Mirage"; + let open OP.Stats in + let desc = { imfr_desc="Mirage"; hw_desc="Mirage"; sw_desc="Mirage_flowvisor"; serial_num="0.1"; - dp_desc="Mirage";}) in - let resp_h = OP.Stats.({st_ty=DESC;more=false;}) in + dp_desc="Mirage";} in + let resp_h = {st_ty=DESC;more=false;} in send_controller t - (OP.Stats_resp(h, (OP.Stats.Desc_resp(resp_h,desc)))) + (OP.Stats_resp(h, (Desc_resp(resp_h,desc)))) | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> begin (*TODO Need to consider the table_id and the out_port and * split reply over multiple openflow packets if they don't * fit a single packet. *) - match (of_match.OP.Match.wildcards.OP.Wildcards.in_port, - (of_match.OP.Match.in_port)) with - | (false, OP.Port.Port(p)) -> - let (dst_dpid, out_port, _) = - Hashtbl.find st.port_map p in - let xid = get_new_xid h.OP.Header.xid st dst_dpid [dpid] (Flows [])in - let h = OP.Header.(create STATS_RESP - ~xid sizeof_ofp_header) in - let out_port = OP.Port.Port(out_port) in - let of_match = OP.Match.translate_port of_match out_port in - (* TODO out_port needs processing. if dpid are between - * different switches need to define the outport - * as the port of the interconnection link *) - let table_id = OP.Stats.int_of_table_id table_id in - let req = OP.Stats.(Flow_req(req_h, of_match, - (OP.Stats.table_id_of_int table_id), - out_port)) in - send_switch st dst_dpid (OP.Stats_req(h, req)) - | (_, _) -> - let req = OP.Stats.(Flow_req(req_h, of_match, - table_id, out_port)) in - let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) (Flows []) in - let h = OP.Header.(create STATS_RESP - ~xid sizeof_ofp_header) in - send_all_switches st (OP.Stats_req(h, req)) + match (of_match.OP.Match.wildcards.OP.Wildcards.in_port, + (of_match.OP.Match.in_port)) with + | (false, OP.Port.Port(p)) -> + let (dst_dpid, out_port) = dpid_port_of_port_exn st + of_match.OP.Match.in_port h.OP.Header.xid msg in + let xid = get_new_xid h.OP.Header.xid st dst_dpid [dpid] (Flows [])in + let h = OP.Header.(create STATS_RESP ~xid 0) in + let of_match = OP.Match.translate_port of_match out_port in + (* TODO out_port needs processing. if dpid are between + * different switches need to define the outport + * as the port of the interconnection link *) + let req = OP.Stats.( + Flow_req(req_h, of_match, table_id, out_port)) in + send_switch st dst_dpid (OP.Stats_req(h, req)) + | (_, _) -> + let req = OP.Stats.(Flow_req(req_h, of_match,table_id, out_port)) in + let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) (Flows []) in + let h = OP.Header.(create STATS_RESP ~xid 0) in + send_all_switches st (OP.Stats_req(h, req)) end | OP.Stats.Aggregate_req (req_h, of_match, table_id, out_port) -> begin - let cache = (Aggr (OP.Stats.({packet_count=0L; byte_count=0L; - flow_count=0l;}))) in - match (of_match.OP.Match.wildcards.OP.Wildcards.in_port, - (of_match.OP.Match.in_port)) with + let open OP.Stats in + let open OP.Header in + let cache = Aggr ({packet_count=0L; byte_count=0L;flow_count=0l;}) in + match OP.Match.(of_match.wildcards.OP.Wildcards.in_port,(of_match.in_port)) with | (false, OP.Port.Port(p)) -> - let (dst_dpid, port, _) = Hashtbl.find st.port_map p in - let xid = get_new_xid h.OP.Header.xid st dpid [dst_dpid] cache in - let h = OP.Header.({ h with xid;}) in - let _ = of_match.in_port <-OP.Port.Port(port) in + let (dst_dpid, port) = dpid_port_of_port_exn st of_match.in_port h.xid msg in + let xid = get_new_xid h.xid st dpid [dst_dpid] cache in + let h = { h with xid;} in + let _ = of_match.in_port <- port in (* TODO out_port needs processing. if dpid are between * different switches need to define the outport as the * port of the interconnection link *) - let m = OP.Stats.(Aggregate_req(req_h, of_match, - table_id, out_port)) in - send_switch st dst_dpid (OP.Stats_req(h, m)) + let m = Aggregate_req(req_h, of_match, table_id, out_port) in + send_switch st dst_dpid (OP.Stats_req(h, m)) | (_, _) -> - let h = OP.Header.({h with xid=(get_new_xid h.OP.Header.xid st dpid - (switch_dpid st) cache);}) in + let open OP.Header in + let h = {h with xid=(get_new_xid h.xid st dpid + (switch_dpid st) cache);} in send_all_switches st (OP.Stats_req(h, req)) end | OP.Stats.Table_req(req_h) -> - let cache = Table (OP.Stats.init_table_stats (OP.Stats.table_id_of_int 1) + let open OP.Header in + let cache = Table OP.Stats.(init_table_stats (OP.Stats.table_id_of_int 1) "mirage" (OP.Wildcards.full_wildcard ()) ) in - let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) cache in - let h = OP.Header.({h with xid;}) in + let xid = get_new_xid h.xid st dpid (switch_dpid st) cache in + let h = {h with xid;} in send_all_switches st (OP.Stats_req(h, req)) | OP.Stats.Port_req(req_h, port) -> begin match port with | OP.Port.No_port -> - let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) (Port - []) in - let h = OP.Header.({h with xid;}) in - send_all_switches st (OP.Stats_req(h, req)) - | OP.Port.Port(port) when (Hashtbl.mem st.port_map port) -> - let (dst_dpid, port, _) = Hashtbl.find st.port_map port in - let xid = get_new_xid h.OP.Header.xid st dpid [dst_dpid] (Port []) in - let h = OP.Header.({h with xid;}) in - let m = OP.Stats.(Port_req(req_h, OP.Port.Port(port))) in - send_all_switches st (OP.Stats_req(h, m)) + let open OP.Header in + let xid = get_new_xid h.xid st dpid (switch_dpid st) (Port []) in + let h = ({h with xid;}) in + send_all_switches st (OP.Stats_req(h, req)) + | OP.Port.Port(_) -> + let open OP.Header in + let (dst_dpid, port) = dpid_port_of_port_exn st port h.xid msg in + let xid = get_new_xid h.xid st dpid [dst_dpid] (Port []) in + let h = {h with xid;} in + let m = OP.Stats.(Port_req(req_h, port)) in + send_all_switches st (OP.Stats_req(h, m)) | _ -> raise (Ofcontroller_error (h.OP.Header.xid, OP.QUEUE_OP_BAD_PORT, msg)) end @@ -491,22 +482,22 @@ let process_openflow st dpid t msg = | OP.Barrier_req(h) -> (* TODO just reply for now. need to check this with all switches *) (* let xid = get_new_xid dpid in *) - let _ = pr "BARRIER_REQ: %s\n%!" (OP.Header.header_to_string h) in + let _ = cp (sp "BARRIER_REQ: %s\n%!" (OP.Header.header_to_string h)) in send_controller t (OP.Barrier_resp (OP.Header.({h with ty=BARRIER_RESP;})) ) | OP.Packet_out(h, pkt) -> begin - let _ = if st.verbose then pr "[flowvisor-switch] PACKET_OUT: %s\n%!" - (OP.Packet_out.packet_out_to_string pkt) in + let _ = if st.verbose then cp (sp "[flowvisor-switch] PACKET_OUT: %s\n%!" + (OP.Packet_out.packet_out_to_string pkt)) in (* Check if controller has the right to send traffic on the specific subnet *) try_lwt OP.Packet_out.(pkt_out_process st h.OP.Header.xid pkt.in_port pkt.buffer_id pkt.data msg [] pkt.actions ) with exn -> - return (pp "[flowvisor-switch] packet_out message error %s\n%!" - (Printexc.to_string exn)) + return (cp (sp "[flowvisor-switch] packet_out message error %s\n%!" + (Printexc.to_string exn))) end | OP.Flow_mod(h,fm) -> begin - let _ = if st.verbose then pr "[flowvisor-switch] FLOW_MOD: %s\n%!" - (OP.Flow_mod.flow_mod_to_string fm) in + let _ = if st.verbose then cp (sp "[flowvisor-switch] FLOW_MOD: %s\n%!" + (OP.Flow_mod.flow_mod_to_string fm)) in let xid = get_new_xid h.OP.Header.xid st dpid (switch_dpid st) No_reply in match (fm.OP.Flow_mod.command) with | OP.Flow_mod.ADD @@ -551,12 +542,14 @@ let switch_channel st dpid of_m sock = with | Nettypes.Closed -> let _ = continue := false in - return (pr "[flowvisor-switch] Ofcontroller channel closed....\n%!") - | OP.Unparsed (m, bs) -> return ((pr "[flowvisor-switch] # unparsed! m=%s\n %!" m)) + return (cp (sp "[flowvisor-switch] control channel closed\n%!") ) + | OP.Unparsed (m, bs) -> + return (cp (sp "[flowvisor-switch] # unparsed! m=%s\n %!" m)) | Ofcontroller_error (xid, error, msg)-> let h = OP.Header.create ~xid OP.Header.ERROR 0 in send_switch st dpid (OP.Error(h, error, (OP.marshal msg))) - | exn -> return (pr "[flowvisor-switch] ERROR:%s\n" (Printexc.to_string exn)) + | exn -> return (cp (sp "[flowvisor-switch] ERROR:%s\n" + (Printexc.to_string exn))) done (* @@ -620,27 +613,24 @@ let translate_stat flv dpid f = let process_switch_channel flv st dpid e = try_lwt + let _ = if (flv.verbose) then cp (sp "[flowvisor-ctrl] %s\n%!" (OE.string_of_event e)) in match e with | OE.Datapath_join(dpid, ports) -> - let _ = pr "[flowvisor-ctrl]+ switch dpid:%Ld\n%!" dpid in - let _ = Flowvisor_topology.add_channel flv.flv_topo dpid st in - (* Update local state *) - let _ = Hashtbl.add flv.switches dpid st in - Lwt_list.iter_p (add_flowvisor_port flv dpid) ports + let _ = cp (sp "[flowvisor-ctrl]+ switch dpid:%Ld\n%!" dpid) in + let _ = Flowvisor_topology.add_channel flv.flv_topo dpid st in + (* Update local state *) + let _ = Hashtbl.replace flv.switches dpid st in + Lwt_list.iter_p (add_flowvisor_port flv dpid) ports | OE.Datapath_leave(dpid) -> - let _ = pr "[flowvisor-ctrl]- switch dpid:%Ld\n%!" dpid in - let _ = Flowvisor_topology.remove_dpid flv.flv_topo dpid in - (* Need to remove ports and port mapping and disard any state + let _ = (cp(sp "[flowvisor-ctrl]- switch dpid:%Ld\n%!" dpid)) in + let _ = Flowvisor_topology.remove_dpid flv.flv_topo dpid in + (* Need to remove ports and port mapping and disard any state * pending for replies. *) - let removed = - Hashtbl.fold - (fun vp (dp, rp, phy) r -> - if (dp = dpid) then - let _ = Hashtbl.remove flv.port_map vp in - phy::r else r) flv.port_map [] in - lwt _ = - Lwt_list.iter_p (del_flowvisor_port flv) removed in - return () + Lwt_list.iter_p (del_flowvisor_port flv) + ( Hashtbl.fold (fun vp (dp, _, phy) r -> + if (dp = dpid) then + let _ = Hashtbl.remove flv.port_map vp in + phy::r else r) flv.port_map []) | OE.Packet_in(in_port, reason, buffer_id, data, dpid) -> begin let m = OP.Match.raw_packet_to_match in_port data in match (in_port, m.OP.Match.dl_type) with @@ -649,39 +639,36 @@ let process_switch_channel flv st dpid e = flv.flv_topo dpid p data) with | true -> return () | false -> - let in_port = map_flv_port flv dpid p in - let h = OP.Header.(create PACKET_IN 0) in - let pkt = OP.Packet_in.({buffer_id=(-1l);in_port;reason;data;}) in - inform_controllers flv m (OP.Packet_in(h, pkt)) + let in_port = map_flv_port flv dpid p in + let h = OP.Header.(create PACKET_IN 0) in + let pkt = OP.Packet_in.({buffer_id=(-1l);in_port;reason;data;}) in + inform_controllers flv m (OP.Packet_in(h, pkt)) end | (OP.Port.Port(p), _) when not (Flowvisor_topology.is_transit_port flv.flv_topo dpid p) -> begin (* translate the buffer id information *) - let buffer_id = flv.buffer_id_count in - let _ = flv.buffer_id_count <- Int32.add flv.buffer_id_count 1l in + let buffer_id = flv.buffer_id_count in + flv.buffer_id_count <- Int32.succ flv.buffer_id_count; (* generate packet bits *) - let in_port = map_flv_port flv dpid p in - let h = OP.Header.(create PACKET_IN 0) in - let pkt = OP.Packet_in.({buffer_id;in_port;reason;data;}) in - let _ = Hashtbl.add flv.buffer_id_map buffer_id (pkt, dpid) in - lwt _ = inform_controllers flv m (OP.Packet_in(h, pkt)) in - return () - end - | (OP.Port.Port(p), _) -> - return ((*pp "XXXXX supress disable transit port"*)) + let in_port = map_flv_port flv dpid p in + let h = OP.Header.(create PACKET_IN 0) in + let pkt = OP.Packet_in.({buffer_id;in_port;reason;data;}) in + let _ = Hashtbl.add flv.buffer_id_map buffer_id (pkt, dpid) in + inform_controllers flv m (OP.Packet_in(h, pkt)) + end + | (OP.Port.Port(p), _) -> return () | _ -> - let _ = pp "[flowvisor-ctrl] Invalid port on Packet_in\n%!" in - let h = OP.Header.(create ERROR 0) in - inform_controllers flv m - (OP.Error(h, OP.REQUEST_BAD_STAT, (Cstruct.create 0))) + let _ = cp (sp "[flowvisor-ctrl] Invalid port on Packet_in\n%!") in + let h = OP.Header.(create ERROR 0) in + inform_controllers flv m + (OP.Error(h, OP.REQUEST_BAD_STAT, (Cstruct.create 0))) end | OE.Flow_removed(of_match, r, dur_s, dur_ns, pkts, bytes, dpid) -> (* translate packet *) - let new_in_port = map_flv_port flv dpid - (OP.Port.int_of_port of_match.OP.Match.in_port) in + let new_in_p = map_flv_port flv dpid (of_port of_match.OP.Match.in_port) in (* TODO need to pass cookie id, idle, and priority *) - let _ = of_match.OP.Match.in_port <- new_in_port in + let _ = of_match.OP.Match.in_port <- new_in_p in let pkt = OP.Flow_removed.( {of_match; cookie=0L;reason=r; priority=0;idle_timeout=0; @@ -691,65 +678,60 @@ let process_switch_channel flv st dpid e = inform_controllers flv of_match (OP.Flow_removed(h, pkt)) (* TODO: Need to write code to handle stats replies *) | OE.Flow_stats_reply(xid, more, flows, dpid) -> begin - try_lwt - let xid_st = Hashtbl.find flv.xid_map xid in - match xid_st.cache with - | Flows fl -> - (* Group reply separation *) - let _ = xid_st.cache <- (Flows (fl @ flows)) in - let flows = List.map (translate_stat flv dpid) flows in - let _ = - if not more then - xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst - in - if (List.length xid_st.dst = 0 ) then - let _ = Hashtbl.remove flv.xid_map xid in - handle_xid flv st xid_st - else - let _ = Hashtbl.replace flv.xid_map xid xid_st in - return () - | _ -> return () - with Not_found -> return (pr "[flowvisor-ctrl] Unknown stats reply xid\n%!") - end + if Hashtbl.mem flv.xid_map xid then ( + let xid_st = Hashtbl.find flv.xid_map xid in + match xid_st.cache with + | Flows fl -> + (* Group reply separation *) + xid_st.cache <- (Flows (fl @ flows)); + let flows = List.map (translate_stat flv dpid) flows in + let _ = + if not more then + xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst + in + if (List.length xid_st.dst = 0 ) then + let _ = Hashtbl.remove flv.xid_map xid in + handle_xid flv st xid_st + else + return (Hashtbl.replace flv.xid_map xid xid_st) + | _ -> return () + ) else + return (cp (sp "[flowvisor-ctrl] Unknown stats reply xid\n%!")) + end | OE.Aggr_flow_stats_reply(xid, pkts, bytes, flows, dpid) -> begin - try_lwt - let xid_st = Hashtbl.find flv.xid_map xid in - match xid_st.cache with - | Aggr aggr -> - (* Group reply separation *) - let aggr = - OP.Stats.({packet_count=(Int64.add pkts aggr.packet_count); - byte_count=(Int64.add bytes aggr.byte_count); - flow_count=(Int32.add flows aggr.flow_count);}) in - let _ = xid_st.cache <- (Aggr aggr) in - let _ = - xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst - in - if (List.length xid_st.dst = 0 ) then - let _ = Hashtbl.remove flv.xid_map xid in - handle_xid flv st xid_st - else - let _ = Hashtbl.replace flv.xid_map xid xid_st in - return () - | _ -> return () - with Not_found -> return () + if (Hashtbl.mem flv.xid_map xid) then ( + let xid_st = Hashtbl.find flv.xid_map xid in + match xid_st.cache with + | Aggr aggr -> + (* Group reply separation *) + let aggr = + OP.Stats.({packet_count=(Int64.add pkts aggr.packet_count); + byte_count=(Int64.add bytes aggr.byte_count); + flow_count=(Int32.add flows aggr.flow_count);}) in + let _ = xid_st.cache <- (Aggr aggr) in + let _ = + xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst + in + if (List.length xid_st.dst = 0 ) then + let _ = Hashtbl.remove flv.xid_map xid in + handle_xid flv st xid_st + else + return (Hashtbl.replace flv.xid_map xid xid_st) + | _ -> return () + ) else return () end | OE.Port_stats_reply(xid, more, ports, dpid) -> begin - try_lwt + if (Hashtbl.mem flv.xid_map xid) then ( let xid_st = Hashtbl.find flv.xid_map xid in match xid_st.cache with | Port p -> - (* Group reply separation *) - let ports = - List.map ( - fun port -> - let port_id = map_flv_port flv dpid port.OP.Port.port_id in - OP.Port.({port with port_id=(OP.Port.int_of_port port_id);})) ports in + (* Group reply separation *) + let ports = List.map (fun port -> + let port_id = map_flv_port flv dpid port.OP.Port.port_id in + OP.Port.({port with port_id=(OP.Port.int_of_port port_id);})) ports in let _ = xid_st.cache <- (Port (p @ ports)) in - let _ = - if not more then - xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst - in + let _ = if not more then + xid_st.dst <- List.filter (fun a -> a <> dpid) xid_st.dst in if (List.length xid_st.dst = 0 ) then let _ = Hashtbl.remove flv.xid_map xid in handle_xid flv st xid_st @@ -757,67 +739,54 @@ let process_switch_channel flv st dpid e = let _ = Hashtbl.replace flv.xid_map xid xid_st in return () | _ -> return () - with Not_found -> return () + ) else return () end | OE.Table_stats_reply(xid, more, tables, dpid) -> return () | OE.Port_status(reason, port, dpid) -> (* TODO: send a port withdrawal to all controllers *) add_flowvisor_port flv dpid port - | _ -> - return (pp "[flowvisor-ctrl] Unsupported event\n%!") - with Not_found -> return (pr "[flowvisor-ctrl] ignore pkt of non existing state\n%!") + | _ -> return (cp "[flowvisor-ctrl] Unsupported event\n%!") + with Not_found -> return (cp(sp "[flowvisor-ctrl] ignore pkt of non existing state\n%!")) let init flv st = (* register all the required handlers *) let fn = process_switch_channel flv in - let _ = OC.register_cb st OE.DATAPATH_JOIN fn in - let _ = OC.register_cb st OE.DATAPATH_LEAVE fn in - let _ = OC.register_cb st OE.PACKET_IN fn in - let _ = OC.register_cb st OE.FLOW_REMOVED fn in - let _ = OC.register_cb st OE.FLOW_STATS_REPLY fn in - let _ = OC.register_cb st OE.AGGR_FLOW_STATS_REPLY fn in - let _ = OC.register_cb st OE.PORT_STATUS_CHANGE fn in - let _ = OC.register_cb st OE.TABLE_STATS_REPLY fn in - () + OC.register_cb st OE.DATAPATH_JOIN fn; + OC.register_cb st OE.DATAPATH_LEAVE fn; + OC.register_cb st OE.PACKET_IN fn; + OC.register_cb st OE.FLOW_REMOVED fn; + OC.register_cb st OE.FLOW_STATS_REPLY fn; + OC.register_cb st OE.AGGR_FLOW_STATS_REPLY fn; + OC.register_cb st OE.PORT_STATUS_CHANGE fn; + OC.register_cb st OE.TABLE_STATS_REPLY fn let create_flowvisor ?(verbose=false) () = let ret = init_flowvisor verbose (Flowvisor_topology.init_topology ()) in let _ = ignore_result (Flowvisor_topology.discover ret.flv_topo) in - ret + ret let add_slice mgr flv of_m dst dpid = - let _ = - ignore_result ( - while_lwt true do + ignore_result ( + while_lwt true do + let switch_connect (addr, port) t = + let rs = Ipaddr.V4.to_string addr in try_lwt - let switch_connect (addr, port) t = - let rs = Ipaddr.V4.to_string addr in - let _ = pp "[flowvisor-switch]+ controller %s:%d\n%!" rs port in - (* Trigger the dance between the 2 nodes *) - let sock = Openflow.Ofsocket.init_socket_conn_state t in - switch_channel flv dpid of_m sock - in - Net.Channel.connect mgr - ( `TCPv4 (None, dst, (switch_connect dst) ) ) + let _ = cp (sp "[flowvisor-switch]+ switch %s:%d\n%!" rs port) in + (* Trigger the dance between the 2 nodes *) + let sock = Openflow.Ofsocket.init_socket_conn_state t in + switch_channel flv dpid of_m sock with exn -> - let _ = pp "[flowvisor-ctrl] controller error %s\n%!" - (Printexc.to_string exn) in - return () - done - ) in - return () + return (cp(sp "[flowvisorswitch]- switch %s:%d %s\n%!" rs port (Printexc.to_string exn))) + in + Net.Channel.connect mgr ( `TCPv4 (None, dst, (switch_connect dst) ) ) + done) let listen st mgr loc = OC.listen mgr loc (init st) let local_listen st conn = - let t = OC.init_controller (init st) in - OC.local_connect t conn + OC.local_connect (OC.init_controller (init st)) conn -let remove_slice _ _ = return () +let remove_slice _ _ = () let add_local_slice flv of_m conn dpid = - let _ = + ignore_result ( switch_channel flv dpid of_m conn) (* TODO Need to store thread for termination on remove_slice *) - ignore_result ( switch_channel flv dpid of_m conn) in - return () - - diff --git a/lib/flowvisor.mli b/lib/flowvisor.mli index b7e22f3..83d8c55 100644 --- a/lib/flowvisor.mli +++ b/lib/flowvisor.mli @@ -39,10 +39,10 @@ val local_listen: t -> Openflow.Ofsocket.conn_state -> unit Lwt.t (** connect to a local control socket and expose a slice of the network control * traffic *) val add_local_slice : t -> Openflow.Ofpacket.Match.t -> - Openflow.Ofsocket.conn_state -> int64 -> unit Lwt.t + Openflow.Ofsocket.conn_state -> int64 -> unit (** connect to a remote controller and expose a slice of the network control * traffic *) val add_slice : Net.Manager.t -> t -> Openflow.Ofpacket.Match.t -> - ipv4_dst -> int64 -> unit Lwt.t + ipv4_dst -> int64 -> unit (** stop exposing a control slice *) -val remove_slice : t -> Openflow.Ofpacket.Match.t -> unit Lwt.t +val remove_slice : t -> Openflow.Ofpacket.Match.t -> unit diff --git a/lib/flowvisor_topology.ml b/lib/flowvisor_topology.ml index 7286d06..e1b0533 100644 --- a/lib/flowvisor_topology.ml +++ b/lib/flowvisor_topology.ml @@ -47,7 +47,6 @@ module E = struct 0 else Pervasives.compare v1 v2 - let default = (0L, 0, 0L, 0, 1) end From 4228f450fdbe45e0a5bb4d5b9ac2c4b902e1651d Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 26 Sep 2013 18:21:05 +0100 Subject: [PATCH 64/75] fixing unix backend example code --- _oasis | 8 +++---- _tags | 42 +++++++++++++++++----------------- controller/learning_switch.ml | 20 +--------------- controller/lwt_controller.ml | 26 +++++++++++++++++++++ setup.ml | 10 ++++---- switch/basic_switch.ml | 43 ++++++++--------------------------- switch/lwt_switch.ml | 29 +++++++++++++++++++++++ 7 files changed, 96 insertions(+), 82 deletions(-) create mode 100644 controller/lwt_controller.ml create mode 100644 switch/lwt_switch.ml diff --git a/_oasis b/_oasis index 344b52f..24d0a84 100644 --- a/_oasis +++ b/_oasis @@ -64,20 +64,20 @@ Executable "ocaml-ofctl" Executable ofcontroller_lwt Path: controller - MainIs: learning_switch.ml + MainIs: lwt_controller.ml Build$: flag(unix) Custom: true CompiledObject: native - Install$: flag(unix) + Install$: flag(unix) BuildDepends: openflow Executable ofswitch_lwt Path: switch - MainIs: basic_switch.ml + MainIs: lwt_switch.ml Build$: flag(unix) && flag(direct) Custom: true CompiledObject: native - Install$: flag(unix) && flag(direct) + Install$: flag(unix) && flag(direct) BuildDepends: openflow, openflow.switch diff --git a/_tags b/_tags index 7b86318..2917e9c 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: b9736de46cc3c7f8e4f2274631f835f5) +# DO NOT EDIT (digest: 40400a50bb46b869aaf10fff14592cbf) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -49,29 +49,29 @@ : pkg_ipaddr "lib/ofswitch_ctrl.native": custom # Executable ofcontroller_lwt -"controller/learning_switch.native": use_openflow -"controller/learning_switch.native": pkg_cstruct -"controller/learning_switch.native": pkg_cstruct.syntax -"controller/learning_switch.native": pkg_rpclib -"controller/learning_switch.native": pkg_rpclib.json -"controller/learning_switch.native": pkg_mirage -"controller/learning_switch.native": pkg_mirage-net -"controller/learning_switch.native": pkg_ipaddr -"controller/learning_switch.native": custom +"controller/lwt_controller.native": use_openflow +"controller/lwt_controller.native": pkg_cstruct +"controller/lwt_controller.native": pkg_cstruct.syntax +"controller/lwt_controller.native": pkg_rpclib +"controller/lwt_controller.native": pkg_rpclib.json +"controller/lwt_controller.native": pkg_mirage +"controller/lwt_controller.native": pkg_mirage-net +"controller/lwt_controller.native": pkg_ipaddr +"controller/lwt_controller.native": custom # Executable ofswitch_lwt -"switch/basic_switch.native": use_openflow -"switch/basic_switch.native": use_switch -"switch/basic_switch.native": pkg_re.str -"switch/basic_switch.native": pkg_cstruct -"switch/basic_switch.native": pkg_cstruct.syntax -"switch/basic_switch.native": pkg_rpclib -"switch/basic_switch.native": pkg_rpclib.json -"switch/basic_switch.native": pkg_mirage -"switch/basic_switch.native": pkg_mirage-net -"switch/basic_switch.native": pkg_ipaddr +"switch/lwt_switch.native": use_openflow +"switch/lwt_switch.native": use_switch +"switch/lwt_switch.native": pkg_re.str +"switch/lwt_switch.native": pkg_cstruct +"switch/lwt_switch.native": pkg_cstruct.syntax +"switch/lwt_switch.native": pkg_rpclib +"switch/lwt_switch.native": pkg_rpclib.json +"switch/lwt_switch.native": pkg_mirage +"switch/lwt_switch.native": pkg_mirage-net +"switch/lwt_switch.native": pkg_ipaddr : use_switch : pkg_re.str -"switch/basic_switch.native": custom +"switch/lwt_switch.native": custom # Executable ofcontroller.o "controller/learning_switch.nobj.o": use_openflow "controller/learning_switch.nobj.o": pkg_cstruct diff --git a/controller/learning_switch.ml b/controller/learning_switch.ml index 7d6e599..d7cf5da 100644 --- a/controller/learning_switch.ml +++ b/controller/learning_switch.ml @@ -16,7 +16,6 @@ (* Simple openflow controller that listens on port 6633 and replies with echo request on every packet_in event *) - open Lwt open Printf open Net @@ -31,18 +30,13 @@ module OE = Openflow.Ofcontroller.Event let pp = Printf.printf let sp = Printf.sprintf -(* TODO this the mapping is incorrect. the datapath must be moved to the key - * of the hashtbl *) type mac_switch = { addr: Macaddr.t; switch: OP.datapath_id; } type switch_state = { -(* mutable mac_cache: (mac_switch, OP.Port.t) Hashtbl.t; *) mutable mac_cache: (Macaddr.t, OP.Port.t) Hashtbl.t; -(* mutable dpid: OP.datapath_id list; - mutable of_ctrl: OC.t list; *) req_count: int ref; } @@ -78,7 +72,6 @@ let packet_in_cb controller dpid evt = (* check if I know the output port in order to define what type of message * we need to send *) - let broadcast = String.make 6 '\255' in let ix = m.OP.Match.dl_dst in if ( (ix = Macaddr.broadcast) || (not (Hashtbl.mem switch_data.mac_cache ix)) ) @@ -120,8 +113,6 @@ let packet_in_cb controller dpid evt = ) let init controller = -(* if (not (List.mem controller switch_data.of_ctrl)) then - switch_data.of_ctrl <- (([controller] @ switch_data.of_ctrl));*) pp "test controller register datapath cb\n"; OC.register_cb controller OE.DATAPATH_JOIN datapath_join_cb; pp "test controller register packet_in cb\n"; @@ -130,21 +121,12 @@ let init controller = let port = 6633 let run () = - let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap9" () in - let _ = Tuntap.set_ipv4 ~devname:("tap9") ~ipv4:"10.20.0.3" - ~netmask:"255.255.255.0" () in - let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in Net.Manager.create (fun mgr interface id -> try_lwt - let ip = -(* (ipv4_addr_of_tuple (10l,0l,0l,253l), *) - ( Ipaddr.V4.make 10l 20l 0l 4l, - Ipaddr.V4.make 255l 255l 255l 0l, - []) in + let ip = Ipaddr.V4.(make 10l 20l 0l 4l, Prefix.mask 24, []) in lwt _ = Manager.configure interface (`IPv4 ip) in OC.listen mgr ~verbose:true (None, port) init with | e -> return (Printf.eprintf "Unexpected exception : %s" (Printexc.to_string e)) ) -let _ = OS.Main.run (run ()) diff --git a/controller/lwt_controller.ml b/controller/lwt_controller.ml new file mode 100644 index 0000000..206fb5d --- /dev/null +++ b/controller/lwt_controller.ml @@ -0,0 +1,26 @@ +(* + * Copyright (c) 2012 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + + +let _ = OS.Main.run ( + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap9" () in + let _ = Tuntap.set_ipv4 ~devname:("tap9") ~ipv4:"10.20.0.3" + ~netmask:"255.255.255.0" () in + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in + Learning_switch.run () + +) + diff --git a/setup.ml b/setup.ml index adb9ee7..145aa40 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 52a3bd2a68b634cd2e887befec9ad7fc) *) +(* DO NOT EDIT (digest: de60f83809d6f973c9faa8ba0142e8d8) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6130,8 +6130,7 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - {exec_custom = true; exec_main_is = "learning_switch.ml"; - }); + {exec_custom = true; exec_main_is = "lwt_controller.ml"; }); Executable ({ cs_name = "ofswitch_lwt"; @@ -6170,7 +6169,7 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - {exec_custom = true; exec_main_is = "basic_switch.ml"; }); + {exec_custom = true; exec_main_is = "lwt_switch.ml"; }); Executable ({ cs_name = "ofcontroller.o"; @@ -6233,7 +6232,8 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "9m\028^\001\214\\l8\001\191B\202\221<8"; + oasis_digest = + Some "\233c\025\140\253\151\222\030\162\\\2329\"\016g\227"; oasis_exec = None; oasis_setup_args = []; setup_update = false; diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index 50501a2..81bc632 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -32,42 +32,20 @@ let sp = Printf.sprintf (**************************************************************** * OpenFlow Switch configuration *****************************************************************) - -let print_time () = - while_lwt true do - OS.Time.sleep 10.0 >> - return (printf "%03.6f: process running..\n%!" (OS.Clock.time ())) - done - let switch_run () = let sw = create_switch 0x100L in let use_mac = ref true in - let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap0" () in -(* let _ = Tuntap.set_ipv4 ~devname:("tap0") ~ipv4:"10.20.0.1" - ~netmask:"255.255.255.0" () in *) - let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in - - let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap1" () in - let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in - try_lwt - Manager.create - (fun mgr interface id -> - match (OS.Netif.string_of_id (OS.Netif.id (Ethif.get_netif - (Manager.get_ethif interface)))) with - | "tap0" - | "0" -> - lwt _ = OS.Time.sleep 5.0 in - let _ = printf "connecting switch...\n%!" in - let ip = - ( Ipaddr.V4.make 10l 20l 0l 2l, - Ipaddr.V4.make 255l 255l 255l 0l, - []) in - lwt _ = Manager.configure interface (`IPv4 ip) in - let dst_ip = Ipaddr.V4.make 10l 20l 0l 4l in - lwt _ = standalone_connect sw mgr (dst_ip, 6633) in - let _ = printf "connect returned...\n%!" in - return () + Manager.create (fun mgr interface id -> + match (OS.Netif.string_of_id id) with + | "tap0" + | "0" -> + lwt _ = OS.Time.sleep 5.0 in + let _ = printf "connecting switch...\n%!" in + let ip = Ipaddr.V4.(make 10l 20l 0l 2l, Prefix.mask 24, []) in + lwt _ = Manager.configure interface (`IPv4 ip) in + let dst_ip = Ipaddr.V4.make 10l 20l 0l 4l in + standalone_connect sw mgr (dst_ip, 6633) | str_id -> let find dev = try @@ -87,4 +65,3 @@ let switch_run () = Printf.eprintf "Error: %s" (Printexc.to_string e); return () -let _ = OS.Main.run(switch_run ()) diff --git a/switch/lwt_switch.ml b/switch/lwt_switch.ml new file mode 100644 index 0000000..9962cfc --- /dev/null +++ b/switch/lwt_switch.ml @@ -0,0 +1,29 @@ +(* + * Copyright (c) 2012 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let _ = OS.Main.run( + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap0" () in +(* let _ = Tuntap.set_ipv4 ~devname:("tap0") ~ipv4:"10.20.0.1" + ~netmask:"255.255.255.0" () in *) + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in + + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap1" () in + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in + + let (fd, dev) = Tuntap.opentap ~persist:true ~devname:"tap2" () in + let _ = OS.Netif.add_vif (OS.Netif.id_of_string dev) OS.Netif.ETH fd in + Basic_switch.switch_run () + ) From de22594cb309e4f7c67f0095ca2db211d256c416 Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 26 Sep 2013 23:00:46 +0100 Subject: [PATCH 65/75] fixing xen examples --- Makefile | 18 +++++++++++ _oasis | 19 +++++------ _tags | 61 ++++++++++++++++++------------------ controller/xen_controller.ml | 17 ++++++++++ setup.ml | 33 +++++++++++-------- switch/xen_switch.ml | 17 ++++++++++ 6 files changed, 111 insertions(+), 54 deletions(-) create mode 100644 controller/xen_controller.ml create mode 100644 switch/xen_switch.ml diff --git a/Makefile b/Makefile index b3040cd..98ddd0d 100644 --- a/Makefile +++ b/Makefile @@ -7,6 +7,8 @@ J=4 UNIX ?= $(shell if ocamlfind query lwt.ssl >/dev/null 2>&1; then echo --enable-unix; fi) DIRECT ?= $(shell if [ $(MIRAGE_NET) = "direct" ]; then echo --enable-direct; fi) XEN ?= $(shell if [ $(MIRAGE_OS) = "xen" ]; then echo --enable-xen; fi) +caml_path ?= $(shell ocamlfind printconf path) + # MIRAGE = --enable-mirage -include Makefile.config @@ -29,6 +31,22 @@ setup: setup.data build: setup.data $(wildcard lib/*.ml) ocaml setup.ml -build -j $(J) $(OFLAGS) $(DR) +ifeq ($(MIRAGE_OS), xen) + ld -d -nostdlib -m elf_x86_64 -T $(caml_path)/mirage-xen/mirage-x86_64.lds \ + $(caml_path)/mirage-xen/x86_64.o _build/switch/xen_switch.nobj.o \ + $(caml_path)/mirage-xen/libocaml.a $(caml_path)/mirage-xen/libxen.a \ + $(caml_path)/mirage-xen/libxencaml.a $(caml_path)/mirage-xen/libdiet.a \ + $(caml_path)/mirage-xen/libm.a $(caml_path)/mirage-xen/longjmp.o \ + -o ofswitch.xen + + ld -d -nostdlib -m elf_x86_64 -T $(caml_path)/mirage-xen/mirage-x86_64.lds \ + $(caml_path)/mirage-xen/x86_64.o _build/controller/xen_controller.nobj.o \ + $(caml_path)/mirage-xen/libocaml.a $(caml_path)/mirage-xen/libxen.a \ + $(caml_path)/mirage-xen/libxencaml.a $(caml_path)/mirage-xen/libdiet.a \ + $(caml_path)/mirage-xen/libm.a $(caml_path)/mirage-xen/longjmp.o \ + -o ofcontroller.xen + +endif doc: setup.data setup.ml ocaml setup.ml -doc -j $(J) $(OFLAGS) diff --git a/_oasis b/_oasis index 24d0a84..52f4abb 100644 --- a/_oasis +++ b/_oasis @@ -80,21 +80,18 @@ Executable ofswitch_lwt Install$: flag(unix) && flag(direct) BuildDepends: openflow, openflow.switch - -Executable "ofcontroller.o" - Path: controller - MainIs: learning_switch.ml +Executable ofswitch + Path: switch + MainIs: xen_switch.ml Build$: flag(xen) - Custom: true CompiledObject: native_object Install: false - BuildDepends: openflow + BuildDepends: openflow, re.str -Executable "ofswitch.o" - Path: switch - MainIs: basic_switch.ml +Executable ofcontroller + Path: controller + MainIs: xen_controller.ml Build$: flag(xen) - Custom: true CompiledObject: native_object Install: false - BuildDepends: openflow + BuildDepends: openflow, re.str diff --git a/_tags b/_tags index 2917e9c..0952fe3 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 40400a50bb46b869aaf10fff14592cbf) +# DO NOT EDIT (digest: f62abd39414d901db360117bdb2f1f55) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -70,36 +70,19 @@ "switch/lwt_switch.native": pkg_mirage-net "switch/lwt_switch.native": pkg_ipaddr : use_switch -: pkg_re.str "switch/lwt_switch.native": custom -# Executable ofcontroller.o -"controller/learning_switch.nobj.o": use_openflow -"controller/learning_switch.nobj.o": pkg_cstruct -"controller/learning_switch.nobj.o": pkg_cstruct.syntax -"controller/learning_switch.nobj.o": pkg_rpclib -"controller/learning_switch.nobj.o": pkg_rpclib.json -"controller/learning_switch.nobj.o": pkg_mirage -"controller/learning_switch.nobj.o": pkg_mirage-net -"controller/learning_switch.nobj.o": pkg_ipaddr -: use_openflow -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_rpclib -: pkg_rpclib.json -: pkg_mirage -: pkg_mirage-net -: pkg_ipaddr -"controller/learning_switch.nobj.o": custom -# Executable ofswitch.o -"switch/basic_switch.nobj.o": use_openflow -"switch/basic_switch.nobj.o": pkg_cstruct -"switch/basic_switch.nobj.o": pkg_cstruct.syntax -"switch/basic_switch.nobj.o": pkg_rpclib -"switch/basic_switch.nobj.o": pkg_rpclib.json -"switch/basic_switch.nobj.o": pkg_mirage -"switch/basic_switch.nobj.o": pkg_mirage-net -"switch/basic_switch.nobj.o": pkg_ipaddr +# Executable ofswitch +"switch/xen_switch.nobj.o": use_openflow +"switch/xen_switch.nobj.o": pkg_re.str +"switch/xen_switch.nobj.o": pkg_cstruct +"switch/xen_switch.nobj.o": pkg_cstruct.syntax +"switch/xen_switch.nobj.o": pkg_rpclib +"switch/xen_switch.nobj.o": pkg_rpclib.json +"switch/xen_switch.nobj.o": pkg_mirage +"switch/xen_switch.nobj.o": pkg_mirage-net +"switch/xen_switch.nobj.o": pkg_ipaddr : use_openflow +: pkg_re.str : pkg_cstruct : pkg_cstruct.syntax : pkg_rpclib @@ -107,7 +90,25 @@ : pkg_mirage : pkg_mirage-net : pkg_ipaddr -"switch/basic_switch.nobj.o": custom +# Executable ofcontroller +"controller/xen_controller.nobj.o": use_openflow +"controller/xen_controller.nobj.o": pkg_re.str +"controller/xen_controller.nobj.o": pkg_cstruct +"controller/xen_controller.nobj.o": pkg_cstruct.syntax +"controller/xen_controller.nobj.o": pkg_rpclib +"controller/xen_controller.nobj.o": pkg_rpclib.json +"controller/xen_controller.nobj.o": pkg_mirage +"controller/xen_controller.nobj.o": pkg_mirage-net +"controller/xen_controller.nobj.o": pkg_ipaddr +: use_openflow +: pkg_re.str +: pkg_cstruct +: pkg_cstruct.syntax +: pkg_rpclib +: pkg_rpclib.json +: pkg_mirage +: pkg_mirage-net +: pkg_ipaddr # OASIS_STOP true: annot : syntax_camlp4o diff --git a/controller/xen_controller.ml b/controller/xen_controller.ml new file mode 100644 index 0000000..6289c68 --- /dev/null +++ b/controller/xen_controller.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2012 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let _ = OS.Main.run(Learning_switch.run ()) diff --git a/setup.ml b/setup.ml index 145aa40..dbbde9e 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: de60f83809d6f973c9faa8ba0142e8d8) *) +(* DO NOT EDIT (digest: c0dab1214371623d2ddc5e97e2123e2d) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6172,7 +6172,7 @@ let setup_t = {exec_custom = true; exec_main_is = "lwt_switch.ml"; }); Executable ({ - cs_name = "ofcontroller.o"; + cs_name = "ofswitch"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -6183,9 +6183,13 @@ let setup_t = (OASISExpr.EFlag "xen", true) ]; bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "controller"; + bs_path = "switch"; bs_compiled_object = Native_object; - bs_build_depends = [InternalLibrary "openflow"]; + bs_build_depends = + [ + InternalLibrary "openflow"; + FindlibPackage ("re.str", None) + ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6196,11 +6200,10 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - {exec_custom = true; exec_main_is = "learning_switch.ml"; - }); + {exec_custom = false; exec_main_is = "xen_switch.ml"; }); Executable ({ - cs_name = "ofswitch.o"; + cs_name = "ofcontroller"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -6211,9 +6214,13 @@ let setup_t = (OASISExpr.EFlag "xen", true) ]; bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "switch"; + bs_path = "controller"; bs_compiled_object = Native_object; - bs_build_depends = [InternalLibrary "openflow"]; + bs_build_depends = + [ + InternalLibrary "openflow"; + FindlibPackage ("re.str", None) + ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6224,7 +6231,8 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - {exec_custom = true; exec_main_is = "basic_switch.ml"; }) + {exec_custom = false; exec_main_is = "xen_controller.ml"; + }) ]; plugins = [(`Extra, "META", Some "0.2")]; schema_data = PropList.Data.create (); @@ -6232,8 +6240,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = - Some "\233c\025\140\253\151\222\030\162\\\2329\"\016g\227"; + oasis_digest = Some "P\029b\192\187x\196\020%]7]\145?b\146"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6241,6 +6248,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6245 "setup.ml" +# 6252 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/switch/xen_switch.ml b/switch/xen_switch.ml new file mode 100644 index 0000000..8d3e363 --- /dev/null +++ b/switch/xen_switch.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2012 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let _ = OS.Main.run(Basic_switch.switch_run ()) From 99cca0d39647e3cd1287af2bdac896f59ef31aa3 Mon Sep 17 00:00:00 2001 From: crotsos Date: Thu, 26 Sep 2013 23:06:20 +0100 Subject: [PATCH 66/75] removing old files --- Makefile.config | 1 - gen_xen.sh | 1 - learning_switch.cfg | 6 ------ mirage-controller.cfg | 9 --------- 4 files changed, 17 deletions(-) delete mode 100644 Makefile.config delete mode 100644 gen_xen.sh delete mode 100644 learning_switch.cfg delete mode 100644 mirage-controller.cfg diff --git a/Makefile.config b/Makefile.config deleted file mode 100644 index a4cb71f..0000000 --- a/Makefile.config +++ /dev/null @@ -1 +0,0 @@ -OFLAGS ?= -classic-display diff --git a/gen_xen.sh b/gen_xen.sh deleted file mode 100644 index 52b4be0..0000000 --- a/gen_xen.sh +++ /dev/null @@ -1 +0,0 @@ -mir-build -b xen-native -o ./_build/controller/learning_switch.xen ./_build/controller/learning_switch.nobj.o diff --git a/learning_switch.cfg b/learning_switch.cfg deleted file mode 100644 index 1ad3729..0000000 --- a/learning_switch.cfg +++ /dev/null @@ -1,6 +0,0 @@ -kernel = "_build/controller/learning_switch.xen" -name = "learning_switch" -vif = [ 'mac=00:16:3e:11:33:44, bridge=xenbr0' ] -memory = 1024 -on_crash = "preserve" -on_exit = "preserve" diff --git a/mirage-controller.cfg b/mirage-controller.cfg deleted file mode 100644 index fabe4a0..0000000 --- a/mirage-controller.cfg +++ /dev/null @@ -1,9 +0,0 @@ -kernel = "./_build/controller/learning_switch_mirage.xen" -name = "ofcontroller" -vif = [ -# 'mac=00:16:3e:e8:20:e6, bridge=br0' - 'bridge=test0' -] -memory = 512 -on_crash = "preserve" -on_exit = "preserve" From 8c10424b9c3d9dc1bc9e14d883202343081e262c Mon Sep 17 00:00:00 2001 From: crotsos Date: Fri, 27 Sep 2013 14:51:29 +0100 Subject: [PATCH 67/75] fixing port removal on unix-direct and fixing the build files --- Makefile | 6 +++--- _oasis | 23 +++++++++++----------- _tags | 12 ++++++------ lib/ofswitch.ml | 9 ++++----- lib/ofswitch_config.ml | 26 ++++++++++++++++++++----- lib/ofswitch_config.mli | 1 + lib/ofswitch_ctrl.ml | 3 +-- myocamlbuild.ml | 4 ++-- setup.ml | 42 ++++++++++++++++++++++------------------- 9 files changed, 73 insertions(+), 53 deletions(-) diff --git a/Makefile b/Makefile index 98ddd0d..bd55045 100644 --- a/Makefile +++ b/Makefile @@ -4,9 +4,9 @@ all: build NAME=openflow J=4 -UNIX ?= $(shell if ocamlfind query lwt.ssl >/dev/null 2>&1; then echo --enable-unix; fi) -DIRECT ?= $(shell if [ $(MIRAGE_NET) = "direct" ]; then echo --enable-direct; fi) -XEN ?= $(shell if [ $(MIRAGE_OS) = "xen" ]; then echo --enable-xen; fi) +UNIX ?= $(shell if ocamlfind query lwt.ssl >/dev/null 2>&1; then echo --enable-unix; else echo --disable-unix; fi) +DIRECT ?= $(shell if [ $(MIRAGE_NET) = "direct" ]; then echo --enable-direct; else echo --disable-direct; fi) +XEN ?= $(shell if [ $(MIRAGE_OS) = "xen" ]; then echo --enable-xen; else echo --disable-xen; fi) caml_path ?= $(shell ocamlfind printconf path) # MIRAGE = --enable-mirage diff --git a/_oasis b/_oasis index 52f4abb..b6e3624 100644 --- a/_oasis +++ b/_oasis @@ -35,31 +35,32 @@ Document openflow XOCamlbuildPath: lib XOCamlbuildModules: Ofpacket, Ofcontroller, Ofsocket -Library switch +Library flv Path: lib - Findlibname: switch + Findlibname: flv Findlibparent: openflow - Build$: flag(direct) CompiledObject: native - Modules: Ofswitch, Ofswitch_config, Ofswitch_standalone + Modules: Flowvisor, Lldp, Flowvisor_topology Pack: True - BuildDepends: re.str -Library flv +Library switch Path: lib - Findlibname: flv + Findlibname: switch Findlibparent: openflow + Build$: flag(direct) + Install$: flag(direct) CompiledObject: native - Modules: Flowvisor,Lldp, Flowvisor_topology + Modules: Ofswitch, Ofswitch_config, Ofswitch_standalone Pack: True + BuildDepends: re.str Executable "ocaml-ofctl" Path: lib MainIs: ofswitch_ctrl.ml Build$: flag(unix) + Install$: flag(unix) Custom: true CompiledObject: native - Install$: flag(unix) BuildDepends: openflow, re.str Executable ofcontroller_lwt @@ -74,10 +75,10 @@ Executable ofcontroller_lwt Executable ofswitch_lwt Path: switch MainIs: lwt_switch.ml - Build$: flag(unix) && flag(direct) Custom: true + Build$: (flag(unix) && flag(direct)) + Install$: (flag(unix) && flag(direct)) CompiledObject: native - Install$: flag(unix) && flag(direct) BuildDepends: openflow, openflow.switch Executable ofswitch diff --git a/_tags b/_tags index 0952fe3..09f1516 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: f62abd39414d901db360117bdb2f1f55) +# DO NOT EDIT (digest: c550df0ef3bf0ac4c5011828fc3ba577) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -18,16 +18,16 @@ "lib/ofpacket.cmx": for-pack(Openflow) "lib/ofcontroller.cmx": for-pack(Openflow) "lib/ofsocket.cmx": for-pack(Openflow) -# Library switch -"lib/switch.cmxs": use_switch -"lib/ofswitch.cmx": for-pack(Switch) -"lib/ofswitch_config.cmx": for-pack(Switch) -"lib/ofswitch_standalone.cmx": for-pack(Switch) # Library flv "lib/flv.cmxs": use_flv "lib/flowvisor.cmx": for-pack(Flv) "lib/lldp.cmx": for-pack(Flv) "lib/flowvisor_topology.cmx": for-pack(Flv) +# Library switch +"lib/switch.cmxs": use_switch +"lib/ofswitch.cmx": for-pack(Switch) +"lib/ofswitch_config.cmx": for-pack(Switch) +"lib/ofswitch_standalone.cmx": for-pack(Switch) # Executable ocaml-ofctl "lib/ofswitch_ctrl.native": use_openflow "lib/ofswitch_ctrl.native": pkg_re.str diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 3277170..60b2eec 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -51,7 +51,6 @@ let get_ethif mgr id = let lst = Net.Manager.get_intfs mgr in let (_, ethif) = List.find (fun (dev_id,_) -> id = dev_id) lst in ethif - module Entry = struct type table_counter = { @@ -996,25 +995,25 @@ let create_switch ?(verbose=false) dpid = let listen st mgr loc = Net.Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> (forward_thread st) <&> - (Ofswitch_config.listen_t mgr + (Ofswitch_config.listen_t mgr (add_port mgr st) (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) let connect st mgr loc = Net.Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> (forward_thread st) <&> - (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) + (Ofswitch_config.listen_t mgr (add_port mgr st) (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) let local_connect st mgr conn = let _ = st.Switch.controller <- (Some conn) in (control_channel_run st conn) <&> (forward_thread st) <&> - (Ofswitch_config.listen_t mgr (del_port mgr st) (get_flow_stats st) + (Ofswitch_config.listen_t mgr (add_port mgr st) (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) let standalone_connect st mgr loc = let of_ctrl = Ofswitch_standalone.init_controller () in - let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (del_port mgr st) + let _ = Lwt.ignore_result (Ofswitch_config.listen_t mgr (add_port mgr st) (del_port mgr st) (get_flow_stats st) (add_flow st) (del_flow st) 6634) in let _ = ignore_result (forward_thread st) in let _ = cp "[switch] Listening socket...\n%!" in diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 8eefaf8..15a5766 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -188,8 +188,12 @@ let hashtbl_to_flow_match t = ) map in of_match +let get_ethif mgr id = + let lst = Net.Manager.get_intfs mgr in + let (_, ethif) = List.find (fun (dev_id,_) -> id = dev_id) lst in + ethif -let listen_t mgr del_port get_stats add_flow del_flow port = +let listen_t mgr add_port del_port get_stats add_flow del_flow port = let manage (dip,dpt) t = try_lwt lwt req = Net.Channel.read_line t in @@ -201,12 +205,24 @@ let listen_t mgr del_port get_stats add_flow del_flow port = let req = Jsonrpc.call_of_string req in lwt success = match (req.Rpc.name, req.Rpc.params) with - | ("add-port", (Rpc.String (dev))::_) -> - (* let _ = Net.Manager.attach mgr dev in *) - return (Rpc.Enum [(Rpc.String "true")]) + | ("add-port", (Rpc.String (devname))::_) -> begin + try_lwt + let (fd, name) = Tuntap.opentap ~persist:true ~devname () in + let id = OS.Netif.id_of_string name in + OS.Netif.add_vif id OS.Netif.ETH fd; + lwt _ = Net.Manager.create (fun _ _ _ -> add_port id) in + return (Rpc.Enum [(Rpc.String "true")]) + with exn -> + cp (sp "[ofswitch-confid] add-port: %s\n%!" (Printexc.to_string exn)); + return (Rpc.Enum [(Rpc.String "false")]) + + end | ("del-port", (Rpc.String (dev))::_) -> + + let ethif = Net.Ethif.get_netif + (Net.Manager.get_ethif (get_ethif mgr (OS.Netif.id_of_string dev))) in + lwt _ = OS.Netif.destroy ethif in lwt _ = del_port dev in -(* lwt _ = Net.Manager.detach mgr dev in *) return (Rpc.Enum [(Rpc.String "true")]) | ("dump-flows", (Rpc.Dict t)::_) -> let of_match = hashtbl_to_flow_match t in diff --git a/lib/ofswitch_config.mli b/lib/ofswitch_config.mli index 3e5f7d1..733bed2 100644 --- a/lib/ofswitch_config.mli +++ b/lib/ofswitch_config.mli @@ -17,6 +17,7 @@ (** initalize a switch configration daemon *) val listen_t: Net.Manager.t -> + (Net.Manager.id -> unit Lwt.t) -> (string -> unit Lwt.t) -> (Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list) -> (Openflow.Ofpacket.Flow_mod.t -> unit Lwt.t) -> diff --git a/lib/ofswitch_ctrl.ml b/lib/ofswitch_ctrl.ml index 4affac8..1dd27ea 100644 --- a/lib/ofswitch_ctrl.ml +++ b/lib/ofswitch_ctrl.ml @@ -17,7 +17,6 @@ open Lwt open Printf -open Ofswitch_config open Lwt_unix let check_cmd_args cmd count = @@ -103,7 +102,7 @@ let send_cmd (input, output) = lwt _ = try_lwt - let dst = ADDR_INET( (Unix.inet_addr_of_string "127.0.0.1"), + let dst = ADDR_INET( (Unix.inet_addr_of_string "10.20.0.2"), 6634) in lwt _ = Lwt_io.with_connection dst (send_cmd) in return () diff --git a/myocamlbuild.ml b/myocamlbuild.ml index b7598f9..93da712 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: b2a966b3ccd88941fecd0a8f887ad47f) *) +(* DO NOT EDIT (digest: e02ba6573f9818d0d9f18eb9a66eb191) *) module OASISGettext = struct (* # 21 "src/oasis/OASISGettext.ml" *) @@ -508,7 +508,7 @@ open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = - [("openflow", ["lib"]); ("switch", ["lib"]); ("flv", ["lib"])]; + [("openflow", ["lib"]); ("flv", ["lib"]); ("switch", ["lib"])]; lib_c = []; flags = []; includes = [("switch", ["lib"]); ("controller", ["lib"])]; diff --git a/setup.ml b/setup.ml index dbbde9e..b4c632e 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: c0dab1214371623d2ddc5e97e2123e2d) *) +(* DO NOT EDIT (digest: 8c9256a5b6430d87407b7ebd53b3cd01) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6000,20 +6000,16 @@ let setup_t = }); Library ({ - cs_name = "switch"; + cs_name = "flv"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "direct", true) - ]; + bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; bs_compiled_object = Native; - bs_build_depends = [FindlibPackage ("re.str", None)]; + bs_build_depends = []; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6026,26 +6022,33 @@ let setup_t = }, { lib_modules = - ["Ofswitch"; "Ofswitch_config"; "Ofswitch_standalone" - ]; + ["Flowvisor"; "Lldp"; "Flowvisor_topology"]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = Some "openflow"; - lib_findlib_name = Some "switch"; + lib_findlib_name = Some "flv"; lib_findlib_containers = []; }); Library ({ - cs_name = "flv"; + cs_name = "switch"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "direct", true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "direct", true) + ]; bs_path = "lib"; bs_compiled_object = Native; - bs_build_depends = []; + bs_build_depends = [FindlibPackage ("re.str", None)]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6058,11 +6061,12 @@ let setup_t = }, { lib_modules = - ["Flowvisor"; "Lldp"; "Flowvisor_topology"]; + ["Ofswitch"; "Ofswitch_config"; "Ofswitch_standalone" + ]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = Some "openflow"; - lib_findlib_name = Some "flv"; + lib_findlib_name = Some "switch"; lib_findlib_containers = []; }); Executable @@ -6240,7 +6244,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "P\029b\192\187x\196\020%]7]\145?b\146"; + oasis_digest = Some "wn\200}\027UB\167\240\185\197.x\247\165\242"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6248,6 +6252,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6252 "setup.ml" +# 6256 "setup.ml" (* OASIS_STOP *) let () = setup ();; From ed4976eaacc42155f5d260a7c9473b6c3a56df92 Mon Sep 17 00:00:00 2001 From: crotsos Date: Fri, 27 Sep 2013 14:56:36 +0100 Subject: [PATCH 68/75] merging --- _oasis | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/_oasis b/_oasis index b63b57b..4b657a0 100644 --- a/_oasis +++ b/_oasis @@ -26,7 +26,7 @@ Library openflow CompiledObject: native Modules: Ofpacket, Ofcontroller, Ofsocket Pack: True - BuildDepends: ipaddr, cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0), re.str, ocamlgraph + BuildDepends: ipaddr, cstruct, cstruct.syntax, rpclib, rpclib.json, mirage, mirage-net (>= 0.3.0) Document openflow Title: OpenFlow docs From c176ffd1cb521c8fcda125abdf2248cb3bb17742 Mon Sep 17 00:00:00 2001 From: crotsos Date: Fri, 27 Sep 2013 15:39:33 +0100 Subject: [PATCH 69/75] partial update of readme and usage files --- README.md | 76 +++++++++++++++++++++++++++++++++++------------------- USAGE.md | 77 +++++++++++++++++++++++++++++++++++++------------------ _tags | 18 ++++++------- lib/META | 4 +-- setup.ml | 8 +++--- 5 files changed, 116 insertions(+), 67 deletions(-) diff --git a/README.md b/README.md index 2396251..4a8f352 100644 --- a/README.md +++ b/README.md @@ -13,17 +13,19 @@ switches in a network. Each OpenFlow switch has three parts: Following this standard model, the implementation comprises three parts: -+ `switch.ml`, containing a skeleton OpenFlow switch; -+ `controller.ml`, containing a skeleton OpenFlow controller; and -+ `ofpacket.ml`, containing `Bitstring` parsers/writers for the - OpenFlow protocol. +* `Openflow` library, contains a complete parsing library in pure Ocaml and a + minimal controller library using an event-driven model. +* `Openflow.switch` library, provides a skeleton OpenFlow switch supporting most + elementary switch functionality. +* `Openflow.flv` library, implements a basic FLowVisor reimplementation in + ocaml. __N.B.__ _There are two versions of the OpenFlow protocol: v1.0.0 (`0x01` on the wire) and v1.1.0 (`0x02` on the wire). The implementation supports wire protocol `0x01` as this is what is implemented in [Open vSwitch][ovs-1.2], used for debugging._ -ofpacket.ml +Openflow.Ofpacket ----------- The file begins with some utility functions, operators, types. The @@ -116,7 +118,16 @@ the request and response messages that transport them. [of-1.1]: http://www.openflow.org/documents/openflow-spec-v1.1.0.pdf [ovs-1.2]: http://openvswitch.org/releases/openvswitch-1.2.2.tar.gz -controller.ml +Openflow.Ofsocket +------------- + +A simple module to create an openflow channel abstraction over a serires of +different transport mechanisms. At the moment the library contains support of +Channel.t connections and Lwt_stream streams. The protocol ensures to read from +the socket full Openflow pdus and transform them to appropriate Ofpacket +structures. + +Openflow.Ofontroller ------------- Initially modelled after [NOX][], this is a skeleton controller @@ -131,43 +142,51 @@ corresponding to basic switch operation: + `PACKET_IN`, representing the forwarding of a packet to the controller, whether through an explicit action corresponding to a flow match, or simply as the default when flow match is found. - ++ `FLOW_REMOVED`, i.e., representing the switch notification regarding the + removal of a flow from the flow table. ++ `FLOW_STATS_REPLY`, i.e., represents the replies transmitted by the switch + after a flow_stats_req. ++ `AGGR_FLOW_STATS_REPLY`, i.e., representing the reply transmitted by the switch +to an aggr_flow_stats_req. ++ ` DESC_STATS_REPLY`, i.e., representing the reply of a switch to desc_stats + request. ++ `PORT_STATS_REPLY`, i.e., representing the replt of a switch to a port_stats + request providing port level counter and the state of the switch. ++ `TABLE_STATS_REPLY`, i.e., representing the reply of a switch to a + table_stats request. ++ `PORT_STATUS_REPLY`, i.e., representing the notification send by the switch + when the state of a port of the switch is changed. + The controller state is mutable and modelled as: + A list of callbacks per event, each taking the current state, the originating datapath, and the event; + Mappings from switch (`datapath_id`) to a Mirage communications channel (`Channel.t`); and -+ Mappings from channel (`endhost` comprising an IPv4 address and - port) tp datapath (`datapath_id`). The main work of the controller is carried out in `process_of_packet` which processes each received packet within the context given by the current state of the switch: this is where the OpenFlow state machine is implemented. -The controller entry point is via the `listen` function which -effectively creates a receiving channel to parse OpenFlow packets, and -pass them to `process_of_packet` which handles a range of standard -protocol-level interactions, e.g., `ECHO_REQ`, `FEATURES_RESP`, -generating Mirage events as appropriate. Specifically, `controller` -is passed as callback to `Channel.listen`, and recursively evaluates -`echo` to read the incoming packet and pass it to -`process_of_packet`. +The controller entry point is via the `listen`, `local_connect` or `connect` +function which effectively creates a receiving channel to parse OpenFlow +packets, and pass them to `process_of_packet` which handles a range of standard +protocol-level interactions, e.g., `ECHO_REQ`, `FEATURES_RESP`, generating +Mirage events as appropriate. Specifically, `controller` is passed as callback +to the respective connection method, and recursively evaluates `read_packet` to +read the incoming packet and pass it to `process_of_packet`. [nox]: http://noxrepo.org/ -switch.ml +Openflow.Switch.Ofswitch --------- -__N.B.__ _This is unwritten as yet, awaiting the new device model being -applied to the network stack._ - -An OpenFlow _switch_ or _datapath_ consists of one or more _flow tables_, a -_group table_ (in later versions, not supported in v1.0.0), and a _secure -channel_ back to the controller. Communication over the channel is via the -OpenFlow protocol, and is how the controller manages the switch. +An OpenFlow _switch_ or _datapath_ consists of a _flow table_, a _group table_ +(in later versions, not supported in v1.0.0), and a _channel_ back to the +controller. Communication over the channel is via the OpenFlow protocol, and is +how the controller manages the switch. In short, each table contains flow entries consisting of _match fields_, _counters_, and _instructions_ to apply to packets. Starting with the first @@ -176,13 +195,14 @@ and the instructions carried out. If no entry in the first table matches, (part of) the packet is forwarded to the controller, or it is dropped, or it proceeds to the next flow table. +At the current point the switch doesn't support any queue principles. + Skeleton code is as follows: ### Entry Represents a single flow table entry. Each entry consists of: -+ _fields_, against which to match (`Ofpacket.Match.t list`);; + _counters_, to keep statistics per-table, -flow, -port, -queue (`Entry.table_counter list`, `Entry.flow_counter list`, `Entry.port_counter list`, `Entry.queue_counter list`); and @@ -191,7 +211,9 @@ Represents a single flow table entry. Each entry consists of: ### Table A simple module representing a table of flow entries. Currently just an id -(`tid`) and a list of entries (`Entry.t list`). +(`tid`) , a hashtbl of entries (`(OP.Match.t, Entry.t) Hashtbl.t`), a list of +exact match entries to reduce the lookup time for wildcard entries and a the +table counter. ### Switch diff --git a/USAGE.md b/USAGE.md index 9d76c36..f293d82 100644 --- a/USAGE.md +++ b/USAGE.md @@ -1,25 +1,40 @@ API === -The source code contains 3 main modules: ofpacket, ofswitch and ofcontroller. +The source code contains 3 main libraries: Openflow, Openflow.Switch and +Openflow.Flv. -The ofpacket module contains all the code to parse, print and generate openflow messages. -The parsing uses cstruct.t objects. +The Openflow module contains all the code to parse, print and generate openflow +messages, as well as, a basic openflow control platform. The ofcontroller +implements an openflow controller library. The library is event driven. The +programmer can access any openflow message by registering event callback during +the init phase of the code for every connected switch. The parsing uses cstruct.t objects. -The ofcontroller implements an openflow controller library. The library is event driven. -The programmer can access any openflow message by registering event callback during -the init phase of the code for every connected switch. - -The ofswitch code implements an openflow switch. The module exposes a simple API through +The Openflow.Switch module implements an openflow switch. The module exposes a simple API through which a user can add and remove ports to the controller and run the default openflow -processing switch functionality. +processing switch functionality. In addition, the module contains an +out-of-channel mechanism to modify the state of the switch using a json-rpc +mechanism and insert, delete and view flow entries or enable or disable network +ports. Finally, the switch provides a standalone mode, when the controller +becomes unavailable, using a local learning switch logic, implemented in module +Openflow.Switch.Ofswitch_standalone. Standalone functionality can be initiated +through the Ofswitch.standalone_connect method. Additionally the library contains a small number of helper functions that enhance the functionality of openflow application. Ofswitch_config is a daemon that exposes a json API through which other apps can have configure the ports of the switch and access the content of the datapath table, using a simple tcp socket. Ofswitch_standalone is a minimum learning switch implementation over openflow that can be enabled on the switch module when -no controller is accessible. +no controller is accessible. + +The Openflow.Flv library reimplements the functionality provided by the flowvisor +switch virtualisation software. FLowvisor is able to aggregate multiple switches +and expose them to controller as a single switch, aggregating all the ports of +the switches. The module provides elementary slicing +functionality using wildcards. Additionally, the module implements a simple +switch topology discovery mechanism using the lldp protocol. The functionality +of this module is currently experimental and the library is not fully +functional (e.g. OP.Port.Flood output actions are not supported by the module ). Programs ======= @@ -27,30 +42,42 @@ Programs The source code of the library contains a number of small appliances that provide simple examples over the functionality of the library. -basic_switch_lwt +lwt_switch ================ This is a unix backend implementation of an openflow switch. The application exposes both the json config web service and uses the standalone embedded controller. The application tries to connect to locahost in order to connect to controller and also run the json-based -configuration daemon on port 6634. +configuration daemon on port 6634. + +lwt_controller +========== -ovs-vsctl -========= +An openflow controller that implements a simple openflow-based learning switch. +The program listens on port 6633. -This is a simple implementation of a configuration client for the switch code. The application -has a lot of similarities with the syntax of the ovs-vsctl code. Uses can access and modify the -state of the switch with the following command line parameters: +ofswitch_ctrl +============ -* dump-flows intf tupple: this command will match all flows on the forwardign table of the switch -and return a dump of the matching flows to the provided tupple. -* del-flows intf tupple: delete matching flows. -* add-flows intf tupple: adding a tupple to the flow table. -* add-port intf network_device : adding a port under the control of the openflow switch. +This is a simple implementation of a configuration client for the switch code. +The application has a lot of similarities with the syntax of the ovs-vsctl code. +Users can access and modify the state of the switch with the following command +line parameters: + +* dump-flows intf tupple: this command will match all flows on the forwardign + table of the switch and return a dump of the matching flows to the + provided tupple. +* del-flows intf tupple: delete matching flows. +* add-flows intf tupple: adding a tupple to the flow table. +* add-port intf network_device : adding a port under the control of the openflow switch. * del-port intf network_device : remove a port from the control of the switch. -learning_switch +ofswitch.xen =============== -An openflow controller that implements a simple openflow-based learning switch. The program listens -on port 6633. +A unikernel appliance of the lwt_switch for the xen backend. + +ofcontroller.xen +============== + +A unikernel application of the lwt_controller for the xen backend. diff --git a/_tags b/_tags index 09f1516..a7f47f1 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: c550df0ef3bf0ac4c5011828fc3ba577) +# DO NOT EDIT (digest: d7120abbd08dc6103d705bb20d52346b) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -31,84 +31,84 @@ # Executable ocaml-ofctl "lib/ofswitch_ctrl.native": use_openflow "lib/ofswitch_ctrl.native": pkg_re.str +"lib/ofswitch_ctrl.native": pkg_ipaddr "lib/ofswitch_ctrl.native": pkg_cstruct "lib/ofswitch_ctrl.native": pkg_cstruct.syntax "lib/ofswitch_ctrl.native": pkg_rpclib "lib/ofswitch_ctrl.native": pkg_rpclib.json "lib/ofswitch_ctrl.native": pkg_mirage "lib/ofswitch_ctrl.native": pkg_mirage-net -"lib/ofswitch_ctrl.native": pkg_ipaddr : use_openflow : pkg_re.str +: pkg_ipaddr : pkg_cstruct : pkg_cstruct.syntax : pkg_rpclib : pkg_rpclib.json : pkg_mirage : pkg_mirage-net -: pkg_ipaddr "lib/ofswitch_ctrl.native": custom # Executable ofcontroller_lwt "controller/lwt_controller.native": use_openflow +"controller/lwt_controller.native": pkg_ipaddr "controller/lwt_controller.native": pkg_cstruct "controller/lwt_controller.native": pkg_cstruct.syntax "controller/lwt_controller.native": pkg_rpclib "controller/lwt_controller.native": pkg_rpclib.json "controller/lwt_controller.native": pkg_mirage "controller/lwt_controller.native": pkg_mirage-net -"controller/lwt_controller.native": pkg_ipaddr "controller/lwt_controller.native": custom # Executable ofswitch_lwt "switch/lwt_switch.native": use_openflow "switch/lwt_switch.native": use_switch "switch/lwt_switch.native": pkg_re.str +"switch/lwt_switch.native": pkg_ipaddr "switch/lwt_switch.native": pkg_cstruct "switch/lwt_switch.native": pkg_cstruct.syntax "switch/lwt_switch.native": pkg_rpclib "switch/lwt_switch.native": pkg_rpclib.json "switch/lwt_switch.native": pkg_mirage "switch/lwt_switch.native": pkg_mirage-net -"switch/lwt_switch.native": pkg_ipaddr : use_switch "switch/lwt_switch.native": custom # Executable ofswitch "switch/xen_switch.nobj.o": use_openflow "switch/xen_switch.nobj.o": pkg_re.str +"switch/xen_switch.nobj.o": pkg_ipaddr "switch/xen_switch.nobj.o": pkg_cstruct "switch/xen_switch.nobj.o": pkg_cstruct.syntax "switch/xen_switch.nobj.o": pkg_rpclib "switch/xen_switch.nobj.o": pkg_rpclib.json "switch/xen_switch.nobj.o": pkg_mirage "switch/xen_switch.nobj.o": pkg_mirage-net -"switch/xen_switch.nobj.o": pkg_ipaddr : use_openflow : pkg_re.str +: pkg_ipaddr : pkg_cstruct : pkg_cstruct.syntax : pkg_rpclib : pkg_rpclib.json : pkg_mirage : pkg_mirage-net -: pkg_ipaddr # Executable ofcontroller "controller/xen_controller.nobj.o": use_openflow "controller/xen_controller.nobj.o": pkg_re.str +"controller/xen_controller.nobj.o": pkg_ipaddr "controller/xen_controller.nobj.o": pkg_cstruct "controller/xen_controller.nobj.o": pkg_cstruct.syntax "controller/xen_controller.nobj.o": pkg_rpclib "controller/xen_controller.nobj.o": pkg_rpclib.json "controller/xen_controller.nobj.o": pkg_mirage "controller/xen_controller.nobj.o": pkg_mirage-net -"controller/xen_controller.nobj.o": pkg_ipaddr : use_openflow : pkg_re.str +: pkg_ipaddr : pkg_cstruct : pkg_cstruct.syntax : pkg_rpclib : pkg_rpclib.json : pkg_mirage : pkg_mirage-net -: pkg_ipaddr # OASIS_STOP true: annot : syntax_camlp4o diff --git a/lib/META b/lib/META index 8e41e3f..92d3787 100644 --- a/lib/META +++ b/lib/META @@ -1,10 +1,10 @@ # OASIS_START -# DO NOT EDIT (digest: fb3a7474b6d3d22fd415ea0a71caf87e) +# DO NOT EDIT (digest: b3b71f3631fe233e81415c476c4af9f7) version = "0.3.0" description = "OpenFlow controller, switch and flowvisor implementation in pure OCaml" requires = -"cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net ipaddr" +"ipaddr cstruct cstruct.syntax rpclib rpclib.json mirage mirage-net" archive(byte) = "openflow.cma" archive(byte, plugin) = "openflow.cma" archive(native) = "openflow.cmxa" diff --git a/setup.ml b/setup.ml index b4c632e..1fdb1a7 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 8c9256a5b6430d87407b7ebd53b3cd01) *) +(* DO NOT EDIT (digest: 48cdf0032977354e953b0f81f05e39fb) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5942,6 +5942,7 @@ let setup_t = bs_compiled_object = Native; bs_build_depends = [ + FindlibPackage ("ipaddr", None); FindlibPackage ("cstruct", None); FindlibPackage ("cstruct.syntax", None); FindlibPackage ("rpclib", None); @@ -5949,8 +5950,7 @@ let setup_t = FindlibPackage ("mirage", None); FindlibPackage ("mirage-net", - Some (OASISVersion.VGreaterEqual "0.3.0")); - FindlibPackage ("ipaddr", None) + Some (OASISVersion.VGreaterEqual "0.3.0")) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -6244,7 +6244,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "wn\200}\027UB\167\240\185\197.x\247\165\242"; + oasis_digest = Some "c\244%\210\159\232;\149\225\210>\030\163\170c\245"; oasis_exec = None; oasis_setup_args = []; setup_update = false; From cf1154d1da612c7fa1091e07027dd7bb6e0dde6c Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 7 Oct 2013 19:36:34 +0100 Subject: [PATCH 70/75] commiting some performance improvement for the ofswitch --- _oasis | 11 +---- _tags | 31 +++++------- lib/META | 4 +- lib/ofswitch.ml | 98 +++++++++++++++++++++++++++++--------- lib/ofswitch_config.ml | 6 +-- lib/ofswitch_standalone.ml | 2 +- setup.ml | 48 ++++--------------- switch/basic_switch.ml | 22 +++++---- 8 files changed, 115 insertions(+), 107 deletions(-) diff --git a/_oasis b/_oasis index 4b657a0..8617385 100644 --- a/_oasis +++ b/_oasis @@ -52,16 +52,7 @@ Library switch CompiledObject: native Modules: Ofswitch, Ofswitch_config, Ofswitch_standalone Pack: True - BuildDepends: re.str - -Executable "ocaml-ofctl" - Path: lib - MainIs: ofswitch_ctrl.ml - Build$: flag(unix) - Install$: flag(unix) - Custom: true - CompiledObject: native - BuildDepends: openflow, re.str + BuildDepends: re.str, tuntap Executable ofcontroller_lwt Path: controller diff --git a/_tags b/_tags index a7f47f1..6f4d654 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: d7120abbd08dc6103d705bb20d52346b) +# DO NOT EDIT (digest: 7c9c51d36fdd7fa35499b1c9d975c796) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -18,6 +18,13 @@ "lib/ofpacket.cmx": for-pack(Openflow) "lib/ofcontroller.cmx": for-pack(Openflow) "lib/ofsocket.cmx": for-pack(Openflow) +: pkg_ipaddr +: pkg_cstruct +: pkg_cstruct.syntax +: pkg_rpclib +: pkg_rpclib.json +: pkg_mirage +: pkg_mirage-net # Library flv "lib/flv.cmxs": use_flv "lib/flowvisor.cmx": for-pack(Flv) @@ -28,26 +35,8 @@ "lib/ofswitch.cmx": for-pack(Switch) "lib/ofswitch_config.cmx": for-pack(Switch) "lib/ofswitch_standalone.cmx": for-pack(Switch) -# Executable ocaml-ofctl -"lib/ofswitch_ctrl.native": use_openflow -"lib/ofswitch_ctrl.native": pkg_re.str -"lib/ofswitch_ctrl.native": pkg_ipaddr -"lib/ofswitch_ctrl.native": pkg_cstruct -"lib/ofswitch_ctrl.native": pkg_cstruct.syntax -"lib/ofswitch_ctrl.native": pkg_rpclib -"lib/ofswitch_ctrl.native": pkg_rpclib.json -"lib/ofswitch_ctrl.native": pkg_mirage -"lib/ofswitch_ctrl.native": pkg_mirage-net -: use_openflow : pkg_re.str -: pkg_ipaddr -: pkg_cstruct -: pkg_cstruct.syntax -: pkg_rpclib -: pkg_rpclib.json -: pkg_mirage -: pkg_mirage-net -"lib/ofswitch_ctrl.native": custom +: pkg_tuntap # Executable ofcontroller_lwt "controller/lwt_controller.native": use_openflow "controller/lwt_controller.native": pkg_ipaddr @@ -62,6 +51,7 @@ "switch/lwt_switch.native": use_openflow "switch/lwt_switch.native": use_switch "switch/lwt_switch.native": pkg_re.str +"switch/lwt_switch.native": pkg_tuntap "switch/lwt_switch.native": pkg_ipaddr "switch/lwt_switch.native": pkg_cstruct "switch/lwt_switch.native": pkg_cstruct.syntax @@ -70,6 +60,7 @@ "switch/lwt_switch.native": pkg_mirage "switch/lwt_switch.native": pkg_mirage-net : use_switch +: pkg_tuntap "switch/lwt_switch.native": custom # Executable ofswitch "switch/xen_switch.nobj.o": use_openflow diff --git a/lib/META b/lib/META index 92d3787..1364637 100644 --- a/lib/META +++ b/lib/META @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: b3b71f3631fe233e81415c476c4af9f7) +# DO NOT EDIT (digest: b787620bd33d2bdf1fe0565f29356a9c) version = "0.3.0" description = "OpenFlow controller, switch and flowvisor implementation in pure OCaml" @@ -14,7 +14,7 @@ package "switch" ( version = "0.3.0" description = "OpenFlow controller, switch and flowvisor implementation in pure OCaml" - requires = "re.str" + requires = "re.str tuntap" archive(byte) = "switch.cma" archive(byte, plugin) = "switch.cma" archive(native) = "switch.cmxa" diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index 60b2eec..a34c111 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -279,16 +279,24 @@ module Switch = struct mgr: Net.Manager.t; port_id: int; ethif: Net.Manager.id; + netif: OS.Netif.t; port_name: string; counter: OP.Port.stats; phy: OP.Port.phy; - queue: Cstruct.t Queue.t; + in_queue: Cstruct.t Lwt_stream.t; + in_push : (Cstruct.t option -> unit); + out_queue: Cstruct.t Lwt_stream.t; + out_push : (Cstruct.t option -> unit); + mutable pkt_count : int; } let init_port mgr port_no id = let ethif = Net.Manager.get_ethif ( get_ethif mgr id ) in + let netif = Net.Ethif.get_netif ethif in let name = OS.Netif.string_of_id (OS.Netif.id (Net.Ethif.get_netif ethif )) in let hw_addr = Net.Ethif.mac ethif in + let (in_queue, in_push) = Lwt_stream.create () in + let (out_queue, out_push) = Lwt_stream.create () in let counter = OP.Port.( { port_id=port_no; rx_packets=0L; tx_packets=0L; rx_bytes=0L; tx_bytes=0L; rx_dropped=0L; tx_dropped=0L; rx_errors=0L; @@ -313,7 +321,8 @@ module Switch = struct supported=features; peer=features;}) in {port_id=port_no; mgr; port_name=name; counter; - ethif=id;phy;queue=(Queue.create ());} + ethif=id;netif;phy;in_queue;in_push;pkt_count=0; + out_queue;out_push;} type stats = { mutable n_frags: uint64; @@ -436,7 +445,9 @@ module Switch = struct let send_packet port bits = update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; - Net.Manager.inject_packet port.mgr port.ethif bits + return (port.out_push (Some bits)) +(* OS.Netif.write port.netif bits *) +(* Net.Manager.inject_packet port.mgr port.ethif bits *) let forward_frame st in_port bits pkt_size checksum port = @@ -467,7 +478,8 @@ module Switch = struct | OP.Port.Port(port) -> if Hashtbl.mem st.int_to_port port then let out_p = (!( Hashtbl.find st.int_to_port port)) in - Net.Manager.inject_packet out_p.mgr out_p.ethif bits + send_packet out_p bits +(* Net.Manager.inject_packet out_p.mgr out_p.ethif bits *) else return (cp (sp "[switch] forward_frame: Port %d not registered\n%!" port)) | OP.Port.No_port -> return () @@ -657,33 +669,73 @@ let process_frame_inner st p frame = return (cp (sp "[switch] process_frame_inner: control channel error: %s\n" (Printexc.to_string exn))) -let forward_thread st = - while_lwt true do - lwt _ = Lwt_condition.wait st.Switch.ready in +let check_packets st = + match_lwt (Lwt_list.exists_p (fun p -> return (p.Switch.pkt_count > 0)) + st.Switch.ports) with + | false -> OS.Time.sleep 0.5 + | true -> return () + +let forward_thread st = +(* while_lwt true do + lwt _ = check_packets st Lwt_condition.wait st.Switch.ready in Lwt_list.iter_s (fun p -> - if (Queue.is_empty p.Switch.queue) then +(* lwt empty = Lwt_stream.is_empty p.Switch.queue in *) + if (p.Switch.pkt_count = 0) then +(* let _ = cp (sp "port %d no packets\n" p.Switch.port_id) in *) + return () + else + lwt frames = Lwt_stream.nget p.Switch.pkt_count p.Switch.queue in + lwt _ = + Lwt_list.iter_p + (fun f -> + p.Switch.pkt_count <- p.Switch.pkt_count - 1; process_frame_inner st p f) + frames in +(* let _ = cp (sp "port %d got packet\n" p.Switch.port_id) in *) +(* let _ = cp (sp "port %d processed packet\n" p.Switch.port_id) in *) return () - else - process_frame_inner st p (Queue.take p.Switch.queue) ) st.Switch.ports - done + done *) + Lwt_list.iter_p (fun p -> + while_lwt true do +(* if (p.Switch.pkt_count > 0) then + lwt frames = Lwt_stream.nget 10 p.Switch.queue in + Lwt_list.iter_p ( + fun f -> p.Switch.pkt_count <- p.Switch.pkt_count - 1; + process_frame_inner st p f) frames + else *) + lwt _ = Lwt_stream.next p.Switch.in_queue >>= process_frame_inner st p in +(* let _ = + if (p.Switch.pkt_count mod 20 = 1) then + cp (sp "port %d got packet %d" p.Switch.port_id p.Switch.pkt_count) in + * *) + return (p.Switch.pkt_count <- p.Switch.pkt_count - 1) + done <&> ( + while_lwt true do + lwt frame = Lwt_stream.next p.Switch.out_queue in +(* lwt _ = OS.Time.sleep 0.0 in *) +(* let frames = Lwt_stream.get_available p.Switch.out_queue in*) +(* let _ = Printf.printf "got %d packets\n%!" (1+(List.length frames)) in + * *) + OS.Netif.writev p.Switch.netif [frame] (*frame::frames*) + done + ) + ) st.Switch.ports let process_frame st p _ frame = let _ = try match frame with | Net.Ethif.Output _ -> () - | Net.Ethif.Input frame -> - Queue.push frame p.Switch.queue; - Lwt_condition.broadcast st.Switch.ready () -(* if (st.Switch.queue_len < 256) then ( - st.Switch.queue_len <- st.Switch.queue_len + 1; - - return(st.Switch.push_packet (Some(frame, ((!p).Switch.port_id) ))) - ) else ( - pr "dropping packet at the switch\n%!"; - return () - ) *) + | Net.Ethif.Input frame -> +(* let _ = Lwt_condition.broadcast st.Switch.ready () in *) +(* if (p.Switch.pkt_count < 1000) then *) + let _ = p.Switch.pkt_count <- p.Switch.pkt_count + 1 in +(* let _ = Printf.printf "pushing packet to port %d %d\n%!" + p.Switch.port_id p.Switch.pkt_count in *) + p.Switch.in_push (Some frame) +(* Printf.printf "pushed packet to port %d\n%!" p.Switch.port_id*) +(* else + cp "[process_frame] blocked queue" *) with | Not_found -> cp (sp "[switch] process_frame: Invalid port\n%!") | Packet_type_unknw -> cp (sp "[switch] process_frame: malformed packet\n%!") @@ -898,7 +950,7 @@ let control_channel_run st conn = in let _ = OSK.close conn in let _ = st.Switch.controller <- None in - return (cp "[switch] control channel thread returned\n%!") + return (cp "[switch] control channel thread returned") let control_channel st (addr, port) t = cp (sp "[switch] controller %s:%d" (Ipaddr.V4.to_string addr) port); diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 15a5766..27abbbb 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -207,10 +207,10 @@ let listen_t mgr add_port del_port get_stats add_flow del_flow port = match (req.Rpc.name, req.Rpc.params) with | ("add-port", (Rpc.String (devname))::_) -> begin try_lwt - let (fd, name) = Tuntap.opentap ~persist:true ~devname () in +(* let (fd, name) = Tuntap.opentap ~persist:true ~devname () in let id = OS.Netif.id_of_string name in OS.Netif.add_vif id OS.Netif.ETH fd; - lwt _ = Net.Manager.create (fun _ _ _ -> add_port id) in + lwt _ = Net.Manager.create (fun _ _ _ -> add_port id) in *) return (Rpc.Enum [(Rpc.String "true")]) with exn -> cp (sp "[ofswitch-confid] add-port: %s\n%!" (Printexc.to_string exn)); @@ -221,7 +221,7 @@ let listen_t mgr add_port del_port get_stats add_flow del_flow port = let ethif = Net.Ethif.get_netif (Net.Manager.get_ethif (get_ethif mgr (OS.Netif.id_of_string dev))) in - lwt _ = OS.Netif.destroy ethif in +(* lwt _ = OS.Netif.destroy ethif in *) lwt _ = del_port dev in return (Rpc.Enum [(Rpc.String "true")]) | ("dump-flows", (Rpc.Dict t)::_) -> diff --git a/lib/ofswitch_standalone.ml b/lib/ofswitch_standalone.ml index acb0479..a914ce8 100644 --- a/lib/ofswitch_standalone.ml +++ b/lib/ofswitch_standalone.ml @@ -152,7 +152,7 @@ let run_controller mgr st = try_lwt OC.local_connect st controller with exn -> - return (printf "[switch] standalone controller dailed %s\n%!" (Printexc.to_string + return (printf "[switch] standalone controllern failed %s\n%!" (Printexc.to_string exn)) ) in return switch diff --git a/setup.ml b/setup.ml index 1fdb1a7..3ee29e0 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 48cdf0032977354e953b0f81f05e39fb) *) +(* DO NOT EDIT (digest: 350be2246dd7ef95a98786cdb09fc99d) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6048,7 +6048,11 @@ let setup_t = ]; bs_path = "lib"; bs_compiled_object = Native; - bs_build_depends = [FindlibPackage ("re.str", None)]; + bs_build_depends = + [ + FindlibPackage ("re.str", None); + FindlibPackage ("tuntap", None) + ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6069,41 +6073,6 @@ let setup_t = lib_findlib_name = Some "switch"; lib_findlib_containers = []; }); - Executable - ({ - cs_name = "ocaml-ofctl"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "unix", true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "unix", true) - ]; - bs_path = "lib"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "openflow"; - FindlibPackage ("re.str", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = true; exec_main_is = "ofswitch_ctrl.ml"; }); Executable ({ cs_name = "ofcontroller_lwt"; @@ -6244,7 +6213,8 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "c\244%\210\159\232;\149\225\210>\030\163\170c\245"; + oasis_digest = + Some "Q\188\147\181)\165\131\189\251\236\178\161\182\233+\023"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6252,6 +6222,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6256 "setup.ml" +# 6226 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index 81bc632..e584d09 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -35,19 +35,23 @@ let sp = Printf.sprintf let switch_run () = let sw = create_switch 0x100L in let use_mac = ref true in - try_lwt - Manager.create (fun mgr interface id -> + try_lwt + let devs = OS.Netif.create () in + lwt _ = + Lwt_list.iter_s ( + ) devs in +(* Manager.create (fun mgr interface id -> match (OS.Netif.string_of_id id) with | "tap0" | "0" -> lwt _ = OS.Time.sleep 5.0 in let _ = printf "connecting switch...\n%!" in - let ip = Ipaddr.V4.(make 10l 20l 0l 2l, Prefix.mask 24, []) in + let ip = Ipaddr.V4.(make 10l 20l 0l 100l, Prefix.mask 24, []) in lwt _ = Manager.configure interface (`IPv4 ip) in - let dst_ip = Ipaddr.V4.make 10l 20l 0l 4l in + let dst_ip = Ipaddr.V4.make 10l 20l 0l 1l in standalone_connect sw mgr (dst_ip, 6633) | str_id -> - let find dev = +(* let find dev = try let _ = Re_str.search_forward (Re_str.regexp "tap") dev 0 in true with Not_found -> false @@ -56,11 +60,11 @@ let switch_run () = if (not (find str_id) ) then lwt _ = add_port mgr ~use_mac:(!use_mac) sw id in return (use_mac := false) - else + else *) add_port mgr ~use_mac:false sw id - in - return () - ) +(* in + return () *) + ) *) with e -> Printf.eprintf "Error: %s" (Printexc.to_string e); return () From b6d34cc22bd5a24381615ebe8ee1ad6a70346a47 Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 11 Nov 2013 00:01:52 +0000 Subject: [PATCH 71/75] fixing a bit the interface --- Makefile | 2 +- _oasis | 2 +- _tags | 5 ++++- lib/META | 4 ++-- lib/ofswitch_config.ml | 4 ++-- setup.ml | 12 ++++++++---- 6 files changed, 18 insertions(+), 11 deletions(-) diff --git a/Makefile b/Makefile index bd55045..2dde307 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ all: build NAME=openflow J=4 -UNIX ?= $(shell if ocamlfind query lwt.ssl >/dev/null 2>&1; then echo --enable-unix; else echo --disable-unix; fi) +UNIX ?= $(shell if [ $(MIRAGE_OS) = "unix" ]; then echo --enable-unix; else echo --disable-unix; fi) DIRECT ?= $(shell if [ $(MIRAGE_NET) = "direct" ]; then echo --enable-direct; else echo --disable-direct; fi) XEN ?= $(shell if [ $(MIRAGE_OS) = "xen" ]; then echo --enable-xen; else echo --disable-xen; fi) caml_path ?= $(shell ocamlfind printconf path) diff --git a/_oasis b/_oasis index 4b657a0..2a507f2 100644 --- a/_oasis +++ b/_oasis @@ -52,7 +52,7 @@ Library switch CompiledObject: native Modules: Ofswitch, Ofswitch_config, Ofswitch_standalone Pack: True - BuildDepends: re.str + BuildDepends: re.str,tuntap Executable "ocaml-ofctl" Path: lib diff --git a/_tags b/_tags index a7f47f1..cc4706a 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: d7120abbd08dc6103d705bb20d52346b) +# DO NOT EDIT (digest: 2d568b09f1aa4bebf0b9ee452cde0d8d) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -28,6 +28,7 @@ "lib/ofswitch.cmx": for-pack(Switch) "lib/ofswitch_config.cmx": for-pack(Switch) "lib/ofswitch_standalone.cmx": for-pack(Switch) +: pkg_tuntap # Executable ocaml-ofctl "lib/ofswitch_ctrl.native": use_openflow "lib/ofswitch_ctrl.native": pkg_re.str @@ -62,6 +63,7 @@ "switch/lwt_switch.native": use_openflow "switch/lwt_switch.native": use_switch "switch/lwt_switch.native": pkg_re.str +"switch/lwt_switch.native": pkg_tuntap "switch/lwt_switch.native": pkg_ipaddr "switch/lwt_switch.native": pkg_cstruct "switch/lwt_switch.native": pkg_cstruct.syntax @@ -70,6 +72,7 @@ "switch/lwt_switch.native": pkg_mirage "switch/lwt_switch.native": pkg_mirage-net : use_switch +: pkg_tuntap "switch/lwt_switch.native": custom # Executable ofswitch "switch/xen_switch.nobj.o": use_openflow diff --git a/lib/META b/lib/META index 92d3787..1364637 100644 --- a/lib/META +++ b/lib/META @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: b3b71f3631fe233e81415c476c4af9f7) +# DO NOT EDIT (digest: b787620bd33d2bdf1fe0565f29356a9c) version = "0.3.0" description = "OpenFlow controller, switch and flowvisor implementation in pure OCaml" @@ -14,7 +14,7 @@ package "switch" ( version = "0.3.0" description = "OpenFlow controller, switch and flowvisor implementation in pure OCaml" - requires = "re.str" + requires = "re.str tuntap" archive(byte) = "switch.cma" archive(byte, plugin) = "switch.cma" archive(native) = "switch.cmxa" diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 15a5766..83c5d7f 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -209,7 +209,7 @@ let listen_t mgr add_port del_port get_stats add_flow del_flow port = try_lwt let (fd, name) = Tuntap.opentap ~persist:true ~devname () in let id = OS.Netif.id_of_string name in - OS.Netif.add_vif id OS.Netif.ETH fd; + (* OS.Netif.add_vif id OS.Netif.ETH fd; *) lwt _ = Net.Manager.create (fun _ _ _ -> add_port id) in return (Rpc.Enum [(Rpc.String "true")]) with exn -> @@ -221,7 +221,7 @@ let listen_t mgr add_port del_port get_stats add_flow del_flow port = let ethif = Net.Ethif.get_netif (Net.Manager.get_ethif (get_ethif mgr (OS.Netif.id_of_string dev))) in - lwt _ = OS.Netif.destroy ethif in + (* lwt _ = OS.Netif.destroy ethif in *) lwt _ = del_port dev in return (Rpc.Enum [(Rpc.String "true")]) | ("dump-flows", (Rpc.Dict t)::_) -> diff --git a/setup.ml b/setup.ml index 1fdb1a7..e1e856a 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 48cdf0032977354e953b0f81f05e39fb) *) +(* DO NOT EDIT (digest: c8f673a6024bd72fae5b9eb7d3bee808) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6048,7 +6048,11 @@ let setup_t = ]; bs_path = "lib"; bs_compiled_object = Native; - bs_build_depends = [FindlibPackage ("re.str", None)]; + bs_build_depends = + [ + FindlibPackage ("re.str", None); + FindlibPackage ("tuntap", None) + ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6244,7 +6248,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "c\244%\210\159\232;\149\225\210>\030\163\170c\245"; + oasis_digest = Some "k\194\197\129\150&\203\229\130c\221\208L^\249\199"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6252,6 +6256,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6256 "setup.ml" +# 6260 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 5cfba622cd84579bdb3e09f3d243b4c7b1484d15 Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 11 Nov 2013 00:20:06 +0000 Subject: [PATCH 72/75] remove tuntap requirement --- _oasis | 2 +- lib/ofswitch_config.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/_oasis b/_oasis index 2a507f2..4b657a0 100644 --- a/_oasis +++ b/_oasis @@ -52,7 +52,7 @@ Library switch CompiledObject: native Modules: Ofswitch, Ofswitch_config, Ofswitch_standalone Pack: True - BuildDepends: re.str,tuntap + BuildDepends: re.str Executable "ocaml-ofctl" Path: lib diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 83c5d7f..8e055d4 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -207,7 +207,7 @@ let listen_t mgr add_port del_port get_stats add_flow del_flow port = match (req.Rpc.name, req.Rpc.params) with | ("add-port", (Rpc.String (devname))::_) -> begin try_lwt - let (fd, name) = Tuntap.opentap ~persist:true ~devname () in +(* let (fd, name) = Tuntap.opentap ~persist:true ~devname () in *) let id = OS.Netif.id_of_string name in (* OS.Netif.add_vif id OS.Netif.ETH fd; *) lwt _ = Net.Manager.create (fun _ _ _ -> add_port id) in From 9b0692d23787524202d36da69dd1b60110ea6d90 Mon Sep 17 00:00:00 2001 From: crotsos Date: Mon, 11 Nov 2013 00:26:54 +0000 Subject: [PATCH 73/75] fixing compilation --- lib/ofswitch_config.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 8e055d4..192ca31 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -207,10 +207,10 @@ let listen_t mgr add_port del_port get_stats add_flow del_flow port = match (req.Rpc.name, req.Rpc.params) with | ("add-port", (Rpc.String (devname))::_) -> begin try_lwt -(* let (fd, name) = Tuntap.opentap ~persist:true ~devname () in *) +(* let (fd, name) = Tuntap.opentap ~persist:true ~devname () in let id = OS.Netif.id_of_string name in (* OS.Netif.add_vif id OS.Netif.ETH fd; *) - lwt _ = Net.Manager.create (fun _ _ _ -> add_port id) in + lwt _ = Net.Manager.create (fun _ _ _ -> add_port id) in *) return (Rpc.Enum [(Rpc.String "true")]) with exn -> cp (sp "[ofswitch-confid] add-port: %s\n%!" (Printexc.to_string exn)); From 378540005e383ec367b2f2cc7aadcf593f36e5bd Mon Sep 17 00:00:00 2001 From: crotsos Date: Fri, 13 Dec 2013 11:47:58 +0000 Subject: [PATCH 74/75] Fixing of switch to work with floodlight --- .exrc | 208 +++++++ .ocp-indent | 1 + lib/ofswitch_model.ml | 1133 +++++++++++++++++++++++++++++++++++++++ lib/ofswitch_model.mli | 60 +++ lib/switch_model.mlpack | 4 + 5 files changed, 1406 insertions(+) create mode 100644 .exrc create mode 100644 .ocp-indent create mode 100644 lib/ofswitch_model.ml create mode 100644 lib/ofswitch_model.mli create mode 100644 lib/switch_model.mlpack diff --git a/.exrc b/.exrc new file mode 100644 index 0000000..97b700e --- /dev/null +++ b/.exrc @@ -0,0 +1,208 @@ +if &cp | set nocp | endif +let s:cpo_save=&cpo +set cpo&vim +inoremap (neocomplcache_start_omni_complete)  +inoremap (neocomplcache_start_auto_complete_no_select)  +inoremap (neocomplcache_start_auto_complete) =neocomplcache#mappings#popup_post() +inoremap (neocomplcache_start_unite_quick_match) unite#sources#neocomplcache#start_quick_match() +inoremap (neocomplcache_start_unite_complete) unite#sources#neocomplcache#start_complete() +inoremap neocomplcache#smart_close_popup()."\" +noremap  h +nmap  :NERDTreeToggle +noremap j +noremap  k +noremap  l +nmap OD h +nmap OC l +nmap OB j +nmap OA k +vnoremap = :call OcpIndentRange() +map == :call OcpIndentRange() +xmap S VSurround +nmap [xx unimpaired_line_xml_encode +xmap [x unimpaired_xml_encode +nmap [x unimpaired_xml_encode +nmap [uu unimpaired_line_url_encode +xmap [u unimpaired_url_encode +nmap [u unimpaired_url_encode +nmap [yy unimpaired_line_string_encode +xmap [y unimpaired_string_encode +nmap [y unimpaired_string_encode +nmap [p unimpairedPutAbove +nnoremap [ox :set cursorline cursorcolumn +nnoremap [ow :set wrap +nnoremap [os :set spell +nnoremap [or :set relativenumber +nnoremap [on :set number +nnoremap [ol :set list +nnoremap [oi :set ignorecase +nnoremap [oh :set hlsearch +nnoremap [od :diffthis +nnoremap [ou :set cursorcolumn +nnoremap [oc :set cursorline +xmap [e unimpairedMoveUp +nmap [e unimpairedMoveUp +nmap [ unimpairedBlankUp +omap [n unimpairedContextPrevious +nmap [n unimpairedContextPrevious +nmap [o unimpairedOPrevious +nmap [f unimpairedDirectoryPrevious +nmap [T unimpairedTFirst +nmap [t unimpairedTPrevious +nmap [ unimpairedQPFile +nmap [Q unimpairedQFirst +nmap [q unimpairedQPrevious +nmap [ unimpairedLPFile +nmap [L unimpairedLFirst +nmap [l unimpairedLPrevious +nmap [B unimpairedBFirst +nmap [b unimpairedBPrevious +nmap [A unimpairedAFirst +nmap [a unimpairedAPrevious +nnoremap \i :call OcpIndentBuffer() +vnoremap \i :call OcpIndentRange() +vmap \t :call Ocaml_print_type("visual") `< +nmap \t :call Ocaml_print_type("normal") +omap \t :call Ocaml_print_type("normal") +map \S :call OCaml_switch(1) +map \s :call OCaml_switch(0) +nmap \\u CommentaryUndo +nmap \\\ CommentaryLine +nmap \\ Commentary +xmap \\ Commentary +map \bta :!/usr/local/bin/ctags -R . +map \ta :TlistToggle +nmap ]xx unimpaired_line_xml_decode +xmap ]x unimpaired_xml_decode +nmap ]x unimpaired_xml_decode +nmap ]uu unimpaired_line_url_decode +xmap ]u unimpaired_url_decode +nmap ]u unimpaired_url_decode +nmap ]yy unimpaired_line_string_decode +xmap ]y unimpaired_string_decode +nmap ]y unimpaired_string_decode +nmap ]p unimpairedPutBelow +nnoremap ]ox :set nocursorline nocursorcolumn +nnoremap ]ow :set nowrap +nnoremap ]os :set nospell +nnoremap ]or :set norelativenumber +nnoremap ]on :set nonumber +nnoremap ]ol :set nolist +nnoremap ]oi :set noignorecase +nnoremap ]oh :set nohlsearch +nnoremap ]od :diffoff +nnoremap ]ou :set nocursorcolumn +nnoremap ]oc :set nocursorline +xmap ]e unimpairedMoveDown +nmap ]e unimpairedMoveDown +nmap ] unimpairedBlankDown +omap ]n unimpairedContextNext +nmap ]n unimpairedContextNext +nmap ]o unimpairedONext +nmap ]f unimpairedDirectoryNext +nmap ]T unimpairedTLast +nmap ]t unimpairedTNext +nmap ] unimpairedQNFile +nmap ]Q unimpairedQLast +nmap ]q unimpairedQNext +nmap ] unimpairedLNFile +nmap ]L unimpairedLLast +nmap ]l unimpairedLNext +nmap ]B unimpairedBLast +nmap ]b unimpairedBNext +nmap ]A unimpairedALast +nmap ]a unimpairedANext +nnoremap cox :set =&cursorline && &cursorcolumn ? 'nocursorline nocursorcolumn' : 'cursorline cursorcolumn'  +nnoremap cod :=&diff ? 'diffoff' : 'diffthis'  +nmap cs Csurround +nmap ds Dsurround +nmap gx NetrwBrowseX +nmap gcu CommentaryUndo +nmap gcc CommentaryLine +nmap gc Commentary +xmap gc Commentary +xmap gS VgSurround +nmap ySS YSsurround +nmap ySs YSsurround +nmap yss Yssurround +nmap yS YSurround +nmap ys Ysurround +nnoremap NetrwBrowseX :call netrw#NetrwBrowseX(expand(""),0) +nnoremap (vimshell_create) :VimShellCreate +nnoremap (vimshell_switch) :VimShell +xnoremap unimpairedMoveDown :exe 'exe "normal! m`"|''<,''>move''>+'.v:count1 `` +xnoremap unimpairedMoveUp :exe 'exe "normal! m`"|''<,''>move--'.v:count1 `` +nmap unimpairedOPrevious unimpairedDirectoryPrevious:echohl WarningMSG|echo "[o is deprecated. Use [f"|echohl NONE +nmap unimpairedONext unimpairedDirectoryNext:echohl WarningMSG|echo "]o is deprecated. Use ]f"|echohl NONE +nnoremap unimpairedTLast :exe "".(v:count ? v:count : "")."tlast" +nnoremap unimpairedTFirst :exe "".(v:count ? v:count : "")."tfirst" +nnoremap unimpairedTNext :exe "".(v:count ? v:count : "")."tnext" +nnoremap unimpairedTPrevious :exe "".(v:count ? v:count : "")."tprevious" +nnoremap unimpairedQNFile :exe "".(v:count ? v:count : "")."cnfile" +nnoremap unimpairedQPFile :exe "".(v:count ? v:count : "")."cpfile" +nnoremap unimpairedQLast :exe "".(v:count ? v:count : "")."clast" +nnoremap unimpairedQFirst :exe "".(v:count ? v:count : "")."cfirst" +nnoremap unimpairedQNext :exe "".(v:count ? v:count : "")."cnext" +nnoremap unimpairedQPrevious :exe "".(v:count ? v:count : "")."cprevious" +nnoremap unimpairedLNFile :exe "".(v:count ? v:count : "")."lnfile" +nnoremap unimpairedLPFile :exe "".(v:count ? v:count : "")."lpfile" +nnoremap unimpairedLLast :exe "".(v:count ? v:count : "")."llast" +nnoremap unimpairedLFirst :exe "".(v:count ? v:count : "")."lfirst" +nnoremap unimpairedLNext :exe "".(v:count ? v:count : "")."lnext" +nnoremap unimpairedLPrevious :exe "".(v:count ? v:count : "")."lprevious" +nnoremap unimpairedBLast :exe "".(v:count ? v:count : "")."blast" +nnoremap unimpairedBFirst :exe "".(v:count ? v:count : "")."bfirst" +nnoremap unimpairedBNext :exe "".(v:count ? v:count : "")."bnext" +nnoremap unimpairedBPrevious :exe "".(v:count ? v:count : "")."bprevious" +nnoremap unimpairedALast :exe "".(v:count ? v:count : "")."last" +nnoremap unimpairedAFirst :exe "".(v:count ? v:count : "")."first" +nnoremap unimpairedANext :exe "".(v:count ? v:count : "")."next" +nnoremap unimpairedAPrevious :exe "".(v:count ? v:count : "")."previous" +nnoremap SurroundRepeat . +nnoremap :call UpdateTags() +inoremap  neocomplcache#cancel_popup() +imap S ISurround +imap s Isurround +inoremap  neocomplcache#undo_completion() +inoremap  neocomplcache#smart_close_popup()."\" +inoremap  pumvisible() ? "\" : "\ " +inoremap  neocomplcache#complete_common_string() +imap  Isurround +inoremap  neocomplcache#close_popup() +imap OD hi +imap OC li +imap OB ji +imap OA ki +let &cpo=s:cpo_save +unlet s:cpo_save +set autoindent +set autoread +set backspace=2 +set completefunc=neocomplcache#complete#manual_complete +set completeopt=menuone +set noequalalways +set expandtab +set fileencodings=ucs-bom,utf-8,default,latin1 +set helplang=en +set history=50 +set hlsearch +set ignorecase +set incsearch +set laststatus=2 +set omnifunc=merlin#Complete +set printoptions=paper:a4 +set ruler +set runtimepath=~/.vim/bundle/vundle,~/.vim/bundle/vim-pathogen,~/.vim/bundle/vim-colors-solarized,~/.vim/bundle/vim-fugitive,~/.vim/bundle/nerdtree,~/.vim/bundle/vim-surround,~/.vim/bundle/tabular,~/.vim/bundle/vim-unimpaired,~/.vim/bundle/vim-endwise,~/.vim/bundle/syntastic,~/.vim/bundle/gist-vim,~/.vim/bundle/grep.vim,~/.vim/bundle/vim-commentary,~/.vim/bundle/minibufexpl.vim,~/.vim/bundle/OmniCppComplete,~/.vim/bundle/c.vim,~/.vim/bundle/vim-diff,~/.vim/bundle/detectindent,~/.vim/bundle/vimshell.vim,~/.vim/bundle/neocomplcache,~/.vim,/var/lib/vim/addons,/usr/share/vim/vimfiles,/usr/share/vim/vim73,/usr/share/vim/vimfiles/after,/var/lib/vim/addons/after,~/.vim/after,~/.vim/bundle/vundle/,~/.vim/bundle/vundle/after,~/.vim/bundle/vim-pathogen/after,~/.vim/bundle/vim-colors-solarized/after,~/.vim/bundle/vim-fugitive/after,~/.vim/bundle/nerdtree/after,~/.vim/bundle/vim-surround/after,~/.vim/bundle/tabular/after,~/.vim/bundle/vim-unimpaired/after,~/.vim/bundle/vim-endwise/after,~/.vim/bundle/syntastic/after,~/.vim/bundle/gist-vim/after,~/.vim/bundle/grep.vim/after,~/.vim/bundle/vim-commentary/after,~/.vim/bundle/minibufexpl.vim/after,~/.vim/bundle/OmniCppComplete/after,~/.vim/bundle/c.vim/after,~/.vim/bundle/vim-diff/after,~/.vim/bundle/detectindent/after,~/.vim/bundle/vimshell.vim/after,~/.vim/bundle/neocomplcache/after,~/.opam/4.00.1/share/ocamlmerlin/vim,~/.opam/4.00.1/share/ocamlmerlin/vimbufsync +set shiftwidth=2 +set smartcase +set smarttab +set softtabstop=2 +set statusline=\ %{HasPaste()}%<%-15.25(%f%)%m%r%h\ %w\ \ \ \ \ [%{&ff}/%Y]\ \ \ %<%20.30(%{hostname()}:%{CurDir()}%)\ %=%-10.(%l,%c%V%)\ %p%%/%L +set suffixes=.bak,~,.swp,.o,.info,.aux,.log,.dvi,.bbl,.blg,.brf,.cb,.ind,.idx,.ilg,.inx,.out,.toc +set textwidth=80 +set timeoutlen=500 +set title +set titlestring=%F\ -\ Vim +set updatetime=1500 +set wildignore=*.o,*.class,*.pdf,*._aux,*.aux,*.bbl,*.big,*.brf,*.blg,*.dvi,*.div,*.ilg,*.lof,*.log,*._log,*.nlo,*.nls,*.out,*.ps,*.tdo,*.tex.project.vim,*.toc +" vim: set ft=vim : diff --git a/.ocp-indent b/.ocp-indent new file mode 100644 index 0000000..6932fe1 --- /dev/null +++ b/.ocp-indent @@ -0,0 +1 @@ +syntax = lwt diff --git a/lib/ofswitch_model.ml b/lib/ofswitch_model.ml new file mode 100644 index 0000000..ace2ae6 --- /dev/null +++ b/lib/ofswitch_model.ml @@ -0,0 +1,1133 @@ +(* + * Copyright (c) 2011 Richard Mortier + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt + +open Ofswitch_config + +module OP = Openflow.Ofpacket +module OSK = Openflow.Ofsocket + +exception Packet_type_unknw + +let sp = Printf.sprintf +let pr = Printf.printf +let pp = Printf.printf +let ep = Printf.eprintf +let cp = OS.Console.log + +(* XXX should really stndardise these *) +type uint16 = OP.uint16 +type uint32 = OP.uint32 +type uint64 = OP.uint64 +type byte = OP.byte + +type port = uint16 +type cookie = uint64 + +type device = string (* XXX placeholder! *) + +let resolve t = Lwt.on_success t (fun _ -> ()) + +let get_new_buffer len = + let buf = OS.Io_page.to_cstruct (OS.Io_page.get 1) in + Cstruct.sub buf 0 len + +let get_intf mgr id = + let lst = Net.Manager.get_intfs mgr in + let (_, intf) = List.find (fun (dev_id,_) -> id = dev_id) lst in + intf + +type delay_model = { + flow_insert : float; + flow_update : float; + pktin_rate : float; + pktin_delay : float; + stats_delay : float; + pktout_delay: float; +} + +module Entry = struct + type table_counter = { + n_active: uint32; + n_lookups: uint64; + n_matches: uint64; + } + + type flow_counter = { + mutable n_packets: uint64; + mutable n_bytes: uint64; + flags : OP.Flow_mod.flags; + priority: uint16; + cookie: int64; + insert_sec: int; + insert_nsec: int; + mutable last_sec: int; + mutable last_nsec: int; + idle_timeout: int; + hard_timeout:int; + } + + type queue_counter = { + tx_queue_packets: uint64; + tx_queue_bytes: uint64; + tx_queue_overrun_errors: uint64; + } + + let init_flow_counters t = + let ts = int_of_float (OS.Clock.time ()) in + {n_packets=0L; n_bytes=0L; priority=t.OP.Flow_mod.priority; + cookie=t.OP.Flow_mod.cookie; insert_sec=ts; insert_nsec=0; + last_sec=ts;last_nsec=0; idle_timeout=t.OP.Flow_mod.idle_timeout; + hard_timeout=t.OP.Flow_mod.hard_timeout; flags=t.OP.Flow_mod.flags; } + + type t = { + counters: flow_counter; + actions: OP.Flow.action list; + mutable cache_entries: OP.Match.t list; + } + let update_flow pkt_len flow = + flow.counters.n_packets <- Int64.add flow.counters.n_packets 1L; + flow.counters.n_bytes <- Int64.add flow.counters.n_bytes pkt_len; + flow.counters.last_sec <- int_of_float (OS.Clock.time ()) + + + let flow_counters_to_flow_stats of_match table_id flow = + let priority = flow.counters.priority in + let idle_timeout=flow.counters.idle_timeout in + let hard_timeout=flow.counters.hard_timeout in + let cookie=flow.counters.cookie in + let packet_count=flow.counters.n_packets in + let byte_count=flow.counters.n_bytes in + let action=flow.actions in + OP.Flow.({table_id; of_match; + duration_sec = Int32.of_int (flow.counters.last_sec - + flow.counters.insert_sec); + duration_nsec = Int32.of_int (flow.counters.last_nsec - + flow.counters.insert_nsec); + priority; idle_timeout; hard_timeout; cookie; + packet_count; byte_count; action; }) + +end + +module Table = struct + type t = { + flow_add_queue: (OP.Match.t * (OP.Flow.action list -> unit Lwt.t) * Entry.t) Lwt_stream.t; + flow_add_push : ((OP.Match.t * (OP.Flow.action list -> unit Lwt.t) * Entry.t) option -> unit); + + flow_upd_queue: (OP.Match.t * (OP.Flow.action list -> unit Lwt.t) * Entry.t) Lwt_stream.t; + flow_upd_push : ((OP.Match.t * (OP.Flow.action list -> unit Lwt.t) * Entry.t) option -> unit); + + tid: cookie; + (* This entry stores wildcard and exact match entries as + * transmitted by the controller *) + mutable entries: (OP.Match.t, Entry.t) Hashtbl.t; + (* Intermediate table to store exact match flos deriving from wildcard + * entries *) + mutable cache : (OP.Match.t, Entry.t ref) Hashtbl.t; + stats : OP.Stats.table; + } + + let init_table () = + let open OP.Wildcards in + let (flow_add_queue, flow_add_push) = Lwt_stream.create () in + let (flow_upd_queue, flow_upd_push) = Lwt_stream.create () in + { tid = 0_L; flow_add_queue; flow_add_push; flow_upd_queue; flow_upd_push; + entries = (Hashtbl.create 10000); cache = (Hashtbl.create 10000); + stats = OP.Stats.( + {table_id=(table_id_of_int 1); name="main_tbl"; + wildcards=(exact_match ()); max_entries=1024l; active_count=0l; + lookup_count=0L; matched_count=0L});} + + let add_flow_nodelay table verbose m entry process_bid = + let open OP.Flow_mod in + let open OP.Match in + let _ = Hashtbl.replace table.entries m entry in + (* In the fast path table, I need to delete any conflicting entries *) + let _ = + Hashtbl.iter ( + fun a e -> + if ((flow_match_compare a m m.wildcards) && + Entry.(entry.counters.priority >= (!e).counters.priority)) then ( + let _ = (!e).Entry.cache_entries <- + List.filter (fun c -> a <> c) (!e).Entry.cache_entries in + let _ = Hashtbl.replace table.cache a (ref entry) in + entry.Entry.cache_entries <- a :: entry.Entry.cache_entries + ) + ) table.cache in + let _ = ignore_result (process_bid entry.Entry.actions) in +(* if (bid = -1l) then return () + else process_buffer_id st t msg h.xid bid entry.Entry.actions *) + + let _ = if (verbose) then + cp (sp "[switch] Adding flow %s" (OP.Match.match_to_string m)) + in + () + + + (* TODO fix flow_mod flag support. overlap is not considered *) + let add_flow table t verbose process_bid = + let open OP.Flow_mod in + let open OP.Match in + let _ = + (* max priority for exact match rules *) + if (t.of_match.wildcards=(OP.Wildcards.exact_match ())) then + t.priority <- 0x1001 + in + let entry = Entry.({actions=t.OP.Flow_mod.actions; + counters=(init_flow_counters t); cache_entries=[];}) in + if (Hashtbl.mem table.entries t.of_match) then + table.flow_upd_push (Some (t.of_match, process_bid, entry)) + else + table.flow_add_push (Some (t.of_match, process_bid, entry) ) + + (* TODO check if the details are correct e.g. IP type etc. *) + let add_flow_t st table delay verbose = + while_lwt true do + lwt (m, bid, entry) = Lwt_stream.next table.flow_add_queue in + lwt () = OS.Time.sleep delay in + let () = add_flow_nodelay table verbose m entry bid in + return () + done + let upd_flow_t table delay verbose = + while_lwt true do + lwt (m, bid, entry) = Lwt_stream.next table.flow_upd_queue in + lwt () = OS.Time.sleep delay in + let () = add_flow_nodelay table verbose m entry bid in + return () + done + + + (* check if a list of actions has an output action forwarding packets to + * out_port. + * Used when removing a port from the switch control in order to clean related + * flows *) + let rec is_output_port out_port = function + | [] -> false + | OP.Flow.Output(port, _)::_ when (port = out_port) -> true + | _ :: tail -> is_output_port out_port tail + + let del_flow table ?(xid=(Random.int32 Int32.max_int)) + ?(reason=OP.Flow_removed.DELETE) tuple out_port t verbose = + (* Delete all matching entries from the flow table*) + let remove_flow = + Hashtbl.fold ( + fun of_match flow ret -> + if ((OP.Match.flow_match_compare of_match tuple + tuple.OP.Match.wildcards) && + ((out_port = OP.Port.No_port) || + (is_output_port out_port flow.Entry.actions))) then ( + let _ = Hashtbl.remove table.entries of_match in + (of_match, flow)::ret + ) else ret + ) table.entries [] in + + (* Delete all entries from cache *) + let _ = + List.iter ( + fun (_, flow) -> + List.iter (Hashtbl.remove table.cache) flow.Entry.cache_entries + ) remove_flow in + + (* Check for notification flag in flow and send + * flow modification warnings *) + Lwt_list.iter_s ( + fun (of_match, flow) -> + let _ = + if verbose then + cp (sp "[switch] Removing flow %s" (OP.Match.match_to_string of_match)) + in + match(t, flow.Entry.counters.Entry.flags.OP.Flow_mod.send_flow_rem) with + | (Some t, true) -> + let duration_sec = (int_of_float (OS.Clock.time ())) - + flow.Entry.counters.Entry.insert_sec in + let fl_rm = OP.Flow_removed.( + {of_match; cookie=flow.Entry.counters.Entry.cookie; + priority=flow.Entry.counters.Entry.priority; + reason; duration_sec=(Int32.of_int duration_sec); duration_nsec=0l; + idle_timeout=flow.Entry.counters.Entry.idle_timeout; + packet_count=flow.Entry.counters.Entry.n_packets; + byte_count=flow.Entry.counters.Entry.n_bytes;}) in + let h = OP.Header.(create ~xid FLOW_REMOVED (OP.Flow_removed.get_len)) in + OSK.send_packet t (OP.Flow_removed (h,fl_rm)) + | _ -> return () + ) remove_flow + + (* table stat update methods *) + let update_table_found table = + let open OP.Stats in + table.stats.lookup_count <- Int64.succ table.stats.lookup_count; + table.stats.matched_count <- Int64.succ table.stats.matched_count + + let update_table_missed table = + let open OP.Stats in + table.stats.lookup_count <- Int64.succ table.stats.lookup_count + + (* monitor thread to timeout flows *) + let monitor_flow_timeout table t verbose = + let open Entry in + let check_flow_timeout table t verbose = + let ts = int_of_float (OS.Clock.time ()) in + let flows = Hashtbl.fold ( + fun of_match entry ret -> + let hard = ts - entry.counters.insert_sec in + let idle = ts - entry.counters.last_sec in + match (hard, idle) with + | (l, _) when ((entry.counters.hard_timeout > 0) && + (l >= entry.counters.hard_timeout)) -> + (of_match, entry, OP.Flow_removed.HARD_TIMEOUT )::ret + | (_, l) when ((entry.counters.idle_timeout > 0) && + (l >= entry.counters.idle_timeout)) -> + ret @ [(of_match, entry, OP.Flow_removed.IDLE_TIMEOUT )] + | _ -> ret + ) table.entries [] in + Lwt_list.iter_s ( + fun (of_match, entry, reason) -> + del_flow table ~reason of_match OP.Port.No_port t verbose + ) flows + in + while_lwt true do + lwt _ = OS.Time.sleep 1.0 in + check_flow_timeout table t verbose + done +end + +module Switch = struct + type port = { + port_id: int; + ethif: Net.Manager.id; + netif: OS.Netif.t; + counter: OP.Port.stats; + phy: OP.Port.phy; + in_queue: Cstruct.t Lwt_stream.t; + in_push : (Cstruct.t option -> unit); + out_queue: Cstruct.t Lwt_stream.t; + out_push : (Cstruct.t option -> unit); + mutable pkt_count : int; + } + + let init_port mgr port_no id = + let ethif = Net.Manager.get_ethif ( get_intf mgr id ) in + let netif = Net.Ethif.get_netif ethif in + let hw_addr = Net.Ethif.mac ethif in + let (in_queue, in_push) = Lwt_stream.create () in + let (out_queue, out_push) = Lwt_stream.create () in + let counter = OP.Port.( + { port_id=port_no; rx_packets=0L; tx_packets=0L; rx_bytes=0L; + tx_bytes=0L; rx_dropped=0L; tx_dropped=0L; rx_errors=0L; + tx_errors=0L; rx_frame_err=0L; rx_over_err=0L; rx_crc_err=0L; + collisions=0L;}) in + + let features = OP.Port.( + {pause_asym=true; pause=true; autoneg=true; fiber=true; + copper=true; f_10GB_FD=true; f_1GB_FD=true; f_1GB_HD=true; + f_100MB_FD=true; f_100MB_HD=true; f_10MB_FD=true; + f_10MB_HD=true;}) in + let port_config = OP.Port.( + { port_down=false; no_stp=false; no_recv=false; + no_recv_stp=false; no_flood=false; no_fwd=false; + no_packet_in=false;}) in + let port_state = OP.Port.( + {link_down =false; stp_listen =false; stp_learn =false; + stp_forward =false; stp_block =false;}) in + let phy = OP.Port.( + {port_no; hw_addr;name=(OS.Netif.string_of_id id); config= port_config; + state= port_state; curr=features; advertised=features; + supported=features; peer=features;}) in + + {port_id=port_no; counter; + ethif=id;netif;phy;in_queue;in_push;pkt_count=0; + out_queue;out_push;} + + type stats = { + mutable n_frags: uint64; + mutable n_hits: uint64; + mutable n_missed: uint64; + mutable n_lost: uint64; + } + + type lookup_ret = + Found of Entry.t ref + | NOT_FOUND + + type t = { + (* Mapping port ids to port numbers *) + ports: (int, port) Hashtbl.t; + mutable controller: OSK.conn_state option; + mutable last_echo_req : float; + mutable echo_resp_received : bool; + model : delay_model; + table: Table.t; + stats: stats; + mutable errornum : uint32; + mutable portnum : int; + features : OP.Switch.features; + mutable packet_buffer: OP.Packet_in.t list; + mutable packet_buffer_id: int32; + ready : unit Lwt_condition.t ; + verbose : bool; + + pktin_queue: OP.t Lwt_stream.t; + pktin_push : OP.t option -> unit; + + pktout_queue: (Cstruct.t * int) Lwt_stream.t; + pktout_push : (Cstruct.t * int) option -> unit; + + stats_queue: (Cstruct.t * int) Lwt_stream.t; + stats_push : (Cstruct.t * int) option -> unit; + } + + let supported_actions () = + OP.Switch.({ output=true; set_vlan_id=true; set_vlan_pcp=true; strip_vlan=true; + set_dl_src=true; set_dl_dst=true; set_nw_src=true; set_nw_dst=true; + set_nw_tos=true; set_tp_src=true; set_tp_dst=true; enqueue=false;vendor=true; }) + let supported_capabilities () = + OP.Switch.({flow_stats=true;table_stats=true;port_stats=true;stp=true; + ip_reasm=false;queue_stats=false;arp_match_ip=true;}) + let switch_features datapath_id = + OP.Switch.({datapath_id; n_buffers=0l; n_tables=(char_of_int 1); ports=[]; + capabilities=(supported_capabilities ()); actions=(supported_actions ()); }) + + + let update_port_tx_stats pkt_len port = + OP.Port.(port.counter.tx_packets <- Int64.add port.counter.tx_packets 1L); + OP.Port.(port.counter.tx_bytes <- Int64.add port.counter.tx_bytes pkt_len) + + let update_port_rx_stats pkt_len port = + OP.Port.(port.counter.rx_packets <- Int64.add port.counter.rx_packets 1L); + OP.Port.(port.counter.rx_bytes <- Int64.add port.counter.rx_bytes pkt_len) + + cstruct dl_header { + uint8_t dl_dst[6]; + uint8_t dl_src[6]; + uint16_t dl_type + } as big_endian + + cstruct arphdr { + uint16_t ar_hrd; + uint16_t ar_pro; + uint8_t ar_hln; + uint8_t ar_pln; + uint16_t ar_op; + uint8_t ar_sha[6]; + uint32_t nw_src; + uint8_t ar_tha[6]; + uint32_t nw_dst + } as big_endian + + cstruct nw_header { + uint8_t hlen_version; + uint8_t nw_tos; + uint16_t total_len; + uint8_t pad[5]; + uint8_t nw_proto; + uint16_t csum; + uint32_t nw_src; + uint32_t nw_dst + } as big_endian + + cstruct tp_header { + uint16_t tp_src; + uint16_t tp_dst + } as big_endian + + cstruct icmphdr { + uint8_t typ; + uint8_t code; + uint16_t checksum + } as big_endian + + cstruct tcpv4 { + uint16_t src_port; + uint16_t dst_port; + uint32_t sequence; + uint32_t ack_number; + uint32_t dataoff_flags_window; + uint16_t checksum + } as big_endian + + cstruct pseudo_header { + uint32_t src; + uint32_t dst; + uint8_t res; + uint8_t proto; + uint16_t len + } as big_endian + + let tcp_checksum ~src ~dst = + let pbuf = Cstruct.sub (Cstruct.of_bigarray (OS.Io_page.get 1)) 0 sizeof_pseudo_header in + fun data -> + set_pseudo_header_src pbuf (Ipaddr.V4.to_int32 src); + set_pseudo_header_dst pbuf (Ipaddr.V4.to_int32 dst); + set_pseudo_header_res pbuf 0; + set_pseudo_header_proto pbuf 6; + set_pseudo_header_len pbuf (Cstruct.lenv data); + Net.Checksum.ones_complement_list (pbuf::data) + + let send_packet port bits = + update_port_tx_stats (Int64.of_int (Cstruct.len bits)) port; +(* return (port.out_push (Some bits)) *) + Lwt.ignore_result (OS.Netif.write port.netif bits) +(* Net.Manager.inject_packet port.mgr port.ethif bits *) + + let process_pktin_nodelay st pkt = + match st.controller with + | None ->(* return *)() + | Some conn -> Lwt.ignore_result (OSK.send_packet conn pkt) + + + let process_pktin st pkt = + if (st.model.pktin_delay > 0.) then + (st.pktin_push (Some pkt) ) + else + process_pktin_nodelay st pkt + + let pktin_t st delay rate = + let start_ts = ref 0.0 in +(* let (fraction, _) = modf !start_ts in *) + let counter = ref 0.0 in + while_lwt true do + lwt pktin = Lwt_stream.next st.pktin_queue in + let now = OS.Clock.time () in + let () = + if ((!start_ts +. 1.0) < now) then + let _ = counter := 0. in + start_ts := (floor now) + in + if ((rate = 0.) || (!counter <= rate)) then + lwt () = OS.Time.sleep delay in + counter := !counter +. 1.; + return (process_pktin_nodelay st pktin) + else + let _ = Printf.printf "%f: counter = %f, start_ts %f dropping packet\n%!" + now !counter !start_ts in + return () + done + + let forward_frame st in_port bits pkt_size checksum port = + let _ = + if ((checksum) && ((get_dl_header_dl_type bits) = 0x800)) then + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let _ = set_nw_header_csum ip_data 0 in + let csm = Net.Checksum.ones_complement (Cstruct.sub ip_data 0 (len*4)) in + let _ = set_nw_header_csum ip_data csm in + let _ = + match (get_nw_header_nw_proto ip_data) with + | 6 (* TCP *) -> + let src = Ipaddr.V4.of_int32 (get_nw_header_nw_src + ip_data) in + let dst = Ipaddr.V4.of_int32 (get_nw_header_nw_dst + ip_data) in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tcpv4_checksum tp_data 0 in + let csm = tcp_checksum ~src ~dst [tp_data] in + set_tcpv4_checksum tp_data csm + | 17 (* UDP *) -> () + | _ -> () + in + () + in + match port with + | OP.Port.Port(port) -> + if Hashtbl.mem st.ports port then + let out_p = (Hashtbl.find st.ports port) in + send_packet out_p bits +(* Net.Manager.inject_packet out_p.mgr out_p.ethif bits *) + else + (* return *)(cp (sp "[switch] forward_frame: Port %d not registered\n%!" port)) + | OP.Port.No_port ->(* return *)() + | OP.Port.Flood + |OP.Port.All -> + let inp = OP.Port.int_of_port in_port in + (*Lwt_l*)List.iter + (fun port -> send_packet port bits) + (Hashtbl.fold (fun ix p r -> + if(ix != inp) then p::r else r) st.ports []) + | OP.Port.In_port -> + let port = (OP.Port.int_of_port in_port) in + if Hashtbl.mem st.ports port then + send_packet (Hashtbl.find st.ports port) bits + else + (* return *)(cp (sp "[switch] forward_frame: Port %d unregistered\n%!" port)) + | OP.Port.Local -> + let local = OP.Port.int_of_port OP.Port.Local in + if Hashtbl.mem st.ports local then + send_packet (Hashtbl.find st.ports local) bits + else + (* return *)(cp (sp "[switch] forward_frame: Port %d unregistered \n%!" local)) + | OP.Port.Controller -> begin + let size = + if (Cstruct.len bits > pkt_size) then + pkt_size + else + Cstruct.len bits + in + let (h, pkt_in) = + OP.Packet_in.(create_pkt_in ~buffer_id:(-1l) ~in_port + ~reason:ACTION ~data:(Cstruct.sub bits 0 size)) in + process_pktin st (OP.Packet_in (h, pkt_in)) + end + (* | Table + * | Normal *) + | _ -> + (* return *)(cp (sp "[switch] forward_frame: unsupported output port\n")) + + (* Assumwe that action are valid. I will not get a flow that sets an ip + * address unless it defines that the ethType is ip. Need to enforce + * these rule in the parsing process of the flow_mod packets *) + let apply_of_actions st in_port bits actions = + let apply_of_actions_inner st in_port bits checksum action = + try (*_lwt *) + match action with + | OP.Flow.Output (port, pkt_size) -> + (* Make a packet copy in case the buffer is modified and multiple + * outputs are defined? *) + let _ = forward_frame st in_port bits pkt_size checksum port in + (* return *)false + | OP.Flow.Set_dl_src(eaddr) -> + let _ = set_dl_header_dl_src (Macaddr.to_bytes eaddr) 0 bits in + (* return *)checksum + | OP.Flow.Set_dl_dst(eaddr) -> + let _ = set_dl_header_dl_dst (Macaddr.to_bytes eaddr) 0 bits in + (* return *)checksum + (* TODO: Add for this actions to check when inserted if + * the flow is an ip flow *) + | OP.Flow.Set_nw_tos(tos) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_tos ip_data (int_of_char tos) in + (* return *)true + (* TODO: wHAT ABOUT ARP? + * *) + | OP.Flow.Set_nw_src(ip) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_src ip_data (Ipaddr.V4.to_int32 ip) in + (* return *)true + | OP.Flow.Set_nw_dst(ip) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let _ = set_nw_header_nw_dst ip_data (Ipaddr.V4.to_int32 ip) in + (* return *)true + | OP.Flow.Set_tp_src(port) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tp_header_tp_src tp_data port in + (* return *)true + | OP.Flow.Set_tp_dst(port) -> + let ip_data = Cstruct.shift bits sizeof_dl_header in + let len = (get_nw_header_hlen_version ip_data) land 0xf in + let tp_data = Cstruct.shift ip_data (len*4) in + let _ = set_tp_header_tp_dst tp_data port in + (* return *)true + (* | OP.Flow.Enqueue(_, _) + | OP.Flow.Set_vlan_pcp _ + | OP.Flow.Set_vlan_vid _ + | OP.Flow.VENDOR_ACT + | OP.Flow.STRIP_VLAN *) + | act -> + let _ = cp (sp "[switch] apply_of_actions: Unsupported action %s" + (OP.Flow.string_of_action act)) in + (* return *)checksum + with exn -> + let _ = cp(sp "[switch] apply_of_actions: (packet size %d) %s %s\n%!" + (Cstruct.len bits) (OP.Flow.string_of_action action) + (Printexc.to_string exn )) in + (* return *)checksum + in + let rec apply_of_actions_rec st in_port bits checksum = function + | [] ->(* return *)false + | head :: actions -> + let checksum = apply_of_actions_inner st in_port bits checksum head in + apply_of_actions_rec st in_port bits checksum actions + in + let _ = apply_of_actions_rec st in_port bits false actions in () + + let lookup_flow st of_match = + (* Check first the match table cache + * NOTE an exact match flow will be found on this step and thus + * return a result immediately, without needing to get to the cache table + * and consider flow priorities *) + let open Table in + let open OP.Match in + if (Hashtbl.mem st.table.cache of_match ) then + let entry = (Hashtbl.find st.table.cache of_match) in + Found(entry) + else begin + (* Check the wilcard card table *) + let lookup_flow flow entry r = + match (r, (flow_match_compare of_match flow flow.wildcards)) with + | (_, false) -> r + | (None, true) -> Some(flow, entry) + | (Some(f,e), true) when (Entry.(e.counters.priority > entry.counters.priority)) -> r + | (Some(f,e), true) when (Entry.(e.counters.priority <= entry.counters.priority)) -> + Some(flow, entry) + | (_, _) -> r + in + let flow_match = Hashtbl.fold lookup_flow st.table.entries None in + match (flow_match) with + | None -> NOT_FOUND + | Some(f,e) -> + Hashtbl.add st.table.cache of_match (ref e); + Entry.(e.cache_entries <- of_match :: e.cache_entries); + Found(ref e) + end +end + +type t = Switch.t + +(********************************************* + * Switch OpenFlow data plane + *********************************************) +let process_frame_inner st p frame = + let open Switch in + let open OP.Packet_in in + try + let in_port = (OP.Port.port_of_int p.Switch.port_id) in + let tupple = (OP.Match.raw_packet_to_match in_port frame ) in + (* Update port rx statistics *) + let _ = Switch.update_port_rx_stats (Int64.of_int (Cstruct.len frame)) p in + + (* Lookup packet flow to existing flows in table *) + match (Switch.lookup_flow st tupple) with + | Switch.NOT_FOUND -> begin + Table.update_table_missed st.table; + let buffer_id = st.packet_buffer_id in + (*TODO Move this code in the Switch module *) + st.packet_buffer_id <- Int32.succ st.packet_buffer_id; + let (h, pkt_in) = create_pkt_in ~buffer_id ~in_port ~reason:NO_MATCH ~data:frame in + st.packet_buffer <- pkt_in::st.packet_buffer; + + (* Disable for now packet trimming for buffered packets *) + let size = + if (Cstruct.len frame > 92) then 92 + else Cstruct.len frame in + let (h, pkt_in) = create_pkt_in ~buffer_id ~in_port ~reason:NO_MATCH + ~data:(Cstruct.sub frame 0 size) in + process_pktin st (OP.Packet_in(h,pkt_in)) +(* return ( *) +(* ( match st.Switch.controller with + | None -> () + | Some conn -> ignore_result (OSK.send_packet conn (OP.Packet_in(h,pkt_in))) + ) + *) + end + (* generate a packet in event *) + | Switch.Found(entry) -> + let _ = Table.update_table_found st.table in + let _ = Entry.update_flow (Int64.of_int (Cstruct.len frame)) !entry in + apply_of_actions st tupple.OP.Match.in_port frame (!entry).Entry.actions + with exn -> + (* return *) (cp (sp "[switch] process_frame_inner: control channel error: %s\n" + (Printexc.to_string exn))) + +let forward_thread st = + Lwt_list.iter_p (fun p -> + while_lwt true do + lwt pkt = Lwt_stream.next p.Switch.in_queue in + let _ = process_frame_inner st p pkt in + return (p.Switch.pkt_count <- p.Switch.pkt_count - 1) + done <&> ( + while_lwt true do + lwt frame = Lwt_stream.next p.Switch.out_queue in + OS.Netif.writev p.Switch.netif [frame] (*frame::frames*) + done + ) + ) (Hashtbl.fold (fun _ p c -> p::c) st.Switch.ports []) + +let process_frame st p _ frame = + let _ = + try + match frame with + | Net.Ethif.Output _ -> () + | Net.Ethif.Input frame -> process_frame_inner st p frame + with + | Not_found -> cp (sp "[switch] process_frame: Invalid port\n%!") + | Packet_type_unknw -> cp (sp "[switch] process_frame: malformed packet\n%!") + | exn -> cp (sp "[switch] process_frame: switch error: %s\n%!" (Printexc.to_string exn)) + in + return () + +(************************************************* + * Switch OpenFlow control channel + *************************************************) +let get_flow_stats st of_match = + let open OP.Match in + let match_flows of_match key value ret = + if (flow_match_compare key of_match of_match.wildcards) then ( + (Entry.flow_counters_to_flow_stats key (char_of_int 1) value)::ret + ) else + ret + in + Hashtbl.fold (fun key value r -> match_flows of_match key value r) + st.Switch.table.Table.entries [] + +let process_buffer_id st t msg xid buffer_id actions = + let open OP.Header in + let pkt_in = ref None in + let _ = + st.Switch.packet_buffer <- + List.filter ( fun a -> + if (a.OP.Packet_in.buffer_id = buffer_id) then + (pkt_in := Some(a); false ) + else true ) st.Switch.packet_buffer in + match (!pkt_in) with + | None -> + cp (sp "[switch] invalid buffer id %ld\n%!" buffer_id); + let bits = OP.marshal msg in + let h = create ~xid ERROR (get_len + 4 + (Cstruct.len bits)) in + OSK.send_packet t (OP.Error(h, OP.REQUEST_BUFFER_UNKNOWN, bits)) + | Some(pkt_in) -> + return (OP.Packet_in.(Switch.apply_of_actions st pkt_in.in_port pkt_in.data + actions)) + +let process_openflow st t msg = + let open OP.Header in + let _ = if st.Switch.verbose then cp (sp "[switch] %s\n%!" (OP.to_string msg)) in + match msg with + | OP.Hello (h) -> return () + | OP.Echo_resp h -> return (st.Switch.echo_resp_received <- true) + | OP.Echo_req h -> (* Reply to ECHO requests *) + OSK.send_packet t (OP.Echo_req (create ~xid:h.xid ECHO_RESP sizeof_ofp_header)) + | OP.Features_req (h) -> + let h = create ~xid:(h.xid) FEATURES_RESP (OP.Switch.get_len st.Switch.features) in + OSK.send_packet t (OP.Features_resp (h, st.Switch.features)) + | OP.Stats_req(h, req) -> begin + let xid = h.xid in + match req with + | OP.Stats.Desc_req(req) -> + let p = OP.Stats.( + Desc_resp({st_ty=DESC; more=false;}, + {imfr_desc="Mirage"; hw_desc="Mirage"; + sw_desc="Mirage";serial_num="0.1";dp_desc="Mirage";})) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len p) in + OSK.send_packet t (OP.Stats_resp (h, p)) + | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> + (*TODO Need to consider the table_id and the out_port and + * split reply over multiple openflow packets if they don't + * fit a single packet. *) + let flows = get_flow_stats st of_match in + let stats = OP.Stats.({st_ty=FLOW; more=true;}) in + lwt (_, flows) = + Lwt_list. fold_right_s ( + fun fl (sz, flows) -> + let fl_sz = OP.Flow.flow_stats_len fl in + if (sz + fl_sz > 0xffff) then + let r = OP.Stats.Flow_resp(stats, flows) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + lwt _ = OSK.send_packet t (OP.Stats_resp (h, r)) in + return ((OP.Header.get_len + OP.Stats.get_resp_hdr_size + fl_sz), [fl]) + else + return ((sz + fl_sz), (fl::flows)) ) + flows ((OP.Header.get_len + OP.Stats.get_resp_hdr_size), []) in + let stats = OP.Stats.({st_ty=FLOW; more=false;}) in + let r = OP.Stats.Flow_resp(stats, flows) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Aggregate_req (req_h, of_match, table, port) -> + let match_flows_aggr of_match key value (fl_b, fl_p, fl)= + let open OP.Match in + let open Entry in + if (flow_match_compare key of_match of_match.wildcards) then + ((Int64.add fl_b value.counters.n_bytes), (Int64.add fl_p + value.counters.n_packets), (Int32.succ fl)) + else (fl_b, fl_p, fl) in + let (byte_count, packet_count,flow_count) = + Hashtbl.fold (match_flows_aggr of_match) + st.Switch.table.Table.entries (0L, 0L, 0l) in + let stats = OP.Stats.({st_ty=AGGREGATE; more=false;}) in + let r = OP.Stats.Aggregate_resp(stats, + OP.Stats.({byte_count;packet_count;flow_count;})) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Table_req(req) -> + let stats = OP.Stats.({st_ty=TABLE; more=false;}) in + let r = OP.Stats.Table_resp(stats, [st.Switch.table.Table.stats]) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Stats.Port_req(req_h, port) -> begin + match port with + | OP.Port.No_port -> + let port_stats = Hashtbl.fold (fun ix p r -> p.Switch.counter::r) + st.Switch.ports [] in + let stats = OP.Stats.({st_ty=PORT; more=false;}) in + let r = OP.Stats.Port_resp(stats, port_stats) in + let h = OP.Header.create ~xid OP.Header.STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + | OP.Port.Port(port_id) -> begin + try_lwt + let port = Hashtbl.find st.Switch.ports port_id in + let stats = OP.Stats.({st_ty=PORT; more=false;}) in + let r = OP.Stats.Port_resp(stats, [port.Switch.counter]) in + let h = create ~xid STATS_RESP (OP.Stats.resp_get_len r) in + OSK.send_packet t (OP.Stats_resp (h, r)) + with Not_found -> + (* TODO reply with right error code *) + cp (sp "[switch] unregistered port %s\n%!"(OP.Port.string_of_port port)); + let h = create ~xid ERROR (OP.Header.get_len + 4) in + OSK.send_packet t (OP.Error (h, OP.ACTION_BAD_OUT_PORT, (get_new_buffer 0))) + end + | _ -> + cp "[switch] unsupported stats request\n%!"; + let h = create ~xid ERROR (get_len + 4) in + OSK.send_packet t OP.(Error (h, ACTION_BAD_OUT_PORT, (marshal msg))) + end + | _ -> begin + let h = create ~xid ERROR (get_len + 4) in + OSK.send_packet t (OP.Error (h, OP.REQUEST_BAD_SUBTYPE, (get_new_buffer 0))) + end + end + | OP.Get_config_req(h) -> + let resp = OP.Switch.init_switch_config in + let h = create ~xid:h.xid GET_CONFIG_RESP OP.Switch.config_get_len in + OSK.send_packet t (OP.Get_config_resp(h, resp)) + | OP.Barrier_req(h) -> + OSK.send_packet t (OP.Barrier_resp(create ~xid:h.xid BARRIER_RESP sizeof_ofp_header)) + + | OP.Packet_out(h, pkt) -> + let open OP.Packet_out in + if (pkt.buffer_id = -1l) then + return (Switch.apply_of_actions st pkt.in_port pkt.data pkt.actions) + else begin + process_buffer_id st t msg h.xid pkt.buffer_id pkt.actions + end + | OP.Flow_mod(h,fm) -> + let open OP.Flow_mod in + lwt _ = + match (fm.command) with + | ADD + | MODIFY + | MODIFY_STRICT -> + let process_bid st t msg xid bid actions = + if (bid = -1l) then + return () + else + process_buffer_id st t msg xid bid actions + in + if (st.Switch.model.flow_insert > 0.) then + return (Table.add_flow st.Switch.table fm st.Switch.verbose + (process_bid st t msg h.xid fm.buffer_id) ) + else + let entry = + Entry.({actions=fm.OP.Flow_mod.actions; + counters=(init_flow_counters fm); cache_entries=[];}) in + return (Table.add_flow_nodelay st.Switch.table st.Switch.verbose + fm.OP.Flow_mod.of_match entry + (process_bid st t msg h.xid fm.buffer_id) ) + | DELETE + | DELETE_STRICT -> + (* Need to implemente strict deletion in order to enable signpost + * switching *) + Table.del_flow st.Switch.table fm.of_match fm.out_port (Some t) st.Switch.verbose + in + return () + | OP.Queue_get_config_resp (h, _, _) + | OP.Queue_get_config_req (h, _) + | OP.Barrier_resp h + | OP.Stats_resp (h, _) + | OP.Port_mod (h, _) + | OP.Port_status (h, _) + | OP.Flow_removed (h, _) + | OP.Packet_in (h, _) + | OP.Set_config (h, _) + | OP.Get_config_resp (h, _) + | OP.Features_resp (h, _) + | OP.Vendor (h, _) + | OP.Error (h, _, _) -> + let bits = OP.marshal msg in + let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR + (OP.Header.get_len + 4 + (Cstruct.len bits)) in + OSK.send_packet t (OP.Error(h, OP.REQUEST_BAD_TYPE, bits)) + +let monitor_control_channel st conn = + let is_active = ref true in + while_lwt !is_active do + let _ = st.Switch.echo_resp_received <- false in + let _ = st.Switch.last_echo_req <- (OS.Clock.time ()) in + lwt _ = OSK.send_packet conn + OP.(Echo_req Header.(create ECHO_REQ sizeof_ofp_header)) in + lwt _ = OS.Time.sleep 10.0 in + return (is_active := st.Switch.echo_resp_received) + done + +let control_channel_run st conn = + (* Trigger the dance between the 2 nodes *) + let h = OP.Header.(create ~xid:1l HELLO sizeof_ofp_header) in + lwt _ = OSK.send_packet conn (OP.Hello(h)) in + let rec echo () = + try_lwt + OSK.read_packet conn >>= process_openflow st conn >>= echo + with + | Net.Nettypes.Closed -> + return (cp "[switch] ERROR:Controller channel closed....\n%!") + | OP.Unparsed (m, bs) -> + cp (sp "[switch] ERROR:unparsed! m=%s\n %!" m); echo () + | exn -> + cp (sp "[switch] ERROR:%s\n%!" (Printexc.to_string exn)); echo () + in + lwt _ = + echo () + Switch.(Table.monitor_flow_timeout st.table (Some conn) st.verbose) + (monitor_control_channel st conn) + in + let _ = OSK.close conn in + let _ = st.Switch.controller <- None in + return (cp "[switch] control channel thread returned") + +let control_channel st (addr, port) t = + cp (sp "[switch] controller %s:%d" (Ipaddr.V4.to_string addr) port); + let conn = OSK.init_socket_conn_state t in + let _ = st.Switch.controller <- (Some conn) in + control_channel_run st conn + +(* + * Interaface with external applications + * *) +let get_port_name mgr id = + let ethif = Net.Manager.get_ethif (get_intf mgr id) in + OS.Netif.string_of_id (OS.Netif.id (Net.Ethif.get_netif ethif)) + +let add_port mgr ?(use_mac=false) sw id = + sw.Switch.portnum <- sw.Switch.portnum + 1; + let ethif = Net.Manager.get_ethif (get_intf mgr id) in + let hw_addr = Macaddr.to_string (Net.Ethif.mac ethif) in + let _ = OS.Console.log (sp "[switch] Adding port %d (%s) '%s' \n %!" + sw.Switch.portnum (OS.Netif.string_of_id id) hw_addr) in + let port = Switch.init_port mgr sw.Switch.portnum id in + Hashtbl.add sw.Switch.ports sw.Switch.portnum port; + sw.Switch.features.OP.Switch.ports <- + sw.Switch.features.OP.Switch.ports @ [port.Switch.phy]; + let _ = Net.Manager.set_promiscuous mgr id (process_frame sw port) in + let h,p = OP.Port.create_port_status OP.Port.ADD port.Switch.phy in + match sw.Switch.controller with + | None -> return () + | Some t -> OSK.send_packet t (OP.Port_status (h,p)) + +let del_port mgr sw name = + try_lwt + let open Switch in + let ix = Hashtbl.fold (fun ix p r -> + if (OS.Netif.string_of_id p.ethif = name) then ix else r) sw.ports 0 in + let port = Hashtbl.find sw.ports ix in + let _ = + Hashtbl.remove sw.ports ix in + let h,p = OP.Port.create_port_status OP.Port.DEL port.phy in + let of_match = OP.Match.create_flow_match (OP.Wildcards.full_wildcard ()) () in + lwt _ = Table.del_flow sw.table of_match + (OP.Port.port_of_int port.port_id) sw.controller sw.verbose in + let of_match = OP.Match.create_flow_match (OP.Wildcards.in_port_match ()) + ~in_port:(port.Switch.port_id) () in + lwt _ = Table.del_flow sw.table of_match + OP.Port.No_port sw.controller sw.verbose in + let _ = cp (sp "[switch] Removing port %s (port_id=%d)" name port.port_id) in + match sw.controller with + | None -> return () + | Some t -> OSK.send_packet t (OP.Port_status (h,p)) + with exn -> + return (cp (sp "[switch] del_port: port %s not found\n%!" name)) + +let add_port_local mgr sw ethif = + (*TODO Find first if a port is already registered as port 0 + * as port 0 and disable it *) +let open Switch in + let local_port_id = OP.Port.int_of_port OP.Port.Local in + let port = init_port mgr local_port_id ethif in + Hashtbl.replace sw.ports local_port_id port; + (*TODO Need to filter out any 0 port *) + sw.features.OP.Switch.ports <- + port.phy :: + (List.filter (fun a -> (a.OP.Port.port_no <> local_port_id)) + sw.Switch.features.OP.Switch.ports ); + let _ = cp (sp "[switch] Adding port %s (port_id=%d)" + (OS.Netif.string_of_id ethif) local_port_id) in + return (Net.Manager.set_promiscuous mgr ethif (process_frame sw port)) + +let create_switch ?(verbose=false) dpid model = + let open Switch in + let (pktin_queue, pktin_push) = Lwt_stream.create () in + let (stats_queue, stats_push) = Lwt_stream.create () in + let (pktout_queue, pktout_push) = Lwt_stream.create () in + let st = Switch.( + { ports = (Hashtbl.create 64); + controller=None; errornum = 0l; portnum=0; model; + stats={n_frags=0L; n_hits=0L;n_missed=0L;n_lost=0L;}; + table = (Table.init_table ()); features=(Switch.switch_features dpid); + packet_buffer=[]; last_echo_req=0.; echo_resp_received=true; + packet_buffer_id=0l;ready=(Lwt_condition.create ()); + verbose;pktin_queue; + pktin_push;pktout_queue;pktout_push;stats_queue;stats_push;}) in + let _ = + if (st.model.flow_insert > 0.) then + let _ = ignore_result (Table.add_flow_t st st.Switch.table + st.Switch.model.flow_insert st.Switch.verbose) in + ignore_result (Table.upd_flow_t st.Switch.table st.Switch.model.flow_update + st.Switch.verbose) + in + let _ = + if (st.Switch.model.pktin_delay > 0.) || (st.Switch.model.pktin_rate > 0.) then + ignore_result (Switch.pktin_t st st.Switch.model.pktin_delay + st.Switch.model.pktin_rate) + in + st + +let listen st mgr loc = + Net.Channel.listen mgr (`TCPv4 (loc, (control_channel st ))) <&> + (forward_thread st) + +let connect st mgr loc = + Net.Channel.connect mgr (`TCPv4 (None, loc, (control_channel st loc))) <&> + (forward_thread st) + +let local_connect st mgr conn = + let _ = st.Switch.controller <- (Some conn) in + (control_channel_run st conn) <&> + (forward_thread st) + +let standalone_connect st mgr loc = + let of_ctrl = Ofswitch_standalone.init_controller () in + (* let _ = ignore_result (forward_thread st) in *) + let _ = cp "[switch] Listening socket...\n%!" in + while_lwt true do + let t,u = Lwt.task () in + ( + let _ = cp "[switch] Standalone controller taking over..." in + lwt conn = + Ofswitch_standalone.run_controller mgr of_ctrl in +(* let conn = OSK.init_local_conn_state switch_in switch_out in *) + let _ = st.Switch.controller <- (Some conn) in + lwt _ = Lwt.pick [(control_channel_run st conn); t] in + let _ = OSK.close conn in + return (cp "[switch] Standalone controller stopped..." ) + ) <&> ( + let rec connect_socket () = + let sock = ref None in + try_lwt + lwt _ = Lwt.pick + [(Net.Channel.connect mgr (`TCPv4(None,loc,(fun t -> return (sock:=Some(t)))))); + (OS.Time.sleep 10.0)] + in + match !sock with + | None -> connect_socket () + | Some t -> return t + with exn -> connect_socket () + in + lwt conn = connect_socket () >|= OSK.init_socket_conn_state in + let _ = wakeup u (st.Switch.controller <- (Some conn)) in + lwt _ = control_channel_run st conn in + let _ = OSK.close conn in + return (cp "[switch ]Remote controller connected...") + ) + done diff --git a/lib/ofswitch_model.mli b/lib/ofswitch_model.mli new file mode 100644 index 0000000..09174df --- /dev/null +++ b/lib/ofswitch_model.mli @@ -0,0 +1,60 @@ +(* + * Copyright (c) 2011 Richard Mortier + * Copyright (c) 2011 Charalampos Rotsos + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +open Net + +type t + +type delay_model = { + flow_insert : float; + flow_update : float; + pktin_rate : float; + pktin_delay : float; + stats_delay : float; + pktout_delay: float; +} + +(** [create dpid] initializes the state for a switch with a datapth id dpid *) +val create_switch : ?verbose:bool -> int64 -> delay_model -> t + +(** Port Management *) + +(** [add_port mgr st intf] add port intf under the control of the switch st *) +val add_port : Manager.t -> ?use_mac:bool -> t -> Manager.id -> unit Lwt.t +(** [del_port mgr st intf] remove port intf from the control of the switch st *) +val del_port : Manager.t -> t -> string -> unit Lwt.t +(** [add_port_local mgr st intf] add port intf as the local loopback interface + * of th switch st *) +val add_port_local : Manager.t -> t -> Manager.id -> unit Lwt.t + +(** [get_flow_stats st fl] fetch statistics for flows matching flow definition + * fl from the switch st *) +val get_flow_stats : t -> Openflow.Ofpacket.Match.t -> Openflow.Ofpacket.Flow.stats list + +(** Daemon run *) + +(** [listen st mgr addr] start a listening switch control channel on addr *) +val listen : t -> Manager.t -> Nettypes.ipv4_src -> unit Lwt.t +(** [connect st mgr addr] connect a switch control channel to a controller + * on addr *) +val connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t +(** [local_connect st mgr conn] setup a switch control channel on the local + * Open`flow socket conn *) +val local_connect : t -> Manager.t -> Openflow.Ofsocket.conn_state -> unit Lwt.t +(** [standalone_connect st mgr addr] same as connect method, but a local + * learning switch is responsible to control the switch, when the remote + * control channel is unresponsive *) +val standalone_connect : t -> Manager.t -> Nettypes.ipv4_dst -> unit Lwt.t diff --git a/lib/switch_model.mlpack b/lib/switch_model.mlpack new file mode 100644 index 0000000..1e68b96 --- /dev/null +++ b/lib/switch_model.mlpack @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: d668207c07c4ef2fe58a2c8043caa223) +Ofswitch_model +# OASIS_STOP From d79336f1a785b475f2051597ab400d1cfee44cf9 Mon Sep 17 00:00:00 2001 From: crotsos Date: Fri, 13 Dec 2013 11:48:04 +0000 Subject: [PATCH 75/75] Fixing of switch to work with floodlight --- .merlin | 17 +++------ Makefile | 2 +- _oasis | 24 +++++++++---- _tags | 8 ++++- lib/META | 14 +++++++- lib/flowvisor.ml | 2 +- lib/ofpacket.ml | 60 ++++++++++++++++++++----------- lib/ofpacket.mli | 8 +++-- lib/ofswitch.ml | 12 ++++--- lib/ofswitch_config.ml | 4 +-- myocamlbuild.ml | 11 ++++-- setup.ml | 82 ++++++++++++++++++++++++++++-------------- switch/basic_switch.ml | 22 ++++++------ 13 files changed, 174 insertions(+), 92 deletions(-) diff --git a/.merlin b/.merlin index 9fba6b2..7314802 100644 --- a/.merlin +++ b/.merlin @@ -1,12 +1,5 @@ -S . -S ./lib/ -S ./controller/ -S ./switch/ -B _build/src -PKG lwt -PKG mirage -PKG mirage-net -PKG cstruct -PKG re -PKG ipaddr -PKG pttcp +PKG lwt mirage mirage-net cstruct ipaddr +S ./lib +S ./controller +S ./switch +B _build/lib diff --git a/Makefile b/Makefile index bd55045..4aa45f5 100644 --- a/Makefile +++ b/Makefile @@ -30,7 +30,7 @@ distclean: setup.ml setup.data setup: setup.data build: setup.data $(wildcard lib/*.ml) - ocaml setup.ml -build -j $(J) $(OFLAGS) $(DR) + ocaml setup.ml -build -cflags -bin-annot -j $(J) $(OFLAGS) $(DR) ifeq ($(MIRAGE_OS), xen) ld -d -nostdlib -m elf_x86_64 -T $(caml_path)/mirage-xen/mirage-x86_64.lds \ $(caml_path)/mirage-xen/x86_64.o _build/switch/xen_switch.nobj.o \ diff --git a/_oasis b/_oasis index 8617385..d3280b5 100644 --- a/_oasis +++ b/_oasis @@ -1,11 +1,11 @@ OASISFormat: 0.3 -OCamlVersion: >= 3.12 +OCamlVersion: >= 4.00.1 Name: openflow Version: 0.3.0 Authors: Charalampos Rotsos, Richard Mortier, Anil Madhavappedy, Balraj Singh License: ISC Synopsis: OpenFlow controller, switch and flowvisor implementation in pure OCaml -Plugins: META (0.2) +Plugins: META (0.3) BuildTools: ocamlbuild Flag direct @@ -54,23 +54,33 @@ Library switch Pack: True BuildDepends: re.str, tuntap +Library switch_model + Path: lib + Findlibname: switch_model + Findlibparent: openflow + Build$: flag(direct) + Install$: flag(direct) + CompiledObject: native + Modules: Ofswitch_model + Pack: True + BuildDepends: re.str, tuntap + Executable ofcontroller_lwt Path: controller MainIs: lwt_controller.ml - Build$: flag(unix) + Build: false Custom: true CompiledObject: native Install$: flag(unix) - BuildDepends: openflow + BuildDepends: openflow,tuntap Executable ofswitch_lwt Path: switch MainIs: lwt_switch.ml Custom: true - Build$: (flag(unix) && flag(direct)) - Install$: (flag(unix) && flag(direct)) + Build: false CompiledObject: native - BuildDepends: openflow, openflow.switch + BuildDepends: openflow, openflow.switch,tuntap Executable ofswitch Path: switch diff --git a/_tags b/_tags index 6f4d654..1025e80 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 7c9c51d36fdd7fa35499b1c9d975c796) +# DO NOT EDIT (digest: 2e93c3b498a48aeea27e4bda67fc628e) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -35,10 +35,14 @@ "lib/ofswitch.cmx": for-pack(Switch) "lib/ofswitch_config.cmx": for-pack(Switch) "lib/ofswitch_standalone.cmx": for-pack(Switch) +# Library switch_model +"lib/switch_model.cmxs": use_switch_model +"lib/ofswitch_model.cmx": for-pack(Switch_model) : pkg_re.str : pkg_tuntap # Executable ofcontroller_lwt "controller/lwt_controller.native": use_openflow +"controller/lwt_controller.native": pkg_tuntap "controller/lwt_controller.native": pkg_ipaddr "controller/lwt_controller.native": pkg_cstruct "controller/lwt_controller.native": pkg_cstruct.syntax @@ -46,6 +50,7 @@ "controller/lwt_controller.native": pkg_rpclib.json "controller/lwt_controller.native": pkg_mirage "controller/lwt_controller.native": pkg_mirage-net +: pkg_tuntap "controller/lwt_controller.native": custom # Executable ofswitch_lwt "switch/lwt_switch.native": use_openflow @@ -110,3 +115,4 @@ true: annot : pkg_lwt.syntax : syntax_camlp4o : pkg_lwt.syntax +true: bin_annot diff --git a/lib/META b/lib/META index 1364637..8f31813 100644 --- a/lib/META +++ b/lib/META @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: b787620bd33d2bdf1fe0565f29356a9c) +# DO NOT EDIT (digest: 27751d9b328e9b59d215c02667dc4f29) version = "0.3.0" description = "OpenFlow controller, switch and flowvisor implementation in pure OCaml" @@ -10,6 +10,18 @@ archive(byte, plugin) = "openflow.cma" archive(native) = "openflow.cmxa" archive(native, plugin) = "openflow.cmxs" exists_if = "openflow.cmxa" +package "switch_model" ( + version = "0.3.0" + description = + "OpenFlow controller, switch and flowvisor implementation in pure OCaml" + requires = "re.str tuntap" + archive(byte) = "switch_model.cma" + archive(byte, plugin) = "switch_model.cma" + archive(native) = "switch_model.cmxa" + archive(native, plugin) = "switch_model.cmxs" + exists_if = "switch_model.cmxa" +) + package "switch" ( version = "0.3.0" description = diff --git a/lib/flowvisor.ml b/lib/flowvisor.ml index 51bb721..a83bedb 100644 --- a/lib/flowvisor.ml +++ b/lib/flowvisor.ml @@ -523,7 +523,7 @@ let process_openflow st dpid t msg = | OP.Barrier_resp h | OP.Stats_resp (h, _) | OP.Features_resp (h, _) - | OP.Vendor (h, _, _) + | OP.Vendor (h, _) | OP.Echo_resp (h) | OP.Error (h, _, _) -> let h = OP.Header.(create ~xid:h.xid OP.Header.ERROR 0) in diff --git a/lib/ofpacket.ml b/lib/ofpacket.ml index c2baa0a..0c14c8c 100644 --- a/lib/ofpacket.ml +++ b/lib/ofpacket.ml @@ -110,7 +110,7 @@ module Header = struct ERROR = 1; ECHO_REQ = 2; ECHO_RESP = 3; - VENDOR = 4; + VENDOR_MSG = 4; FEATURES_REQ = 5; FEATURES_RESP = 6; GET_CONFIG_REQ = 7; @@ -673,7 +673,8 @@ module Switch = struct miss_send_len: uint16; } - let init_switch_config = {drop=true; reasm=true;miss_send_len=1000;} + let init_switch_config = {drop=true; + reasm=true;miss_send_len=1000;} cstruct ofp_switch_config { uint16_t flags; @@ -690,6 +691,11 @@ module Switch = struct let _ = set_ofp_switch_config_miss_send_len bits config.miss_send_len in (Header.sizeof_ofp_header + sizeof_ofp_switch_config) + let parse_switch_config bits = + let _ = get_ofp_switch_config_flags bits in + let miss_send_len = get_ofp_switch_config_miss_send_len bits in + {drop=false; reasm=false; miss_send_len} + end module Wildcards = struct @@ -2159,6 +2165,17 @@ module Stats = struct uint64_t collisions } as big_endian + let create_desc_stat_resp imfr hw sw serial dp = + let ret = {imfr_desc=(String.create 256); hw_desc=(String.create 256); + sw_desc=(String.create 356); serial_num=(String.create 32); + dp_desc=(String.create 256);} in + let _ = String.blit imfr 0 ret.imfr_desc 0 (String.length imfr) in + let _ = String.blit hw 0 ret.hw_desc 0 (String.length hw) in + let _ = String.blit sw 0 ret.sw_desc 0 (String.length sw) in + let _ = String.blit serial 0 ret.serial_num 0 (String.length serial) in + let _ = String.blit dp 0 ret.dp_desc 0 (String.length dp) in + ret + let parse_stats_resp bits = let typ = stats_type_of_int (get_ofp_stats_reply_typ bits) in let more = ((get_ofp_stats_reply_flags bits) = 1) in @@ -2210,7 +2227,8 @@ module Stats = struct match resp with | Desc_resp(resp_hdr, desc) -> let len = (Header.sizeof_ofp_header + sizeof_ofp_stats_reply + - sizeof_ofp_desc_stats) in + sizeof_ofp_desc_stats) in + let _ = Printf.printf "marshaling description response\n%!" in let of_header = Header.create ~xid Header.STATS_RESP len in let (ofp_len, bits) = marshal_and_shift (Header.marshal_header of_header) bits in @@ -2221,7 +2239,8 @@ module Stats = struct let _ = set_ofp_desc_stats_hw_desc desc.hw_desc 0 bits in let _ = set_ofp_desc_stats_sw_desc desc.sw_desc 0 bits in let _ = set_ofp_desc_stats_serial_num desc.serial_num 0 bits in - let _ = set_ofp_desc_stats_dp_desc desc.dp_desc 0 bits in + let _ = set_ofp_desc_stats_dp_desc desc.dp_desc 0 bits in + let _ = Printf.printf "done marshaling description response\n%!" in len | Flow_resp(resp_h, flows) -> let flow_len = List.fold_right @@ -2423,19 +2442,19 @@ and string_of_error_code = function uint16_t code } as big_endian -let marshal_error errornum data xid bits = - let req_len = Cstruct.len data in - let req_h = Header.create ~xid Header.ERROR - (Header.get_len + sizeof_ofp_error_msg + req_len) in - let (len, bits) = marshal_and_shift (Header.marshal_header req_h) bits in - let errornum = int_of_error_code errornum in - let _ = set_ofp_error_msg_typ bits - (Int32.to_int (Int32.shift_left errornum 16)) in - let _ = set_ofp_error_msg_code bits - (Int32.to_int (Int32.logand errornum 0xffff0000l)) in - let bits = Cstruct.shift bits sizeof_ofp_error_msg in - let _ = Cstruct.blit data 0 bits 0 (Cstruct.len data) in - (Header.get_len + sizeof_ofp_error_msg + req_len) +let marshal_error errornum data xid bits = + let req_len = Cstruct.len data in + let req_h = Header.create ~xid Header.ERROR + (Header.get_len + sizeof_ofp_error_msg + req_len) in + let (len, bits) = marshal_and_shift (Header.marshal_header req_h) bits in + let errornum = int_of_error_code errornum in + let _ = set_ofp_error_msg_typ bits + (Int32.to_int (Int32.logand errornum 0xffffl)) in + let _ = set_ofp_error_msg_code bits + (Int32.to_int (Int32.shift_right (Int32.logand errornum 0xffff0000l) 16)) in + let bits = Cstruct.shift bits sizeof_ofp_error_msg in + let _ = Cstruct.blit data 0 bits 0 (Cstruct.len data) in + (Header.get_len + sizeof_ofp_error_msg + req_len) let build_features_req xid bits = Header.marshal_header (Header.(create ~xid FEATURES_REQ 8)) bits @@ -2452,7 +2471,7 @@ type t = | Error of Header.h * error_code * Cstruct.t | Echo_req of Header.h | Echo_resp of Header.h - | Vendor of Header.h * vendor * Cstruct.t + | Vendor of Header.h * (* vendor * *) Cstruct.t | Features_req of Header.h | Features_resp of Header.h * Switch.features @@ -2483,12 +2502,12 @@ let parse h bits = | ERROR -> raise (Unparsed ("ERROR", bits)) | ECHO_REQ -> Echo_req h | ECHO_RESP -> Echo_resp h - | VENDOR -> raise (Unparsed ("VENDOR", bits)) + | VENDOR_MSG -> Vendor(h, bits) | FEATURES_REQ -> Features_req (h) | FEATURES_RESP -> Features_resp (h, Switch.parse_features bits) | GET_CONFIG_REQ -> Get_config_req(h) | GET_CONFIG_RESP -> raise (Unparsed ("GET_CONFIG_RESP", bits)) - | SET_CONFIG -> raise (Unparsed ("SET_CONFIG", bits)) + | SET_CONFIG -> Set_config(h, (Switch.parse_switch_config bits) ) | PACKET_IN -> Packet_in (h, Packet_in.parse_packet_in bits) | PORT_STATUS -> Port_status(h, (Port.parse_status bits)) | FLOW_REMOVED -> Flow_removed(h, (Flow_removed.parse_flow_removed bits)) @@ -2534,6 +2553,7 @@ let marshal msg = | Echo_req (h) | Echo_resp (h) | Get_config_req (h) + | Vendor(h, _) | Hello (h) -> Header.marshal_header h | Flow_removed (h, frm) -> Flow_removed.marshal_flow_removed ~xid:(h.Header.xid) frm diff --git a/lib/ofpacket.mli b/lib/ofpacket.mli index dc21403..5d87289 100644 --- a/lib/ofpacket.mli +++ b/lib/ofpacket.mli @@ -36,7 +36,7 @@ module Header : | ERROR | ECHO_REQ | ECHO_RESP - | VENDOR + | VENDOR_MSG | FEATURES_REQ | FEATURES_RESP | GET_CONFIG_REQ @@ -481,7 +481,9 @@ module Stats : | Port_resp of resp_hdr * Port.stats list | Queue_resp of resp_hdr * queue list | Vendor_resp of resp_hdr - val resp_get_len : resp -> int + val resp_get_len : resp -> int + val create_desc_stat_resp : string -> string -> string -> string -> string + -> desc val marshal_stats_resp : int32 -> resp -> Cstruct.t -> int val string_of_stats : resp -> string end @@ -531,7 +533,7 @@ type t = | Error of Header.h * error_code * Cstruct.t | Echo_req of Header.h | Echo_resp of Header.h - | Vendor of Header.h * vendor * Cstruct.t + | Vendor of Header.h * (* vendor *) Cstruct.t | Features_req of Header.h | Features_resp of Header.h * Switch.features | Get_config_req of Header.h diff --git a/lib/ofswitch.ml b/lib/ofswitch.ml index a34c111..b24c02b 100644 --- a/lib/ofswitch.ml +++ b/lib/ofswitch.ml @@ -290,7 +290,8 @@ module Switch = struct mutable pkt_count : int; } - let init_port mgr port_no id = + let init_port mgr port_no id = + let ethif = Net.Manager.get_ethif ( get_ethif mgr id ) in let netif = Net.Ethif.get_netif ethif in let name = OS.Netif.string_of_id (OS.Netif.id (Net.Ethif.get_netif ethif )) in @@ -791,8 +792,8 @@ let process_openflow st t msg = match req with | OP.Stats.Desc_req(req) -> let p = OP.Stats.(Desc_resp ({st_ty=DESC; more=false;}, - { imfr_desc="Mirage"; hw_desc="Mirage"; - sw_desc="Mirage"; serial_num="0.1";dp_desc="Mirage";})) in + (create_desc_stat_resp "Mirage" "Mirage" "Mirage" + "0.1" "Mirage"))) in let h = create ~xid STATS_RESP (OP.Stats.resp_get_len p) in OSK.send_packet t (OP.Stats_resp (h, p)) | OP.Stats.Flow_req(req_h, of_match, table_id, out_port) -> @@ -899,6 +900,7 @@ let process_openflow st t msg = in if (fm.buffer_id = -1l) then return () else process_buffer_id st t msg h.xid fm.buffer_id fm.actions + | OP.Set_config (h, _) -> return () | OP.Queue_get_config_resp (h, _, _) | OP.Queue_get_config_req (h, _) | OP.Barrier_resp h @@ -907,10 +909,9 @@ let process_openflow st t msg = | OP.Port_status (h, _) | OP.Flow_removed (h, _) | OP.Packet_in (h, _) - | OP.Set_config (h, _) | OP.Get_config_resp (h, _) | OP.Features_resp (h, _) - | OP.Vendor (h, _, _) + | OP.Vendor (h, _) | OP.Error (h, _, _) -> let bits = OP.marshal msg in let h = OP.Header.create ~xid:h.OP.Header.xid OP.Header.ERROR @@ -1084,6 +1085,7 @@ let standalone_connect st mgr loc = let rec connect_socket () = let sock = ref None in try_lwt + let _ = Printf.printf "trying to connect to controller\n%!" in lwt _ = Lwt.pick [(Net.Channel.connect mgr (`TCPv4(None,loc,(fun t -> return (sock:=Some(t)))))); (OS.Time.sleep 10.0)] diff --git a/lib/ofswitch_config.ml b/lib/ofswitch_config.ml index 27abbbb..0de6a9f 100644 --- a/lib/ofswitch_config.ml +++ b/lib/ofswitch_config.ml @@ -219,10 +219,10 @@ let listen_t mgr add_port del_port get_stats add_flow del_flow port = end | ("del-port", (Rpc.String (dev))::_) -> - let ethif = Net.Ethif.get_netif +(* let ethif = Net.Ethif.get_netif (Net.Manager.get_ethif (get_ethif mgr (OS.Netif.id_of_string dev))) in (* lwt _ = OS.Netif.destroy ethif in *) - lwt _ = del_port dev in + lwt _ = del_port dev in *) return (Rpc.Enum [(Rpc.String "true")]) | ("dump-flows", (Rpc.Dict t)::_) -> let of_match = hashtbl_to_flow_match t in diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 93da712..1630e89 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: e02ba6573f9818d0d9f18eb9a66eb191) *) +(* DO NOT EDIT (digest: d09f38b5f845453a33251ed8fef2743c) *) module OASISGettext = struct (* # 21 "src/oasis/OASISGettext.ml" *) @@ -508,7 +508,12 @@ open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = - [("openflow", ["lib"]); ("flv", ["lib"]); ("switch", ["lib"])]; + [ + ("openflow", ["lib"]); + ("flv", ["lib"]); + ("switch", ["lib"]); + ("switch_model", ["lib"]) + ]; lib_c = []; flags = []; includes = [("switch", ["lib"]); ("controller", ["lib"])]; @@ -517,6 +522,6 @@ let package_default = let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 521 "myocamlbuild.ml" +# 526 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index 3ee29e0..b0f361d 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 350be2246dd7ef95a98786cdb09fc99d) *) +(* DO NOT EDIT (digest: a74b50c4be9714be24cc3dd375101778) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5834,7 +5834,7 @@ let setup_t = package = { oasis_version = "0.3"; - ocaml_version = Some (OASISVersion.VGreaterEqual "3.12"); + ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1"); findlib_version = None; name = "openflow"; version = "0.3.0"; @@ -6073,9 +6073,9 @@ let setup_t = lib_findlib_name = Some "switch"; lib_findlib_containers = []; }); - Executable + Library ({ - cs_name = "ofcontroller_lwt"; + cs_name = "switch_model"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, @@ -6083,16 +6083,20 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "unix", true) + (OASISExpr.EFlag "direct", true) ]; bs_install = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "unix", true) + (OASISExpr.EFlag "direct", true) ]; - bs_path = "controller"; + bs_path = "lib"; bs_compiled_object = Native; - bs_build_depends = [InternalLibrary "openflow"]; + bs_build_depends = + [ + FindlibPackage ("re.str", None); + FindlibPackage ("tuntap", None) + ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6103,34 +6107,61 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - {exec_custom = true; exec_main_is = "lwt_controller.ml"; }); + { + lib_modules = ["Ofswitch_model"]; + lib_pack = true; + lib_internal_modules = []; + lib_findlib_parent = Some "openflow"; + lib_findlib_name = Some "switch_model"; + lib_findlib_containers = []; + }); Executable ({ - cs_name = "ofswitch_lwt"; + cs_name = "ofcontroller_lwt"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - bs_build = + bs_build = [(OASISExpr.EBool true, false)]; + bs_install = [ (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "unix", - OASISExpr.EFlag "direct"), - true) + (OASISExpr.EFlag "unix", true) ]; - bs_install = + bs_path = "controller"; + bs_compiled_object = Native; + bs_build_depends = [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "unix", - OASISExpr.EFlag "direct"), - true) + InternalLibrary "openflow"; + FindlibPackage ("tuntap", None) ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = true; exec_main_is = "lwt_controller.ml"; }); + Executable + ({ + cs_name = "ofswitch_lwt"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, false)]; + bs_install = [(OASISExpr.EBool true, true)]; bs_path = "switch"; bs_compiled_object = Native; bs_build_depends = - [InternalLibrary "openflow"; InternalLibrary "switch" + [ + InternalLibrary "openflow"; + InternalLibrary "switch"; + FindlibPackage ("tuntap", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -6207,14 +6238,13 @@ let setup_t = {exec_custom = false; exec_main_is = "xen_controller.ml"; }) ]; - plugins = [(`Extra, "META", Some "0.2")]; + plugins = [(`Extra, "META", Some "0.3")]; schema_data = PropList.Data.create (); plugin_data = []; }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = - Some "Q\188\147\181)\165\131\189\251\236\178\161\182\233+\023"; + oasis_digest = Some "\004\143t\131\247\170^h\230d\b\132-\211\201P"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6222,6 +6252,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6226 "setup.ml" +# 6256 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/switch/basic_switch.ml b/switch/basic_switch.ml index e584d09..2629004 100644 --- a/switch/basic_switch.ml +++ b/switch/basic_switch.ml @@ -24,7 +24,7 @@ let resolve t = Lwt.on_success t (fun _ -> ()) module OP = Openflow.Ofpacket module OC = Openflow.Ofcontroller module OE = Openflow.Ofcontroller.Event -open Switch.Ofswitch +open Ofswitch let pp = Printf.printf let sp = Printf.sprintf @@ -32,15 +32,17 @@ let sp = Printf.sprintf (**************************************************************** * OpenFlow Switch configuration *****************************************************************) -let switch_run () = - let sw = create_switch 0x100L in +let switch_run () = +(* let delay = {flow_insert=0.; flow_update=0.; pktin_rate=50.; pktin_delay=0.002; + stats_delay=0.; pktout_delay=0.;} in *) + let model = Ofswitch_model.( + {flow_insert=0.002; + flow_update=0.002; pktin_rate=18.; pktin_delay=0.002;stats_delay=0.; + pktout_delay=0.;}) in + let sw = create_switch 0x100L (* model *) in let use_mac = ref true in try_lwt - let devs = OS.Netif.create () in - lwt _ = - Lwt_list.iter_s ( - ) devs in -(* Manager.create (fun mgr interface id -> + Manager.create (fun mgr interface id -> match (OS.Netif.string_of_id id) with | "tap0" | "0" -> @@ -48,7 +50,7 @@ let switch_run () = let _ = printf "connecting switch...\n%!" in let ip = Ipaddr.V4.(make 10l 20l 0l 100l, Prefix.mask 24, []) in lwt _ = Manager.configure interface (`IPv4 ip) in - let dst_ip = Ipaddr.V4.make 10l 20l 0l 1l in + let dst_ip = Ipaddr.V4.make 10l 20l 0l 4l in standalone_connect sw mgr (dst_ip, 6633) | str_id -> (* let find dev = @@ -64,7 +66,7 @@ let switch_run () = add_port mgr ~use_mac:false sw id (* in return () *) - ) *) + ) with e -> Printf.eprintf "Error: %s" (Printexc.to_string e); return ()